十進BASIC 第3掲示板

十進BASIC第3掲示板

十進BASICプログラミングについての質問や研究成果の公開にご利用ください。
メッセージ入力枠は右下をドラッグして拡大できます。 画像,URLは省略可能です。
編集/削除キーを入力しなくてもエラーにはなりませんが,何か適当な半角英数字4~8文字を指定してください。
特に,長文投稿の場合,プレビューで最後の行を確認しても,実際には途中で切れてしまうことがあるので,投稿後の確認が必要です。
名前
件名
メッセージ
画像
メールアドレス
URL
編集/削除キー (半角英数字のみで4~8文字)
プレビューする (投稿前に、内容をプレビューして確認できます)

テキストファイルの文字コード - gnuutera2012or文句うさぴょん URL

2024/03/08 (Fri) 09:08:57

編集済みのテキストファイルを十進basicに貼り付けたら文字化けしてできなかったものの、
色々試して復旧できたので御報告いたします。
現象が発生したら一旦すべてコピーして、名前をつけて保存します。
この際に文字コードをANJIにして保存してください。
この操作後でしたら貼り付けても文字化けは発生しないはずです。
既出事項でしたら申し訳ございません。

Re: テキストファイルの文字コード - しばっち

2024/03/10 (Sun) 09:05:37

下記プログラムでUTF-8からSHIFT-JISに変換できます。
SET文を入れ替えるとSHIFT-JISからUTF-8にもできます。
改造(FILES文及びFILE LIST文)すれば複数まとめて変換もできるようになります。


FILE GETOPENNAME F$, "テキストファイル|*.txt;*.bas"
IF F$="" THEN STOP
FOR I=LEN(F$) TO 1 STEP -1
IF F$(I:I)="\" THEN EXIT FOR
NEXT I
OPEN #1:NAME F$
OPEN #2:NAME F$(1:I)&"変換済み."&F$(LEN(F$)-2:LEN(F$))
SET #1:CODING "UTF-8"
SET #2:CODING "SYSTEM"
DO
LINE INPUT #1,IF MISSING THEN EXIT DO:A$
PRINT #2:A$
LOOP
CLOSE #1
CLOSE #2
END

月齢カレンダーの修正 - gnuutera2012or文句うさぴょん URL

2024/03/08 (Fri) 08:34:23

!' カレンダー
!'
!' 投稿者:しばっち
!' 投稿日:2014年 9月 2日(火)19時16分5秒   通報 返信・引用
!'
!' ----------------------------------------------------------------------------------------------------
!' 加筆修正者:gnuutera2012
!' ※新元号が令和となり、あちこち加筆修正させていただきました。
!' (例)
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
!' 加筆修正加筆修正加筆修正加筆修正加筆修正加筆修正
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
!' ----------------------------------------------------------------------------------------------------
DECLARE EXTERNAL FUNCTION SHUKU28$
DECLARE EXTERNAL FUNCTION CALC_ETO60$
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
DECLARE EXTERNAL FUNCTION TYOKU12$
DECLARE EXTERNAL FUNCTION CALC_ETO61$
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
PUBLIC STRING SEKKI24$(0 TO 23, 0 TO 1),QROKUYOU$,QJUKKAN$,Z$
PUBLIC NUMERIC QYEAR,QURUU,QMONTH,QDAY,QMAGE,QMAGENOON,QILLUMI,QMPHASE,RM_SUN0
LET A4=297/210
!' LET B5=257/182
!' LET B4=364/257
LET XSIZE=800
LET YSIZE=INT(XSIZE*A4)
LET XS=XSIZE*75/800
LET YS=YSIZE*250/800
CALL GINIT(XSIZE,YSIZE)
LET HEIGHT=XSIZE*50/800
SET TEXT HEIGHT HEIGHT

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
!' センター数学(BASIC)による「ゲームプログラミングの宝箱」をダウンロードして、実例\ユーティリティー\時間・日付\カレンダー.BASを開く。
!' https://hp.vector.co.jp/authors/VA008683/QA_Primary.htmも参照
FUNCTION IsLeapYear(y) ! うるう年の判定
LET IsLeapYear=0
IF (MOD(y,4)=0 AND MOD(y,100)<>0) OR MOD(y,400)=0 THEN LET IsLeapYear=1 ! うるう年
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

DIM DD(12),MON$(12)
MAT READ DD
DATA 31,28,31,30,31,30,31,31,30,31,30,31

MAT READ MON$
DATA "睦月","如月","弥生","卯月","皐月","水無月","文月","葉月","長月","神無月","霜月","師走"
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
!' LET YEAR = INT(VAL(DATE$)/10000)
!' LET MONTH = MOD(INT(VAL(DATE$)/100),100)
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
INPUT PROMPT "西暦=":YEAR$
IF YEAR$<>"" THEN LET YEAR=VAL(YEAR$)
INPUT PROMPT "月=":MONTH$
IF MONTH$<>"" THEN LET MONTH=VAL(MONTH$)
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF IsLeapYear(YEAR)<>0 THEN LET DD(2)=29 !うるう年なら
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
LET TM = YMDT2JD(YEAR, MONTH, 1, 0, 0, 0)
LET R=MOD(TM+2,7)
SET LINE COLOR "BLACK"
LET XX=R*XSIZE/8

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF ((YEAR= 2019 AND MONTH>= 5) AND (YEAR= 2019 AND MONTH=<12)) OR (YEAR>=2020 AND MONTH>= 1) THEN LET M$=" 令和"&STR$(YEAR-2018)&"年" !' 令和元年は2019年5月1日から。
IF ((YEAR>=1989 AND MONTH>= 1) AND (YEAR=<2018 AND MONTH=<12)) OR ((YEAR= 2019 AND MONTH>= 1) AND (YEAR= 2019 AND MONTH=< 4)) THEN LET M$=" 平成"&STR$(YEAR-1988)&"年" !' IF YEAR=<2018 AND YEAR>=1989 THEN LET GENGOUNEN$=STR$(YEAR-1988)
IF ((YEAR>=1926 AND MONTH>= 1) AND (YEAR=<1988 AND MONTH=<12)) THEN LET M$=" 昭和"&STR$(YEAR-1925)&"年" !' IF YEAR=<1988 AND YEAR>=1926 THEN LET GENGOUNEN$=STR$(YEAR-1925)
IF ((YEAR= 1912 AND MONTH>= 8) AND (YEAR= 1912 AND MONTH=<12)) OR ((YEAR>=1913 AND MONTH>= 1) AND (YEAR=<1925 AND MONTH=<12)) THEN LET M$=" 大正"&STR$(YEAR-1911)&"年" !' IF YEAR=<1925 AND YEAR>=1912 THEN LET GENGOUNEN$=STR$(YEAR-1911)
IF ((YEAR= 1868 AND MONTH>= 9) AND (YEAR= 1868 AND MONTH=<12)) OR ((YEAR>=1869 AND MONTH>= 1) AND (YEAR=<1911 AND MONTH=<12)) OR ((YEAR= 1912 AND MONTH>= 1) AND (YEAR= 1912 AND MONTH=< 7)) THEN LET M$=" 明治"&STR$(YEAR-1867)&"年" !' IF YEAR=<1911 AND YEAR>=1868 THEN LET GENGOUNEN$=STR$(YEAR-1867)
!' IF YEAR<1989 AND YEAR>=1926 THEN LET M$=" 昭和"&STR$(YEAR-1925)&"年"
!' IF YEAR<1926 AND YEAR>=1912 THEN LET M$=" 大正"&STR$(YEAR-1911)&"年"
!' IF YEAR<1912 AND YEAR>=1868 THEN LET M$=" 明治"&STR$(YEAR-1867)&"年"
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF ((YEAR= 2019 AND MONTH>= 5) AND (YEAR= 2019 AND MONTH=<12)) OR (YEAR>=2020 AND MONTH>= 1) THEN LET ERA$="令和"&RIGHT$(" "&STR$(YEAR-2018),2)&"年" ! 令和元年は2019年5月1日から。
IF ((YEAR>=1989 AND MONTH>= 1) AND (YEAR=<2018 AND MONTH=<12)) OR ((YEAR= 2019 AND MONTH>= 1) AND (YEAR= 2019 AND MONTH=< 4)) THEN LET ERA$="平成"&RIGHT$(" "&STR$(YEAR-1988),2)&"年"
IF ((YEAR>=1926 AND MONTH>= 1) AND (YEAR=<1988 AND MONTH=<12)) THEN LET ERA$="昭和"&RIGHT$(" "&STR$(YEAR-1925),2)&"年"
IF ((YEAR= 1912 AND MONTH>= 8) AND (YEAR= 1912 AND MONTH=<12)) OR ((YEAR>=1913 AND MONTH>= 1) AND (YEAR=<1925 AND MONTH=<12)) THEN LET ERA$="大正"&RIGHT$(" "&STR$(YEAR-1911),2)&"年"
IF ((YEAR= 1868 AND MONTH>= 9) AND (YEAR= 1868 AND MONTH=<12)) OR ((YEAR>=1869 AND MONTH>= 1) AND (YEAR=<1911 AND MONTH=<12)) OR ((YEAR= 1912 AND MONTH>= 1) AND (YEAR= 1912 AND MONTH=< 7)) THEN LET ERA$="明治"&RIGHT$(" "&STR$(YEAR-1867),2)&"年"
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
CALL SYMBOL(XSIZE/2-HEIGHT*3,YSIZE/8,"BLACK",STR$(YEAR)&"年"&" "&STR$(MONTH)&"月")
SET TEXT HEIGHT HEIGHT/2
CALL SYMBOL(XSIZE/2+HEIGHT*4,YSIZE/9,"BLACK",M$)
CALL SYMBOL(XSIZE/2+HEIGHT*5,YSIZE/9+HEIGHT*2/3,"BLACK",CALC_ETO60$(YEAR))
CALL SYMBOL(XSIZE/2+HEIGHT*5,YSIZE/9+HEIGHT*4/3,"BLACK",MON$(MONTH))
SET TEXT HEIGHT HEIGHT
FOR I=0 TO 6
READ A$,COL$
DATA "日","RED","月","BLACK","火","BLACK","水","BLACK","木","BLACK","金","BLACK","土","BLUE"
CALL SYMBOL(XS+I*XSIZE/8,YSIZE/4,COL$,A$)
NEXT I
CALL CALC_SEKKI24(YEAR)
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
! メモ帳に用いる場合に使う。
PRINT USING ">######## >######## ":RIGHT$(" "&YEAR$,4)&"年",RIGHT$(" "&MONTH$,2)&"月"
PRINT USING ">######## >######## ":ERA$,MON$(MONTH)
PRINT USING ">######## ":CALC_ETO60$(YEAR)
PRINT USING " ######## #### ################ ########## ######## ######## ###### #### #### #### ######## ###### ######## ##########":"新暦","曜日","祝祭日","旧暦","零時月齢","正午月齢","輝面比","月相","六曜","干支","九星","十二直","二十八宿","二十四節気"
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
FOR I=1 TO DD(MONTH)
LET FL=0
SET TEXT HEIGHT HEIGHT
LET COL$=DAYCOLOR$(YEAR,MONTH,I,R)
CALL SYMBOL(XS+XX,YS+YY,COL$,USING$("##",I))
CALL CALC_KYUREKI(YEAR,MONTH,I)
IF QURUU<>0 THEN LET N$="閏" ELSE LET N$=""
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF QMONTH=1 AND QDAY=1 THEN LET Z$="旧正月"
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
LET TM = YMDT2JD(YEAR, MONTH, I, 0, 0, 0)
LET A$=CALC_JUKKAN$(TM)
LET B$=QSEI$(TM)
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
! メモ帳に用いる場合に使う。
LET C$=MEMO_JUKKAN$(TM)
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
! メモ帳に用いる場合に使う。
IF MONTH=1 OR MONTH=2 THEN LET ye=YEAR-1
IF MONTH=1 THEN LET mo=13
IF MONTH=2 THEN LET mo=14
IF MONTH<>1 AND MONTH<>2 THEN LET ye=YEAR
IF MONTH<>1 AND MONTH<>2 THEN LET mo=MONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET NIJYUUHASSHUKU=MOD(INT(12.25*c)+INT(1.25*n)+INT(2.6*(mo+1))+16+I,28)
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
DIM SEKKIOF24$(31)
FOR K=0 TO 23
IF VAL(SEKKI24$(K, 0)(6:7))=MONTH AND VAL(SEKKI24$(K, 0)(9:10))=I THEN
IF Z$<>"" THEN
LET SEKKIOF24$(I)=SEKKI24$(K, 1)
LET FL=1
ELSE
LET SEKKIOF24$(I)=SEKKI24$(K, 1)
LET FL=2
END IF
EXIT FOR
END IF
NEXT K
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
LET JDSHOUKANN=YMDT2JD(YEAR, VAL(SEKKI24$(0, 0)(6:6))*10+VAL(SEKKI24$(0, 0)(7:7)), VAL(SEKKI24$(0, 0)(9:9))*10+VAL(SEKKI24$(0, 0)(10:10)), 0, 0, 0)
FOR JUSHI=1 TO 12 !' Jではなく、JUSHIとする。
LET JDSHOUKANNUSHIKOUHO=JDSHOUKANN+JUSHI !' Jではなく、JUSHIとする。
LET DATEOFSHOUKANNUSHIKOUHO$=JD2YMDT$(JDSHOUKANNUSHIKOUHO)
LET SHOUKANNUSHIKOUHOMONTH=VAL(DATEOFSHOUKANNUSHIKOUHO$(6:6))*10+VAL(DATEOFSHOUKANNUSHIKOUHO$(7:7))
LET SHOUKANNUSHIKOUHODAY=VAL(DATEOFSHOUKANNUSHIKOUHO$(9:9))*10+VAL(DATEOFSHOUKANNUSHIKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,SHOUKANNUSHIKOUHOMONTH,SHOUKANNUSHIKOUHODAY, 0, 0, 0)
IF SHOUKANNUSHIKOUHOMONTH=1 OR SHOUKANNUSHIKOUHOMONTH=2 THEN LET ye=YEAR-1
IF SHOUKANNUSHIKOUHOMONTH=1 THEN LET mo=13
IF SHOUKANNUSHIKOUHOMONTH=2 THEN LET mo=14
IF SHOUKANNUSHIKOUHOMONTH<>1 AND SHOUKANNUSHIKOUHOMONTH<>2 THEN LET ye=YEAR
IF SHOUKANNUSHIKOUHOMONTH<>1 AND SHOUKANNUSHIKOUHOMONTH<>2 THEN LET mo=SHOUKANNUSHIKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+SHOUKANNUSHIKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF SHOUKANNUSHIKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="丑" THEN LET SHOUKANNUSHIMONTH=SHOUKANNUSHIKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="丑" THEN LET SHOUKANNUSHIDAY=SHOUKANNUSHIKOUHODAY
IF ETOMOJIWATASHI$(2:2)="丑" THEN EXIT FOR
NEXT JUSHI !' Jではなく、JUSHIとする。
LET JDRISSHUNN=YMDT2JD(YEAR, VAL(SEKKI24$(2, 0)(6:6))*10+VAL(SEKKI24$(2, 0)(7:7)), VAL(SEKKI24$(2, 0)(9:9))*10+VAL(SEKKI24$(2, 0)(10:10)), 0, 0, 0)
FOR JTORA=1 TO 12 !' Jではなく、JTORAとする。
LET JDRISSHUNNTORAKOUHO=JDRISSHUNN+JTORA !' Jではなく、JTORAとする。
LET DATEOFRISSHUNNTORAKOUHO$=JD2YMDT$(JDRISSHUNNTORAKOUHO)
LET RISSHUNNTORAKOUHOMONTH=VAL(DATEOFRISSHUNNTORAKOUHO$(6:6))*10+VAL(DATEOFRISSHUNNTORAKOUHO$(7:7))
LET RISSHUNNTORAKOUHODAY=VAL(DATEOFRISSHUNNTORAKOUHO$(9:9))*10+VAL(DATEOFRISSHUNNTORAKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,RISSHUNNTORAKOUHOMONTH,RISSHUNNTORAKOUHODAY, 0, 0, 0)
IF RISSHUNNTORAKOUHOMONTH=1 OR RISSHUNNTORAKOUHOMONTH=2 THEN LET ye=YEAR-1
IF RISSHUNNTORAKOUHOMONTH=1 THEN LET mo=13
IF RISSHUNNTORAKOUHOMONTH=2 THEN LET mo=14
IF RISSHUNNTORAKOUHOMONTH<>1 AND RISSHUNNTORAKOUHOMONTH<>2 THEN LET ye=YEAR
IF RISSHUNNTORAKOUHOMONTH<>1 AND RISSHUNNTORAKOUHOMONTH<>2 THEN LET mo=RISSHUNNTORAKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+RISSHUNNTORAKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF RISSHUNNTORAKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="寅" THEN LET RISSHUNNTORAMONTH=RISSHUNNTORAKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="寅" THEN LET RISSHUNNTORADAY=RISSHUNNTORAKOUHODAY
IF ETOMOJIWATASHI$(2:2)="寅" THEN EXIT FOR
NEXT JTORA !' Jではなく、JTORAとする。
LET JDKEICHITU=YMDT2JD(YEAR, VAL(SEKKI24$(4, 0)(6:6))*10+VAL(SEKKI24$(4, 0)(7:7)), VAL(SEKKI24$(4, 0)(9:9))*10+VAL(SEKKI24$(4, 0)(10:10)), 0, 0, 0)
FOR JUU=1 TO 12 !' Jではなく、JUUとする。
LET JDKEICHITUUUKOUHO=JDKEICHITU+JUU !' Jではなく、JUUとする。
LET DATEOFKEICHITUUUKOUHO$=JD2YMDT$(JDKEICHITUUUKOUHO)
LET KEICHITUUUKOUHOMONTH=VAL(DATEOFKEICHITUUUKOUHO$(6:6))*10+VAL(DATEOFKEICHITUUUKOUHO$(7:7))
LET KEICHITUUUKOUHODAY=VAL(DATEOFKEICHITUUUKOUHO$(9:9))*10+VAL(DATEOFKEICHITUUUKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,KEICHITUUUKOUHOMONTH,KEICHITUUUKOUHODAY, 0, 0, 0)
IF KEICHITUUUKOUHOMONTH=1 OR KEICHITUUUKOUHOMONTH=2 THEN LET ye=YEAR-1
IF KEICHITUUUKOUHOMONTH=1 THEN LET mo=13
IF KEICHITUUUKOUHOMONTH=2 THEN LET mo=14
IF KEICHITUUUKOUHOMONTH<>1 AND KEICHITUUUKOUHOMONTH<>2 THEN LET ye=YEAR
IF KEICHITUUUKOUHOMONTH<>1 AND KEICHITUUUKOUHOMONTH<>2 THEN LET mo=KEICHITUUUKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+KEICHITUUUKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF KEICHITUUUKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="卯" THEN LET KEICHITUUUMONTH=KEICHITUUUKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="卯" THEN LET KEICHITUUUDAY=KEICHITUUUKOUHODAY
IF ETOMOJIWATASHI$(2:2)="卯" THEN EXIT FOR
NEXT JUU !' Jではなく、JUUとする。
LET JDSEIMEI=YMDT2JD(YEAR, VAL(SEKKI24$(6, 0)(6:6))*10+VAL(SEKKI24$(6, 0)(7:7)), VAL(SEKKI24$(6, 0)(9:9))*10+VAL(SEKKI24$(6, 0)(10:10)), 0, 0, 0)
FOR JTATSU=1 TO 12 !' Jではなく、JTATSUとする。
LET JDSEIMEITATSUKOUHO=JDSEIMEI+JTATSU !' Jではなく、JTATSUとする。
LET DATEOFSEIMEITATSUKOUHO$=JD2YMDT$(JDSEIMEITATSUKOUHO)
LET SEIMEITATSUKOUHOMONTH=VAL(DATEOFSEIMEITATSUKOUHO$(6:6))*10+VAL(DATEOFSEIMEITATSUKOUHO$(7:7))
LET SEIMEITATSUKOUHODAY=VAL(DATEOFSEIMEITATSUKOUHO$(9:9))*10+VAL(DATEOFSEIMEITATSUKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,SEIMEITATSUKOUHOMONTH,SEIMEITATSUKOUHODAY, 0, 0, 0)
IF SEIMEITATSUKOUHOMONTH=1 OR SEIMEITATSUKOUHOMONTH=2 THEN LET ye=YEAR-1
IF SEIMEITATSUKOUHOMONTH=1 THEN LET mo=13
IF SEIMEITATSUKOUHOMONTH=2 THEN LET mo=14
IF SEIMEITATSUKOUHOMONTH<>1 AND SEIMEITATSUKOUHOMONTH<>2 THEN LET ye=YEAR
IF SEIMEITATSUKOUHOMONTH<>1 AND SEIMEITATSUKOUHOMONTH<>2 THEN LET mo=SEIMEITATSUKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+SEIMEITATSUKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF SEIMEITATSUKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="辰" THEN LET SEIMEITATSUMONTH=SEIMEITATSUKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="辰" THEN LET SEIMEITATSUDAY=SEIMEITATSUKOUHODAY
IF ETOMOJIWATASHI$(2:2)="辰" THEN EXIT FOR
NEXT JTATSU !' Jではなく、JTATSUとする。
LET JDRIKKA=YMDT2JD(YEAR, VAL(SEKKI24$(8, 0)(6:6))*10+VAL(SEKKI24$(8, 0)(7:7)), VAL(SEKKI24$(8, 0)(9:9))*10+VAL(SEKKI24$(8, 0)(10:10)), 0, 0, 0)
FOR JMI=1 TO 12 !' Jではなく、JMIとする。
LET JDRIKKAMIKOUHO=JDRIKKA+JMI !' Jではなく、JMIとする。
LET DATEOFRIKKAMIKOUHO$=JD2YMDT$(JDRIKKAMIKOUHO)
LET RIKKAMIKOUHOMONTH=VAL(DATEOFRIKKAMIKOUHO$(6:6))*10+VAL(DATEOFRIKKAMIKOUHO$(7:7))
LET RIKKAMIKOUHODAY=VAL(DATEOFRIKKAMIKOUHO$(9:9))*10+VAL(DATEOFRIKKAMIKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,RIKKAMIKOUHOMONTH,RIKKAMIKOUHODAY, 0, 0, 0)
IF RIKKAMIKOUHOMONTH=1 OR RIKKAMIKOUHOMONTH=2 THEN LET ye=YEAR-1
IF RIKKAMIKOUHOMONTH=1 THEN LET mo=13
IF RIKKAMIKOUHOMONTH=2 THEN LET mo=14
IF RIKKAMIKOUHOMONTH<>1 AND RIKKAMIKOUHOMONTH<>2 THEN LET ye=YEAR
IF RIKKAMIKOUHOMONTH<>1 AND RIKKAMIKOUHOMONTH<>2 THEN LET mo=RIKKAMIKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+RIKKAMIKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF RIKKAMIKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="巳" THEN LET RIKKAMIMONTH=RIKKAMIKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="巳" THEN LET RIKKAMIDAY=RIKKAMIKOUHODAY
IF ETOMOJIWATASHI$(2:2)="巳" THEN EXIT FOR
NEXT JMI !' Jではなく、JMIとする。
LET JDBOUSHU=YMDT2JD(YEAR, VAL(SEKKI24$(10, 0)(6:6))*10+VAL(SEKKI24$(10, 0)(7:7)), VAL(SEKKI24$(10, 0)(9:9))*10+VAL(SEKKI24$(10, 0)(10:10)), 0, 0, 0)
FOR JUMA=1 TO 12 !' Jではなく、JUMAとする。
LET JDBOUSHUUMAKOUHO=JDBOUSHU+JUMA !' Jではなく、JUMAとする。
LET DATEOFBOUSHUUMAKOUHO$=JD2YMDT$(JDBOUSHUUMAKOUHO)
LET BOUSHUUMAKOUHOMONTH=VAL(DATEOFBOUSHUUMAKOUHO$(6:6))*10+VAL(DATEOFBOUSHUUMAKOUHO$(7:7))
LET BOUSHUUMAKOUHODAY=VAL(DATEOFBOUSHUUMAKOUHO$(9:9))*10+VAL(DATEOFBOUSHUUMAKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,BOUSHUUMAKOUHOMONTH,BOUSHUUMAKOUHODAY, 0, 0, 0)
IF BOUSHUUMAKOUHOMONTH=1 OR BOUSHUUMAKOUHOMONTH=2 THEN LET ye=YEAR-1
IF BOUSHUUMAKOUHOMONTH=1 THEN LET mo=13
IF BOUSHUUMAKOUHOMONTH=2 THEN LET mo=14
IF BOUSHUUMAKOUHOMONTH<>1 AND BOUSHUUMAKOUHOMONTH<>2 THEN LET ye=YEAR
IF BOUSHUUMAKOUHOMONTH<>1 AND BOUSHUUMAKOUHOMONTH<>2 THEN LET mo=BOUSHUUMAKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+BOUSHUUMAKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF BOUSHUUMAKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="午" THEN LET BOUSHUUMAMONTH=BOUSHUUMAKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="午" THEN LET BOUSHUUMADAY=BOUSHUUMAKOUHODAY
IF ETOMOJIWATASHI$(2:2)="午" THEN EXIT FOR
NEXT JUMA !' Jではなく、JUMAとする。
LET JDSHOUSHO=YMDT2JD(YEAR, VAL(SEKKI24$(12, 0)(6:6))*10+VAL(SEKKI24$(12, 0)(7:7)), VAL(SEKKI24$(12, 0)(9:9))*10+VAL(SEKKI24$(12, 0)(10:10)), 0, 0, 0)
FOR JHITUJI=1 TO 12 !' Jではなく、JHITUJIとする。
LET JDSHOUSHOHITUJIKOUHO=JDSHOUSHO+JHITUJI !' Jではなく、JHITUJIとする。
LET DATEOFSHOUSHOHITUJIKOUHO$=JD2YMDT$(JDSHOUSHOHITUJIKOUHO)
LET SHOUSHOHITUJIKOUHOMONTH=VAL(DATEOFSHOUSHOHITUJIKOUHO$(6:6))*10+VAL(DATEOFSHOUSHOHITUJIKOUHO$(7:7))
LET SHOUSHOHITUJIKOUHODAY=VAL(DATEOFSHOUSHOHITUJIKOUHO$(9:9))*10+VAL(DATEOFSHOUSHOHITUJIKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,SHOUSHOHITUJIKOUHOMONTH,SHOUSHOHITUJIKOUHODAY, 0, 0, 0)
IF SHOUSHOHITUJIKOUHOMONTH=1 OR SHOUSHOHITUJIKOUHOMONTH=2 THEN LET ye=YEAR-1
IF SHOUSHOHITUJIKOUHOMONTH=1 THEN LET mo=13
IF SHOUSHOHITUJIKOUHOMONTH=2 THEN LET mo=14
IF SHOUSHOHITUJIKOUHOMONTH<>1 AND SHOUSHOHITUJIKOUHOMONTH<>2 THEN LET ye=YEAR
IF SHOUSHOHITUJIKOUHOMONTH<>1 AND SHOUSHOHITUJIKOUHOMONTH<>2 THEN LET mo=SHOUSHOHITUJIKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+SHOUSHOHITUJIKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF SHOUSHOHITUJIKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="未" THEN LET SHOUSHOHITUJIMONTH=SHOUSHOHITUJIKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="未" THEN LET SHOUSHOHITUJIDAY=SHOUSHOHITUJIKOUHODAY
IF ETOMOJIWATASHI$(2:2)="未" THEN EXIT FOR
NEXT JHITUJI !' Jではなく、JHITUJIとする。
LET JDRISSHUU=YMDT2JD(YEAR, VAL(SEKKI24$(14, 0)(6:6))*10+VAL(SEKKI24$(14, 0)(7:7)), VAL(SEKKI24$(14, 0)(9:9))*10+VAL(SEKKI24$(14, 0)(10:10)), 0, 0, 0)
FOR JSARU=1 TO 12 !' Jではなく、JSARUとする。
LET JDRISSHUUSARUKOUHO=JDRISSHUU+JSARU !' Jではなく、JSARUとする。
LET DATEOFRISSHUUSARUKOUHO$=JD2YMDT$(JDRISSHUUSARUKOUHO)
LET RISSHUUSARUKOUHOMONTH=VAL(DATEOFRISSHUUSARUKOUHO$(6:6))*10+VAL(DATEOFRISSHUUSARUKOUHO$(7:7))
LET RISSHUUSARUKOUHODAY=VAL(DATEOFRISSHUUSARUKOUHO$(9:9))*10+VAL(DATEOFRISSHUUSARUKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,RISSHUUSARUKOUHOMONTH,RISSHUUSARUKOUHODAY, 0, 0, 0)
IF RISSHUUSARUKOUHOMONTH=1 OR RISSHUUSARUKOUHOMONTH=2 THEN LET ye=YEAR-1
IF RISSHUUSARUKOUHOMONTH=1 THEN LET mo=13
IF RISSHUUSARUKOUHOMONTH=2 THEN LET mo=14
IF RISSHUUSARUKOUHOMONTH<>1 AND RISSHUUSARUKOUHOMONTH<>2 THEN LET ye=YEAR
IF RISSHUUSARUKOUHOMONTH<>1 AND RISSHUUSARUKOUHOMONTH<>2 THEN LET mo=RISSHUUSARUKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+RISSHUUSARUKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF RISSHUUSARUKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="申" THEN LET RISSHUUSARUMONTH=RISSHUUSARUKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="申" THEN LET RISSHUUSARUDAY=RISSHUUSARUKOUHODAY
IF ETOMOJIWATASHI$(2:2)="申" THEN EXIT FOR
NEXT JSARU !' Jではなく、JSARUとする。
LET JDHAKURO=YMDT2JD(YEAR, VAL(SEKKI24$(16, 0)(6:6))*10+VAL(SEKKI24$(16, 0)(7:7)), VAL(SEKKI24$(16, 0)(9:9))*10+VAL(SEKKI24$(16, 0)(10:10)), 0, 0, 0)
FOR JTORI=1 TO 12 !' Jではなく、JTORIとする。
LET JDHAKUROTORIKOUHO=JDHAKURO+JTORI !' Jではなく、JTORIとする。
LET DATEOFHAKUROTORIKOUHO$=JD2YMDT$(JDHAKUROTORIKOUHO)
LET HAKUROTORIKOUHOMONTH=VAL(DATEOFHAKUROTORIKOUHO$(6:6))*10+VAL(DATEOFHAKUROTORIKOUHO$(7:7))
LET HAKUROTORIKOUHODAY=VAL(DATEOFHAKUROTORIKOUHO$(9:9))*10+VAL(DATEOFHAKUROTORIKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,HAKUROTORIKOUHOMONTH,HAKUROTORIKOUHODAY, 0, 0, 0)
IF HAKUROTORIKOUHOMONTH=1 OR HAKUROTORIKOUHOMONTH=2 THEN LET ye=YEAR-1
IF HAKUROTORIKOUHOMONTH=1 THEN LET mo=13
IF HAKUROTORIKOUHOMONTH=2 THEN LET mo=14
IF HAKUROTORIKOUHOMONTH<>1 AND HAKUROTORIKOUHOMONTH<>2 THEN LET ye=YEAR
IF HAKUROTORIKOUHOMONTH<>1 AND HAKUROTORIKOUHOMONTH<>2 THEN LET mo=HAKUROTORIKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+HAKUROTORIKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF RISSHUUSARUKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="酉" THEN LET HAKUROTORIMONTH=HAKUROTORIKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="酉" THEN LET HAKUROTORIDAY=HAKUROTORIKOUHODAY
IF ETOMOJIWATASHI$(2:2)="酉" THEN EXIT FOR
NEXT JTORI !' Jではなく、JTORIとする。
LET JDKANNRO=YMDT2JD(YEAR, VAL(SEKKI24$(18, 0)(6:6))*10+VAL(SEKKI24$(18, 0)(7:7)), VAL(SEKKI24$(18, 0)(9:9))*10+VAL(SEKKI24$(18, 0)(10:10)), 0, 0, 0)
FOR JINU=1 TO 12 !' Jではなく、JINUとする。
LET JDKANNROINUKOUHO=JDKANNRO+JINU !' Jではなく、JINUとする。転記ミス発見。LET JDKANNROINUKOUHO=JDHAKURO+JINUをLET JDKANNROINUKOUHO=JDKANNRO+JINUに直した。
LET DATEOFKANNROINUKOUHO$=JD2YMDT$(JDKANNROINUKOUHO)
LET KANNROINUKOUHOMONTH=VAL(DATEOFKANNROINUKOUHO$(6:6))*10+VAL(DATEOFKANNROINUKOUHO$(7:7))
LET KANNROINUKOUHODAY=VAL(DATEOFKANNROINUKOUHO$(9:9))*10+VAL(DATEOFKANNROINUKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,KANNROINUKOUHOMONTH,KANNROINUKOUHODAY, 0, 0, 0)
IF KANNROINUKOUHOMONTH=1 OR KANNROINUKOUHOMONTH=2 THEN LET ye=YEAR-1
IF KANNROINUKOUHOMONTH=1 THEN LET mo=13
IF KANNROINUKOUHOMONTH=2 THEN LET mo=14
IF KANNROINUKOUHOMONTH<>1 AND KANNROINUKOUHOMONTH<>2 THEN LET ye=YEAR
IF KANNROINUKOUHOMONTH<>1 AND KANNROINUKOUHOMONTH<>2 THEN LET mo=KANNROINUKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+KANNROINUKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF KANNROINUKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="戌" THEN LET KANNROINUMONTH=KANNROINUKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="戌" THEN LET KANNROINUDAY=KANNROINUKOUHODAY
IF ETOMOJIWATASHI$(2:2)="戌" THEN EXIT FOR
NEXT JINU !' Jではなく、JINUとする。
LET JDRITTOU=YMDT2JD(YEAR, VAL(SEKKI24$(20, 0)(6:6))*10+VAL(SEKKI24$(20, 0)(7:7)), VAL(SEKKI24$(20, 0)(9:9))*10+VAL(SEKKI24$(20, 0)(10:10)), 0, 0, 0)
FOR JII=1 TO 12 !' Jではなく、JIIとする。
LET JDRITTOUIIKOUHO=JDRITTOU+JII !' Jではなく、JIIとする。
LET DATEOFRITTOUIIKOUHO$=JD2YMDT$(JDRITTOUIIKOUHO)
LET RITTOUIIKOUHOMONTH=VAL(DATEOFRITTOUIIKOUHO$(6:6))*10+VAL(DATEOFRITTOUIIKOUHO$(7:7))
LET RITTOUIIKOUHODAY=VAL(DATEOFRITTOUIIKOUHO$(9:9))*10+VAL(DATEOFRITTOUIIKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,RITTOUIIKOUHOMONTH,RITTOUIIKOUHODAY, 0, 0, 0)
IF RITTOUIIKOUHOMONTH=1 OR RITTOUIIKOUHOMONTH=2 THEN LET ye=YEAR-1
IF RITTOUIIKOUHOMONTH=1 THEN LET mo=13
IF RITTOUIIKOUHOMONTH=2 THEN LET mo=14
IF RITTOUIIKOUHOMONTH<>1 AND RITTOUIIKOUHOMONTH<>2 THEN LET ye=YEAR
IF RITTOUIIKOUHOMONTH<>1 AND RITTOUIIKOUHOMONTH<>2 THEN LET mo=RITTOUIIKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+RITTOUIIKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF RITTOUIIKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="亥" THEN LET RITTOUIIMONTH=RITTOUIIKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="亥" THEN LET RITTOUIIDAY=RITTOUIIKOUHODAY
IF ETOMOJIWATASHI$(2:2)="亥" THEN EXIT FOR
NEXT JII !' Jではなく、JIIとする。
LET JDDAISETSU=YMDT2JD(YEAR, VAL(SEKKI24$(22, 0)(6:6))*10+VAL(SEKKI24$(22, 0)(7:7)), VAL(SEKKI24$(22, 0)(9:9))*10+VAL(SEKKI24$(22, 0)(10:10)), 0, 0, 0)
FOR JNE=1 TO 12 !' Jではなく、JNEとする。
LET JDDAISETSUNEKOUHO=JDDAISETSU+JNE !' Jではなく、JNEとする。
LET DATEOFDAISETSUNEKOUHO$=JD2YMDT$(JDDAISETSUNEKOUHO)
LET DAISETSUNEKOUHOMONTH=VAL(DATEOFDAISETSUNEKOUHO$(6:6))*10+VAL(DATEOFDAISETSUNEKOUHO$(7:7))
LET DAISETSUNEKOUHODAY=VAL(DATEOFDAISETSUNEKOUHO$(9:9))*10+VAL(DATEOFDAISETSUNEKOUHO$(10:10))
LET TM=YMDT2JD(YEAR,DAISETSUNEKOUHOMONTH,DAISETSUNEKOUHODAY, 0, 0, 0)
IF DAISETSUNEKOUHOMONTH=1 OR DAISETSUNEKOUHOMONTH=2 THEN LET ye=YEAR-1
IF DAISETSUNEKOUHOMONTH=1 THEN LET mo=13
IF DAISETSUNEKOUHOMONTH=2 THEN LET mo=14
IF DAISETSUNEKOUHOMONTH<>1 AND DAISETSUNEKOUHOMONTH<>2 THEN LET ye=YEAR
IF DAISETSUNEKOUHOMONTH<>1 AND DAISETSUNEKOUHOMONTH<>2 THEN LET mo=DAISETSUNEKOUHOMONTH
LET c=INT(ye/100)
LET n=ye-INT(ye/100)*100
LET JYUUNISHIJOUYOKEI=MOD(INT(44.25*c)+INT(5.25*n)+INT(30.6*(mo+1))+6+DAISETSUNEKOUHODAY,12)
LET ETOMOJIWATASHI$=CALC_ETO61$(JYUUNISHIJOUYOKEI) !' IF DAISETSUNEKOUHODAY>SD THENは不要かも?結局削除した。
IF ETOMOJIWATASHI$(2:2)="子" THEN LET DAISETSUNEMONTH=DAISETSUNEKOUHOMONTH
IF ETOMOJIWATASHI$(2:2)="子" THEN LET DAISETSUNEDAY=DAISETSUNEKOUHODAY
IF ETOMOJIWATASHI$(2:2)="子" THEN EXIT FOR
NEXT JNE !' Jではなく、JNEとする。
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
DIM TYOKUOF12$(42)
IF MONTH=SHOUKANNUSHIMONTH AND I <SHOUKANNUSHIDAY-JUSHI AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUKANNUSHIDAY+1,12))
IF MONTH=SHOUKANNUSHIMONTH AND I=>SHOUKANNUSHIDAY-JUSHI AND I=<DD(SHOUKANNUSHIMONTH) THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUKANNUSHIDAY,12))
IF MONTH=RISSHUNNTORAMONTH AND I <RISSHUNNTORADAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUKANNUSHIDAY +DD(SHOUKANNUSHIMONTH),12))
IF MONTH=RISSHUNNTORAMONTH AND I=>RISSHUNNTORADAY-JTORA AND I<RISSHUNNTORADAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUKANNUSHIDAY +DD(SHOUKANNUSHIMONTH)-1,12))
IF MONTH=RISSHUNNTORAMONTH AND I=>RISSHUNNTORADAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RISSHUNNTORADAY,12))
IF MONTH=KEICHITUUUMONTH AND I <KEICHITUUUDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RISSHUNNTORADAY +DD(RISSHUNNTORAMONTH),12))
IF MONTH=KEICHITUUUMONTH AND I=>KEICHITUUUDAY-JUU AND I<KEICHITUUUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RISSHUNNTORADAY +DD(RISSHUNNTORAMONTH)-1,12))
IF MONTH=KEICHITUUUMONTH AND I=>KEICHITUUUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-KEICHITUUUDAY,12))
IF MONTH=SEIMEITATSUMONTH AND I <SEIMEITATSUDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-KEICHITUUUDAY +DD(KEICHITUUUMONTH),12))
IF MONTH=SEIMEITATSUMONTH AND I=>SEIMEITATSUDAY-JTATSU AND I<SEIMEITATSUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-KEICHITUUUDAY +DD(KEICHITUUUMONTH)-1,12))
IF MONTH=SEIMEITATSUMONTH AND I=>SEIMEITATSUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SEIMEITATSUDAY,12))
IF MONTH=RIKKAMIMONTH AND I <RIKKAMIDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SEIMEITATSUDAY +DD(SEIMEITATSUMONTH),12))
IF MONTH=RIKKAMIMONTH AND I=>RIKKAMIDAY-JMI AND I<RIKKAMIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SEIMEITATSUDAY +DD(SEIMEITATSUMONTH)-1,12))
IF MONTH=RIKKAMIMONTH AND I=>RIKKAMIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RIKKAMIDAY,12))
IF MONTH=BOUSHUUMAMONTH AND I <BOUSHUUMADAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RIKKAMIDAY +DD(RIKKAMIMONTH),12))
IF MONTH=BOUSHUUMAMONTH AND I=>BOUSHUUMADAY-JUMA AND I<BOUSHUUMADAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RIKKAMIDAY +DD(RIKKAMIMONTH)-1,12))
IF MONTH=BOUSHUUMAMONTH AND I=>BOUSHUUMADAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-BOUSHUUMADAY,12))
IF MONTH=SHOUSHOHITUJIMONTH AND I <SHOUSHOHITUJIDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-BOUSHUUMADAY +DD(BOUSHUUMAMONTH),12))
IF MONTH=SHOUSHOHITUJIMONTH AND I=>SHOUSHOHITUJIDAY-JHITUJI AND I<SHOUSHOHITUJIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-BOUSHUUMADAY +DD(BOUSHUUMAMONTH)-1,12))
IF MONTH=SHOUSHOHITUJIMONTH AND I=>SHOUSHOHITUJIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUSHOHITUJIDAY,12))
IF MONTH=RISSHUUSARUMONTH AND I <RISSHUUSARUDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUSHOHITUJIDAY +DD(SHOUSHOHITUJIMONTH),12))
IF MONTH=RISSHUUSARUMONTH AND I=>RISSHUUSARUDAY-JSARU AND I<RISSHUUSARUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-SHOUSHOHITUJIDAY +DD(SHOUSHOHITUJIMONTH)-1,12)) !' RISSHUUSARUDAY-JSARU =< I < RISSHUUSARUDAY を満たす日だけはRISSHUUSARUDAY-JSARUの日はRISSHUUSARUDAY-JSARU-1の十二直を一日だけ繰り返したあとで、さらに規則を続ける。
IF MONTH=RISSHUUSARUMONTH AND I=>RISSHUUSARUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RISSHUUSARUDAY,12))
IF MONTH=HAKUROTORIMONTH AND I <HAKUROTORIDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RISSHUUSARUDAY +DD(RISSHUUSARUMONTH),12))
IF MONTH=HAKUROTORIMONTH AND I=>HAKUROTORIDAY-JTORI AND I<HAKUROTORIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RISSHUUSARUDAY +DD(RISSHUUSARUMONTH)-1,12))
IF MONTH=HAKUROTORIMONTH AND I=>HAKUROTORIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-HAKUROTORIDAY,12))
IF MONTH=KANNROINUMONTH AND I <KANNROINUDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-HAKUROTORIDAY +DD(HAKUROTORIMONTH),12))
IF MONTH=KANNROINUMONTH AND I=>KANNROINUDAY-JINU AND I<KANNROINUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-HAKUROTORIDAY +DD(HAKUROTORIMONTH)-1,12))
IF MONTH=KANNROINUMONTH AND I=>KANNROINUDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-KANNROINUDAY,12))
IF MONTH=RITTOUIIMONTH AND I <RITTOUIIDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-KANNROINUDAY +DD(KANNROINUMONTH),12))
IF MONTH=RITTOUIIMONTH AND I=>RITTOUIIDAY-JII AND I<RITTOUIIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-KANNROINUDAY +DD(KANNROINUMONTH)-1,12))
IF MONTH=RITTOUIIMONTH AND I=>RITTOUIIDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RITTOUIIDAY,12))
IF MONTH=DAISETSUNEMONTH AND I <DAISETSUNEDAY AND I>0 THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RITTOUIIDAY +DD(RITTOUIIMONTH),12))
IF MONTH=DAISETSUNEMONTH AND I=>DAISETSUNEDAY-JNE AND I<DAISETSUNEDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-RITTOUIIDAY +DD(RITTOUIIMONTH)-1,12))
IF MONTH=DAISETSUNEMONTH AND I=>DAISETSUNEDAY THEN LET TYOKUOF12$(I)=TYOKU12$(MOD(I-DAISETSUNEDAY,12))
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
SET TEXT HEIGHT HEIGHT*.2
CALL MOON(XS+XX+HEIGHT*.6,YS+YY+HEIGHT*.5,HEIGHT*.5,QMAGENOON-.5,QILLUMI/100)
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*.25,COL$,QROKUYOU$&" "&N$&STR$(QMONTH)&"/"&STR$(QDAY))
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*.5,COL$,A$)
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*.75,COL$,B$)
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.0,COL$,TYOKUOF12$(I))
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.25,COL$,SHUKU28$(NIJYUUHASSHUKU))
IF Z$<>"" THEN CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.5,"GREEN",Z$)
FOR K=0 TO 23
IF VAL(SEKKI24$(K, 0)(6:7))=MONTH AND VAL(SEKKI24$(K, 0)(9:10))=I THEN
IF Z$<>"" THEN
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.75,"MAGENTA",SEKKI24$(K, 1))
LET FL=1
ELSE
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.5,"MAGENTA",SEKKI24$(K, 1))
LET FL=2
END IF
EXIT FOR
END IF
NEXT K
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
FOR K=0 TO 23
IF VAL(SEKKI24$(K, 0)(6:7))=MONTH THEN
IF VAL(SEKKI24$(K, 0)(9:10))= I THEN
IF MOD(I+R-1,7)=0 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","日",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=1 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","月",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=2 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","火",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=3 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","水",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=4 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","木",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=5 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","金",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=6 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","土",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
ELSE
IF MOD(I+R-1,7)=0 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","日",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=1 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","月",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=2 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","火",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=3 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","水",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=4 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","木",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=5 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","金",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
IF MOD(I+R-1,7)=6 THEN
PRINT USING ">######## ####>################>########## --.# --.#>######>####>####>####>########>######>########>##########" : RIGHT$(" "&MONTH$,2)&"月"&RIGHT$(" "&STR$(I),2)&"日","土",Z$,RIGHT$(" "&N$&STR$(QMONTH),3)&"月"&RIGHT$(" "&STR$(QDAY),2)&"日",QMAGE,QMAGENOON,QILLUMI,QMPHASE,QROKUYOU$,C$,B$,TYOKUOF12$(I),SHUKU28$(NIJYUUHASSHUKU),SEKKIOF24$(I)
END IF
END IF
EXIT FOR
END IF
NEXT K
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
IF QMPHASE=14 THEN
LET S$="満月"
ELSEIF QMPHASE=0 THEN
LET S$="新月"
ELSE
!'LET S$=USING$("##.#",QILLUMI)&"%"
LET S$=""
END IF
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF S$<>"" THEN
IF Z$="" AND FL<>2 THEN
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.6,"BLUE",S$)
ELSEIF FL<>1 THEN
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.8,"BLUE",S$)
ELSE
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*2.0,"BLUE",S$)
END IF
END IF
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
LET XX=XX+XSIZE/8
IF MOD(R+I,7)=0 THEN
LET XX=0
LET YY=YY+YSIZE/8
END IF
NEXT I
END

EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
CLEAR
END SUB

EXTERNAL SUB SYMBOL(X,Y,COL$,A$)
SET TEXT COLOR COL$
PLOT TEXT,AT X,Y:A$
END SUB

EXTERNAL FUNCTION DAYCOLOR$(Y,M,N,R)
LET DAYCOLOR$="BLACK"
LET Z$=""
IF MOD(N+R,7)=1 THEN LET DAYCOLOR$="RED"
IF MOD(N+R,7)=0 THEN LET DAYCOLOR$="BLUE"
IF M=1 AND N=1 THEN
LET DAYCOLOR$="RED"
LET Z$="元日"
END IF
IF Y>=1973 AND M=1 AND N=2 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y>=2000 THEN
IF M=1 AND ((R<=1 AND R+N=9) OR (R>1 AND R+N=16)) THEN
LET DAYCOLOR$="RED"
LET Z$="成人の日"
END IF
ELSE
IF M=1 AND N=15 THEN
LET DAYCOLOR$="RED"
LET Z$="成人の日"
END IF
IF Y>=1973 AND M=1 AND N=16 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF M=2 AND N=11 THEN
LET DAYCOLOR$="RED"
LET Z$="建国記念の日"
END IF
IF Y>=1973 AND M=2 AND N=12 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF Y>=2020 THEN
IF M=2 AND N=23 THEN
LET DAYCOLOR$="RED"
LET Z$="天皇誕生日"
END IF
IF M=2 AND N=24 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
IF Y>=1900 AND Y<1980 THEN
IF M=3 AND N=INT(20.8357+0.242194*(Y-1980)-INT((Y-1983)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="春分の日"
END IF
IF Y>=1973 AND M=3 AND N=INT(20.8357+0.242194*(Y-1980)-INT((Y-1983)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=9 AND N=INT(23.2588+0.242194*(Y-1980)-INT((Y-1983)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="秋分の日"
END IF
IF Y>=1973 AND M=9 AND N=INT(23.2588+0.242194*(Y-1980)-INT((Y-1983)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
ELSEIF Y>=1980 AND Y<2100 THEN
IF M=3 AND N=INT(20.8431 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4) THEN
LET DAYCOLOR$="RED"
LET Z$="春分の日"
END IF
IF M=3 AND N=INT(20.8431 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4)+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=9 AND N=INT(23.2488 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4) THEN
LET DAYCOLOR$="RED"
LET Z$="秋分の日"
END IF
IF M=9 AND N=INT(23.2488 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4)+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
ELSEIF Y>=2100 AND Y<2150 THEN
IF M=3 AND N=INT(21.8510+0.242194*(Y-1980)-INT((Y-1980)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="春分の日"
END IF
IF M=3 AND N=INT(21.8510+0.242194*(Y-1980)-INT((Y-1980)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=9 AND N=INT(24.2488+0.242194*(Y-1980)-INT((Y-1980)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="秋分の日"
END IF
IF M=9 AND N=INT(24.2488+0.242194*(Y-1980)-INT((Y-1980)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF M=4 AND N=29 THEN
LET DAYCOLOR$="RED"
IF Y>=2007 THEN
LET Z$="昭和の日"
ELSEIF Y>=1989 AND Y<2007 THEN
LET Z$="みどりの日"
ELSEIF Y>1948 THEN
LET Z$="天皇誕生日"
END IF
END IF
IF Y>=1973 AND M=4 AND N=30 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y=2019 AND M=4 AND N=30 AND MOD(N+R-1,7)<>1 THEN ! 令和元年昭和の日は2019年4月29日、即位の日は2019年5月1日。
LET DAYCOLOR$="RED" ! 間の2019年4月30日は振替休日でなくても公休日。
LET Z$="公休日"
END IF
IF Y=2019 AND M=5 AND N=1 THEN ! 令和元年即位の日は2019年5月1日。
LET DAYCOLOR$="RED"
LET Z$="即位の日"
END IF
IF Y=2019 AND M=5 AND N=2 AND MOD(N+R-1,7)=1 THEN ! 2019年5月2日が月曜なら振替休日とする。
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y=2019 AND M=5 AND N=2 AND MOD(N+R-1,7)<>1 THEN ! 令和元年即位の日は2019年5月1日、憲法記念日は西暦何年であっても5月3日。
LET DAYCOLOR$="RED" ! 間の2019年5月2日は振替休日でなくても公休日。
LET Z$="公休日"
END IF
IF M=5 AND N=3 THEN
LET DAYCOLOR$="RED"
LET Z$="憲法記念日"
END IF
IF Y>=2007 THEN
IF M=5 AND N=4 THEN
LET DAYCOLOR$="RED"
LET Z$="みどりの日"
END IF
ELSEIF Y>=1988 AND Y<2007 THEN
IF M=5 AND N=4 THEN
LET DAYCOLOR$="RED"
LET Z$="国民の休日"
END IF
END IF
IF M=5 AND N=5 THEN
LET DAYCOLOR$="RED"
LET Z$="こどもの日"
END IF
IF Y>=1973 AND M=5 AND N=6 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF Y>=2003 THEN
IF Y=2021 AND M=7 AND N=22 THEN
LET DAYCOLOR$="RED"
LET Z$="海の日"
END IF
IF Y=2020 AND M=7 AND N=23 THEN
LET DAYCOLOR$="RED"
LET Z$="海の日"
END IF
IF Y<>2020 AND Y<>2021 AND M=7 AND ((R<=1 AND R+N=16) OR (R>1 AND R+N=23)) THEN
LET DAYCOLOR$="RED"
LET Z$="海の日"
END IF
ELSEIF Y>=1996 AND Y<2003 THEN
IF M=7 AND N=20 THEN
LET DAYCOLOR$="RED"
LET Z$="海の日"
END IF
IF M=7 AND N=21 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF Y>=2016 THEN
IF Y<>2020 AND Y<>2021 AND M=8 AND N=11 THEN
LET DAYCOLOR$="RED"
LET Z$="山の日"
END IF
IF Y<>2020 AND Y<>2021 AND M=8 AND N=12 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y=2021 AND M=8 AND N=8 THEN
LET DAYCOLOR$="RED"
LET Z$="山の日"
END IF
IF Y=2021 AND M=8 AND N=9 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y=2020 AND M=8 AND N=10 THEN
LET DAYCOLOR$="RED"
LET Z$="山の日"
END IF
IF Y=2020 AND M=8 AND N=11 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
IF Y>=2003 THEN
IF M=9 AND ((R<=1 AND R+N=16) OR (R>1 AND R+N=23)) THEN
LET DAYCOLOR$="RED"
LET Z$="敬老の日"
END IF
ELSEIF Y>=1966 AND Y<2003 THEN
IF M=9 AND N=15 THEN
LET DAYCOLOR$="RED"
LET Z$="敬老の日"
END IF
IF Y>=1973 AND M=9 AND N=16 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF Y=2019 AND M=10 AND N=22 THEN ! 令和元年即位礼正殿の儀は2019年10月22日に執り行われる。
LET DAYCOLOR$="RED"
LET Z$="即位礼正殿の儀"
END IF
IF Y=2019 AND M=10 AND N=23 AND MOD(N+R-1,7)=1 THEN ! 2019年10月23日が月曜なら振替休日とする。
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF Y>=2022 THEN
IF M=10 AND ((R<=1 AND R+N=9) OR (R>1 AND R+N=16)) THEN
LET DAYCOLOR$="RED"
LET Z$="体育の日"
END IF
END IF
IF Y=2021 THEN
IF M=7 AND N=23 THEN
LET DAYCOLOR$="RED"
LET Z$="スポーツの日"
END IF
IF M=7 AND N=24 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF Y=2020 THEN
IF M=7 AND N=24 THEN
LET DAYCOLOR$="RED"
LET Z$="スポーツの日"
END IF
IF M=7 AND N=25 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF Y>=2000 AND Y<2020 THEN
IF M=10 AND ((R<=1 AND R+N=9) OR (R>1 AND R+N=16)) THEN
LET DAYCOLOR$="RED"
LET Z$="体育の日"
END IF
ELSEIF Y>=1966 AND Y<2000 THEN
IF M=10 AND N=10 THEN
LET DAYCOLOR$="RED"
LET Z$="体育の日"
END IF
IF Y>=1973 AND M=10 AND N=11 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
IF M=11 AND N=3 THEN
LET DAYCOLOR$="RED"
LET Z$="文化の日"
END IF
IF M=11 AND N=23 THEN
LET DAYCOLOR$="RED"
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
LET Z$="勤労感謝の日"
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
END IF
IF Y>=1973 AND M=11 AND (N=4 OR N=24) AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
IF Y=2019 THEN
IF M=12 AND N=23 THEN
LET DAYCOLOR$="BLACK" ! 祝日にならない模様。∴LET DAYCOLOR$="BLACK"
LET Z$="平成の天皇誕生日"
END IF
END IF
IF Y>=1989 AND Y<=2018 THEN
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
IF M=12 AND N=23 THEN
LET DAYCOLOR$="RED"
LET Z$="天皇誕生日"
END IF
IF M=12 AND N=24 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
LET D$=DATE$
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
! IF Y=VAL(D$(1:4)) AND M=VAL(D$(5:6)) AND N=VAL(D$(7:8)) THEN LET DAYCOLOR$="CYAN" ! ← 当日の日付の色がシアンになる。
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
END FUNCTION

EXTERNAL FUNCTION QSEI$(TM)
DIM A$(9)
MAT READ A$
LET QSEI$=A$(MOD(TM-1,9)+1)
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
!' DATA 九紫火星
!' DATA 八白土星
!' DATA 七赤金星
!' DATA 六白金星
!' DATA 五黄土星
!' DATA 四緑木星
!' DATA 三碧木星
!' DATA 二黒土星
!' DATA 一白水星
DATA " "
DATA " "
DATA " "
DATA " "
DATA " "
DATA " "
DATA " "
DATA " "
DATA " "
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
EXTERNAL FUNCTION CALC_ETO60$(ALLYEAR)
DIM A$(10),B$(12)
MAT READ A$,B$
LET CALC_ETO60$=A$(MOD(ALLYEAR+6,10)+1)&B$(MOD(ALLYEAR+8,12)+1)
DATA "甲", "乙", "丙", "丁", "戊"
DATA "己", "庚", "辛", "壬", "癸"
DATA "子", "丑", "寅", "卯", "辰", "巳"
DATA "午", "未", "申", "酉", "戌", "亥"
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
EXTERNAL FUNCTION CALC_ETO61$(JOUYOKEI)
DIM A$(60)
MAT READ A$
LET CALC_ETO61$=A$(JOUYOKEI+1)
DATA "甲子","乙丑","丙寅","丁卯","戊辰","己巳","庚午","辛未","壬申","癸酉","甲戌","乙亥","丙子","丁丑","戊寅","己卯","庚辰","辛巳","壬午","癸未"
DATA "甲申","乙酉","丙戌","丁亥","戊子","己丑","庚寅","辛卯","壬辰","癸巳","甲午","乙未","丙申","丁酉","戊戌","己亥","庚子","辛丑","壬寅","癸卯"
DATA "甲辰","乙巳","丙午","丁未","戊申","己酉","庚戌","辛亥","壬子","癸丑","甲寅","乙卯","丙辰","丁巳","戊午","己未","庚申","辛酉","壬戌","癸亥"
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

Re: 月齢カレンダーの修正 - gnuutera2012or文句うさびょん URL

2024/03/08 (Fri) 08:38:20


!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
!' (1)黄道に沿って、天球を28に区分し、星宿(星座の意)の所在を明瞭にしたもの。太陰(月(つき))はおよそ1日に1宿ず
!' つ運行する。中国では蒼竜(東)・玄武(北)・白虎(西)・朱雀(南)の4宮に分け、さらに各宮を七分した。
!' 東は角(すぼし)・亢(あみぼし)・氏(とも)・房(そい)・心(なかご)・尾(あしたれ)・箕(み)
!' 北は斗(ひきつ)・牛(いなみ)・女(うるき)・虚(とみて)・危(うみやめ)・室(はつい)・壁(なまめ)
!' 西は奎(とかき)・婁(たたら)・胃(えきえ)・昴(すばる)・畢(あめふり)・觜(とろき)・參(からすき)
!' 南は井(ちちり)・鬼(たまほめ)・柳(ぬりこ)・星(ほとほり)・張(ちりこ)・翼(たすき)・軫(みつかけ)
!' (2)(1)のうち、牛宿を除いた二十七宿を月日にあてて吉凶を占う法。宿曜道の系統の選日。【広辞苑】
!' (注)氏(とも)と記載したものは、正しくは、五胡十六国時代の「てい」に該当し、低から人偏をとりさったものと同じである。以下同じ。
!' 二十八宿
EXTERNAL FUNCTION SHUKU28$(JOUYOKEI)
DIM A$(28)
MAT READ A$
LET SHUKU28$=A$(JOUYOKEI+1)
DATA "角","亢","氏","房","心","尾","箕","斗","牛","女","虚","危","室","壁"
DATA "奎","婁","胃","昴","畢","觜","參","井","鬼","柳","星","張","翼","軫"
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
!' 中国秦時代からある暦注で、出土した最古の元光元年暦に書かれている。建(たつ),除(のぞく),満(みつ),平(たいら)
!' ,定(さだん),執(とる),破(やぶる),危(あやぶ),成(なる),納(おさん),開(ひらく),閉(とづ)の12あり、納は古い具注暦
!' では収と書かれている。読みは「仮名暦」の記載である。選日法は立春後の最初の寅、啓蟄後の最初の卯、清明後の最
!' 初の辰、立夏後の最初の巳、芒種後の最初の午、小暑後の最初の未、立秋後の最初の申、白露後の最初の酉、寒露後の
!' 最初の戌、立冬後の最初の亥、大雪後の最初の子、小寒後の最初の丑の日を建として順番に配当する。【日本歴史大辞典】
!' 十二直
EXTERNAL FUNCTION TYOKU12$(JOUYOKEI)
DIM A$(12)
MAT READ A$
LET TYOKU12$=A$(JOUYOKEI+1)
DATA "建","除","満","平","定","執","破","危","成","納","開","閉"
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲

EXTERNAL SUB MOON(X,Y,R,H,N)
DIM XX(73),YY(73)
SET COLOR "GRAY"
DRAW DISK WITH SCALE(R)*SHIFT(X,Y)
SET AREA COLOR "YELLOW"
IF H>15 THEN LET SW=-1 ELSE LET SW=1
LET RR=2*(N-.5)
IF RR>0 THEN
FOR T=0 TO 360 STEP 5
LET B=R
IF T>=90 AND T<=270 THEN LET B=R*RR
LET I=I+1
LET YY(I)=R*SIN(RAD(T))+Y
LET XX(I)=SW*B*COS(RAD(T))+X
NEXT T
ELSE
FOR T=-90 TO 90 STEP 5
LET I=I+1
LET YY(I)=R*SIN(RAD(T))+Y
LET XX(I)=SW*R*COS(RAD(T))+X
NEXT T
LET B=R*ABS(RR)
FOR T=85 TO -90 STEP -5
LET I=I+1
LET YY(I)=R*SIN(RAD(T))+Y
LET XX(I)=SW*B*COS(RAD(T))+X
NEXT T
END IF
IF RR>-1 THEN MAT PLOT AREA :XX,YY
END SUB

!'これより以下は、「旧暦 for VB」から「旧暦.bas」を(仮称)十進BASICに移植したものです。
!' http://www.vector.co.jp/soft/win95/personal/se243537.html?_ga=1.114790919.1276112294.1407498580

!' 旧暦計算 標準モジュール「旧暦.bas」Version 1.0
!' Arranged for Visual Basic 6.0 or 5.0 & Excel97 VBA & Access97 VBA
!'              by Masayuki Kanari (C)2002
!'
!' 原典 「旧暦計算サンプルプログラム」
!' Copyright (C) 1993,1994 by H.Takano
!' http://www.vector.co.jp/soft/dos/personal/se016093.html
!'
!' 原典 旧暦計算 JavaScript(ECMAScript) Library "qreki.js" Version 1.5
!' Arranged for ECMAScript(ECMA-262) by Nagano Yutaka (C)1999-2001
!' http://www.ai.wakwak.com/~y-nagano/Programs/koyomi/
!'
!' この標準モジュールの計算結果は無保証です。
!' この標準モジュールはフリーソフトであり、自由に再利用・改良を行ってかまいませんが、
!' 著作権は原典のjgAWK版を開発された高野英明氏、およびJavaScript版を開発された長野隆氏に
!' 帰属しています。上記のリンクより高野氏の「QRSAMP」、長野氏の「qreki.js」を取得し、
!' そのドキュメント内に書かれている再配布規定に従ってください。
!'
!' 使用法
!' 1.旧暦は下記コードをFormモジュールで実行すると、Kyurekiに旧暦が入っています。
!' Kyureki.QYear に旧暦年 Kyureki.QMonth に旧暦月 下記コードの Type Q_Rekiを参照
!' Calc_Kyureki "2002","5","26"   "2002"などは当然ですが、変数でも可
!'
!' 2.二十四節季は下記コードをFormモジュールで実行すると、Sekki24に二十四節季が入っています。
!' Sekki24(i,0) に節季の日時 Sekki24(i,1) に節季の名称が入ります。
!' Calc_Sekki24 "2002"       "2002"は当然ですが、変数でも可
!'Type Q_Reki ' ユーザー定義型を作成
!' QYear As Integer ' 旧暦年
!' QUruu As Boolean ' 平月:False 閏月:True
!' QMonth As Integer ' 旧暦月
!' QDay As Integer ' 旧暦日
!' QRokuyou As String ' 六曜名
!' QJukkan As String ' 十干十二支
!' QMage ' リアルタイム月齢
!' QMagenoon ' 正午月齢
!' QIllumi ' 輝面比 %
!' QMphase As Integer ' 月相 0~27
!'End Type
!' 十干十二支
EXTERNAL FUNCTION CALC_JUKKAN$(TM)
DIM A$(10),B$(12)
MAT READ A$,B$
LET N$ = A$(MOD(INT(TM / 2), 5) * 2 + MOD(TM ,2) + 1)
DATA "甲", "乙", "丙", "丁", "戊"
DATA "己", "庚", "辛", "壬", "癸"
LET CALC_JUKKAN$ = N$ & " " & B$(MOD(TM - 10,12) + 1)
DATA "子", "丑", "寅", "卯", "辰", "巳"
DATA "午", "未", "申", "酉", "戌", "亥"
END FUNCTION
!' ▼▼▼▼▼▼▼▼▼▼ここから▼▼▼▼▼▼▼▼▼▼
EXTERNAL FUNCTION MEMO_JUKKAN$(TM)
DIM A$(10),B$(12)
MAT READ A$,B$
LET N$ = A$(MOD(INT(TM / 2), 5) * 2 + MOD(TM ,2) + 1)
DATA "甲", "乙", "丙", "丁", "戊"
DATA "己", "庚", "辛", "壬", "癸"
LET MEMO_JUKKAN$ = N$ & "" & B$(MOD(TM - 10,12) + 1)
DATA "子", "丑", "寅", "卯", "辰", "巳"
DATA "午", "未", "申", "酉", "戌", "亥"
END FUNCTION
!' ▲▲▲▲▲▲▲▲▲▲ここまで▲▲▲▲▲▲▲▲▲▲
!' 二分二至の時刻または中気の時刻を求める二分二至の時刻
!' 引数 tm .... 計算対象となる時刻(ユリウス日)
!' logitudeas .... 二分二至の時90 中気の時30
!' 戻り値 .... 二分二至の時刻または中気の時刻(ユリウス日)
!' グローバル変数rm_sun0にその時の太陽黄経をセットする
EXTERNAL FUNCTION CALC_CHU(TM, LOGITUDEAS)
LET TM1 = INT(TM) !' 時刻引数を分解する
LET TM2 = TM - TM1 - 9 / 24 !' JST ==> DT
!' 二分二至の時刻または中気の黄経λsun0を求める
LET T = (TM2 + 0.5 + TM1 - 2451545) / 36525
LET RM_SUN = LONGITUDE_SUN(T)
LET RM_SUN0 = LOGITUDEAS * INT(RM_SUN / LOGITUDEAS)
!' 繰り返し計算によって中気の時刻を計算する(誤差が±1.0 sec以内になったら打ち切る)
DO
LET T = (TM2 + 0.5 + TM1 - 2451545) / 36525
LET RM_SUN = LONGITUDE_SUN(T) !' 太陽の黄経λsunを計算
LET DELTA_RM = RM_SUN - RM_SUN0 !' 黄経差Δλ
!' Δλの引き込み範囲(±180°)を逸脱した場合には、補正を行う
IF DELTA_RM > 180 THEN
LET DELTA_RM = DELTA_RM - 360
ELSEIF DELTA_RM < -180 THEN
LET DELTA_RM = DELTA_RM + 360
END IF
LET DELTA_T1 = INT(DELTA_RM * 365.24219878 / 360) !' 時刻引数の補正値 Δt
LET DELTA_T2 = DELTA_RM * 365.24219878 / 360
LET DELTA_T2 = DELTA_T2 - DELTA_T1
LET TM1 = TM1 - DELTA_T1 !' 時刻引数の補正
LET TM2 = TM2 - DELTA_T2
IF TM2 < 0 THEN
LET TM2 = TM2 + 1
LET TM1 = TM1 - 1
END IF
LOOP UNTIL ABS(DELTA_T1 + DELTA_T2) < (1 / 86400)
LET CALC_CHU = TM1 + TM2 + 9 / 24
END FUNCTION

!' 朔の計算
!' 与えられた時刻の直近の朔の時刻(JST)を求める
!' 引数 tm ........ 計算対象となる時刻(ユリウス日)
!' 戻り値 ........ 朔の時刻 引数、戻り値ともユリウス日で表し、時分秒は日の小数で表す
EXTERNAL FUNCTION CALC_SAKU(TM)
LET LC = 1 !' ループカウンタのセット
LET TM1 = INT(TM) !' 時刻引数を分解する
LET TM2 = TM - TM1 - 9 / 24 !' JST ==> DT
!' 繰り返し計算によって朔の時刻を計算する(誤差が±1.0 sec以内になったら打ち切る)
DO
LET T = (TM2 + 0.5 + TM1 - 2451545) / 36525
LET RM_SUN = LONGITUDE_SUN(T) !' 太陽の黄経λsunを計算
LET RM_MOON = LONGITUDE_MOON(T) !' 月の黄経λmoonを計算
LET DELTA_RM = RM_MOON - RM_SUN !' 月と太陽の黄経差Δλ
!' ループの1回目(Lc=1)で delta_rm < 0 の場合には引き込み範囲に入るように補正する
IF LC = 1 AND DELTA_RM < 0 THEN
LET DELTA_RM = NORMALIZATION_ANGLE(DELTA_RM)
!' 春分の近くで朔がある場合(0 ≦λsun≦ 20)で、月の黄経λmoon≧300 の
!' 場合には、Δλ= 360 - Δλ と計算して補正する
ELSEIF RM_SUN >= 0 AND RM_SUN <= 20 AND RM_MOON >= 300 THEN
LET DELTA_RM = NORMALIZATION_ANGLE(DELTA_RM)
LET DELTA_RM = 360 - DELTA_RM
!' Δλの引き込み範囲(±40°)を逸脱した場合には、補正を行う
ELSEIF ABS(DELTA_RM) > 40 THEN
LET DELTA_RM = NORMALIZATION_ANGLE(DELTA_RM)
END IF
LET DELTA_T1 = INT(DELTA_RM * 29.530589 / 360) !' 時刻引数の補正値 Δt
LET DELTA_T2 = DELTA_RM * 29.530589 / 360
LET DELTA_T2 = DELTA_T2 - DELTA_T1
LET TM1 = TM1 - DELTA_T1 !' 時刻引数の補正
LET TM2 = TM2 - DELTA_T2
IF TM2 < 0 THEN
LET TM2 = TM2 + 1
LET TM1 = TM1 - 1
END IF
!' ループ回数が15回になったら、初期値 tm を tm-26 とする
IF LC = 15 AND ABS(DELTA_T1 + DELTA_T2) > (1 / 86400) THEN
LET TM1 = INT(TM - 26)
LET TM2 = 0
!' 初期値を補正したにも関わらず、振動を続ける場合には初期値を答えとして返して強制的にループを抜け出して異常終了させる
ELSEIF LC > 30 AND ABS(DELTA_T1 + DELTA_T2) > (1 / 86400) THEN
LET TM1 = TM
LET TM2 = 0
EXIT DO
END IF
LET LC = LC + 1
LOOP UNTIL ABS(DELTA_T1 + DELTA_T2) < (1 / 86400)
!' 時刻引数を合成するのと、DT ==> JST 変換を行い、戻り値とする
LET CALC_SAKU = TM2 + TM1 + 9 / 24
END FUNCTION


REM 続き

!' 角度の正規化を行う。すなわち引数の範囲を0≦θ<360にする
EXTERNAL FUNCTION NORMALIZATION_ANGLE(ANGLE)
LET NORMALIZATION_ANGLE = MOD(ANGLE+360,360)
END FUNCTION

EXTERNAL FUNCTION LONGITUDE_SUN(T) !' 太陽の黄経λsunを計算する
!' 摂動項の計算
LET ANG = NORMALIZATION_ANGLE(31557 * T + 161)
LET TH = 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(29930 * T + 48)
LET TH = TH + 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(2281 * T + 221)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(155 * T + 118)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(33718 * T + 316)
LET TH = TH + 0.0006 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(9038 * T + 64)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(3035 * T + 110)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(65929 * T + 45)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(22519 * T + 352)
LET TH = TH + 0.0013 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(45038 * T + 254)
LET TH = TH + 0.0015 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(445267 * T + 208)
LET TH = TH + 0.0018 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(19 * T + 159)
LET TH = TH + 0.0018 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(32964 * T + 158)
LET TH = TH + 0.002 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(71998.1 * T + 265.1)
LET TH = TH + 0.02 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(35999.05 * T + 267.52)
LET TH = TH - 0.0048 * T * COS(PI * ANG / 180)
LET TH = TH + 1.9147 * COS(PI * ANG / 180)
!' 比例項の計算
LET ANG = NORMALIZATION_ANGLE(36000.7695 * T)
LET ANG = NORMALIZATION_ANGLE(ANG + 280.4659)
LET LONGITUDE_SUN = NORMALIZATION_ANGLE(TH + ANG)
END FUNCTION

EXTERNAL FUNCTION LONGITUDE_MOON(T) !' 月の黄経λmoonを計算する
!' 摂動項の計算
LET ANG = NORMALIZATION_ANGLE(2322131 * T + 191)
LET TH = 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(4067 * T + 70)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(549197 * T + 220)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1808933 * T + 58)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(349472 * T + 337)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(381404 * T + 354)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(958465 * T + 340)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(12006 * T + 187)
LET TH = TH + 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(39871 * T + 223)
LET TH = TH + 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(509131 * T + 242)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1745069 * T + 24)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1908795 * T + 90)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(2258267 * T + 156)
LET TH = TH + 0.0006 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(111869 * T + 38)
LET TH = TH + 0.0006 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(27864 * T + 127)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(485333 * T + 186)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(405201 * T + 50)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(790672 * T + 114)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1403732 * T + 98)
LET TH = TH + 0.0008 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(858602 * T + 129)
LET TH = TH + 0.0009 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1920802 * T + 186)
LET TH = TH + 0.0011 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1267871 * T + 249)
LET TH = TH + 0.0012 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1856938 * T + 152)
LET TH = TH + 0.0016 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(401329 * T + 274)
LET TH = TH + 0.0018 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(341337 * T + 16)
LET TH = TH + 0.0021 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(71998 * T + 85)
LET TH = TH + 0.0021 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(990397 * T + 357)
LET TH = TH + 0.0021 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(818536 * T + 151)
LET TH = TH + 0.0022 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(922466 * T + 163)
LET TH = TH + 0.0023 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(99863 * T + 122)
LET TH = TH + 0.0024 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1379739 * T + 17)
LET TH = TH + 0.0026 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(918399 * T + 182)
LET TH = TH + 0.0027 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1934 * T + 145)
LET TH = TH + 0.0028 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(541062 * T + 259)
LET TH = TH + 0.0037 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1781068 * T + 21)
LET TH = TH + 0.0038 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(133 * T + 29)
LET TH = TH + 0.004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1844932 * T + 56)
LET TH = TH + 0.004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1331734 * T + 283)
LET TH = TH + 0.004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(481266 * T + 205)
LET TH = TH + 0.005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(31932 * T + 107)
LET TH = TH + 0.0052 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(926533 * T + 323)
LET TH = TH + 0.0068 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(449334 * T + 188)
LET TH = TH + 0.0079 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(826671 * T + 111)
LET TH = TH + 0.0085 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1431597 * T + 315)
LET TH = TH + 0.01 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1303870 * T + 246)
LET TH = TH + 0.0107 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(489205 * T + 142)
LET TH = TH + 0.011 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1443603 * T + 52)
LET TH = TH + 0.0125 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(75870 * T + 41)
LET TH = TH + 0.0154 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(513197.9 * T + 222.5)
LET TH = TH + 0.0304 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(445267.1 * T + 27.9)
LET TH = TH + 0.0347 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(441199.8 * T + 47.4)
LET TH = TH + 0.0409 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(854535.2 * T + 148.2)
LET TH = TH + 0.0458 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1367733.1 * T + 280.7)
LET TH = TH + 0.0533 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(377336.3 * T + 13.2)
LET TH = TH + 0.0571 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(63863.5 * T + 124.2)
LET TH = TH + 0.0588 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(966404 * T + 276.5)
LET TH = TH + 0.1144 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(35999.05 * T + 87.53)
LET TH = TH + 0.1851 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(954397.74 * T + 179.93)
LET TH = TH + 0.2136 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(890534.22 * T + 145.7)
LET TH = TH + 0.6583 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(413335.35 * T + 10.74)
LET TH = TH + 1.274 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(477198.868 * T + 44.963)
LET TH = TH + 6.2888 * COS(PI * ANG / 180)
!' 比例項の計算
LET ANG = NORMALIZATION_ANGLE(481267.8809 * T)
LET ANG = NORMALIZATION_ANGLE(ANG + 218.3162)
LET LONGITUDE_MOON = NORMALIZATION_ANGLE(TH + ANG)
END FUNCTION

!' ユリウス日(JD)から年月日、時分秒(世界時)を計算する
!' この関数で求めた年月日は、グレゴリオ暦法によって表されている
EXTERNAL FUNCTION JD2YMDT$(JD)
LET X0 = INT(JD + 68570)
LET X1 = INT(X0 / 36524.25)
LET X2 = X0 - INT(36524.25 * X1 + 0.75)
LET X3 = INT((X2 + 1) / 365.2425)
LET X4 = X2 - INT(365.25 * X3) + 31
LET X5 = INT(INT(X4) / 30.59)
LET X6 = INT(INT(X5) / 11)
LET GDAY = X4 - INT(30.59 * X5)
LET GMONTH = X5 - 12 * X6 + 2
LET GYEAR = 100 * (X1 - 49) + X3 + X6
!' 2月30日の補正
IF GMONTH = 2 AND GDAY > 28 THEN
IF MOD(GYEAR,100) = 0 AND MOD(GYEAR,400) = 0 THEN
LET GDAY = 29
ELSEIF MOD(GYEAR,4) = 0 AND MOD(GYEAR,100) > 0 THEN
LET GDAY = 29
ELSE
LET GDAY = 28
END IF
END IF
LET X0 = 24 * (JD - INT(JD))
LET GHOUR = INT(X0)
LET GMINUTE = INT((X0 - GHOUR) * 60)
LET GSECOND = INT((X0 - GHOUR - GMINUTE / 60) * 3600 + 0.05)
LET JD2YMDT$ = STR$(GYEAR) & "/" & RIGHT$("0"&STR$(GMONTH),2) & "/" & RIGHT$("0"&STR$(GDAY),2) & " " & RIGHT$("0"&STR$(GHOUR),2) & ":" & RIGHT$("0"&STR$(GMINUTE),2) & ":" & RIGHT$("0"&STR$(GSECOND),2)
END FUNCTION

!' 年月日、時分秒(世界時)からユリウス日(JD)を計算する
EXTERNAL FUNCTION YMDT2JD(GYEAR, GMONTH, GDAY, GHOUR, GMINUTE, GSECOND)
IF GMONTH < 3 THEN
LET CALC_GYEAR = GYEAR - 1
LET CALC_GMONTH = GMONTH + 12
ELSE
LET CALC_GYEAR = GYEAR
LET CALC_GMONTH = GMONTH
END IF
LET Y = INT(365.25 * CALC_GYEAR) + INT(CALC_GYEAR / 400) - INT(CALC_GYEAR / 100)
LET Y = Y + INT(30.59 * (CALC_GMONTH - 2)) + 1721088 + GDAY
LET YMDT2JD = Y + (GHOUR + GMINUTE / 60 + GSECOND / 3600) / 24
END FUNCTION

!' 二十四節季
!' Sekki(x,0)  .... 節季日
!' Sekki(x,1)  .... 節季
EXTERNAL SUB CALC_SEKKI24(GYEAR)
DIM A$(24)
MAT READ A$
LET YMD = YMDT2JD(GYEAR, 1, 1, 0, 0, 0)
LET J = 0
FOR I = 0 TO 400 STEP 15
LET SEKKI$ = JD2YMDT$(CALC_CHU(YMD + I, 15))
IF VAL(LEFT$(SEKKI$, 4)) = GYEAR THEN
LET SEKKI24$(J, 0) = SEKKI$
LET SEKKI24$(J, 1) = A$(RM_SUN0 / 15+1)
DATA "春分", "清明", "穀雨", "立夏", "小満", "芒種"
DATA "夏至", "小暑", "大暑", "立秋", "処暑", "白露"
DATA "秋分", "寒露", "霜降", "立冬", "小雪", "大雪"
DATA "冬至", "小寒", "大寒", "立春", "雨水", "啓蟄"
LET J = J + 1
END IF
NEXT I
END SUB

!' 新暦に対応する、旧暦を求める
!' 引数 tm .... 計算する日付(ユリウス日)
!' 戻り値 .... kyureki
EXTERNAL SUB CALC_KYUREKI(GYEAR, GMONTH, GDAY)
DIM CHU(0 TO 4), SAKU(0 TO 5), M(0 TO 5, 0 TO 2),ROKU$(6)
LET TM = YMDT2JD(GYEAR, GMONTH, GDAY, 0, 0, 0)
LET CHU(0) = CALC_CHU(TM, 90) !' 計算対象の直前にあたる二分二至の時刻を求める
LET M(0, 0) = INT(RM_SUN0 / 30) + 2 !' 上で求めた二分二至の時の太陽黄経をもとに朔日行列の先頭に月名をセット
FOR I = 1 TO 4
LET CHU(I) = CALC_CHU(CHU(I - 1) + 32, 30)
NEXT I
!' 計算対象の直前にあたる二分二至の直前の朔の時刻を求める
LET SAKU(0) = CALC_SAKU(CHU(0))
!' 朔の時刻を求める
FOR I = 1 TO 5
LET SAKU(I) = CALC_SAKU(SAKU(I - 1) + 30)
!' 前と同じ時刻を計算した場合(両者の差が26日以内)には、初期値を+33日にして再実行させる
IF ABS(INT(SAKU(I - 1)) - INT(SAKU(I))) <= 26 THEN
LET SAKU(I) = CALC_SAKU(SAKU(I - 1) + 35)
END IF
NEXT I
!' saku(1)が二分二至の時刻以前になってしまった場合には、朔をさかのぼり過ぎたと考えて、
!' 朔の時刻を繰り下げて修正する
!' その際、計算もれsaku(4)になっている部分を補うため、朔の時刻を計算する
!' 近日点通過の近辺で朔があると起こる事があるようだ...?
IF INT(SAKU(1)) <= INT(CHU(0)) THEN
FOR I = 0 TO 4
LET SAKU(I) = SAKU(I + 1)
NEXT I
LET SAKU(4) = CALC_SAKU(SAKU(3) + 35)
!' saku(0)が二分二至の時刻以後になってしまった場合には、朔をさかのぼり足りないと見て、
!' 朔の時刻を繰り上げて修正する
!' その際、計算もれsaku(0)になっている部分を補うため、朔の時刻を計算する
!' 春分点の近辺で朔があると起こる事があるようだ...?
ELSEIF INT(SAKU(0)) > INT(CHU(0)) THEN
FOR I = 4 TO 1 STEP -1
LET SAKU(I) = SAKU(I - 1)
NEXT I
LET SAKU(0) = CALC_SAKU(SAKU(0) - 27)
END IF
!' 閏月検索Flagセット 節月で4ヶ月の間に朔が5回あると、閏月がある可能性がある
!' lap=false:平月 lap=true:閏月
IF INT(SAKU(4)) <= INT(CHU(3)) THEN LET LAP=1 ELSE LET LAP=0
!' 朔日行列の作成
!' m(i,0) ... 月名(1:正月 2:2月 3:3月 ....)
!' m(i,1) ... 閏フラグ(false:平月 true:閏月)
!' m(i,2) ... 朔日のjd
!' m(0, 0)はこの関数の始めの方ですでに代入済み
LET M(0, 1) = 0
LET M(0, 2) = INT(SAKU(0))
FOR I = 1 TO 5
IF LAP=1 AND I > 1 THEN
IF CHU(I - 1) <= INT(SAKU(I - 1)) OR CHU(I - 1) >= INT(SAKU(I)) THEN
LET M(I - 1, 0) = M(I - 2, 0)
LET M(I - 1, 1) = 1
LET M(I - 1, 2) = INT(SAKU(I - 1))
LET LAP = 0
END IF
END IF
LET M(I, 0) = M(I - 1, 0) + 1
IF M(I, 0) > 12 THEN
LET M(I, 0) = M(I, 0) - 12
END IF
LET M(I, 2) = INT(SAKU(I))
LET M(I, 1) = 0
NEXT I
!' 朔日行列から旧暦を求める
LET STATE = 0
FOR I = 0 TO 5
IF INT(TM) < INT(M(I, 2)) THEN
LET STATE = 1
EXIT FOR
ELSEIF INT(TM) = INT(M(I, 2)) THEN
LET STATE = 2
EXIT FOR
END IF
NEXT I
IF STATE = 0 OR STATE = 1 THEN
LET I = I - 1
END IF
LET QURUU = M(I, 1)
LET QMONTH = M(I, 0)
LET QDAY = INT(TM) - INT(M(I, 2)) + 1
!'旧暦年の計算 旧暦月が10以上でかつ新暦月より大きい場合には、まだ年を越していないはず...
!'YMD$ = JD2YMDT$(tm)
!'QYear = Val(Left$(YMD$, 4))
!'If QMonth > 9 And QMonth > Val(Mid$(YMD$, 6, 2)) Then
LET QYEAR = GYEAR
IF QMONTH > 9 AND QMONTH > GMONTH THEN
LET QYEAR = QYEAR - 1
END IF
!' 六曜を求める
MAT READ ROKU$
DATA "大安", "赤口", "先勝", "友引", "先負", "仏滅"
LET QROKUYOU$ = ROKU$(MOD((QMONTH + QDAY) ,6) + 1)
!' 十干十二支を求める
LET QJUKKAN$ = CALC_JUKKAN$(TM)
!' リアルタイム月齢を求める
LET QMAGE = TM - SAKU(I)
IF QMAGE < 0 THEN
LET QMAGE = TM - SAKU(I - 1)
END IF
!' 正午月齢を求める
LET QMAGENOON = INT(TM) + 0.5 - SAKU(I)
IF QMAGENOON < 0 THEN
LET QMAGENOON = INT(TM) + 0.5 - SAKU(I - 1)
END IF
!' 輝面比を求める
LET TM1 = INT(TM)
LET TM2 = TM - TM1 - 9 / 24
LET T = (TM2 + 0.5) / 36525 + (TM1 - 2451545) / 36525
LET QILLUMI = (1 - COS(PI * NORMALIZATION_ANGLE(LONGITUDE_MOON(T) - LONGITUDE_SUN(T)) / 180)) * 50
!' 月相を求める 輝面比の計算で求めた変数tを使用
LET QMPHASE = INT(NORMALIZATION_ANGLE(LONGITUDE_MOON(T) - LONGITUDE_SUN(T)) / 360 * 28 + 0.5)
LET QMPHASE = MOD(QMPHASE, 28)
END SUB

人工知能でプログラミング - しばっち

2024/02/25 (Sun) 08:38:56

copilot(Windows AI)で十進BASICプログラム作ってみた。
https://copilot.microsoft.com/

現状では若干の追記・修正が必要なようです。

AI(人工知能)で大まかに生成してエラー箇所を
修正していけばプログラミングはできる
のではないでしょうか!?


RANDOMIZE
10 PRINT "数あてゲームを始めます!"
20 LET ANSWER = INT(RND * 100) + 1
30 INPUT PROMPT "1から100までの数字を入力してください:": GUESS
40 IF GUESS = ANSWER THEN
PRINT "正解です!"
STOP
END IF
50 IF GUESS < ANSWER THEN
PRINT "もっと大きな数字です。"
GOTO 30
END IF
60 IF GUESS > ANSWER THEN
PRINT "もっと小さな数字です。"
GOTO 30
END IF
END

実行結果

数あてゲームを始めます!
1から100までの数字を入力してください:50
もっと大きな数字です。
1から100までの数字を入力してください:75
もっと大きな数字です。
1から100までの数字を入力してください:87
もっと大きな数字です。
1から100までの数字を入力してください:93
もっと大きな数字です。
1から100までの数字を入力してください:96
もっと大きな数字です。
1から100までの数字を入力してください:99
正解です!

マンデルボックス - しばっち

2024/02/12 (Mon) 08:13:37

マンデルボックス

https://en.wikipedia.org/wiki/Mandelbox
https://digitalfreepen.com/mandelbox370/
https://www.fractalforums.com/programming/mandelbox-2d-questions-and-code-attempt/

とりあえずそれっぽいものは描けるようですが、もしプログラム(アルゴリズム)が間違っていても悪しからず。
マンデルボックスでは複素数ではなく、ベクトルで特定の計算をします。
SCALEやITERを変更するとパターンが変わります。



PUBLIC NUMERIC Z(2),C(2),SCALE
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
SET POINT STYLE 1
LET SCALE=2
LET ITER=6
SET WINDOW -1,1,1,-1
ASK BITMAP SIZE XSIZE,YSIZE
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
LET C(1)=WORLDX(X)
LET C(2)=WORLDY(Y)
FOR K=1 TO ITER
CALL ITERATE(Z)
NEXT K
SET POINT COLOR MAGNITUDE(Z)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
NEXT X
NEXT Y
END

EXTERNAL SUB ITERATE(Z())
FOR I=1 TO 2
IF Z(I)>1 THEN
LET Z(I)=2-Z(I)
ELSEIF Z(I)<-1 THEN
LET Z(I)=-2-Z(I)
END IF
NEXT I
IF MAGNITUDE(Z)<.5 THEN
MAT Z=4*Z
ELSEIF MAGNITUDE(Z)<1 THEN
MAT Z=(1/MAGNITUDE(Z)^2)*Z
END IF
MAT Z=SCALE*Z
MAT Z=Z+C
END SUB

EXTERNAL FUNCTION MAGNITUDE(Z())
LET MAGNITUDE=SQR(DOT(Z,Z))
END FUNCTION
----------------------------------------------------------------------------------------
DIM Z(2),C(2)
FOR I=0 TO 255
SET COLOR MIX(I) I/255,I/255,I/255
NEXT I
CLEAR
LET SCALE=-2.5
LET ITER=50
SET WINDOW -2,2,2,-2
ASK BITMAP SIZE XSIZE,YSIZE
DIM MAP(0 TO XSIZE,0 TO YSIZE)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
LET C(1)=WORLDX(X)
LET C(2)=WORLDY(Y)
FOR K=1 TO ITER
CALL T(SCALE,Z,C)
IF MAGNITUDE(Z)>4 THEN EXIT FOR
NEXT K
IF K>=ITER THEN
LET MAP(X,Y)=0
ELSE
LET MAP(X,Y)=MAGNITUDE(Z)+1
END IF
LET HIGHVAL=MAX(HIGHVAL,MAP(X,Y))
NEXT X
NEXT Y
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
LET MAP(X,Y)=MAP(X,Y)*255/HIGHVAL
NEXT X
NEXT Y
MAT PLOT CELLS ,IN -2,-2;2,2:MAP
END

EXTERNAL SUB T(SCALE,Z(),C())
CALL FBOX(Z)
CALL FBALL(Z)
MAT Z=SCALE*Z
MAT Z=Z+C
END SUB

EXTERNAL SUB FBOX(Z())
FOR I=1 TO 2
IF Z(I)>1 THEN
LET Z(I)=2-Z(I)
ELSEIF Z(I)<-1 THEN
LET Z(I)=-2-Z(I)
END IF
NEXT I
END SUB

EXTERNAL SUB FBALL(Z())
IF MAGNITUDE(Z)<.5 THEN
MAT Z=4*Z
ELSEIF MAGNITUDE(Z)<1 THEN
MAT Z=(1/MAGNITUDE(Z)^2)*Z
END IF
END SUB

EXTERNAL FUNCTION MAGNITUDE(Z())
LET MAGNITUDE=SQR(DOT(Z,Z))
END FUNCTION
----------------------------------------------------------------------------------------
PUBLIC NUMERIC Z(2),C(2),SCALE
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
SET POINT STYLE 1
LET SCALE=1.5
LET ITER=100
LET S=2
SET WINDOW -S,S,S,-S
ASK BITMAP SIZE XSIZE,YSIZE
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
LET C(1)=WORLDX(X)
LET C(2)=WORLDY(Y)
FOR K=1 TO ITER
CALL ITERATE(Z)
IF MAGNITUDE(Z)>4 THEN
SET POINT COLOR MAGNITUDE(Z)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB ITERATE(Z())
FOR I=1 TO 2
IF Z(I)>1 THEN
LET Z(I)=2-Z(I)
ELSEIF Z(I)<-1 THEN
LET Z(I)=-2-Z(I)
END IF
NEXT I
IF MAGNITUDE(Z)<.5 THEN
MAT Z=4*Z
ELSEIF MAGNITUDE(Z)<1 THEN
MAT Z=(1/MAGNITUDE(Z)^2)*Z
END IF
MAT Z=SCALE*Z
MAT Z=Z+C
END SUB

EXTERNAL FUNCTION MAGNITUDE(Z())
LET MAGNITUDE=SQR(DOT(Z,Z))
END FUNCTION

メンガースポンジ - しばっち

2024/01/21 (Sun) 09:06:38

シェルピンスキーのカーペットを3次元化してメンガースポンジを作成してみました。

https://ja.wikipedia.org/wiki/メンガーのスポンジ

実行するとSTLファイル(アスキー形式)を書き出します。
別途STLファイル対応3Dビューワソフト、3Dモデリングソフト等が必要です。

https://apps.microsoft.com/store/detail/3d-viewer/9NBLGGH42THS?hl=ja-jp&gl=jp
http://www.vector.co.jp/soft/winnt/art/se379971.html
http://www.vector.co.jp/soft/winnt/art/se502626.html
https://blender.jp/
https://www.meshlab.net/

https://3dviewer.net/
http://fablabshibuya.org/applications/3dviewer/
https://products.aspose.app/3d/jp/conversion

なお、3Dプリントには補修、補正、修正作業等が別途必要です。
https://idarts.co.jp/3dp/3d-model-stl-repair-checker-select/

3Dプリントサービス(有料)
https://make.dmm.com/print/

色々な形を定義したり改造してみるとおもしろいかと思います。


PUBLIC NUMERIC A(-1 TO 1,-1 TO 1,-1 TO 1)
FOR J=-1 TO 1
FOR I=-1 TO 1
READ P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT I
NEXT J
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1

FOR J=-1 TO 1
FOR I=-1 TO 1
READ P
LET A(I,J,0)=P
NEXT I
NEXT J
DATA 1,0,1
DATA 0,0,0
DATA 1,0,1

INPUT PROMPT "LEVEL=":N ! N=2~3 N=3でおよそ23MB
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="menger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*3,#1)
ELSE
FOR K=-1 TO 1
FOR J=-1 TO 1
FOR I=-1 TO 1
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/3,#1)
! IF A(I,J,K)=0 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/3,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

EXTERNAL SUB VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
LET XX=(Y3-Y2)*(Z1-Z3)-(Z3-Z2)*(Y1-Y3)
LET YY=(Z3-Z2)*(X1-X3)-(X3-X2)*(Z1-Z3)
LET ZZ=(X3-X2)*(Y1-Y3)-(Y3-Y2)*(X1-X3)
LET S=SQR(XX^2+YY^2+ZZ^2)
IF S<>0 THEN
LET XX=XX/S
LET YY=YY/S
LET ZZ=ZZ/S
END IF
END SUB

EXTERNAL SUB CUBE(X,Y,Z,L,#1)
LET X1=X-L/2
LET Y1=Y+L/2
LET Z1=Z-L/2
LET X2=X+L/2
LET Y2=Y+L/2
LET Z2=Z-L/2
LET X3=X+L/2
LET Y3=Y+L/2
LET Z3=Z+L/2
LET X4=X-L/2
LET Y4=Y+L/2
LET Z4=Z+L/2
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X2);" ";USING$("-%.######^^^^^",Y2);" ";USING$("-%.######^^^^^",Z2)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"endloop"
PRINT #1:"endfacet"
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X4);" ";USING$("-%.######^^^^^",Y4);" ";USING$("-%.######^^^^^",Z4)
PRINT #1:"endloop"
PRINT #1:"endfacet"
LET X1=X-L/2
LET Y1=Y+L/2
LET Z1=Z+L/2
LET X2=X+L/2
LET Y2=Y+L/2
LET Z2=Z+L/2
LET X3=X+L/2
LET Y3=Y-L/2
LET Z3=Z+L/2
LET X4=X-L/2
LET Y4=Y-L/2
LET Z4=Z+L/2
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X2);" ";USING$("-%.######^^^^^",Y2);" ";USING$("-%.######^^^^^",Z2)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"endloop"
PRINT #1:"endfacet"
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X4);" ";USING$("-%.######^^^^^",Y4);" ";USING$("-%.######^^^^^",Z4)
PRINT #1:"endloop"
PRINT #1:"endfacet"
LET X1=X-L/2
LET Y1=Y-L/2
LET Z1=Z+L/2
LET X2=X+L/2
LET Y2=Y-L/2
LET Z2=Z+L/2
LET X3=X+L/2
LET Y3=Y-L/2
LET Z3=Z-L/2
LET X4=X-L/2
LET Y4=Y-L/2
LET Z4=Z-L/2
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X2);" ";USING$("-%.######^^^^^",Y2);" ";USING$("-%.######^^^^^",Z2)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"endloop"
PRINT #1:"endfacet"
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X4);" ";USING$("-%.######^^^^^",Y4);" ";USING$("-%.######^^^^^",Z4)
PRINT #1:"endloop"
PRINT #1:"endfacet"
LET X1=X-L/2
LET Y1=Y-L/2
LET Z1=Z-L/2
LET X2=X+L/2
LET Y2=Y-L/2
LET Z2=Z-L/2
LET X3=X+L/2
LET Y3=Y+L/2
LET Z3=Z-L/2
LET X4=X-L/2
LET Y4=Y+L/2
LET Z4=Z-L/2
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X2);" ";USING$("-%.######^^^^^",Y2);" ";USING$("-%.######^^^^^",Z2)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"endloop"
PRINT #1:"endfacet"
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X4);" ";USING$("-%.######^^^^^",Y4);" ";USING$("-%.######^^^^^",Z4)
PRINT #1:"endloop"
PRINT #1:"endfacet"
LET X1=X+L/2
LET Y1=Y+L/2
LET Z1=Z-L/2
LET X2=X+L/2
LET Y2=Y-L/2
LET Z2=Z-L/2
LET X3=X+L/2
LET Y3=Y-L/2
LET Z3=Z+L/2
LET X4=X+L/2
LET Y4=Y+L/2
LET Z4=Z+L/2
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X2);" ";USING$("-%.######^^^^^",Y2);" ";USING$("-%.######^^^^^",Z2)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"endloop"
PRINT #1:"endfacet"
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X4);" ";USING$("-%.######^^^^^",Y4);" ";USING$("-%.######^^^^^",Z4)
PRINT #1:"endloop"
PRINT #1:"endfacet"
LET X1=X-L/2
LET Y1=Y-L/2
LET Z1=Z-L/2
LET X2=X-L/2
LET Y2=Y+L/2
LET Z2=Z-L/2
LET X3=X-L/2
LET Y3=Y+L/2
LET Z3=Z+L/2
LET X4=X-L/2
LET Y4=Y-L/2
LET Z4=Z+L/2
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X2);" ";USING$("-%.######^^^^^",Y2);" ";USING$("-%.######^^^^^",Z2)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"endloop"
PRINT #1:"endfacet"
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XX,YY,ZZ)
PRINT #1:"facet normal ";USING$("-%.######^^^^^",XX);" ";USING$("-%.######^^^^^",YY);" ";USING$("-%.######^^^^^",ZZ)
PRINT #1:"outer loop"
PRINT #1:"vertex ";USING$("-%.######^^^^^",X1);" ";USING$("-%.######^^^^^",Y1);" ";USING$("-%.######^^^^^",Z1)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X3);" ";USING$("-%.######^^^^^",Y3);" ";USING$("-%.######^^^^^",Z3)
PRINT #1:"vertex ";USING$("-%.######^^^^^",X4);" ";USING$("-%.######^^^^^",Y4);" ";USING$("-%.######^^^^^",Z4)
PRINT #1:"endloop"
PRINT #1:"endfacet"
END SUB
----------------------------------------------------------------------------------------------------------------------------------------
5*5*5サイズにして4穴のメンガースポンジです。
必要ルーチンを上からコピペしてください。


PUBLIC NUMERIC A(-2 TO 2,-2 TO 2,-2 TO 2)
FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET A(I,J,-2)=P
LET A(I,J,0)=P
LET A(I,J,2)=P
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT I
NEXT J
DATA 1,0,1,0,1
DATA 0,0,0,0,0
DATA 1,0,1,0,1
DATA 0,0,0,0,0
DATA 1,0,1,0,1

INPUT PROMPT "LEVEL=":N ! N=1~2
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="4穴menger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*5,#1)
ELSE
FOR K=-2 TO 2
FOR J=-2 TO 2
FOR I=-2 TO 2
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/5,#1)
! IF A(I,J,K)=0 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/5,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

以下略
----------------------------------------------------------------------------------------------------------------------------------------
三線(横線)のメンガースポンジです。
必要ルーチンを上からコピペしてください。


PUBLIC NUMERIC A(-3 TO 3,-3 TO 3,-3 TO 3)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-3)=P
LET A(I,J,3)=P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-2)=P
LET A(I,J,0)=P
LET A(I,J,2)=P
NEXT I
NEXT J
DATA 1,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,1

INPUT PROMPT "LEVEL=":N ! N=1~2
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="三線menger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*7,#1)
ELSE
FOR K=-3 TO 3
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/7,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

以下略
----------------------------------------------------------------------------------------------------------------------------------------
十字型のメンガースポンジです。
必要ルーチンを上からコピペしてください。


PUBLIC NUMERIC A(-2 TO 2,-2 TO 2,-2 TO 2)
FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET A(I,J,-2)=P
LET A(I,J,2)=P
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,1,0,1,1
DATA 1,0,0,0,1
DATA 1,1,0,1,1
DATA 1,1,1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT J
NEXT I
DATA 1,1,0,1,1
DATA 1,1,0,1,1
DATA 0,0,0,0,0
DATA 1,1,0,1,1
DATA 1,1,0,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET A(I,J,0)=P
NEXT I
NEXT J
DATA 1,0,0,0,1
DATA 0,0,0,0,0
DATA 0,0,0,0,0
DATA 0,0,0,0,0
DATA 1,0,0,0,1

INPUT PROMPT "LEVEL=":N ! N=1~2
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="十字型menger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*5,#1)
ELSE
FOR K=-2 TO 2
FOR J=-2 TO 2
FOR I=-2 TO 2
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/5,#1)
! IF A(I,J,K)=0 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/5,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

以下略
----------------------------------------------------------------------------------------------------------------------------------------
王型メンガースポンジです。
必要ルーチンをコピペしてください。


PUBLIC NUMERIC A(-3 TO 3,-3 TO 3,-3 TO 3)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-3)=P
LET A(I,J,3)=P
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-2)=P
LET A(I,J,0)=P
LET A(I,J,2)=P
NEXT I
NEXT J
DATA 1,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT I
NEXT J
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 0,0,0,0,0,0,0
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1

INPUT PROMPT "LEVEL=":N ! N=1~2
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="王型menger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*7,#1)
ELSE
FOR K=-3 TO 3
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/7,#1)
! IF A(I,J,K)=0 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/7,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

以下略
----------------------------------------------------------------------------------------------------------------------------------------
相互再帰による王型と十字型のメンガースポンジです。
必要ルーチンをコピペしてください。


PUBLIC NUMERIC A(-3 TO 3,-3 TO 3,-3 TO 3),B(-2 TO 2,-2 TO 2,-2 TO 2)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-3)=P
LET A(I,J,3)=P
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-2)=P
LET A(I,J,0)=P
LET A(I,J,2)=P
NEXT I
NEXT J
DATA 1,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT I
NEXT J
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 0,0,0,0,0,0,0
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET B(I,J,-2)=P
LET B(I,J,2)=P
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,1,0,1,1
DATA 1,0,0,0,1
DATA 1,1,0,1,1
DATA 1,1,1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET B(I,J,-1)=P
LET B(I,J,1)=P
NEXT I
NEXT J
DATA 1,1,0,1,1
DATA 1,1,0,1,1
DATA 0,0,0,0,0
DATA 1,1,0,1,1
DATA 1,1,0,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ P
LET B(I,J,0)=P
NEXT I
NEXT J
DATA 1,0,0,0,1
DATA 0,0,0,0,0
DATA 0,0,0,0,0
DATA 0,0,0,0,0
DATA 1,0,0,0,1

INPUT PROMPT "LEVEL=":N ! N=1~2
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="menger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER1(N,0,0,0,1,#1)
! CALL MENGER2(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER1(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*7,#1)
ELSE
FOR K=-3 TO 3
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A(I,J,K)=1 THEN CALL MENGER2(N-1,X+I*L,Y+J*L,Z+K*L,L/5,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

EXTERNAL SUB MENGER2(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*5,#1)
ELSE
FOR K=-2 TO 2
FOR J=-2 TO 2
FOR I=-2 TO 2
IF B(I,J,K)=1 THEN CALL MENGER1(N-1,X+I*L,Y+J*L,Z+K*L,L/7,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

以下略
----------------------------------------------------------------------------------------------------------------------------------------
ハート型を定義してみました。※ 3次元で考えるのは結構難しい !?
必要ルーチンをコピペしてください。


PUBLIC NUMERIC A(-5 TO 5,-5 TO 5,-5 TO 5)
FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,-5)=P
LET A(I,J,5)=P
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1,1,1,1,1
DATA 1,1,0,1,1,1,1,1,0,1,1
DATA 1,0,0,0,1,1,1,0,0,0,1
DATA 1,0,0,0,0,1,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 1,1,1,0,0,0,0,0,1,1,1
DATA 1,1,1,1,0,0,0,1,1,1,1
DATA 1,1,1,1,1,0,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,4)=P
NEXT I
NEXT J
DATA 1,1,0,1,1,1,1,1,0,1,1
DATA 1,1,0,1,1,1,1,1,0,1,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,1,0,1,1,0,1,1,0,1,1
DATA 1,1,0,1,1,1,1,1,0,1,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,3)=P
NEXT I
NEXT J
DATA 1,0,0,0,1,1,1,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,1,1,1,0,0,0,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,2)=P
NEXT I
NEXT J
DATA 1,0,0,0,0,1,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,1,0,0,0,0,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,1)=P
LET A(I,J,0)=P
NEXT I
NEXT J
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,-1)=P
NEXT I
NEXT J
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 1,1,0,0,0,0,0,0,0,1,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,-2)=P
NEXT I
NEXT J
DATA 1,1,1,0,0,0,0,0,1,1,1
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,1,1,0,0,0,0,0,1,1,1
DATA 1,1,1,0,0,0,0,0,1,1,1
DATA 1,1,1,0,0,0,0,0,1,1,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,-3)=P
NEXT I
NEXT J
DATA 1,1,1,1,0,0,0,1,1,1,1
DATA 1,1,0,1,0,0,0,1,0,1,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,1,1,0,0,0,0,0,1,1,1
DATA 1,1,1,1,0,0,0,1,1,1,1
DATA 1,1,1,1,0,0,0,1,1,1,1
DATA 1,1,1,1,0,0,0,1,1,1,1

FOR J=-5 TO 5
FOR I=-5 TO 5
READ P
LET A(I,J,-4)=P
NEXT I
NEXT J
DATA 1,1,1,1,1,0,1,1,1,1,1
DATA 1,1,0,1,1,0,1,1,0,1,1
DATA 1,0,0,0,1,0,1,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 1,0,0,0,0,0,0,0,0,0,1
DATA 0,0,0,0,0,0,0,0,0,0,0
DATA 1,1,0,0,0,0,0,0,0,1,1
DATA 1,1,1,0,0,0,0,0,1,1,1
DATA 1,1,1,1,0,0,0,1,1,1,1
DATA 1,1,1,1,1,0,1,1,1,1,1
DATA 1,1,1,1,1,0,1,1,1,1,1

INPUT PROMPT "LEVEL=":N ! N=1~2
!FILE GETSAVENAME F$,"STLファイル|*.stl"
!IF F$="" THEN STOP
!IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$&".stl"
LET F$="ハートmenger"&STR$(N)&".stl"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"solid ";F$
CALL MENGER(N,0,0,0,1,#1)
PRINT #1:"endsolid"
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,L*11,#1)
ELSE
FOR K=-5 TO 5
FOR J=-5 TO 5
FOR I=-5 TO 5
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/11,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB

以下略

Re: メンガースポンジ - しばっち

2024/01/21 (Sun) 09:09:09

前ページでは直接STLファイルを書き出していましたが
OPENSCADというツールを使用すれば簡単にできます。
https://openscad.org/

実行するとscadファイルを書き出します。※OPENSCADでは直接プログラムすることもできます。
OPENSCADからscadファイルを読み込みrenderボタンでレンダリングしてくれます。(※レンダリングには少々時間を要します)
レンダリングが終わればSTLファイルをエクスポートできます。


PUBLIC NUMERIC A(-1 TO 1,-1 TO 1,-1 TO 1)
FOR J=-1 TO 1
FOR I=-1 TO 1
READ P
LET A(I,J,-1)=P
LET A(I,J,1)=P
NEXT I
NEXT J
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1
FOR J=-1 TO 1
FOR I=-1 TO 1
READ P
LET A(I,J,0)=P
NEXT I
NEXT J
DATA 1,0,1
DATA 0,0,0
DATA 1,0,1
INPUT PROMPT "LEVEL=":N
LET F$="menger"&STR$(N)&".scad"
OPEN #1:NAME F$
ERASE #1
CALL MENGER(N,0,0,0,1,#1)
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
PRINT #1:"translate([";x;",";y;",";z;"]) {"
PRINT #1:" cube(";L*3;",center=true);" ! 球や多角柱、円柱、多角錐、円錐等も指定できます。
PRINT #1:" }"
ELSE
FOR K=-1 TO 1
FOR J=-1 TO 1
FOR I=-1 TO 1
IF A(I,J,K)=1 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/3,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB
---------------------------------------------------------------------------------------------------
上のプログラムは下記の条件式を使っても記述できます。

INPUT PROMPT "LEVEL=":N
LET F$="menger"&STR$(N)&".scad"
OPEN #1:NAME F$
ERASE #1
CALL MENGER(N,0,0,0,1,#1)
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,L,#1)
IF N=0 THEN
PRINT #1:"translate([";x;",";y;",";z;"]) {"
PRINT #1:" cube(";L*3;",center=true);"
PRINT #1:" }"
ELSE
FOR K=-1 TO 1
FOR J=-1 TO 1
FOR I=-1 TO 1
IF BITOR(I,J)<>0 AND BITOR(I,K)<>0 AND BITOR(J,K)<>0 THEN CALL MENGER(N-1,X+I*L,Y+J*L,Z+K*L,L/3,#1)
NEXT I
NEXT J
NEXT K
END IF
END SUB
---------------------------------------------------------------------------------------------------
ツールと組み合わせると3次元グラフィックスはそんなに難しくはない !? (と思う)
3D平面のデータを書き出します。


OPEN #1:NAME "surface.dat"
ERASE #1
LET XS=-4*PI
LET XE=4*PI
LET YS=-4*PI
LET YE=4*PI
LET N=100
LET L=(XE-XS)/N
LET W=(YE-YS)/N
FOR Y=YS TO YE STEP W
FOR X=XS TO XE STEP L
LET Z=F(X,Y) ! Z>0
PRINT #1:Z;
NEXT X
PRINT #1
NEXT Y
CLOSE #1
OPEN #1:NAME "surface.scad"
ERASE #1
PRINT #1:"surface(file=";CHR$(34);"surface.dat";CHR$(34);",center=true);"
CLOSE #1
!EXECUTE "openscad.exe" WITH ("-o","surface.stl","surface.scad")
END

EXTERNAL FUNCTION F(X,Y) ! 3次元陽関数
LET F=COS(SQR(X*X+Y*Y))+2 ! F(X,Y)>0
END FUNCTION
---------------------------------------------------------------------------------------------------
リサージュ曲線を書き出します。

RANDOMIZE
OPTION BASE 0
OPTION ANGLE DEGREES
LET N=500
LET R=10
LET A=INT(RND*10+1)
LET B=INT(RND*10+1)
LET C=INT(RND*10+1)
DIM X(N),Y(N),Z(N)
LET F$="lissajous"&STR$(A)&"-"&STR$(B)&"-"&STR$(C)&".scad"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"r=1;"
FOR I=0 TO N
LET T=360/N*I
LET X(I)=R*COS(A*T)
LET Y(I)=R*SIN(B*T)
LET Z(I)=R*SIN(C*T)
NEXT I
FOR I=0 TO N-1
PRINT #1:"hull(){"
PRINT #1:" translate([";X(I);",";Y(I);",";Z(I);"]) sphere(r);"
PRINT #1:" translate([";X(I+1);",";Y(I+1);",";Z(I+1);"]) sphere(r);"
PRINT #1:"};"
NEXT I
CLOSE #1
END
---------------------------------------------------------------------------------------------------
立方体(6面体)を定義しています。


LET VERTEX$="vertex=["
FOR I=1 TO 7
READ X,Y,Z
LET VERTEX$=VERTEX$&"["&STR$(X)&","&STR$(Y)&","&STR$(Z)&"],"
NEXT I
READ X,Y,Z
LET VERTEX$=VERTEX$&"["&STR$(X)&","&STR$(Y)&","&STR$(Z)&"]];"
DATA 1 , 1 , 1 ! 座標データ
DATA 1 ,-1 , 1
DATA 1 ,-1 ,-1
DATA 1 , 1 ,-1
DATA -1 , 1 , 1
DATA -1 ,-1 , 1
DATA -1 , 1 ,-1
DATA -1 ,-1 ,-1
OPEN #1:NAME "立方体.scad"
ERASE #1
LET MESH$="mesh=["
FOR I=1 TO 11
READ A,B,C
LET MESH$=MESH$&"["&STR$(A)&","&STR$(B)&","&STR$(C)&"],"
NEXT I
READ A,B,C
LET MESH$=MESH$&"["&STR$(A)&","&STR$(B)&","&STR$(C)&"]];"
PRINT #1:VERTEX$
PRINT #1:MESH$
PRINT #1:"polyhedron(points=vertex,faces=mesh);"
CLOSE #1
DATA 0,1,2 ! メッシュデータ
DATA 0,2,3
DATA 1,0,4
DATA 1,4,5
DATA 4,0,3
DATA 4,3,6
DATA 2,1,5
DATA 2,5,7
DATA 6,3,2
DATA 6,2,7
DATA 5,4,6
DATA 5,6,7
END

Re: メンガースポンジ - しばっち

2024/01/21 (Sun) 09:11:20

前ページにあるプログラムでは条件式によって3次元メンガースポンジを定義した。
これを拡張すると4次元のメンガースポンジを定義できる。


EXTERNAL SUB MENGER(N,X,Y,Z,W,SIZE,#1)
IF N=0 THEN
CALL CUBE(X,Y,Z,W,SIZE*4,#1) ! 4次元立方体
ELSE
FOR L=-1 TO 1
FOR K=-1 TO 1
FOR J=-1 TO 1
FOR I=-1 TO 1
IF BITOR(I,J)<>0 AND BITOR(I,K)<>0 AND BITOR(I,L)<>0 AND BITOR(J,K)<>0 AND BITOR(J,L)<>0 AND BITOR(K,L)<>0 THEN CALL MENGER(N-1,X+I*SIZE,Y+J*SIZE,Z+K*SIZE,W+L*SIZE,SIZE/4,#1)
NEXT I
NEXT J
NEXT K
NEXT L
END IF
END SUB

但し、サブルーチンCUBEは正真正銘の4次元立方体(超立方体)です。
残念ながらこのCUBEルーチンは定義できません。
※この4次元立方体の頂点は16個になります。2次元(平面)では4個、3次元では8個です。


そこで3次元を2次元に投影するときに行う透視変換(3次元→2次元)を
4次元に適用してみる(4次元→3次元)

透視変換にはZ値を無視した平行投影([X,Y,Z]→[X,Y])や
1点透視([X,Y,Z]→[X/(1-Z/H),Y/(1-Z/H)])等があります。


まず、3次元メンガーを透視変換して2次元化してみる。
※回転、陰面処理等はしていません。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
SET WINDOW -5,5,5,-5
INPUT PROMPT "LEVEL=":N
CALL MENGER(N,0,0,0,1)
END

EXTERNAL SUB MENGER(N,X,Y,Z,SIZE)
LET H=3 ! 要調整
IF N=0 THEN
CALL BOX(X/(1-Z/H),Y/(1-Z/H),SIZE*3) ! 1点透視
! CALL BOX(X,Y,SIZE*3) ! 平行投影
ELSE
FOR K=-1 TO 1
FOR J=-1 TO 1
FOR I=-1 TO 1
IF BITOR(I,J)<>0 AND BITOR(I,K)<>0 AND BITOR(J,K)<>0 THEN CALL MENGER(N-1,X+I*SIZE,Y+J*SIZE,Z+K*SIZE,SIZE/3)
NEXT I
NEXT J
NEXT K
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB


以上の実行結果を踏まえ4次元メンガーを定義し3次元投影してみた。


INPUT PROMPT "LEVEL=":N
LET F$="4Dmenger"&STR$(N)&".scad"
OPEN #1:NAME F$
ERASE #1
CALL MENGER(N,0,0,0,0,1,#1)
CLOSE #1
END

EXTERNAL SUB MENGER(N,X,Y,Z,W,SIZE,#1)
LET H=3 ! 要調整
IF N=0 THEN
PRINT #1:"translate([";X/(1-W/H);",";Y/(1-W/H);",";Z/(1-W/H);"]) {"
PRINT #1:" cube(";SIZE*4;",center=true);"
PRINT #1:" }"
ELSE
FOR L=-1 TO 1
FOR K=-1 TO 1
FOR J=-1 TO 1
FOR I=-1 TO 1
IF BITOR(I,J)<>0 AND BITOR(I,K)<>0 AND BITOR(I,L)<>0 AND BITOR(J,K)<>0 AND BITOR(J,L)<>0 AND BITOR(K,L)<>0 THEN CALL MENGER(N-1,X+I*SIZE,Y+J*SIZE,Z+K*SIZE,W+L*SIZE,SIZE/4,#1)
NEXT I
NEXT J
NEXT K
NEXT L
END IF
END SUB


ここでは敢えて実行結果を図示しませんので、気になる方はぜひ実行してみてください。(チャンチャン!!)

非心カイ二乗分布CDF - gnuutera2012or文句うさぴょん URL

2024/01/04 (Thu) 21:13:42

non-central chi squared distribution CDF
非心カイ二乗分布のCDFです。
チェックお願いいたします。
DECLARE EXTERNAL FUNCTION EXP
!マチン(Machin)の公式 π/4=4*ArcTan(1/5)-ArcTan(1/239)
OPTION ARITHMETIC DECIMAL_HIGH !1000桁モード
LET p=0
!テイラー展開より、ArcTan(x)=x-x^3/3+x^5/5-x^7/7+ …
!第n項 {16/5^(2n-1)-4/239^(2n-1)}/(2n-1) 符号はnが奇数なら正
LET k=1
LET te=16/5
DO
LET last=p
LET p=p+te/k
LET te=te/(-5*5)
LET k=k+2
LOOP WHILE p<>last

LET k=1
LET te=4/239
DO
LET last=p
LET p=p-te/k
LET te=te/(-239*239)
LET k=k+2
LOOP WHILE p<>last

LET c=1
LET nu=3
LET ramda=2
LET keta=50

FUNCTION GAMMA(w)
IF MOD(w,2)=1 THEN GOTO 100
IF MOD(w,2)=0 THEN GOTO 200
100 LET V=1
FOR I=w TO 1 STEP -2
LET V=I/2*V
NEXT I
LET GAMMA=V*SQR(p)
GOTO 300
200 LET V=1
FOR I=w/2 TO 1 STEP -1
LET V=I*V
NEXT I
LET GAMMA=V
GOTO 300
300 END FUNCTION

FUNCTION CHI(w,chisquared)
LET SUN=1
LET TUE=1
FOR I=1 TO MAXNUM
IF TUE<10^(-(keta+1)) THEN EXIT FOR
LET TUE=TUE*chisquared/(w+2*I)
LET SUN=SUN+TUE
NEXT I
LET CHI=INT(SQR(chisquared/2)^w/GAMMA(w)*EXP(-chisquared/2)*SUN*10^1000+0.5)/10^1000
END FUNCTION

LET SUM=0
FOR J=0 TO MAXNUM
IF (ramda/2)^J/FACT(J)*EXP(-ramda/2)<10^(-(keta+1)) THEN EXIT FOR
LET SUM=SUM+(ramda/2)^J/FACT(J)*CHI(nu+2*J,c)
NEXT J
LET SUM=SUM*EXP(-ramda/2)
LET bbketa=INT(SUM*10^keta+0.5)/10^keta
PRINT bbketa
END

EXTERNAL FUNCTION EXP(x)
OPTION ARITHMETIC DECIMAL_HIGH
FUNCTION s(y,n)
LET t=y*x/n
IF ABS(t)<=EPS(0) THEN
LET s=y+t
ELSE
LET s=y+s(t,n+1)
END IF
END FUNCTION
LET EXP=s(1,1)
END FUNCTION

http://yutorinonatuyasumi.blog.fc2.com/blog-entry-295.html

Re: 非心カイ二乗分布CDF - しばっち

2024/01/07 (Sun) 08:50:40

下記サイトで調べてみると合っているようです。

https://keisan.casio.jp/exec/system/1161228847

※円周率はシステム変数PIに定義されています。(PRINT PIで円周率表示)


私も作ってみました。但し、精度はあまり高くないです。

https://keisan.casio.jp/exec/system/1161228846


LET V=3 ! 自由度
LET LAMBDA=1 ! 非心度λ
SET WINDOW -1,20,-.1,1
DRAW GRID(2,.1)
LET N=50 ! 分割数
FOR X=0 TO 20 STEP 1/2
PLOT LINES:X,INTEGRAL(V,LAMBDA,0,X,N); ! 下側累積確率
! PLOT LINES:X,INFINTEGRAL(V,LAMBDA,X,N); ! 上側累積確率
! PLOT LINES:X,F(X,V,LAMBDA); ! 確率密度
NEXT X
END

EXTERNAL FUNCTION F(X,V,LAMBDA) ! 確率密度
FOR J=0 TO 1000
LET A=(LAMBDA/2)^J*X^((V+2*J)/2-1)*EXP(-X/2)/FACT(J)/2^((V+2*J)/2)/GAMMA((V+2*J)/2)
LET SUM=SUM+A
IF ABS(A)<EPS(0) THEN EXIT FOR
NEXT J
LET F=SUM*EXP(-LAMBDA/2)
END FUNCTION

EXTERNAL FUNCTION GAMMA(X) ! ガンマ関数(複素数可)
LET GAMMA=EXP(LOGGAMMA(X))
END FUNCTION

EXTERNAL FUNCTION LOGGAMMA(X)
LET S=(X-.5)*LOG(X)-X+LOG(2*PI)/2
LET A=1/X
FOR N=1 TO 5
LET S=S+BERNOULLI(2*N)/(2*N)/(2*N-1)*A
LET A=A/X/X
NEXT N
LET LOGGAMMA=S
END FUNCTION

EXTERNAL FUNCTION BERNOULLI(K) ! ベルヌーイ数
LET BN=(-1/2)^K
LET C=1
LET D=1
FOR M=K-1 TO 1 STEP -1
LET T=T+(-1)^(M-1)*D*M^(K-1)
LET C=C*(M+1)/(K-M)
LET D=D+C
NEXT M
LET BERNOULLI=BN*T*K/(2^K-1)
END FUNCTION

EXTERNAL FUNCTION INTEGRAL(V,LAMDA,A,B,N) ! 有限区間数値積分 A~B
LET N=N*2
LET H=(B-A)/N
FOR K=0 TO N/2-1
LET S=S+1/3*H*F(A+H*2*K,V,LAMDA)+4/3*H*F(A+H*(2*K+1),V,LAMDA)+1/3*H*F(A+H*(2*K+2),V,LAMDA)
NEXT K
LET INTEGRAL=S
END FUNCTION

EXTERNAL FUNCTION INFINTEGRAL(V,LAMBDA,C,N) ! 半無限区間数値積分 C~+∞
DIM R(0 TO 2)
LET A=0
LET B=1
LET R(0)=1/3
LET R(1)=4/3
LET R(2)=1/3
LET H=(B-A)/N/2
FOR K=0 TO N-1
FOR J=0 TO 2
LET T=A+H*(2*K+J)
IF T<>0 THEN
LET S=S+H*R(J)*F(C+(1-T)/T,V,LAMBDA)/T/T
END IF
NEXT J
NEXT K
LET INFINTEGRAL=S
END FUNCTION

Re: Re: 非心カイ二乗分布CDF - gnuutera2012or文句うさぴょん URL

2024/01/07 (Sun) 18:56:01

しばっち様

チェック有難う御座います。
gnuutera2012or文句うさぴょん

バグでしょうか? - しばっち

2023/12/24 (Sun) 08:50:58

下記の2つのプログラムで実行結果が異なります。

WINDOWS版 Lazarus版共に同じ結果です。
他の関数名(LOG SIN EXP INT等)で定義しても似たような
現象になります。

PRINT SQR(3)

FUNCTION SQR(X)
LET SQR=X*X
END FUNCTION
END

実行結果
9
--------------------------------
PRINT SQR(3)
END

EXTERNAL FUNCTION SQR(X)
LET SQR=X*X
END FUNCTION

実行結果
1.73205080756888

Re: バグでしょうか? - SHIRAISHI Kazuo

2023/12/24 (Sun) 16:50:01

組込関数と同名の関数を外部関数として定義するとき,
DECLARE EXTERNAL FUNCTION文を省略することができません。

DECLARE EXTERNAL FUNCTION SQR
PRINT SQR(3)
END

EXTERNAL FUNCTION SQR(X)
LET SQR=X*X
END FUNCTION

Re: バグでしょうか? - SHIRAISHI Kazuo

2023/12/27 (Wed) 09:27:10

規模の大きなプログラムを書く際は,
オプション-互換性-文法-外部関数宣言
で「省略を許さない(JIS)」を選んでおくと混乱が少ないと思います。

シェルピンスキーのカーペット - しばっち

2023/12/24 (Sun) 08:53:50

https://ja.wikipedia.org/wiki/シェルピンスキーのカーペット

シェルピンスキーのカーペットと言われるくりぬき図形です。
下記プログラムでは直感的にデータ文を書き換えるだけで簡単に
変更できます。
自分なりに色々と改造してみるとおもしろいかと思います。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1

!DATA 1,0,1
!DATA 0,1,0
!DATA 1,0,1

!DATA 1,0,1
!DATA 0,0,0
!DATA 1,0,1

!DATA 0,1,0
!DATA 1,1,1
!DATA 0,1,0

!DATA 1,0,1
!DATA 0,0,1
!DATA 1,1,1
SET WINDOW -1.5,1.5,1.5,-1.5
INPUT PROMPT "LEVEL=":N ! N=1~5
CALL SIERPINSKI(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A(J,I)=1 THEN CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
3*3の全パターン512種(2^9)を表示させてみました。

SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
PUBLIC NUMERIC A(-1 TO 1,-1 TO 1)
DIM M(9)
SET WINDOW -1.5,1.5,1.5,-1.5
CALL RECURSIVE(9,M)
!FOR N9=0 TO 1
! LET A(-1,-1)=N9
! FOR N8=0 TO 1
! LET A(0,-1)=N8
! FOR N7=0 TO 1
! LET A(1,-1)=N7
! FOR N6=0 TO 1
! LET A(-1,0)=N6
! FOR N5=0 TO 1
! LET A(0,0)=N5
! FOR N4=0 TO 1
! LET A(1,0)=N4
! FOR N3=0 TO 1
! LET A(-1,1)=N3
! FOR N2=0 TO 1
! LET A(0,1)=N2
! FOR N1=0 TO 1
! LET A(1,1)=N1
! CLEAR
! CALL SIERPINSKI(3,0,0,1)
! WAIT DELAY .5
! NEXT N1
! NEXT N2
! NEXT N3
! NEXT N4
! NEXT N5
! NEXT N6
! NEXT N7
! NEXT N8
!NEXT N9
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A(J,I)=1 THEN CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB

EXTERNAL SUB RECURSIVE(N,M())
IF N=0 THEN
FOR I=1 TO 9
LET A(MOD(I-1,3)-1,INT((I-1)/3)-1)=M(I)
NEXT I
CLEAR
CALL SIERPINSKI(3,0,0,1)
WAIT DELAY .5
ELSE
FOR I=0 TO 1
LET M(N)=I
CALL RECURSIVE(N-1,M)
LET M(N)=0
NEXT I
END IF
END SUB
------------------------------------------------------------------------------------------------
2*2で模様を描いてみました。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(0 TO 1,0 TO 1)
FOR I=0 TO 1
FOR J=0 TO 1
READ A(J,I)
NEXT J
NEXT I
DATA 1,1
DATA 1,0

SET WINDOW 0,2,2,0
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*2)
ELSE
FOR I=0 TO 1
FOR J=0 TO 1
IF A(J,I)=1 THEN CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/2) ELSE CALL BOX(X+J*L,Y+I*L,L)
NEXT J
NEXT I
END IF
END SUB

!EXTERNAL SUB BOX(X,Y,L)
!PLOT AREA:X,Y;X+L,Y;X+L,Y+L;X,Y+L
!END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT LINES:X,Y;X+L,Y;X+L,Y+L;X,Y+L;X,Y
END SUB
------------------------------------------------------------------------------------------------
下記では条件式で与えています。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC SIZE
LET SIZE=3 ! SIZE=3,5,7,9,11...奇数
SET WINDOW -SIZE/2,SIZE/2,SIZE/2,-SIZE/2
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*SIZE)
ELSE
FOR J=-INT(SIZE/2) TO INT(SIZE/2)
FOR I=-INT(SIZE/2) TO INT(SIZE/2)
! IF I>=0 OR J>=0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
! IF I>=0 OR J<0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
! IF I*J>=0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
! IF I<>0 OR J<>0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
! IF I+J>=0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
! IF BITOR(I,J)<>0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
IF ABS(I-J)>0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/SIZE)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
サイズを5*5にして4穴にしてみた。

SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(-2 TO 2,-2 TO 2)
FOR J=-2 TO 2
FOR I=-2 TO 2
READ A(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1
SET WINDOW -2.5,2.5,2.5,-2.5
INPUT PROMPT "LEVEL=":N ! N=1~3
CALL SIERPINSKI(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR J=-2 TO 2
FOR I=-2 TO 2
IF A(I,J)=1 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/5)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB

データ文を下記に変更すると十字型にできます。

DATA 1,1,1,1,1
DATA 1,1,0,1,1
DATA 1,0,0,0,1
DATA 1,1,0,1,1
DATA 1,1,1,1,1
------------------------------------------------------------------------------------------------
更に7*7にして王型にしてみた。

SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(-3 TO 3,-3 TO 3)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ A(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1
SET WINDOW -3.5,3.5,3.5,-3.5
INPUT PROMPT "LEVEL=":N ! N=1~3
CALL SIERPINSKI(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*7)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A(I,J)=1 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/7)
! IF A(I,J)=0 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*L,L/7)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB

下記に書き換えると卍型にできます。

DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,1,0,1
DATA 1,1,1,0,1,0,1
DATA 1,0,0,0,0,0,1
DATA 1,0,1,0,1,1,1
DATA 1,0,1,0,0,0,1
DATA 1,1,1,1,1,1,1

下記は9穴です。

DATA 1,1,1,1,1,1,1
DATA 1,0,1,0,1,0,1
DATA 1,1,1,1,1,1,1
DATA 1,0,1,0,1,0,1
DATA 1,1,1,1,1,1,1
DATA 1,0,1,0,1,0,1
DATA 1,1,1,1,1,1,1
------------------------------------------------------------------------------------------------
データ文を色々といじってみるのとおもしろいかもしれません。

SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(0 TO 50,0 TO 50),XSIZE,YSIZE
READ S$
DO
LET XSIZE=LEN(S$)
FOR I=0 TO XSIZE-1
!IF S$(I+1:I+1)="*" THEN LET A(I,J)=1
IF S$(I+1:I+1)=" " THEN LET A(I,J)=1
NEXT I
LET J=J+1
READ IF MISSING THEN EXIT DO:S$
LOOP
LET YSIZE=J
SET WINDOW 0,1,1,0
CALL SIERPINSKI(2,0,0,1/XSIZE,1/YSIZE)
DATA " ** ** "
DATA " ** ** "
DATA " **** *** "
DATA " ** *** *** ** "
DATA " ** ** *** ** "
DATA " * **** * "
DATA " * * "
DATA " * * "
DATA " ** ** "
DATA " * * "
DATA " ** ** "
DATA " * *** *** * "
DATA "***** *** *** *****"
DATA " * * "
DATA " * * "
DATA "***** ** ** ** *****"
DATA " * **** * "
DATA " ** ** "
DATA " ** ** "
DATA " ********** "

!DATA " "
!DATA " "
!DATA " "
!DATA " **** **** "
!DATA " ******** ******** "
!DATA " ******************** "
!DATA " ********************** "
!DATA " ********************** "
!DATA " ************************ "
!DATA " ************************ "
!DATA " ************************ "
!DATA " ************************ "
!DATA " ************************ "
!DATA " ********************** "
!DATA " ********************** "
!DATA " ********************** "
!DATA " ******************** "
!DATA " ****************** "
!DATA " ****************** "
!DATA " **************** "
!DATA " ************** "
!DATA " ************ "
!DATA " ********** "
!DATA " ******** "
!DATA " **** "
!DATA " ** "
!DATA " "
!DATA " "
!DATA " "
!DATA " "
!DATA " "
!DATA " "
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L,M)
IF N=0 THEN
CALL BOX(X,Y,L*XSIZE,M*YSIZE)
ELSE
FOR J=0 TO YSIZE-1
FOR I=0 TO XSIZE-1
IF A(I,J)=1 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*M,L/XSIZE,M/YSIZE)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,M)
PLOT AREA:X-L/2,Y-M/2;X+L/2,Y-M/2;X+L/2,Y+M/2;X-L/2,Y+M/2
END SUB
------------------------------------------------------------------------------------------------
「BASIC」の再帰文字です。

SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
PUBLIC NUMERIC A(0 TO 49,0 TO 49),XSIZE,YSIZE
READ S$
LET J=0
LET XSIZE=LEN(S$)
DO
FOR I=0 TO XSIZE-1
IF S$(I+1:I+1)="*" THEN LET A(I,J)=1
NEXT I
LET J=J+1
READ IF MISSING THEN EXIT DO:S$
LOOP
LET YSIZE=J
LET N=2
SET BITMAP SIZE XSIZE^N,YSIZE^N
SET WINDOW 0,XSIZE-1,YSIZE-1,0
CLEAR
CALL SIERPINSKI(N,0,0,1,1)
DATA " ***** ** **** *** *** "
DATA " ***** ** **** *** *** "
DATA " * * * * * * * * * "
DATA " * * * * * * * * * "
DATA " * * * * * * * "
DATA " * * * * * * * "
DATA " ***** ****** **** * * "
DATA " ***** ****** **** * * "
DATA " * * * * * * * "
DATA " * * * * * * * "
DATA " * * * * * * * * * "
DATA " * * * * * * * * * "
DATA " ***** * * **** *** *** "
DATA " ***** * * **** *** *** "
DATA " "
DATA " "
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L,M)
IF N=0 THEN
CALL BOX(X,Y,L*XSIZE,M*YSIZE)
ELSE
FOR J=0 TO YSIZE-1
FOR I=0 TO XSIZE-1
IF A(I,J)=1 THEN CALL SIERPINSKI(N-1,X+I*L,Y+J*M,L/XSIZE,M/YSIZE)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,M)
PLOT AREA:X-L/2,Y-M/2;X+L/2,Y-M/2;X+L/2,Y+M/2;X-L/2,Y+M/2
END SUB

Re: シェルピンスキーのカーペット - しばっち

2023/12/24 (Sun) 08:55:52

カラーにしてみました。データ文の数字は色番号です。



FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
PUBLIC NUMERIC A(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A(J,I)
NEXT J
NEXT I
DATA 1,2,1
DATA 2,0,2
DATA 1,2,1
SET WINDOW -1.5,1.5,1.5,-1.5
INPUT PROMPT "LEVEL=":N ! N=1~4
CALL SIERPINSKI(N,0,0,1,0)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L,C)
IF N=0 THEN
CALL BOX(X,Y,L*3,C)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
LET C=A(J,I)
IF C<>0 THEN CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/3,C)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
SET AREA COLOR C
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
サイズを7*7でやってみました。


FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
PUBLIC NUMERIC A(-3 TO 3,-3 TO 3)
FOR I=-3 TO 3
FOR J=-3 TO 3
READ A(J,I)
NEXT J
NEXT I
DATA 1,2,2,2,2,2,1
DATA 5,0,1,1,1,0,3
DATA 5,1,0,6,0,1,3
DATA 5,1,6,0,6,1,3
DATA 5,1,0,6,0,1,3
DATA 5,0,1,1,1,0,3
DATA 1,4,4,4,4,4,1
SET WINDOW -3.5,3.5,3.5,-3.5
INPUT PROMPT "LEVEL=":N ! N=1~3
CALL SIERPINSKI(N,0,0,1,1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L,C)
IF N=1 THEN
FOR I=-3 TO 3
FOR J=-3 TO 3
IF A(J,I)<>0 THEN CALL BOX(X+J*L,Y+I*L,L,C)
NEXT J
NEXT I
ELSE
FOR I=-3 TO 3
FOR J=-3 TO 3
LET C=A(J,I)
IF C<>0 THEN CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/7,C)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
SET AREA COLOR C
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
フルカラーモードでもやってみました。

SET COLOR MODE "NATIVE"
CLEAR
PUBLIC NUMERIC A(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ COL$
LET A(J,I)=COLORNAME(COL$)
NEXT J
NEXT I
DATA "桃","撫子","桃"
DATA "苺","黒","藤"
DATA "桃","海老茶","桃"
SET WINDOW -1.5,1.5,1.5,-1.5
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI(N,0,0,1,2^24-1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L,C)
IF N=1 THEN
FOR I=-1 TO 1
FOR J=-1 TO 1
LET CC=COLORMIX(A(J,I),C,"MUL")
CALL BOX(X+J*L,Y+I*L,L,CC)
NEXT J
NEXT I
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
LET CC=A(J,I)
CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/3,CC)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
LET B=MOD(INT(C/65536),256)
LET G=MOD(INT(C/256),256)
LET R=MOD(C,256)
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB

EXTERNAL FUNCTION COLORNAME(NAME$) ! 色名
RESTORE
DO
READ IF MISSING THEN EXIT DO:N$,ROMA$,COL$
IF NAME$=N$ OR UCASE$(NAME$)=ROMA$ THEN
!LET COLORNAME=COLORINDEX(BVAL(COL$(1:2),16)/255,BVAL(COL$(3:4),16)/255,BVAL(COL$(5:6),16)/255)
LET COLORNAME=65536*BVAL(COL$(5:6),16)+256*BVAL(COL$(3:4),16)+BVAL(COL$(1:2),16)
EXIT FUNCTION
END IF
LOOP
LET COLORNAME=-1
DATA "撫子",NADESHIKO,DC9FB4
DATA "紅梅",KOHBAI,E16B8C
DATA "蘇芳",SUOH,8E354A
DATA "退紅",TAIKOH,F8C3CD
DATA "桃",MOMO,F596AA
DATA "苺",ICHIGO,B5495B
DATA "薄紅",USUBENI,E87A90
DATA "中紅",NAKABENI,DB4D6D
DATA "桜",SAKURA,FEDFE1
DATA "梅鼠",UMENEZUMI,9E7A7A
DATA "燕脂",ENJI,9F353A
DATA "紅",KURENAI,CB1B45
DATA "小豆",AZUKI,954A45
DATA "蘇芳香",SUOHKOH,A96360
DATA "赤紅",AKABENI,CB4042
DATA "真朱",SHINSYU,AB3B3A
DATA "海老茶",EBICHA,734338
DATA "胡桃",KURUMI,947A6D
DATA "紅鬱金",BENIUKON,E98B2A
DATA "梅染",UMEZOME,E9A368
DATA "枇杷茶",BIWACHA,B17844
DATA "丁子茶",CHOJICHA,96632E
DATA "憲法染",KENPOHZOME,43341B
DATA "琥珀",KOHAKU,CA7A2C
DATA "金茶",KINCHA,C7802D
DATA "狐",KITSUNE,9B6E23
DATA "山吹",YAMABUKI,FFB11B
DATA "山吹茶",YAMABUKICHA,D19826
DATA "瑠璃紺",RURIKON,0B346E
DATA "紅碧",BENIMIDORI,7B90D2
DATA "藤鼠",FUJINEZUMI,6E75A4
DATA "藤",FUJI,8B81C3
DATA "二藍",FUTAAI,70649A
DATA "藤紫",FUJIMURASAKI,8A6BBE
DATA "銀鼠",GINNEZUMI,91989F
DATA "鉛",NAMARI,787878
DATA "灰",HAI,828282
DATA "黒",KURO,080808
END FUNCTION

EXTERNAL FUNCTION COLORMIX(C1,C2,MODE$) ! 色合成
LET B0=MOD(INT(C1/65536),256)
LET G0=MOD(INT(C1/256),256)
LET R0=MOD(C1,256)
LET BB=MOD(INT(C2/65536),256)
LET GG=MOD(INT(C2/256),256)
LET RR=MOD(C2,256)
SELECT CASE UCASE$(MODE$)
CASE "AND"
LET R=BITAND(R0,RR)
LET G=BITAND(G0,GG)
LET B=BITAND(B0,BB)
CASE "OR"
LET R=BITOR(R0,RR)
LET G=BITOR(G0,GG)
LET B=BITOR(B0,BB)
CASE "XOR"
LET R=BITXOR(R0,RR)
LET G=BITXOR(G0,GG)
LET B=BITXOR(B0,BB)
CASE "NOT"
LET R=MOD(BITNOT(R0)+RR,256)
LET G=MOD(BITNOT(G0)+GG,256)
LET B=MOD(BITNOT(B0)+BB,256)
CASE "MUL","乗算"
LET R=R0*RR/255
LET G=G0*GG/255
LET B=B0*BB/255
CASE "COVER","覆い焼き"
IF R0=255 THEN LET R=255 ELSE LET R=RR*255/(255-R0)
IF G0=255 THEN LET G=255 ELSE LET G=GG*255/(255-G0)
IF B0=255 THEN LET B=255 ELSE LET B=BB*255/(255-B0)
CASE "BURN","焼きこみ"
IF R0=0 THEN LET R=0 ELSE LET R=255-255*(255-RR)/R0
IF G0=0 THEN LET G=0 ELSE LET G=255-255*(255-GG)/G0
IF B0=0 THEN LET B=0 ELSE LET B=255-255*(255-BB)/B0
CASE "SCREEN","スクリーン"
LET R=255-(255-R0)*(255-RR)/255
LET G=255-(255-G0)*(255-GG)/255
LET B=255-(255-B0)*(255-BB)/255
CASE "OVERLAY","オーバーレイ"
IF R0<128 THEN LET R=2*R0*RR/255 ELSE LET R=2*(R0+RR+R0*RR/255)-255
IF G0<128 THEN LET G=2*G0*GG/255 ELSE LET G=2*(G0+GG+G0*GG/255)-255
IF B0<128 THEN LET B=2*B0*BB/255 ELSE LET B=2*(B0+BB+B0*BB/255)-255
CASE "ALPHA","アルファーブレンド"
LET T=50
LET R=(T*R0+(100-T)*RR)/100
LET G=(T*G0+(100-T)*GG)/100
LET B=(T*B0+(100-T)*BB)/100
CASE "LIGHT","明るい方","MAX"
LET R=MAX(R0,RR)
LET G=MAX(G0,GG)
LET B=MAX(B0,BB)
CASE "DARK","暗い方","MIN"
LET R=MIN(R0,RR)
LET G=MIN(G0,GG)
LET B=MIN(B0,BB)
CASE "SUB","差の絶対値"
LET R=ABS(R0-RR)
LET G=ABS(G0-GG)
LET B=ABS(B0-BB)
CASE "ADD","和"
LET R=MOD(R0+RR,256)
LET G=MOD(G0+GG,256)
LET B=MOD(B0+BB,256)
END SELECT
LET R=MAX(0,MIN(255,INT(R)))
LET G=MAX(0,MIN(255,INT(G)))
LET B=MAX(0,MIN(255,INT(B)))
LET COLORMIX=COLORINDEX(R/255,G/255,B/255)
END FUNCTION
------------------------------------------------------------------------------------------------
5*5にしてみた。上記から必要ルーチンをコピペしてください。


SET COLOR MODE "NATIVE"
CLEAR
PUBLIC NUMERIC A(-2 TO 2,-2 TO 2)
FOR I=-2 TO 2
FOR J=-2 TO 2
READ COL$
LET A(J,I)=COLORNAME(COL$)
NEXT J
NEXT I
DATA "苺","桜","小豆","桜","苺"
DATA "桜","黒","桜","黒","桜"
DATA "小豆","桜","黒","桜","小豆"
DATA "桜","黒","桜","黒","桜"
DATA "苺","桜","小豆","桜","苺"
SET WINDOW -2.5,2.5,2.5,-2.5
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI(N,0,0,1,2^24-1)
END

EXTERNAL SUB SIERPINSKI(N,X,Y,L,C)
IF N=1 THEN
FOR I=-2 TO 2
FOR J=-2 TO 2
LET CC=COLORMIX(A(J,I),C,"MUL")
CALL BOX(X+J*L,Y+I*L,L,CC)
NEXT J
NEXT I
ELSE
FOR I=-2 TO 2
FOR J=-2 TO 2
LET CC=A(J,I)
CALL SIERPINSKI(N-1,X+J*L,Y+I*L,L/5,CC)
NEXT J
NEXT I
END IF
END SUB

以下略

Re: シェルピンスキーのカーペット - しばっち

2023/12/24 (Sun) 08:57:43

3*3の相互再帰にしてみました。
最初にどちらを(SIERPINSKI1 または SIERPINSKI2)呼び出すかで結果が変わります。
自分なりに色々と改造してみるとおもしろいかと思います。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-1 TO 1,-1 TO 1),A2(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A1(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1

FOR I=-1 TO 1
FOR J=-1 TO 1
READ A2(J,I)
NEXT J
NEXT I
DATA 0,1,0
DATA 1,0,1
DATA 0,1,0
INPUT PROMPT "LEVEL=":N
SET WINDOW -1.5,1.5,1.5,-1.5
CALL SIERPINSKI1(N,0,0,1)
! CALL SIERPINSKI2(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A1(J,I)=1 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A2(J,I)=1 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
3*3と5*5の相互再帰です。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-1 TO 1,-1 TO 1),A2(-2 TO 2,-2 TO 2)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A1(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ A2(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1
INPUT PROMPT "LEVEL=":N
SET WINDOW -1.5,1.5,1.5,-1.5
CALL SIERPINSKI1(N,0,0,1)

!SET WINDOW -2.5,2.5,2.5,-2.5
!CALL SIERPINSKI2(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A1(J,I)=1 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/5)
! IF A1(J,I)=0 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/5)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR I=-2 TO 2
FOR J=-2 TO 2
IF A2(J,I)=1 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3)
! IF A2(J,I)=0 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
7*7の王型と卍型の相互再帰呼び出しです。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-3 TO 3,-3 TO 3),A2(-3 TO 3,-3 TO 3)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ A1(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,0,1,1,1
DATA 1,0,0,0,0,0,1
DATA 1,1,1,1,1,1,1
FOR J=-3 TO 3
FOR I=-3 TO 3
READ A2(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,1,0,1
DATA 1,1,1,0,1,0,1
DATA 1,0,0,0,0,0,1
DATA 1,0,1,0,1,1,1
DATA 1,0,1,0,0,0,1
DATA 1,1,1,1,1,1,1
SET WINDOW -3.5,3.5,3.5,-3.5
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI1(N,0,0,1)
!CALL SIERPINSKI2(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*7)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A1(I,J)=1 THEN CALL SIERPINSKI2(N-1,X+I*L,Y+J*L,L/7)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*7)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A2(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/7)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
5*5と7*7の相互再帰です。
データ文の数値は呼び出し先です。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-2 TO 2,-2 TO 2),A2(-3 TO 3,-3 TO 3)
FOR J=-2 TO 2
FOR I=-2 TO 2
READ A1(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,0,2,0,1
DATA 1,2,2,2,1
DATA 1,0,2,0,1
DATA 1,1,1,1,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ A2(I,J)
NEXT I
NEXT J
DATA 2,2,2,2,2,2,2
DATA 2,0,1,0,1,0,2
DATA 2,1,1,1,1,1,2
DATA 2,0,1,0,1,0,2
DATA 2,1,1,1,1,1,2
DATA 2,0,1,0,1,0,2
DATA 2,2,2,2,2,2,2
INPUT PROMPT "LEVEL=":N
SET WINDOW -2.5,2.5,2.5,-2.5
CALL SIERPINSKI1(N,0,0,1)

!SET WINDOW -3.5,3.5,3.5,-3.5
!CALL SIERPINSKI2(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR J=-2 TO 2
FOR I=-2 TO 2
IF A1(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/5)
IF A1(I,J)=2 THEN CALL SIERPINSKI2(N-1,X+I*L,Y+J*L,L/7)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*7)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A2(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/5)
IF A2(I,J)=2 THEN CALL SIERPINSKI2(N-1,X+I*L,Y+J*L,L/7)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
3*3相互再帰でカラーにしてみました。


PUBLIC NUMERIC A1(-1 TO 1,-1 TO 1),A2(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A1(J,I)
NEXT J
NEXT I
DATA 2,2,2
DATA 2,2,2
DATA 2,2,2

FOR I=-1 TO 1
FOR J=-1 TO 1
READ A2(J,I)
NEXT J
NEXT I
DATA 1,2,1
DATA 2,1,2
DATA 1,2,1

SET WINDOW -1.5,1.5,1.5,-1.5
CALL SIERPINSKI1(5,0,0,1,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L,C)
IF N=0 THEN
CALL BOX(X,Y,L*3,C)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A1(J,I)=1 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3,2)
IF A1(J,I)=2 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/3,3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L,C)
IF N=0 THEN
CALL BOX(X,Y,L*3,C)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A2(J,I)=1 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3,4)
IF A2(J,I)=2 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/3,5)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
SET AREA COLOR C
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
7*7サイズ王型と卍型の相互再帰のカラーバージョンです。


PUBLIC NUMERIC A1(-3 TO 3,-3 TO 3),A2(-3 TO 3,-3 TO 3)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ A1(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,2,2,2,2,2,1
DATA 1,1,1,2,1,1,1
DATA 1,2,2,2,2,2,1
DATA 1,1,1,2,1,1,1
DATA 1,2,2,2,2,2,1
DATA 1,1,1,1,1,1,1
FOR J=-3 TO 3
FOR I=-3 TO 3
READ A2(I,J)
NEXT I
NEXT J
DATA 2,2,2,2,2,2,2
DATA 2,1,1,1,2,1,2
DATA 2,2,2,1,2,1,2
DATA 2,1,1,1,1,1,2
DATA 2,1,2,1,2,2,2
DATA 2,1,2,1,1,1,2
DATA 2,2,2,2,2,2,2
SET WINDOW -3.5,3.5,3.5,-3.5
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI1(N,0,0,1,2)
!CALL SIERPINSKI2(N,0,0,1,2)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L,C)
IF N=0 THEN
CALL BOX(X,Y,L*7,C)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A1(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/7,1)
IF A1(I,J)=2 THEN CALL SIERPINSKI2(N-1,X+I*L,Y+J*L,L/7,2)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L,C)
IF N=0 THEN
CALL BOX(X,Y,L*7,C)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A2(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/7,3)
IF A2(I,J)=2 THEN CALL SIERPINSKI2(N-1,X+I*L,Y+J*L,L/7,4)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
SET AREA COLOR C
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
3*3サイズの3重相互再帰呼び出しです。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-1 TO 1,-1 TO 1),A2(-1 TO 1,-1 TO 1),A3(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A1(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1

FOR I=-1 TO 1
FOR J=-1 TO 1
READ A2(J,I)
NEXT J
NEXT I
DATA 0,1,0
DATA 1,0,1
DATA 0,1,0

FOR I=-1 TO 1
FOR J=-1 TO 1
READ A3(J,I)
NEXT J
NEXT I
DATA 1,0,1
DATA 0,1,0
DATA 1,0,1
SET WINDOW -1.5,1.5,1.5,-1.5
INPUT PROMPT "LEVEL=":N
CALL SIERPINSKI1(N,0,0,1)
!CALL SIERPINSKI2(N,0,0,1)
!CALL SIERPINSKI3(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
! IF A1(J,I)=1 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/3)
IF A1(J,I)=1 THEN CALL SIERPINSKI3(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A2(J,I)=1 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3)
! IF A2(J,I)=1 THEN CALL SIERPINSKI3(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI3(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
! IF A3(J,I)=1 THEN CALL SIERPINSKI1(N-1,X+J*L,Y+I*L,L/3)
IF A3(J,I)=1 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/3)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
5*5の3重相互再帰呼び出しです。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-2 TO 2,-2 TO 2),A2(-2 TO 2,-2 TO 2),A3(-2 TO 2,-2 TO 2)
FOR I=-2 TO 2
FOR J=-2 TO 2
READ A1(J,I)
NEXT J
NEXT I
DATA 1,1,1,1,1
DATA 1,0,1,0,1
DATA 1,1,0,1,1
DATA 1,0,1,0,1
DATA 1,1,1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ A2(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,1,0,1,1
DATA 1,0,0,0,1
DATA 1,1,0,1,1
DATA 1,1,1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ A3(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,0,0,0,1
DATA 1,0,1,0,1
DATA 1,0,0,0,1
DATA 1,1,1,1,1

INPUT PROMPT "LEVEL=":N
SET WINDOW -2.5,2.5,2.5,-2.5
CALL SIERPINSKI1(N,0,0,1)
!CALL SIERPINSKI2(N,0,0,1)
!CALL SIERPINSKI3(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR I=-2 TO 2
FOR J=-2 TO 2
IF A1(J,I)=1 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/5)
! IF A1(J,I)=1 THEN CALL SIERPINSKI3(N-1,X+J*L,Y+I*L,L/5)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR J=-2 TO 2
FOR I=-2 TO 2
! IF A2(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/5)
IF A2(I,J)=1 THEN CALL SIERPINSKI3(N-1,X+I*L,Y+J*L,L/5)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB SIERPINSKI3(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR J=-2 TO 2
FOR I=-2 TO 2
IF A3(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/5)
! IF A3(I,J)=1 THEN CALL SIERPINSKI2(N-1,X+I*L,Y+J*L,L/5)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
------------------------------------------------------------------------------------------------
3*3,5*5,7*7の3重相互再帰です。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-1 TO 1,-1 TO 1),A2(-2 TO 2,-2 TO 2),A3(-3 TO 3,-3 TO 3)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A1(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1

FOR J=-2 TO 2
FOR I=-2 TO 2
READ A2(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1
DATA 1,1,0,1,1
DATA 1,0,0,0,1
DATA 1,1,0,1,1
DATA 1,1,1,1,1

FOR J=-3 TO 3
FOR I=-3 TO 3
READ A3(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,0,0,0,1,0,1
DATA 1,1,1,0,1,0,1
DATA 1,0,0,0,0,0,1
DATA 1,0,1,0,1,1,1
DATA 1,0,1,0,0,0,1
DATA 1,1,1,1,1,1,1

INPUT PROMPT "LEVEL=":N
SET WINDOW -1.5,1.5,1.5,-1.5
CALL SIERPINSKI1(N,0,0,1)

!SET WINDOW -2.5,2.5,2.5,-2.5
!CALL SIERPINSKI2(N,0,0,1)

!SET WINDOW -3.5,3.5,3.5,-3.5
!CALL SIERPINSKI3(N,0,0,1)
END

EXTERNAL SUB SIERPINSKI1(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*3)
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF A1(J,I)=1 THEN CALL SIERPINSKI2(N-1,X+J*L,Y+I*L,L/5)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB SIERPINSKI2(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*5)
ELSE
FOR J=-2 TO 2
FOR I=-2 TO 2
IF A2(I,J)=1 THEN CALL SIERPINSKI3(N-1,X+I*L,Y+J*L,L/7)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB SIERPINSKI3(N,X,Y,L)
IF N=0 THEN
CALL BOX(X,Y,L*7)
ELSE
FOR J=-3 TO 3
FOR I=-3 TO 3
IF A3(I,J)=1 THEN CALL SIERPINSKI1(N-1,X+I*L,Y+J*L,L/3)
NEXT I
NEXT J
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB

Re: シェルピンスキーのカーペット - しばっち

2023/12/24 (Sun) 09:00:19

SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
OPTION BASE 0
PUBLIC NUMERIC C(2,2)
FOR I=0 TO 2
FOR J=0 TO 2
READ C(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,0,1
DATA 1,1,1
INPUT PROMPT "LEVEL=":LEV
CALL FIGURE(LEV)
END

EXTERNAL SUB FIGURE(D)
OPTION BASE 0
DIM M(3^D-1,3^D-1)
FOR I=0 TO 3^D-1
FOR J=0 TO 3^D-1
LET M(J,I)=EXISTAT(J,I,D)
NEXT J
NEXT I
MAT PLOT CELLS ,IN 0,1;1,0:M
END SUB

EXTERNAL FUNCTION EXISTAT(I,J,D)
IF D=0 THEN
LET EXISTAT=1
ELSEIF EXISTAT(INT(I/3),INT(J/3),D-1)=0 THEN
LET EXISTAT=0
ELSE
LET EXISTAT=C(MOD(I,3),MOD(J,3))
END IF
END FUNCTION
---------------------------------------------------------------------------------------------
再帰呼び出しに配列変数を渡しています。渡す配列変数でパターンが変わります。
カラーにしてみました。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(-1 TO 1,-1 TO 1),B(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A(J,I)
NEXT J
NEXT I
DATA 1,1,1
DATA 1,1,1
DATA 1,1,1

FOR I=-1 TO 1
FOR J=-1 TO 1
READ B(J,I)
NEXT J
NEXT I
DATA 0,1,0
DATA 1,0,1
DATA 0,1,0

SET WINDOW -1.5,1.5,1.5,-1.5
CALL FIGURE(5,0,0,1,A,3)
!CALL FIGURE(5,0,0,1,B,3)
END

EXTERNAL SUB FIGURE(N,X,Y,L,C(,),CC)
IF N=1 THEN
FOR I=-1 TO 1
FOR J=-1 TO 1
IF C(J,I)=1 THEN CALL BOX(X+J*L,Y+I*L,L,CC)
NEXT J
NEXT I
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF C(J,I)=0 THEN
CALL FIGURE(N-1,X+J*L,Y+I*L,L/3,A,2)
ELSE
CALL FIGURE(N-1,X+J*L,Y+I*L,L/3,B,4)
END IF
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
SET AREA COLOR C
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
---------------------------------------------------------------------------------------------
データ文の数値で渡す配列変数を指定してます。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(-1 TO 1,-1 TO 1),B(-1 TO 1,-1 TO 1)
FOR I=-1 TO 1
FOR J=-1 TO 1
READ A(J,I)
NEXT J
NEXT I
DATA 1,2,1
DATA 2,0,2
DATA 1,2,1

FOR I=-1 TO 1
FOR J=-1 TO 1
READ B(J,I)
NEXT J
NEXT I
DATA 0,1,0
DATA 1,2,1
DATA 0,1,0

SET WINDOW -1.5,1.5,1.5,-1.5
INPUT PROMPT "LEVEL=":N
CALL FIGURE(N,0,0,1,A,1)
END

EXTERNAL SUB FIGURE(N,X,Y,L,C(,),CC)
IF N=1 THEN
FOR I=-1 TO 1
FOR J=-1 TO 1
IF C(J,I)<>0 THEN CALL BOX(X+J*L,Y+I*L,L,CC)
NEXT J
NEXT I
ELSE
FOR I=-1 TO 1
FOR J=-1 TO 1
IF C(J,I)=1 THEN CALL FIGURE(N-1,X+J*L,Y+I*L,L/3,A,3)
IF C(J,I)=2 THEN CALL FIGURE(N-1,X+J*L,Y+I*L,L/3,B,4)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L,C)
SET AREA COLOR C
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
---------------------------------------------------------------------------------------------
7*7パターンです。


SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A(-3 TO 3,-3 TO 3),B(-3 TO 3,-3 TO 3)
FOR J=-3 TO 3
FOR I=-3 TO 3
READ A(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1
DATA 1,2,2,2,2,2,1
DATA 1,1,1,2,1,1,1
DATA 1,2,2,2,2,2,1
DATA 1,1,1,2,1,1,1
DATA 1,2,2,2,2,2,1
DATA 1,1,1,1,1,1,1
FOR J=-3 TO 3
FOR I=-3 TO 3
READ B(I,J)
NEXT I
NEXT J
DATA 0,0,0,0,0,0,0
DATA 0,1,1,1,0,1,0
DATA 0,0,0,1,0,1,0
DATA 0,1,1,1,1,1,0
DATA 0,1,0,1,0,0,0
DATA 0,1,0,1,1,1,0
DATA 0,0,0,0,0,0,0
SET WINDOW -3.5,3.5,3.5,-3.5
CALL FIGURE(3,0,0,1,A)
END

EXTERNAL SUB FIGURE(N,X,Y,L,C(,))
IF N=1 THEN
FOR I=-3 TO 3
FOR J=-3 TO 3
! IF C(J,I)=1 THEN CALL BOX(X+J*L,Y+I*L,L)
IF C(J,I)<>0 THEN CALL BOX(X+J*L,Y+I*L,L)
NEXT J
NEXT I
ELSE
FOR I=-3 TO 3
FOR J=-3 TO 3
IF C(J,I)=1 THEN CALL FIGURE(N-1,X+J*L,Y+I*L,L/7,A)
IF C(J,I)=2 THEN CALL FIGURE(N-1,X+J*L,Y+I*L,L/7,B)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB
---------------------------------------------------------------------------------------------
9*9パターンです。



SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
PUBLIC NUMERIC A1(-4 TO 4,-4 TO 4),A2(-4 TO 4,-4 TO 4)
FOR J=-4 TO 4
FOR I=-4 TO 4
READ A1(I,J)
NEXT I
NEXT J
DATA 1,0,2,2,2,2,2,2,2
DATA 1,0,0,0,0,0,0,0,1
DATA 1,2,2,2,2,2,2,0,1
DATA 1,0,0,0,0,0,1,0,1
DATA 1,0,2,2,2,0,1,0,1
DATA 1,0,1,0,0,0,1,0,1
DATA 1,0,1,0,2,2,1,0,1
DATA 1,0,1,0,0,0,0,0,1
DATA 1,0,2,2,2,2,2,2,2

FOR J=-4 TO 4
FOR I=-4 TO 4
READ A2(I,J)
NEXT I
NEXT J
DATA 1,1,1,1,1,1,1,1,1
DATA 0,0,0,0,0,0,2,0,0
DATA 2,1,1,1,1,0,2,0,2
DATA 2,0,0,0,1,0,2,0,2
DATA 2,0,2,0,1,0,2,0,2
DATA 2,0,2,0,0,0,2,0,2
DATA 2,0,2,1,1,1,2,0,2
DATA 2,0,0,0,0,0,0,0,2
DATA 2,1,1,1,1,1,1,1,2
SET WINDOW -4.5,4.5,4.5,-4.5
CALL FIGURE(2,0,0,1,A1)
END

EXTERNAL SUB FIGURE(N,X,Y,L,C(,))
IF N=1 THEN
FOR I=-4 TO 4
FOR J=-4 TO 4
IF C(J,I)<>0 THEN CALL BOX(X+J*L,Y+I*L,L)
NEXT J
NEXT I
ELSE
FOR I=-4 TO 4
FOR J=-4 TO 4
IF C(J,I)=1 THEN CALL FIGURE(N-1,X+J*L,Y+I*L,L/9,A1)
IF C(J,I)=2 THEN CALL FIGURE(N-1,X+J*L,Y+I*L,L/9,A2)
NEXT J
NEXT I
END IF
END SUB

EXTERNAL SUB BOX(X,Y,L)
PLOT AREA:X-L/2,Y-L/2;X+L/2,Y-L/2;X+L/2,Y+L/2;X-L/2,Y+L/2
END SUB

有理数モードで実数を入力すると整数に丸められるバグ報告 - nagram

2023/10/12 (Thu) 16:39:02

有理数モードで,代入文(LET文)以外の方法で変数に実数を入力すると TRUNCATE(a,0) で得られる整数に丸められます.
指数を使用したE表記は,指数部を無視し仮数部を整数に丸めます.
READ文,INPUT文,ファイルから入力する READ #n, INPUT #n でこの現象が生じます.

OPTION ARITHMETIC RATIONAL
DATA 3.141, 2.718, -1.414, -1.732, 2.236E-6, -244.9E+4
READ a,b,c,d,e,f
PRINT a;b;c;d;e;f
PRINT
INPUT p ! 実数を入力 (E表記も入力は可能だが)
PRINT p
PRINT
LET x=1.618
PRINT x ! 正しい
PRINT USING "-%.###": x
LET y=2.6457E-5
PRINT y ! 正しい
PRINT USING "-%.#########": y
END

Re: 有理数モードで実数を入力すると整数に丸められるバグ報告 - SHIRAISHI Kazuo

2023/10/13 (Fri) 09:51:18

ご報告ありがとうございました。
昔のバージョンだと問題が生じないことから,不具合箇所を特定できるので,修正版を用意します。

Re: 有理数モードで実数を入力すると整数に丸められるバグ報告 - SHIRAISHI Kazuo

2023/10/16 (Mon) 08:27:10

小数点'.' , 'E' , 'e' を含むとき旧来の処理を適用することにしましたが,
正号'+'で始まる定数を正しく処理せず,また,数値定数の形式の誤りが検出されない誤りが残っていました。
再修正します。

Re: 有理数モードで実数を入力すると整数に丸められるバグ報告 - SHIRAISHI Kazuo

2023/10/20 (Fri) 10:11:44

再修正版も誤りが残っていました。正しくない入力に対し誤りが検出されないことがあります。
正しい入力に対し正しく応答することができているか,しばらく様子を見てから,再々修正版を公開します。

Re: 有理数モードで実数を入力すると整数に丸められるバグ報告 - SHIRAISHI Kazuo

2023/11/10 (Fri) 11:22:02

バグ修正のついでにDATA文の文法を改定して,DATA文に複素数や有理数の定数が書けるようにしました。

Re: 有理数モードで実数を入力すると整数に丸められるバグ報告 - nagram

2023/11/13 (Mon) 15:15:39

対応していただき,ありがとうございます.
複素数,有理数のDATA読込みテストの結果報告です.

OPTION ARITHMETIC COMPLEX
! エラーにならないデータ
DATA (1 2),( 3 4),(5 6),(7 8) ! 実部と虚部の間に空白はいくつあってもエラーにはならない
READ a,b,c,d
PRINT a;b;c;d
! エラーになるデータ (EXTYPE 8101)
DATA ( 9 10) ! 左括弧の右側に2個以上の空白がある
DATA (11 12 ) ! 右括弧の左側に空白がある
READ x
PRINT x
END


OPTION ARITHMETIC RATIONAL
! エラーにならないデータ
DATA 1/2,-3/4,5/ 6,7/+8,9/+ 10,11/+ 12,13/-14,+15.17
READ a,b,c,d,e,f,g,h
PRINT a;b;c;d;e;f;g;h
! エラーになるデータ (EXTYPE 8101)
DATA +31/32 ! 正号を付加した有理数
DATA 33 /34 ! 斜線の左側に空白がある
DATA 35/ +36 ! 斜線,空白,符号の並び
DATA 37/ -38
DATA 39/- 40 ! DATA 39/+ 40 は,正号の右側に空白がいくつあってもエラーにならない
DATA 41/ 42 ! 斜線の右側に2個以上の空白がある
READ x
PRINT x
END

カオスアトラクタ - しばっち

2023/11/12 (Sun) 08:48:28

カオスアトラクタを描きます。
計算式 X'=F(X,Y) Y'=G(X,Y)が収束するまでの回数等で
色分けしています。
パラメーターをスライドバーで与えています。


PUBLIC NUMERIC A,B,KMAX,EPS,PX(1000),PY(1000),NUM
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
LET EPS=1E-5
LET KMAX=400
LOCATE VALUE ,RANGE -1 TO 1,AT -.6: A
LOCATE VALUE ,RANGE -1 TO 1,AT .7: B
LOCATE VALUE ,RANGE -100 TO 100,AT -10: XMIN
LOCATE VALUE ,RANGE -100 TO 100,AT -10: YMIN
LOCATE VALUE ,RANGE 10 TO 100,AT 20: SIZE
PRINT "A=";A;"B=";B
LET XMAX=XMIN+SIZE
LET YMAX=YMIN+SIZE
!DO
CLEAR
PRINT XMIN;YMIN;XMAX;YMAX
SET WINDOW XMIN,XMAX,YMAX,YMIN
FOR Y=YMIN TO YMAX STEP (YMAX-YMIN)/YSIZE
FOR X=XMIN TO XMAX STEP (XMAX-XMIN)/XSIZE
LET K=FIXED(X,Y)
IF K>0 THEN
SET POINT COLOR MOD(K,256)
ELSE
SET POINT COLOR 255
END IF
PLOT POINTS:X,Y
NEXT X
NEXT Y
! PRINT "エリアを指定してください"
! CALL GETSQUARE(XMIN,YMAX,XMAX,YMIN)
!LOOP UNTIL XMIN=XMAX OR YMIN=YMAX
END

EXTERNAL FUNCTION FIXED(X,Y)
FOR K=1 TO KMAX
LET XX=F(X,Y)
LET YY=G(X,Y)
IF ABS(XX)+ABS(YY)>200 THEN ! 発散したら
LET FIXED=-1
EXIT FUNCTION
END IF
IF ABS(XX-X)<EPS AND ABS(YY-Y)<EPS THEN ! 収束したら
LET FIXED=K ! 収束までの回数
EXIT FUNCTION
END IF
LET X=XX
LET Y=YY
NEXT K
FOR ID=1 TO NUM
IF ABS(PX(ID)-XX)<EPS AND ABS(PY(ID)-YY)<EPS THEN ! アトラクタ
LET FIXED=ID
EXIT FUNCTION
END IF
NEXT ID
LET NUM=NUM+1
LET PX(NUM)=XX
LET PY(NUM)=YY
LET FIXED=NUM
END FUNCTION

EXTERNAL FUNCTION F(X,Y)
LET F=Y+A*X+4*X/(1+X*X)
END FUNCTION

EXTERNAL FUNCTION G(X,Y)
LET G=-B*X
END FUNCTION

EXTERNAL SUB GETSQUARE(L,T,R,B)
ASK LINE STYLE LSTYLE
SET DRAW MODE NOTXOR
SET LINE STYLE 2
DO
MOUSE POLL L,T,I,J
LOOP WHILE I=0
LET L0=L
LET T0=T
LET R0=L0
LET B0=T0
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
DO WHILE I=1
MOUSE POLL R,B,I,J
LET W=R-L
LET H=T-B
IF ABS(H)<ABS(W) THEN
LET B=T-SGN(H)*ABS(W)
ELSE
LET R=L+SGN(W)*ABS(H)
END IF
IF L0<>L OR R0<>R OR B0<>B OR T0<>T THEN
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
PLOT LINES:L,T;L,B;R,B;R,T;L,T
LET L0=L
LET T0=T
LET R0=R
LET B0=B
END IF
LOOP
WAIT DELAY 1
PLOT LINES:L,T;L,B;R,B;R,T;L,T
SET DRAW MODE OVERWRITE
SET LINE STYLE LSTYLE
IF L>R THEN SWAP L,R
IF B>T THEN SWAP B,T
END SUB
-------------------------------------------------------------------------------------------------------
PUBLIC NUMERIC A,B,C,U,KMAX,EPS,PX(1000),PY(1000),NUM
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
LET EPS=1E-5
LET KMAX=400
LOCATE VALUE ,RANGE -1 TO 1,AT .6: A
LOCATE VALUE ,RANGE -1 TO 1,AT .85: B
LOCATE VALUE ,RANGE -10 TO 10,AT 4: C
LOCATE VALUE ,RANGE -10 TO 10,AT 0: U
LOCATE VALUE ,RANGE -100 TO 100,AT -30: XMIN
LOCATE VALUE ,RANGE -100 TO 100,AT -30: YMIN
LOCATE VALUE ,RANGE 10 TO 200,AT 60: SIZE
PRINT A;B;C;U;XMIN;YMIN;SIZE
LET XMAX=XMIN+SIZE
LET YMAX=YMIN+SIZE
SET WINDOW XMIN,XMAX,YMAX,YMIN
FOR Y=YMIN TO YMAX STEP (YMAX-YMIN)/YSIZE
FOR X=XMIN TO XMAX STEP (XMAX-XMIN)/XSIZE
LET K=FIXED(X,Y)
IF K>0 THEN
SET POINT COLOR MOD(K,256)
ELSE
SET POINT COLOR 255
END IF
PLOT POINTS:X,Y
NEXT X
NEXT Y
END

EXTERNAL FUNCTION FIXED(X,Y)
FOR K=1 TO KMAX
LET XX=F(X,Y)
LET YY=G(X,Y)
IF ABS(XX)+ABS(YY)>200 THEN
LET FIXED=-1
EXIT FUNCTION
END IF
IF ABS(XX-X)<EPS AND ABS(YY-Y)<EPS THEN
LET FIXED=K
EXIT FUNCTION
END IF
LET X=XX
LET Y=YY
NEXT K
FOR ID=1 TO NUM
IF ABS(PX(ID)-XX)<EPS AND ABS(PY(ID)-YY)<EPS THEN
LET FIXED=ID
EXIT FUNCTION
END IF
NEXT ID
LET NUM=NUM+1
LET PX(NUM)=XX
LET PY(NUM)=YY
LET FIXED=NUM
END FUNCTION

EXTERNAL FUNCTION F(X,Y)
LET F=Y+A*X+C/(1+X*X)+U
END FUNCTION

EXTERNAL FUNCTION G(X,Y)
LET G=-B*X
END FUNCTION
-------------------------------------------------------------------------------------------------------
PUBLIC NUMERIC A,B,KMAX,EPS,PX(1000),PY(1000),NUM
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
LET EPS=1E-5
LET KMAX=400
LOCATE VALUE ,RANGE -2 TO 2,AT .11: A
LOCATE VALUE ,RANGE -2 TO 2,AT -1.19: B
LOCATE VALUE ,RANGE -10 TO 10,AT -2: XMIN
LOCATE VALUE ,RANGE -10 TO 10,AT -2: YMIN
LOCATE VALUE ,RANGE 1 TO 10,AT 4: SIZE
PRINT A;B;XMIN;YMIN;SIZE
LET XMAX=XMIN+SIZE
LET YMAX=YMIN+SIZE
SET WINDOW XMIN,XMAX,YMAX,YMIN
FOR Y=YMIN TO YMAX STEP (YMAX-YMIN)/YSIZE
FOR X=XMIN TO XMAX STEP (XMAX-XMIN)/XSIZE
LET K=FIXED(X,Y)
IF K>0 THEN
SET POINT COLOR MOD(K,256)
ELSE
SET POINT COLOR 255
END IF
PLOT POINTS:X,Y
NEXT X
NEXT Y
END

EXTERNAL FUNCTION FIXED(X,Y)
FOR K=1 TO KMAX
LET XX=F(X,Y)
LET YY=G(X,Y)
IF ABS(XX)+ABS(YY)>200 THEN
LET FIXED=-1
EXIT FUNCTION
END IF
IF ABS(XX-X)<EPS AND ABS(YY-Y)<EPS THEN
LET FIXED=K
EXIT FUNCTION
END IF
LET X=XX
LET Y=YY
NEXT K
FOR ID=1 TO NUM
IF ABS(PX(ID)-XX)<EPS AND ABS(PY(ID)-YY)<EPS THEN
LET FIXED=ID
EXIT FUNCTION
END IF
NEXT ID
LET NUM=NUM+1
LET PX(NUM)=XX
LET PY(NUM)=YY
LET FIXED=NUM
END FUNCTION

EXTERNAL FUNCTION F(X,Y)
LET F=Y+A*X
END FUNCTION

EXTERNAL FUNCTION G(X,Y)
LET G=X*X+B
END FUNCTION

極形式 - しばっち

2023/11/12 (Sun) 08:46:26

極形式をいろいろ求めてみました。

https://ja.wikipedia.org/wiki/複素数

複素数 z=a+bi (i^2=-1)
r^2=z*conj(z)=(a+bi)(a-bi)=a^2+b^2
I=bi/sqr(b^2)=i

z=r(cosθ+Isinθ)
r=sqr(a^2+b^2)
θ=acos(a/r) ※r>0

exp(ix)=1+xi-x^2/2!-x^3i/3!+x^4/4!+x^5i/5!-x^6/6!-x^7i/7!+...
=(1-x^2/2!+x^4/4!-x^6/6!+...)+i(x-x^3/3!+x^5/5!-x^7/7!+...)
=cos(x)+isin(x)


DIM Z(2),A(2),ZZ(2)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
!LET N=-SQR(60)
LET N=2
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y))
IF N>0 THEN MAT Z=ZER ELSE MAT Z=A
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CSET(X(),A,B)
LET X(1)=A
LET X(2)=B
END SUB

EXTERNAL FUNCTION CABS(Z())
LET CABS=SQR(DOT(Z,Z)) ! ユークリッド距離 N=2
!LET CABS=ABS(Z(1))+ABS(Z(2)) ! マンハッタン距離 N=1
!LET N=-.5
!LET CABS=(ABS(Z(1))^N+ABS(Z(2))^N)^(1/N) ! ミンコフスキー距離 N
!LET CABS=MAX(ABS(Z(1)),ABS(Z(2))) ! チェビシェフ距離 N=∞
!LET CABS=MIN(ABS(Z(1)),ABS(Z(2))) ! チェビシェフ距離 N=-∞
!LET CABS=SMIN(ABS(Z(1)),ABS(Z(2)))
END FUNCTION

EXTERNAL FUNCTION CABS2(A(),B())
LET N=2
FOR I=1 TO 2
LET S=S+ABS(A(I)-B(I))^N ! ミンコフスキー距離
NEXT I
LET CABS2=S^(1/N)
END FUNCTION

!EXTERNAL FUNCTION SMIN(A,B) !exponential smooth min
!LET K=32
!LET RES=EXP(-K*A)+EXP(-K*B)
!LET SMIN=-LOG(RES)/K
!END FUNCTION

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB GETPARA(X(),R,TH)
LET R=SQR(DOT(X,X))
IF R=0 THEN
LET TH=0
ELSE
LET TH=ANGLE(X(1),X(2))
END IF
END SUB

EXTERNAL SUB SETPARA(X(),R,TH)
LET X(1)=R*COS(TH)
LET X(2)=R*SIN(TH)
END SUB

EXTERNAL SUB CMUL(S(),X(),Y())
CALL GETPARA(X,R1,TH1)
CALL GETPARA(Y,R2,TH2)
CALL SETPARA(S,R1*R2,TH1+TH2)
END SUB

EXTERNAL SUB CDIV(S(),X(),Y())
CALL GETPARA(X,R1,TH1)
CALL GETPARA(Y,R2,TH2)
CALL SETPARA(S,R1/R2,TH1-TH2)
END SUB

EXTERNAL SUB CPRINT(A())
PRINT A(1);
IF A(2)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2));"i"
END SUB

EXTERNAL SUB CPOW(Y(),X(),N) ! Y=X^N
CALL GETPARA(X,R,TH)
CALL SETPARA(Y,R^N,TH*N)
END SUB
----------------------------------------------------------------------------------------
下記はニュートン法は使わずに3乗根への収束過程によるフラクタルです。


DIM Z(2),A(2),B(2),T(2)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
CALL CSET(Z,1,0)
LET N=3 ! 3乗根 N=2,3
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y))
MAT B=ZER
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CADD(A,A,B)
MAT A=.5*A
CALL CPOW(T,A,N-1)
CALL CDIV(B,Z,T)
IF CABS2(A,B)<1E-8 THEN EXIT FOR
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
NEXT X
NEXT Y
END
***********************************************
下記は分解型複素数を極形式にしています。

https://ja.wikipedia.org/wiki/分解型複素数

分解型複素数 z=a+bj (j^2=1)
r^2=z*conj(z)=(a+bj)(a-bj)=a^2-b^2
I=bj/sqr(b^2)=j

z=r(coshθ+Isinhθ)
r=sqr(a^2-b^2) ※a>b
θ=acosh(a/r)

exp(jx)=1+xj+x^2/2!+x^3j/3!+x^4/4!+x^5j/5!+x^6/6!+x^7j/7!+...
=(1+x^2/2!+x^4/4!+x^6/6!+..)+j(x+x^3/3!+x^5/5!+x^7/7!+...)
=cosh(x)+jsinh(x)

EXTERNAL SUB GETPARA(X(),R,TH)
LET RR=X(1)^2-X(2)^2
! LET RR=ABS(RR)
IF RR<=0 THEN
LET TH=0
LET R=0
ELSE
LET R=SQR(RR)
LET TH=ACOSH(X(1)/R)
END IF
END SUB

EXTERNAL SUB SETPARA(X(),R,TH)
LET X(1)=R*COSH(TH)
LET X(2)=R*SINH(TH)
END SUB

EXTERNAL FUNCTION ACOSH(X)
LET ACOSH=LOG(X+SQR(X*X-1)) !'arc-hyperbolic cosine
END FUNCTION
***********************************************
下記は2重数を極形式にしてみました。

https://ja.wikipedia.org/wiki/二重数

2重数 z=a+bε(ε^2=0)

r^2=z*conj(z)=(a+bε)(a-bε)=a^2
I=bε/sqr(b^2)=ε

z=r(1+Iw)
r=a
w=b/r ※r<>0

exp(εx)=1+xε

EXTERNAL SUB GETPARA(X(),R,T)
LET R=X(1)
IF R=0 THEN
LET T=0
ELSE
LET T=X(2)/R
END IF
END SUB

EXTERNAL SUB SETPARA(S(),R,T)
LET S(1)=R
LET S(2)=R*T
END SUB
----------------------------------------------------------------------------------------
複素数形式を拡張して4元数を極形式にしてみました。

4元数 z=a+bi+cj+dk (i^2=j^2=k^2=-1)

r^2=z*conj(z)=(a+bi+cj+dk)(a-bi-cj-dk)=a^2+b^2+c^2+d^2
I=(bi+cj+dk)/sqr(b^2+c^2+d^2)

z=r(cosθ+Isinθ)
r=sqr(a^2+b^2+c^2+d^2)
θ=acos(a/r) ※r<>0


EXTERNAL FUNCTION CABS_(X())
LET X(1)=0
LET CABS_=SQR(DOT(X,X))
END FUNCTION

EXTERNAL SUB GETPARA(X(),R,RR,TH,B,C,D)
LET R=SQR(DOT(X,X))
LET RR=CABS_(X)
IF R=0 THEN
LET TH=0
ELSE
LET TH=ACOS(X(1)/R)
END IF
LET B=X(2)
LET C=X(3)
LET D=X(4)
END SUB

EXTERNAL SUB SETPARA(X(),R,RR,TH,B,C,D)
MAT X=ZER
LET X(1)=R*COS(TH)
IF RR<>0 THEN
LET X(2)=R*SIN(TH)*B/RR
LET X(3)=R*SIN(TH)*C/RR
LET X(4)=R*SIN(TH)*D/RR
END IF
END SUB

EXTERNAL SUB CMUL(Z(),X(),Y())
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1)
CALL GETPARA(Y,R2,RR2,TH2,B2,C2,D2)
CALL SETPARA(Z,R1*R2,RR1+RR2,TH1+TH2,B1+B2,C1+C2,D1+D2)
END SUB

EXTERNAL SUB CPOW(Z(),X(),N)
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1)
CALL SETPARA(Z,R1^N,RR1*N,TH1*N,B1*N,C1*N,D1*N)
END SUB
----------------------------------------------------------------------------------------
更に拡張して8元数定義してみた。

8元数 z=a+bi+cj+dk+el+fm+gn+ho (i^2=j^2=k^2=l^2=m^2=n^2=o^2=-1)

r^2=z*conj(z)=(a+bi+cj+dk+el+fm+gn+ho)(a-bi-cj-dk-el-fm-gn-ho)=a^2+b^2+c^2+d^2+e^2+f^2+g^2+h^2
I=(bi+cj+dk+el+fm+gn+ho)/sqr(b^2+c^2+d^2+e^2+f^2+g^2+h^2)

z=r(cosθ+Isinθ)
r=sqr(a^2+b^2+c^2+d^2+e^2+f^2+g^2+h^2)
θ=acos(a/r) ※r<>0

EXTERNAL SUB GETPARA(X(),R,RR,TH,B,C,D,E,F,G,H)
LET R=SQR(DOT(X,X))
LET RR=CABS_(X)
IF R=0 THEN
LET TH=0
ELSE
LET TH=ACOS(X(1)/R)
END IF
LET B=X(2)
LET C=X(3)
LET D=X(4)
LET E=X(5)
LET F=X(6)
LET G=X(7)
LET H=X(8)
END SUB

EXTERNAL SUB SETPARA(X(),R,RR,TH,B,C,D,E,F,G,H)
MAT X=ZER
LET X(1)=R*COS(TH)
IF RR<>0 THEN
LET X(2)=R*SIN(TH)*B/RR
LET X(3)=R*SIN(TH)*C/RR
LET X(4)=R*SIN(TH)*D/RR
LET X(5)=R*SIN(TH)*E/RR
LET X(6)=R*SIN(TH)*F/RR
LET X(7)=R*SIN(TH)*G/RR
LET X(8)=R*SIN(TH)*H/RR
END IF
END SUB

EXTERNAL SUB CMUL(Z(),X(),Y())
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1,E1,F1,G1,H1)
CALL GETPARA(Y,R2,RR2,TH2,B2,C2,D2,E2,F2,G2,H2)
CALL SETPARA(Z,R1*R2,RR1+RR2,TH1+TH2,B1+B2,C1+C2,D1+D2,E1+E2,F1+F2,G1+G2,H1+H2)
END SUB

EXTERNAL SUB CPOW(Z(),X(),N)
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1,E1,F1,G1,H1)
CALL SETPARA(Z,R1^N,RR1*N,TH1*N,B1*N,C1*N,D1*N,E1*N,F1*N,G1*N,H1*N)
END SUB

EXTERNAL SUB CDIV(Z(),X(),Y())
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1,E1,F1,G1,H1)
CALL GETPARA(Y,R2,RR2,TH2,B2,C2,D2,E2,F2,G2,H2)
CALL SETPARA(Z,R1/R2,RR1-RR2,TH1-TH2,B1-B2,C1-C2,D1-D2,E1-E2,F1-F2,G1-G2,H1-H2)
END SUB

EXTERNAL FUNCTION CABS_(X())
LET X(1)=0
LET CABS_=SQR(DOT(X,X))
END FUNCTION
----------------------------------------------------------------------------------------
上と同様に分解型複素数を拡張して分解型4元数定義してみた。

分解型4元数 z=a+bi+cj+dk (i^2=j^2=k^2=1) ※本来はi^2=-1ですが、ここではi^2=1とする
r^2=z*conj(z)=(a+bi+cj+dk)(a-bi-cj-dk)=a^2-b^2-c^2-d^2
I=(bi+cj+dk)/sqr(b^2+c^2+d^2)

z=r(coshθ+Isinhθ)
r=sqr(a^2-b^2-c^2-d^2) ※a^2-b^2-c^2-d^2>0
θ=acosh(a/r)

EXTERNAL SUB GETPARA(X(),R,RR,TH,B,C,D)
LET R=X(1)^2-X(2)^2-X(3)^2-X(4)^2
LET RR=SQR(X(2)^2+X(3)^2+X(4)^2)
IF R<=0 THEN
LET TH=0
ELSE
LET R=SQR(R)
LET TH=ACOSH(X(1)/R)
END IF
LET B=X(2)
LET C=X(3)
LET D=X(4)
END SUB

EXTERNAL SUB SETPARA(X(),R,RR,TH,B,C,D)
MAT X=ZER
LET X(1)=R*COSH(TH)
IF RR<>0 THEN
LET X(2)=R*SINH(TH)*B/RR
LET X(3)=R*SINH(TH)*C/RR
LET X(4)=R*SINH(TH)*D/RR
END IF
END SUB

EXTERNAL SUB CMUL(Z(),X(),Y())
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1)
CALL GETPARA(Y,R2,RR2,TH2,B2,C2,D2)
CALL SETPARA(Z,R1*R2,RR1+RR2,TH1+TH2,B1+B2,C1+C2,D1+D2)
END SUB

EXTERNAL SUB CPOW(Z(),X(),N)
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1)
CALL SETPARA(Z,R1^N,RR1*N,TH1*N,B1*N,C1*N,D1*N)
END SUB

EXTERNAL SUB CDIV(Z(),X(),Y())
CALL GETPARA(X,R1,RR1,TH1,B1,C1,D1)
CALL GETPARA(Y,R2,RR2,TH2,B2,C2,D2)
CALL SETPARA(Z,R1/R2,RR1-RR2,TH1-TH2,B1-B2,C1-C2,D1-D2)
END SUB
----------------------------------------------------------------------------------------
上と同様に4重数(造語です)定義してみた。

4重数 z=a+bε+cζ+dη (ε^2=ζ^2=η^2=0)

r^2=z*conj(z)=(a+bε+cζ+dη)(a-bε-cζ-dη)=a^2
I=(bε+cζ+dη)/sqr(b^2+c^2+d^2)

z=r(1+Iw)
r=a
w=sqr(b^2+c^2+d^2)/r ※r<>0

EXTERNAL SUB GETPARA(X(),R,PARA())
LET R=X(1)
IF R=0 THEN
LET PARA(1)=0
LET PARA(2)=0
LET PARA(3)=0
ELSE
FOR I=1 TO 3
LET PARA(I)=X(I+1)/R
NEXT I
END IF
END SUB

EXTERNAL SUB SETPARA(S(),R,PARA())
LET S(1)=R
FOR I=1 TO 3
LET S(I+1)=R*PARA(I)
NEXT I
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM PARA1(3),PARA2(3)
CALL GETPARA(A,R1,PARA1)
CALL GETPARA(B,R2,PARA2)
MAT PARA1=PARA1+PARA2
CALL SETPARA(S,R1*R2,PARA1)
END SUB

EXTERNAL SUB CDIV(S(),A(),B())
DIM PARA1(3),PARA2(3)
CALL GETPARA(A,R1,PARA1)
CALL GETPARA(B,R2,PARA2)
MAT PARA1=PARA1-PARA2
CALL SETPARA(S,R1/R2,PARA1)
END SUB

EXTERNAL SUB CPOW(Z(),X(),N)
DIM PARA(3)
CALL GETPARA(X,R,PARA)
MAT PARA=N*PARA
CALL SETPARA(Z,R^N,PARA)
END SUB
-------------------------------------------------------------------------------------
更に8重数(造語です)定義してみた。

8重数 z=a+bε+cζ+dη+eθ+fι+gκ+hλ (ε^2=ζ^2=η^2=θ^2=ι^2=κ^2=λ^2=0)

r^2=z*conj(z)=(a+bε+cζ+dη+eθ+fι+gκ+hλ)(a-bε-cζ-dη-eθ-fι-gκ-hλ)=a^2
I=(bε+cζ+dη+eθ+fι+gκ+hλ)/sqr(b^2+c^2+d^2+e^2+f^2+g^2+h^2)

z=r(1+Iw)
r=a
w=sqr(b^2+c^2+d^2+e^2+f^2+g^2+h^2)/r ※r<>0

EXTERNAL SUB GETPARA(X(),R,PARA())
LET R=X(1)
IF R=0 THEN
MAT PARA=ZER
ELSE
FOR I=1 TO 7
LET PARA(I)=X(I+1)/R
NEXT I
END IF
END SUB

EXTERNAL SUB SETPARA(S(),R,PARA())
LET S(1)=R
FOR I=1 TO 7
LET S(I+1)=R*PARA(I)
NEXT I
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM PARA1(7),PARA2(7)
CALL GETPARA(A,R1,PARA1)
CALL GETPARA(B,R2,PARA2)
MAT PARA1=PARA1+PARA2
CALL SETPARA(S,R1*R2,PARA1)
END SUB

EXTERNAL SUB CDIV(S(),A(),B())
DIM PARA1(7),PARA2(7)
CALL GETPARA(A,R1,PARA1)
CALL GETPARA(B,R2,PARA2)
MAT PARA1=PARA1-PARA2
CALL SETPARA(S,R1/R2,PARA1)
END SUB

EXTERNAL SUB CPOW(Z(),X(),N)
DIM PARA(7)
CALL GETPARA(X,R,PARA)
MAT PARA=N*PARA
CALL SETPARA(Z,R^N,PARA)
END SUB
----------------------------------------------------------------------------------------
下記に次のような4元数、16元数も定義してみた。


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)
LET SS(2)=A(1)*B(2)+A(2)*B(1)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)-A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)+A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB
***********************************************
EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(16)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)
LET SS(9)=A(1)*B(9)-A(2)*B(10)-A(3)*B(11)-A(4)*B(12)-A(5)*B(13)-A(6)*B(14)-A(7)*B(15)-A(8)*B(16)+A(9)*B(1)-A(10)*B(2)-A(11)*B(3)-A(12)*B(4)-A(13)*B(5)-A(14)*B(6)-A(15)*B(7)-A(16)*B(8)
LET SS(10)=A(1)*B(10)+A(2)*B(9)+A(3)*B(12)-A(4)*B(11)+A(5)*B(14)-A(6)*B(13)-A(7)*B(16)+A(8)*B(15)+A(9)*B(2)+A(10)*B(1)+A(11)*B(4)-A(12)*B(3)+A(13)*B(6)-A(14)*B(5)-A(15)*B(8)+A(16)*B(7)
LET SS(11)=A(1)*B(11)-A(2)*B(12)+A(3)*B(9)+A(4)*B(10)+A(5)*B(15)+A(6)*B(16)-A(7)*B(13)-A(8)*B(14)+A(9)*B(3)-A(10)*B(4)+A(11)*B(1)+A(12)*B(2)+A(13)*B(7)+A(14)*B(8)-A(15)*B(5)-A(16)*B(6)
LET SS(12)=A(1)*B(12)+A(2)*B(11)-A(3)*B(10)+A(4)*B(9)+A(5)*B(16)-A(6)*B(15)+A(7)*B(14)-A(8)*B(13)+A(9)*B(4)+A(10)*B(3)-A(11)*B(2)+A(12)*B(1)+A(13)*B(8)-A(14)*B(7)+A(15)*B(6)-A(16)*B(5)
LET SS(13)=A(1)*B(13)-A(2)*B(14)-A(3)*B(15)-A(4)*B(16)+A(5)*B(9)+A(6)*B(10)+A(7)*B(11)+A(8)*B(12)+A(9)*B(5)-A(10)*B(6)-A(11)*B(7)-A(12)*B(8)+A(13)*B(1)+A(14)*B(2)+A(15)*B(3)+A(16)*B(4)
LET SS(14)=A(1)*B(14)+A(2)*B(13)-A(3)*B(16)+A(4)*B(15)-A(5)*B(10)+A(6)*B(9)-A(7)*B(12)+A(8)*B(11)+A(9)*B(6)+A(10)*B(5)-A(11)*B(8)+A(12)*B(7)-A(13)*B(2)+A(14)*B(1)-A(15)*B(4)+A(16)*B(3)
LET SS(15)=A(1)*B(15)+A(2)*B(16)+A(3)*B(13)-A(4)*B(14)-A(5)*B(11)+A(6)*B(12)+A(7)*B(9)-A(8)*B(10)+A(9)*B(7)+A(10)*B(8)+A(11)*B(5)-A(12)*B(6)-A(13)*B(3)+A(14)*B(4)+A(15)*B(1)-A(16)*B(2)
LET SS(16)=A(1)*B(16)-A(2)*B(15)+A(3)*B(14)+A(4)*B(13)-A(5)*B(12)-A(6)*B(11)+A(7)*B(10)+A(8)*B(9)+A(9)*B(8)-A(10)*B(7)+A(11)*B(6)+A(12)*B(5)-A(13)*B(4)-A(14)*B(3)+A(15)*B(2)+A(16)*B(1)
MAT S=SS
END SUB
----------------------------------------------------------------------------------------
下記のような4元数を定義し乗積表及び
掛け算ルーチンを書き出します。

乗積表は
1*1,1*i,1*j,1*k
i*1,i*i,i*j,i*k
j*1,j*i,j*j,j*k
k*1,k*i,k*j,k*k
の計算結果を表しています。


DIM S(4),X(4),Y(4),M(4,4),A$(4)
MAT READ A$
DATA "1 ","i ","j ","k "
FOR I=1 TO 4
LET X(I)=1
FOR J=1 TO 4
LET Y(J)=1
CALL CMUL(S,X,Y)
FOR K=1 TO 4
IF ABS(S(K))<1E-3 THEN LET S(K)=0
IF S(K)>0 THEN
PRINT " ";A$(K);
LET M(I,J)=K
EXIT FOR
ELSEIF S(K)<0 THEN
PRINT "-";A$(K);
LET M(I,J)=-K
EXIT FOR
END IF
NEXT K
LET Y(J)=0
NEXT J
PRINT
LET X(I)=0
NEXT I
PRINT
PRINT "SUB CMUL(S(),A(),B())"
PRINT "DIM SS(4)"
FOR K=1 TO 4
PRINT "SS(";STR$(K);")=";
FOR I=1 TO 4
FOR J=1 TO 4
IF M(I,J)=K THEN
PRINT "+A(";STR$(I);")*B(";STR$(J);")";
ELSEIF M(I,J)=-K THEN
PRINT "-A(";STR$(I);")*B(";STR$(J);")";
END IF
NEXT J
NEXT I
PRINT
NEXT K
PRINT "MAT S=SS"
PRINT "END SUB"
END

EXTERNAL SUB SETPARA(Z(),R,TH())
LET Z(1)=R*COS(TH(1))*COS(TH(2))
LET Z(2)=R*COS(TH(1))*SIN(TH(2))
LET Z(3)=R*SIN(TH(1))*COS(TH(2))
LET Z(4)=R*SIN(TH(1))*SIN(TH(2))
END SUB

EXTERNAL SUB GETPARA(Z(),R,TH())
LET R=SQR(DOT(Z,Z))
IF R=0 THEN
MAT TH=ZER
ELSE
LET TH(1)=ACOS(SQR(Z(1)^2+Z(2)^2)/R)
LET TH(2)=ACOS(SQR(Z(1)^2+Z(3)^2)/R)
END IF
END SUB

EXTERNAL SUB CMUL(Z(),A(),B())
DIM TH1(2),TH2(2)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1+TH2
CALL SETPARA(Z,R1*R2,TH1)
END SUB
----------------------------------------------------------------------------------------
上記を拡張して32元数(造語です)だって定義できます。


DIM S(32),X(32),Y(32),M(32,32),A$(32)
MAT READ A$
DATA "1 ","i ","j ","k ","l ","m ","n ","o ","p ","q ","r ","s ","t ","u ","v ","w ","x ","y ","z ","a ","b ","c ","d ","e ","f ","g ","h ","I ","J ","K ","L ","M "
FOR I=1 TO 32
LET X(I)=1
FOR J=1 TO 32
LET Y(J)=1
CALL CMUL(S,X,Y)
FOR K=1 TO 32
IF ABS(S(K))<1E-3 THEN LET S(K)=0
IF S(K)>0 THEN
PRINT " ";A$(K);
LET M(I,J)=K
EXIT FOR
ELSEIF S(K)<0 THEN
PRINT "-";A$(K);
LET M(I,J)=-K
EXIT FOR
END IF
NEXT K
LET Y(J)=0
NEXT J
PRINT
LET X(I)=0
NEXT I
PRINT
PRINT "SUB CMUL(S(),A(),B())"
PRINT "DIM SS(32)"
FOR K=1 TO 32
PRINT "SS(";STR$(K);")=";
FOR I=1 TO 32
FOR J=1 TO 32
IF M(I,J)=K THEN
PRINT "+A(";STR$(I);")*B(";STR$(J);")";
ELSEIF M(I,J)=-K THEN
PRINT "-A(";STR$(I);")*B(";STR$(J);")";
END IF
NEXT J
NEXT I
PRINT
NEXT K
PRINT "MAT S=SS"
PRINT "END SUB"
END

EXTERNAL SUB SETPARA(Z(),R,TH())
FOR I=0 TO 31
LET Z(I+1)=R
IF BITAND(I,16)=0 THEN LET Z(I+1)=Z(I+1)*COS(TH(1)) ELSE LET Z(I+1)=Z(I+1)*SIN(TH(1))
IF BITAND(I,8)=0 THEN LET Z(I+1)=Z(I+1)*COS(TH(2)) ELSE LET Z(I+1)=Z(I+1)*SIN(TH(2))
IF BITAND(I,4)=0 THEN LET Z(I+1)=Z(I+1)*COS(TH(3)) ELSE LET Z(I+1)=Z(I+1)*SIN(TH(3))
IF BITAND(I,2)=0 THEN LET Z(I+1)=Z(I+1)*COS(TH(4)) ELSE LET Z(I+1)=Z(I+1)*SIN(TH(4))
IF BITAND(I,1)=0 THEN LET Z(I+1)=Z(I+1)*COS(TH(5)) ELSE LET Z(I+1)=Z(I+1)*SIN(TH(5))
NEXT I
END SUB

EXTERNAL SUB GETPARA(Z(),R,TH())
LET R=SQR(DOT(Z,Z))
IF R=0 THEN
MAT TH=ZER
ELSE
FOR I=0 TO 31
IF BITAND(I,16)=0 THEN LET S1=S1+Z(I+1)^2
IF BITAND(I,8)=0 THEN LET S2=S2+Z(I+1)^2
IF BITAND(I,4)=0 THEN LET S3=S3+Z(I+1)^2
IF BITAND(I,2)=0 THEN LET S4=S4+Z(I+1)^2
IF BITAND(I,1)=0 THEN LET S5=S5+Z(I+1)^2
NEXT I
LET TH(1)=ACOS(SQR(S1)/R)
LET TH(2)=ACOS(SQR(S2)/R)
LET TH(3)=ACOS(SQR(S3)/R)
LET TH(4)=ACOS(SQR(S4)/R)
LET TH(5)=ACOS(SQR(S5)/R)
END IF
END SUB

EXTERNAL SUB CMUL(Z(),A(),B())
DIM TH1(5),TH2(5)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1+TH2
CALL SETPARA(Z,R1*R2,TH1)
END SUB

macとwindowsの違い - Twitter@hiro_1729

2023/10/05 (Thu) 15:32:42

MacとWindowsではグラフィックスにおける文字の表示が異なるのですか?
Windows版で正常に動作するプログラムがMacではずれて表示されたのでふと思いました

Re: macとwindowsの違い - Twitter@hiro_1729

2023/10/05 (Thu) 15:35:12

すみません、具体的なプログラムを書き忘れていました

SET WINDOW 0,9,0,9
DRAW GRID
SET TEXT HEIGHT 0.8
DATA "歩","歩","歩","歩","歩","歩","歩","歩","歩"
DATA " ","角"," "," "," "," "," ","飛"," "
DATA "香","桂","銀","金","王","金","銀","桂","香"
FOR J=2 TO 0 STEP -1
  FOR I=0 TO 8
    READ A$
    PLOT TEXT ,AT I,J : A$
  NEXT I
NEXT J
END

Re: macとwindowsの違い - SHIRAISHI Kazuo

2023/10/05 (Thu) 18:58:57

やってみました。
MACだと、漢字が上にズレるみたいです。
SET WINDOW 0,9,0,9
DRAW GRID
SET TEXT HEIGHT 0.8
DATA "12","歩","歩","歩","歩","歩","歩","歩","歩"
DATA " ","角"," "," "," "," "," ","飛"," "
DATA "香","桂","銀","金","王","金","銀","桂","香"
FOR J=2 TO 0 STEP -1
FOR I=0 TO 8
READ A$
PLOT TEXT ,AT I,J : A$
NEXT I
NEXT J
END
フォントの選び方によっても違うようで、対応が難しそうです。

Re: macとwindowsの違い SHIRAISHI Kazuo

2023/10/07 (Sat) 09:07:57

本来,日本語を含まないフォントを指定すると,日本語だけ上にずれ,
日本語用のフォントを指定すると,英数字も含めて一様に上にずれるような気がします。

Re: macとwindowsの違い - Twitter@hiro_1729

2023/10/07 (Sat) 15:13:13

なるほどー

Re: macとwindowsの違い - SHIRAISHI Kazuo

2023/10/08 (Sun) 18:36:55

フォントを変えて実行してみると、不思議なことが出てきます。
図は、PCMyungjoを選択した場合で、「歩」だけ上にずれます。
字の形も「歩」だけ違います。
InaiMathiを選ぶと,すべて正しい位置に描かれますが,InaiMathiは日本語用に作られたフォントではないようです。

Re: macとwindowsの違い - nagram

2023/10/12 (Thu) 16:27:49

MACを使ったことはないのですが,PCMyungjoは中文フォントなのではないでしょうか.
「歩」は日本語独自の漢字で,中文フォントでは対応していないと思います.
ですから欧文フォントと同じようなことが起きるのではないでしょうか.
(「歩」に相当する中国語の漢字は,字画が一画少ない別の漢字です.)

フラクタル画像 - しばっち

2023/10/08 (Sun) 13:59:16

フラクタル画像
https://decimalbasic.ninja-web.net/bbs2/board2020.html#4891


PUBLIC NUMERIC A(2),B(2),C(2),D(2),XMAX,XMIN,YMIN,YMAX,S(2),NUM,X0,Y0
DIM Z(2)
SET POINT STYLE 1
DO
LET XMIN=1E+10
LET XMAX=-1E+10
LET YMIN=1E+10
LET YMAX=-1E+10
LET NUM=0
LET X0=0
LET Y0=0
MAT S=ZER
READ IF MISSING THEN EXIT DO:A1,A2,B1,B2,C1,C2,D1,D2
CALL CSET(A,A1,A2)
CALL CSET(B,B1,B2)
CALL CSET(C,C1,C2)
CALL CSET(D,D1,D2)
CALL CSET(Z,0,0)
CALL DRAW(12,Z)
LET X0=S(1)/NUM ! 重心
LET Y0=S(2)/NUM
LET XS=MIN(XMIN-X0,YMIN-Y0)
LET XE=MAX(XMAX-X0,YMAX-Y0)
SET WINDOW XS,XE,XS,XE
CLEAR
CALL CSET(Z,0,0)
CALL DRAW(15,Z)
PAUSE
LOOP
DATA 0,0,.5,.288675134594813,0,0,.5,-.288675134594813
DATA 0,0,.4614,.4614,.622,-.196,0,0
DATA .4614,.4614,0,0,0,0,.622,-.196
DATA 0,0,.5,.28867,0,0,.6667,0
DATA 0,0,0,.6667,0,0,.6667,0
DATA 0,.7071,0,0,.5,0,0,0
DATA 0,0,.4,.5,0,0,.4,-.5
DATA .4614,.4614,0,0,0,0,.2896,-.585
DATA .4614,.4614,0,0,.622,-.196,0,0
END

EXTERNAL SUB DRAW(N,Z())
DIM AA(2),BB(2),CC(2),DD(2),ZZ(2),T(2)
IF N>0 THEN
LET XMIN=MIN(XMIN,Z(1))
LET XMAX=MAX(XMAX,Z(1))
LET YMIN=MIN(YMIN,Z(2))
LET YMAX=MAX(YMAX,Z(2))
LET NUM=NUM+1
MAT S=S+Z

CALL CMUL(AA,A,Z) ! AA=A*Z
CALL CCONJ(ZZ,Z) ! ZZ=CONJ(Z)
CALL CMUL(BB,B,ZZ) ! BB=B*CONJ(Z)
CALL CADD(ZZ,AA,BB) ! ZZ=A*Z+B*CONJ(Z)
CALL DRAW(N-1,ZZ)

CALL CSET(T,1,0)
CALL CSUB(CC,Z,T) ! CC=Z-1
CALL CMUL(CC,C,CC) ! CC=C*(Z-1)
CALL CCONJ(ZZ,Z) ! ZZ=CONJ(Z)
CALL CSUB(ZZ,ZZ,T) ! ZZ=CONJ(Z)-1
CALL CMUL(DD,D,ZZ) ! DD=D*(CONJ(Z)-1)
CALL CADD(DD,DD,T) ! DD=D*(CONJ(Z)-1)+1
CALL CADD(ZZ,CC,DD) ! ZZ=C*(Z-1)+D*(CONJ(Z)-1)+1
CALL DRAW(N-1,ZZ)
PLOT POINTS:Z(1)-X0,Z(2)-Y0
END IF
END SUB

EXTERNAL SUB CSET(X(),A,B)
LET X(1)=A
LET X(2)=B
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(2)
LET SS(1)=A(1)*B(1)-A(2)*B(2)
LET SS(2)=A(2)*B(1)+A(1)*B(2)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
LET S(2)=-A(2)
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(),A(),B())
MAT S=A-B
END SUB
*************************************************************
下記のCMULルーチンに置き換えると2重数となります。

サンプル画像は2重数コッホ曲線です。

https://ja.wikipedia.org/wiki/二重数


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(2)
LET SS(1)=A(1)*B(1)
LET SS(2)=A(2)*B(1)+A(1)*B(2)
MAT S=SS
END SUB
*************************************************************
下記のCMULルーチンに置き換えると分解型複素数となります。

https://ja.wikipedia.org/wiki/分解型複素数


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(2)
LET SS(1)=A(1)*B(1)+A(2)*B(2)
LET SS(2)=A(2)*B(1)+A(1)*B(2)
MAT S=SS
END SUB

ガウス素数 - しばっち

2023/10/08 (Sun) 13:57:29

ガウス素数

ガウス素数を求めます。
https://ja.wikipedia.org/wiki/ガウス整数


LET N=50
DIM M(-N TO N,-N TO N)
FOR X=1 TO N
FOR Y=0 TO N
IF (Y=0 OR GCD(X,Y)=1) AND ISPRIME(X,Y)<>0 THEN
LET M(X,Y)=1
LET M(X,-Y)=1
LET M(-X,Y)=1
LET M(-X,-Y)=1
END IF
NEXT Y
NEXT X
MAT PLOT CELLS ,IN 0,0;1,1:M
END

EXTERNAL FUNCTION ISPRIME(X,Y)
DIM A(2),B(2),C(2)
LET RR=INT(SQR(X))
LET II=INT(SQR(Y))
LET A(1)=X
LET A(2)=Y
FOR I1=0 TO II
LET B(2)=I1
FOR R=0 TO RR
LET B(1)=R
IF R+I1>1 THEN
WHEN EXCEPTION IN
CALL CDIV(C,A,B)
IF FP(C(1))=0 AND FP(C(2))=0 THEN
LET ISPRIME=0
EXIT FUNCTION
END IF
USE
LET ISPRIME=1
EXIT FUNCTION
END WHEN
END IF
NEXT R
NEXT I1
LET ISPRIME=1
END FUNCTION

EXTERNAL FUNCTION GCD(M,N) !'最大公約数
DO WHILE N<>0
LET T=MOD(M,N)
LET M=N
LET N=T
LOOP
LET GCD=M
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(2)
LET SS(1)=A(1)*B(1)-A(2)*B(2)
LET SS(2)=A(2)*B(1)+A(1)*B(2)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
LET S(2)=-A(2)
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(2),S1(2),S2(2)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB
*******************************************************************
下記ルーチンでは分解型複素数になります。


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(2)
LET SS(1)=A(1)*B(1)+A(2)*B(2)
LET SS(2)=A(2)*B(1)+A(1)*B(2)
MAT S=SS
END SUB

6元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:56:07

6元数マンデルブロ集合

6元数を定義してみた。


DIM Z(6),A(6),ZZ(6)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
LET N=SQR(5)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CSET(X(),A,B,C,D,E,F)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 6
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB GETPARA(Z(),R,TH())
LET R=SQR(DOT(Z,Z))
IF R=0 THEN
MAT TH=ZER
EXIT SUB
END IF
LET TH(1)=ACOS(Z(1)/R)
IF R*SIN(TH(1))=0 THEN
LET TH(2)=0
LET TH(3)=0
LET TH(4)=0
LET TH(5)=0
ELSE
LET T2=MAX(-1,MIN(Z(2)/(R*SIN(TH(1))),1))
LET TH(2)=ACOS(T2)
END IF
IF R*SIN(TH(1))*SIN(TH(2))=0 THEN
LET TH(3)=0
LET TH(4)=0
LET TH(5)=0
ELSE
LET T3=MAX(-1,MIN(Z(3)/(R*SIN(TH(1))*SIN(TH(2))),1))
LET TH(3)=ACOS(T3)
END IF
IF R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))=0 THEN
LET TH(4)=0
LET TH(5)=0
ELSE
LET T4=MAX(-1,MIN(Z(4)/(R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))),1))
LET TH(4)=ACOS(T4)
END IF
IF Z(5)=0 AND Z(6)=0 THEN LET TH(5)=0 ELSE LET TH(5)=ANGLE(Z(5),Z(6))
END SUB

EXTERNAL SUB SETPARA(Z(),R,TH())
LET Z(1)=R*COS(TH(1))
LET Z(2)=R*SIN(TH(1))*COS(TH(2))
LET Z(3)=R*SIN(TH(1))*SIN(TH(2))*COS(TH(3))
LET Z(4)=R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))*COS(TH(4))
LET Z(5)=R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))*SIN(TH(4))*COS(TH(5))
LET Z(6)=R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))*SIN(TH(4))*SIN(TH(5))
!'Z(n-1)=R*SIN(TH(1))*SIN(TH(2))*...SIN(TH(n-2))*COS(TH(n-1))
!'Z(n )=R*SIN(TH(1))*SIN(TH(2))*...SIN(TH(n-2))*SIN(TH(n-1))
END SUB

EXTERNAL SUB CMUL(Z(),A(),B())
DIM TH1(5),TH2(5)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1+TH2
CALL SETPARA(Z,R1*R2,TH1)
END SUB

EXTERNAL SUB CDIV(Z(),A(),B())
DIM TH1(5),TH2(5)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1-TH2
CALL SETPARA(Z,R1/R2,TH1)
END SUB

EXTERNAL SUB CADD(Z(),A(),B())
MAT Z=A+B
END SUB

EXTERNAL SUB CSUB(Z(),A(),B())
MAT Z=A-B
END SUB

EXTERNAL SUB CPOW(S(),Z(),N)
DIM TH(5)
CALL GETPARA(Z,R,TH)
MAT TH=N*TH
CALL SETPARA(S,R^N,TH)
END SUB

EXTERNAL SUB CPRINT(Z())
IF ABS(Z(1))<1E-5 THEN PRINT " 0 ";ELSE PRINT Z(1);
IF Z(2)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(2))<1E-5 THEN PRINT " 0 i";ELSE PRINT ABS(Z(2));"i ";
IF Z(3)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(3))<1E-5 THEN PRINT " 0 j";ELSE PRINT ABS(Z(3));"j ";
IF Z(4)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(4))<1E-5 THEN PRINT " 0 k";ELSE PRINT ABS(Z(4));"k ";
IF Z(5)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(5))<1E-5 THEN PRINT " 0 l";ELSE PRINT ABS(Z(5));"l ";
IF Z(6)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(6))<1E-5 THEN PRINT " 0 m" ELSE PRINT ABS(Z(6));"m "
END SUB
------------------------------------------------------------------------------------------------------------------------------------
6元数ジュリア集合


DIM Z(6),A(6),ZZ(6)
RANDOMIZE
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
LET N=SQR(5)
CALL CSET(A,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1)
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(Z,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CSET(X(),A,B,C,D,E,F)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 6
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB GETPARA(Z(),R,TH())
LET R=SQR(DOT(Z,Z))
IF R=0 THEN
MAT TH=ZER
EXIT SUB
END IF
LET TH(1)=ACOS(Z(1)/R)
IF R*SIN(TH(1))=0 THEN
LET TH(2)=0
LET TH(3)=0
LET TH(4)=0
LET TH(5)=0
ELSE
LET T2=MAX(-1,MIN(Z(2)/(R*SIN(TH(1))),1))
LET TH(2)=ACOS(T2)
END IF
IF R*SIN(TH(1))*SIN(TH(2))=0 THEN
LET TH(3)=0
LET TH(4)=0
LET TH(5)=0
ELSE
LET T3=MAX(-1,MIN(Z(3)/(R*SIN(TH(1))*SIN(TH(2))),1))
LET TH(3)=ACOS(T3)
END IF
IF R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))=0 THEN
LET TH(4)=0
LET TH(5)=0
ELSE
LET T4=MAX(-1,MIN(Z(4)/(R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))),1))
LET TH(4)=ACOS(T4)
END IF
IF Z(5)=0 AND Z(6)=0 THEN LET TH(5)=0 ELSE LET TH(5)=ANGLE(Z(5),Z(6))
END SUB

EXTERNAL SUB SETPARA(Z(),R,TH())
LET Z(1)=R*COS(TH(1))
LET Z(2)=R*SIN(TH(1))*COS(TH(2))
LET Z(3)=R*SIN(TH(1))*SIN(TH(2))*COS(TH(3))
LET Z(4)=R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))*COS(TH(4))
LET Z(5)=R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))*SIN(TH(4))*COS(TH(5))
LET Z(6)=R*SIN(TH(1))*SIN(TH(2))*SIN(TH(3))*SIN(TH(4))*SIN(TH(5))
!'Z(n-1)=R*SIN(TH(1))*SIN(TH(2))*...SIN(TH(n-2))*COS(TH(n-1))
!'Z(n )=R*SIN(TH(1))*SIN(TH(2))*...SIN(TH(n-2))*SIN(TH(n-1))
END SUB

EXTERNAL SUB CMUL(Z(),A(),B())
DIM TH1(5),TH2(5)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1+TH2
CALL SETPARA(Z,R1*R2,TH1)
END SUB

EXTERNAL SUB CDIV(Z(),A(),B())
DIM TH1(5),TH2(5)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1-TH2
CALL SETPARA(Z,R1/R2,TH1)
END SUB

EXTERNAL SUB CADD(Z(),A(),B())
MAT Z=A+B
END SUB

EXTERNAL SUB CSUB(Z(),A(),B())
MAT Z=A-B
END SUB

EXTERNAL SUB CPOW(S(),Z(),N)
DIM TH(5)
CALL GETPARA(Z,R,TH)
MAT TH=N*TH
CALL SETPARA(S,R^N,TH)
END SUB

EXTERNAL SUB CPRINT(Z())
IF ABS(Z(1))<1E-5 THEN PRINT " 0 ";ELSE PRINT Z(1);
IF Z(2)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(2))<1E-5 THEN PRINT " 0 i";ELSE PRINT ABS(Z(2));"i ";
IF Z(3)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(3))<1E-5 THEN PRINT " 0 j";ELSE PRINT ABS(Z(3));"j ";
IF Z(4)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(4))<1E-5 THEN PRINT " 0 k";ELSE PRINT ABS(Z(4));"k ";
IF Z(5)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(5))<1E-5 THEN PRINT " 0 l";ELSE PRINT ABS(Z(5));"l ";
IF Z(6)<0 THEN PRINT "-";ELSE PRINT "+";
IF ABS(Z(6))<1E-5 THEN PRINT " 0 m" ELSE PRINT ABS(Z(6));"m "
END SUB

5元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:54:59

5元数マンデルブロ集合

https://paulbourke.net/fractals/volumetric/


OPTION BASE 0
DIM Z(4),A(4),ZZ(4)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z) ! ZZ=Z^2
CALL CADD(Z,ZZ,A) ! Z=Z^2+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CPOW(A(),Q1()) ! A=Q1^2
LET A(0) = Q1(0)*Q1(0)+2*(Q1(1)*Q1(4)+Q1(2)*Q1(3))
LET A(1) = Q1(3)*Q1(3)+2*(Q1(0)*Q1(1)+Q1(2)*Q1(4))
LET A(2) = Q1(1)*Q1(1)+2*(Q1(0)*Q1(2)+Q1(3)*Q1(4))
LET A(3) = Q1(4)*Q1(4)+2*(Q1(0)*Q1(3)+Q1(1)*Q1(2))
LET A(4) = Q1(2)*Q1(2)+2*(Q1(0)*Q1(4)+Q1(1)*Q1(3))
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D,E)
LET X(0)=A
LET X(1)=B
LET X(2)=C
LET X(3)=D
LET X(4)=E
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=0 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION
-----------------------------------------------------------------------------------------------------------
5元数ジュリア集合


RANDOMIZE
OPTION BASE 0
DIM Z(4),A(4),ZZ(4)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
CALL CSET(A,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1)
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
CALL CSET(Z,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z) ! ZZ=Z^2
CALL CADD(Z,ZZ,A) ! Z=Z^2+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CPOW(A(),Q1()) ! A=Q1^2
LET A(0) = Q1(0)*Q1(0)+2*(Q1(1)*Q1(4)+Q1(2)*Q1(3))
LET A(1) = Q1(3)*Q1(3)+2*(Q1(0)*Q1(1)+Q1(2)*Q1(4))
LET A(2) = Q1(1)*Q1(1)+2*(Q1(0)*Q1(2)+Q1(3)*Q1(4))
LET A(3) = Q1(4)*Q1(4)+2*(Q1(0)*Q1(3)+Q1(1)*Q1(2))
LET A(4) = Q1(2)*Q1(2)+2*(Q1(0)*Q1(4)+Q1(1)*Q1(3))
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D,E)
LET X(0)=A
LET X(1)=B
LET X(2)=C
LET X(3)=D
LET X(4)=E
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=0 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CPRINT(A())
OPTION BASE 0
DIM S$(4)
MAT READ S$
DATA "",i,j,k,l
FOR I=0 TO 4
IF A(I)<0 THEN
PRINT "-";
ELSE
IF I>0 THEN PRINT "+";
END IF
PRINT ABS(A(I));S$(I);
NEXT I
PRINT
END SUB

3元数マンデルブロー集合 - しばっち

2023/10/08 (Sun) 13:53:34

3元数マンデルブロー集合

掛け算を設定し3元数を定義してみた。

3元数(z=a+bi+cj) i^2=j^2=ij=ji=-1


DIM Z(3),A(3),ZZ(3)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
LET N=2
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 3
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CSET(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(3)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(2)*B(3)-A(3)*B(2)
LET SS(2)=A(1)*B(2)+A(2)*B(1)
LET SS(3)=A(1)*B(3)+A(3)*B(1)
MAT S=SS
END SUB
**********************************************************
上記とは異なる3元数


EXTERNAL SUB CMUL(S(),A(),B()) !'S=A*B
DIM SS(3)
LET P1=SQR(A(1)^2+A(2)^2)
LET P2=SQR(B(1)^2+B(2)^2)
IF P1<>0 AND P2<>0 THEN
LET AA=1-A(2)*B(2)/(P1*P2)
LET SS(1)=AA*(A(1)*B(1)-A(2)*B(2))
LET SS(2)=AA*(B(1)*A(2)+A(1)*B(2))
END IF
LET SS(3)=P1*B(3)+P2*A(3)
MAT S=SS
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) !'S=A/B
DIM SS(3)
LET P1=SQR(A(1)^2+A(2)^2)
LET P2=SQR(B(1)^2+B(2)^2)
IF P1<>0 AND P2<>0 THEN
LET AA=1+A(3)*B(3)/(P1*P2)
LET D=1/(B(1)^2+B(2)^2+B(3)^2)
LET SS(1)=D*AA*(A(1)*B(1)+A(2)*B(2))
LET SS(2)=D*AA*(B(1)*A(2)-A(1)*B(2))
END IF
LET SS(3)=D*(P2*A(3)-P1*B(3))
MAT S=SS
END SUB
**********************************************************
上記とはまた異なる3元数


EXTERNAL SUB CMUL(Z(),A(),B())
DIM TH1(2),TH2(2)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1+TH2
CALL SETPARA(Z,R1*R2,TH1)
END SUB

EXTERNAL SUB CDIV(Z(),A(),B())
DIM TH1(2),TH2(2)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1-TH2
CALL SETPARA(Z,R1/R2,TH1)
END SUB

EXTERNAL SUB GETPARA(ZZ(),R,TH())
LET R = SQR(DOT(ZZ,ZZ))
IF R=0 THEN LET TH(1)=0 ELSE LET TH(1)=ACOS(ZZ(1)/R)
IF ZZ(2)=0 AND ZZ(3)=0 THEN LET TH(2)=0 ELSE LET TH(2) = ANGLE(ZZ(2),ZZ(3))
END SUB

EXTERNAL SUB SETPARA(Z(),R,TH())
LET Z(1) = R * COS(TH(1))
LET Z(2) = R * SIN(TH(1)) * COS(TH(2))
LET Z(3) = R * SIN(TH(1)) * SIN(TH(2))
END SUB

EXTERNAL SUB CPOW(A(),Z(),N) ! A=Z^N
DIM TH(2)
CALL GETPARA(Z,R,TH)
MAT TH=N*TH
CALL SETPARA(A,R^N,TH)
END SUB
------------------------------------------------------------------------------------------
3元数ジュリア集合


DIM Z(3),A(3),ZZ(3)
RANDOMIZE
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
LET N=2
CALL CSET(A,2*RND-1,2*RND-1,2*RND-1)
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(Z,WORLDX(X),WORLDY(Y),WORLDY(X))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CPRINT(A())
PRINT A(1);
IF A(2)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2));"i";
IF A(3)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(3));"j";
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 3
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CSET(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(3)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(2)*B(3)-A(3)*B(2)
LET SS(2)=A(1)*B(2)+A(2)*B(1)
LET SS(3)=A(1)*B(3)+A(3)*B(1)
MAT S=SS
END SUB
------------------------------------------------------------------------------------------
ニュートン法(x^3-1=0)の収束回数によるフラクタル


LET N=3
DIM S(3),X(3),XX(3),SS(3),T(3),COEF(0 TO N,3),DIFFCOEF(0 TO N-1,3)
FOR I=0 TO N
FOR J=1 TO 3
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0
DATA 0,0,0
DATA 0,0,0
DATA 1,0,0
FOR I=1 TO N
FOR J=1 TO 3
LET DIFFCOEF(I-1,J)=I*COEF(I,J)
NEXT J
NEXT I
SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(S,X,COEF,N) ! S=COEF(3)*X^3+COEF(2)*X^2+COEF(1)*X+COEF(0)
CALL CHORNER(SS,X,DIFFCOEF,N-1) ! SS=DIFFCOEF(2)*X^2+DIFFCOEF(1)*X+DIFFCOEF(0)
CALL CDIV(XX,S,SS) ! XX=S/SS
CALL CSUB(T,X,XX) ! T=X-S/SS
IF CABS2(T,X)<EPS THEN EXIT FOR
MAT X=T
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

EXTERNAL SUB CSET(X(),A,B,C)
LET X(1)=A
LET X(2)=B
LET X(3)=C
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
LET S(2)=-A(2)
LET S(3)=-A(3)
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(3),S1(3),S2(3)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(),A(),B())
MAT S=A-B
END SUB

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 3
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION

EXTERNAL SUB CHORNER(S(),X(),COEF(,),N) ! S=COEF(0)+COEF(1)*X+COEF(2)*X^2+...+COEF(N)*X^N
DIM SS(3),T(3),C(3)
CALL CSET(T,COEF(0,1),COEF(0,2),COEF(0,3))
FOR I=1 TO N
CALL CSET(C,COEF(I,1),COEF(I,2),COEF(I,3))
CALL CPOW(SS,X,I) ! SS=X^I
CALL CMUL(SS,C,SS)! SS=COEF(I)*X^I
CALL CADD(T,T,SS) ! T=T+SS
NEXT I
MAT S=T
END SUB

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(3)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(2)*B(3)-A(3)*B(2)
LET SS(2)=A(1)*B(2)+A(2)*B(1)
LET SS(3)=A(1)*B(3)+A(3)*B(1)
MAT S=SS
END SUB

16元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:50:56

16元数マンデルブロ集合

https://ja.wikipedia.org/wiki/十六元数

収束した部分は黒、発散した部分は黒以外の色になります。

次数Nを実数に拡張しています。


実行に時間がかかる場合はBASICAcc又はParactBASICを使用してください。

https://decimalbasic.web.fc2.com/BASICAccJa.htm
https://decimalbasic.web.fc2.com/BASICAcc2Ja.htm


DIM Z(16),A(16),ZZ(16)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
LET N=2
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
MAT Z=ZER
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
USE
END WHEN
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
LET X(7)=G
LET X(8)=H
LET X(9)=I
LET X(10)=J
LET X(11)=K
LET X(12)=L
LET X(13)=M
LET X(14)=N
LET X(15)=O
LET X(16)=P
END SUB

EXTERNAL FUNCTION CABS(A())
LET CABS=SQR(DOT(A,A))
END FUNCTION

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 16
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(16)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)-A(9)*B(9)-A(10)*B(10)-A(11)*B(11)-A(12)*B(12)-A(13)*B(13)-A(14)*B(14)-A(15)*B(15)-A(16)*B(16)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)+A(9)*B(10)-A(10)*B(9)-A(11)*B(12)+A(12)*B(11)-A(13)*B(14)+A(14)*B(13)+A(15)*B(16)-A(16)*B(15)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)+A(9)*B(11)+A(10)*B(12)-A(11)*B(9)-A(12)*B(10)-A(13)*B(15)-A(14)*B(16)+A(15)*B(13)+A(16)*B(14)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)+A(9)*B(12)-A(10)*B(11)+A(11)*B(10)-A(12)*B(9)-A(13)*B(16)+A(14)*B(15)-A(15)*B(14)+A(16)*B(13)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)+A(9)*B(13)+A(10)*B(14)+A(11)*B(15)+A(12)*B(16)-A(13)*B(9)-A(14)*B(10)-A(15)*B(11)-A(16)*B(12)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)+A(9)*B(14)-A(10)*B(13)+A(11)*B(16)-A(12)*B(15)+A(13)*B(10)-A(14)*B(9)+A(15)*B(12)-A(16)*B(11)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)+A(9)*B(15)-A(10)*B(16)-A(11)*B(13)+A(12)*B(14)+A(13)*B(11)-A(14)*B(12)-A(15)*B(9)+A(16)*B(10)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)+A(9)*B(16)+A(10)*B(15)-A(11)*B(14)-A(12)*B(13)+A(13)*B(12)+A(14)*B(11)-A(15)*B(10)-A(16)*B(9)
LET SS(9)=A(1)*B(9)-A(2)*B(10)-A(3)*B(11)-A(4)*B(12)-A(5)*B(13)-A(6)*B(14)-A(7)*B(15)-A(8)*B(16)+A(9)*B(1)+A(10)*B(2)+A(11)*B(3)+A(12)*B(4)+A(13)*B(5)+A(14)*B(6)+A(15)*B(7)+A(16)*B(8)
LET SS(10)=A(1)*B(10)+A(2)*B(9)-A(3)*B(12)+A(4)*B(11)-A(5)*B(14)+A(6)*B(13)+A(7)*B(16)-A(8)*B(15)-A(9)*B(2)+A(10)*B(1)-A(11)*B(4)+A(12)*B(3)-A(13)*B(6)+A(14)*B(5)+A(15)*B(8)-A(16)*B(7)
LET SS(11)=A(1)*B(11)+A(2)*B(12)+A(3)*B(9)-A(4)*B(10)-A(5)*B(15)-A(6)*B(16)+A(7)*B(13)+A(8)*B(14)-A(9)*B(3)+A(10)*B(4)+A(11)*B(1)-A(12)*B(2)-A(13)*B(7)-A(14)*B(8)+A(15)*B(5)+A(16)*B(6)
LET SS(12)=A(1)*B(12)-A(2)*B(11)+A(3)*B(10)+A(4)*B(9)-A(5)*B(16)+A(6)*B(15)-A(7)*B(14)+A(8)*B(13)-A(9)*B(4)-A(10)*B(3)+A(11)*B(2)+A(12)*B(1)-A(13)*B(8)+A(14)*B(7)-A(15)*B(6)+A(16)*B(5)
LET SS(13)=A(1)*B(13)+A(2)*B(14)+A(3)*B(15)+A(4)*B(16)+A(5)*B(9)-A(6)*B(10)-A(7)*B(11)-A(8)*B(12)-A(9)*B(5)+A(10)*B(6)+A(11)*B(7)+A(12)*B(8)+A(13)*B(1)-A(14)*B(2)-A(15)*B(3)-A(16)*B(4)
LET SS(14)=A(1)*B(14)-A(2)*B(13)+A(3)*B(16)-A(4)*B(15)+A(5)*B(10)+A(6)*B(9)+A(7)*B(12)-A(8)*B(11)-A(9)*B(6)-A(10)*B(5)+A(11)*B(8)-A(12)*B(7)+A(13)*B(2)+A(14)*B(1)+A(15)*B(4)-A(16)*B(3)
LET SS(15)=A(1)*B(15)-A(2)*B(16)-A(3)*B(13)+A(4)*B(14)+A(5)*B(11)-A(6)*B(12)+A(7)*B(9)+A(8)*B(10)-A(9)*B(7)-A(10)*B(8)-A(11)*B(5)+A(12)*B(6)+A(13)*B(3)-A(14)*B(4)+A(15)*B(1)+A(16)*B(2)
LET SS(16)=A(1)*B(16)+A(2)*B(15)-A(3)*B(14)-A(4)*B(13)+A(5)*B(12)+A(6)*B(11)-A(7)*B(10)+A(8)*B(9)-A(9)*B(8)+A(10)*B(7)-A(11)*B(6)-A(12)*B(5)+A(13)*B(4)+A(14)*B(3)-A(15)*B(2)+A(16)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CPOW(S(),A(),M) ! S=A^M
DIM Y(16)
IF M<0 THEN LET SIGN=-1
LET N=ABS(M)
LET NN=IP(N)
LET N=FP(N)
MAT Y=A
CALL CSET(S,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
FOR I=1 TO NN
CALL CMUL(S,S,A)
NEXT I
DO WHILE N>0 AND C<50
LET N=N*2
CALL CSQR(Y,Y)
IF N>=1 THEN CALL CMUL(S,S,Y)
LET N=FP(N)
LET C=C+1
LOOP
IF SIGN<0 THEN
CALL CSET(Y,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
CALL CDIV(S,Y,S)
END IF
END SUB

EXTERNAL SUB CSQR(X(),Y()) ! Y=SQR(X)
DIM A(16),B(16)
MAT A=ZER
CALL CSET(B,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
FOR I=1 TO 100
CALL CADD(B,A,B)
MAT B=.5*B
CALL CDIV(A,X,B)
IF CABS2(A,B)<1E-8 THEN EXIT FOR
NEXT I
MAT Y=B
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
FOR I=2 TO 16
LET S(I)=-A(I)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(16),S1(16),S2(16)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB
------------------------------------------------------------------------------------------------------------------------------------
16元数ジュリア集合

収束した部分は黒、発散した部分は黒以外の色になります。


RANDOMIZE
DIM Z(16),A(16),ZZ(16)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50
LET N=2
CALL CSET(A,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1)
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(Z,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>20 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS :WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CPRINT(A())
FOR I=1 TO 16
IF A(I)<>0 THEN
IF A(I)<0 THEN
PRINT " - ";
ELSE
IF I>1 THEN PRINT " + ";
END IF
IF ABS(A(I))<>1 OR I=1 THEN PRINT STR$(ABS(A(I)));
IF I>1 THEN PRINT MID$("ijklmnopqrstuvw",I-1,1);
END IF
NEXT I
PRINT
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
LET X(7)=G
LET X(8)=H
LET X(9)=I
LET X(10)=J
LET X(11)=K
LET X(12)=L
LET X(13)=M
LET X(14)=N
LET X(15)=O
LET X(16)=P
END SUB

EXTERNAL FUNCTION CABS(A())
LET CABS=SQR(DOT(A,A))
END FUNCTION

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 16
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(16)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)-A(9)*B(9)-A(10)*B(10)-A(11)*B(11)-A(12)*B(12)-A(13)*B(13)-A(14)*B(14)-A(15)*B(15)-A(16)*B(16)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)+A(9)*B(10)-A(10)*B(9)-A(11)*B(12)+A(12)*B(11)-A(13)*B(14)+A(14)*B(13)+A(15)*B(16)-A(16)*B(15)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)+A(9)*B(11)+A(10)*B(12)-A(11)*B(9)-A(12)*B(10)-A(13)*B(15)-A(14)*B(16)+A(15)*B(13)+A(16)*B(14)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)+A(9)*B(12)-A(10)*B(11)+A(11)*B(10)-A(12)*B(9)-A(13)*B(16)+A(14)*B(15)-A(15)*B(14)+A(16)*B(13)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)+A(9)*B(13)+A(10)*B(14)+A(11)*B(15)+A(12)*B(16)-A(13)*B(9)-A(14)*B(10)-A(15)*B(11)-A(16)*B(12)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)+A(9)*B(14)-A(10)*B(13)+A(11)*B(16)-A(12)*B(15)+A(13)*B(10)-A(14)*B(9)+A(15)*B(12)-A(16)*B(11)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)+A(9)*B(15)-A(10)*B(16)-A(11)*B(13)+A(12)*B(14)+A(13)*B(11)-A(14)*B(12)-A(15)*B(9)+A(16)*B(10)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)+A(9)*B(16)+A(10)*B(15)-A(11)*B(14)-A(12)*B(13)+A(13)*B(12)+A(14)*B(11)-A(15)*B(10)-A(16)*B(9)
LET SS(9)=A(1)*B(9)-A(2)*B(10)-A(3)*B(11)-A(4)*B(12)-A(5)*B(13)-A(6)*B(14)-A(7)*B(15)-A(8)*B(16)+A(9)*B(1)+A(10)*B(2)+A(11)*B(3)+A(12)*B(4)+A(13)*B(5)+A(14)*B(6)+A(15)*B(7)+A(16)*B(8)
LET SS(10)=A(1)*B(10)+A(2)*B(9)-A(3)*B(12)+A(4)*B(11)-A(5)*B(14)+A(6)*B(13)+A(7)*B(16)-A(8)*B(15)-A(9)*B(2)+A(10)*B(1)-A(11)*B(4)+A(12)*B(3)-A(13)*B(6)+A(14)*B(5)+A(15)*B(8)-A(16)*B(7)
LET SS(11)=A(1)*B(11)+A(2)*B(12)+A(3)*B(9)-A(4)*B(10)-A(5)*B(15)-A(6)*B(16)+A(7)*B(13)+A(8)*B(14)-A(9)*B(3)+A(10)*B(4)+A(11)*B(1)-A(12)*B(2)-A(13)*B(7)-A(14)*B(8)+A(15)*B(5)+A(16)*B(6)
LET SS(12)=A(1)*B(12)-A(2)*B(11)+A(3)*B(10)+A(4)*B(9)-A(5)*B(16)+A(6)*B(15)-A(7)*B(14)+A(8)*B(13)-A(9)*B(4)-A(10)*B(3)+A(11)*B(2)+A(12)*B(1)-A(13)*B(8)+A(14)*B(7)-A(15)*B(6)+A(16)*B(5)
LET SS(13)=A(1)*B(13)+A(2)*B(14)+A(3)*B(15)+A(4)*B(16)+A(5)*B(9)-A(6)*B(10)-A(7)*B(11)-A(8)*B(12)-A(9)*B(5)+A(10)*B(6)+A(11)*B(7)+A(12)*B(8)+A(13)*B(1)-A(14)*B(2)-A(15)*B(3)-A(16)*B(4)
LET SS(14)=A(1)*B(14)-A(2)*B(13)+A(3)*B(16)-A(4)*B(15)+A(5)*B(10)+A(6)*B(9)+A(7)*B(12)-A(8)*B(11)-A(9)*B(6)-A(10)*B(5)+A(11)*B(8)-A(12)*B(7)+A(13)*B(2)+A(14)*B(1)+A(15)*B(4)-A(16)*B(3)
LET SS(15)=A(1)*B(15)-A(2)*B(16)-A(3)*B(13)+A(4)*B(14)+A(5)*B(11)-A(6)*B(12)+A(7)*B(9)+A(8)*B(10)-A(9)*B(7)-A(10)*B(8)-A(11)*B(5)+A(12)*B(6)+A(13)*B(3)-A(14)*B(4)+A(15)*B(1)+A(16)*B(2)
LET SS(16)=A(1)*B(16)+A(2)*B(15)-A(3)*B(14)-A(4)*B(13)+A(5)*B(12)+A(6)*B(11)-A(7)*B(10)+A(8)*B(9)-A(9)*B(8)+A(10)*B(7)-A(11)*B(6)-A(12)*B(5)+A(13)*B(4)+A(14)*B(3)-A(15)*B(2)+A(16)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CPOW(S(),A(),M) ! S=A^M
DIM Y(16)
IF M<0 THEN LET SIGN=-1
LET N=ABS(M)
LET NN=IP(N)
LET N=FP(N)
MAT Y=A
CALL CSET(S,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
FOR I=1 TO NN
CALL CMUL(S,S,A)
NEXT I
DO WHILE N>0 AND C<50
LET N=N*2
CALL CSQR(Y,Y)
IF N>=1 THEN CALL CMUL(S,S,Y)
LET N=FP(N)
LET C=C+1
LOOP
IF SIGN<0 THEN
CALL CSET(Y,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
CALL CDIV(S,Y,S)
END IF
END SUB

EXTERNAL SUB CSQR(X(),Y()) ! Y=SQR(X)
DIM A(16),B(16)
MAT A=ZER
CALL CSET(B,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
FOR I=1 TO 100
CALL CADD(B,A,B)
MAT B=.5*B
CALL CDIV(A,X,B)
IF CABS2(A,B)<1E-8 THEN EXIT FOR
NEXT I
MAT Y=B
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
FOR I=2 TO 16
LET S(I)=-A(I)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(16),S1(16),S2(16)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB
------------------------------------------------------------------------------------------------------------------------------------
ニュートン法(x^3-1=0)の収束回数によるフラクタル


LET N=3
DIM S(16),X(16),XX(16),SS(16),T(16),COEF(0 TO N,16),DIFFCOEF(0 TO N-1,16)
FOR I=0 TO N
FOR J=1 TO 16
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FOR I=1 TO N
FOR J=1 TO 16
LET DIFFCOEF(I-1,J)=I*COEF(I,J)
NEXT J
NEXT I
SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J),WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J),WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J),WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(S,X,COEF,N) ! S=COEF(3)*X^3+COEF(2)*X^2+COEF(1)*X+COEF(0)
CALL CHORNER(SS,X,DIFFCOEF,N-1) ! SS=DIFFCOEF(2)*X^2+DIFFCOEF(1)*X+DIFFCOEF(0)
CALL CDIV(XX,S,SS) ! XX=S/SS
CALL CSUB(T,X,XX) ! T=X-S/SS
IF CABS2(T,X)<EPS THEN EXIT FOR
MAT X=T
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

EXTERNAL SUB CSET(X(),A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
LET X(7)=G
LET X(8)=H
LET X(9)=I
LET X(10)=J
LET X(11)=K
LET X(12)=L
LET X(13)=M
LET X(14)=N
LET X(15)=O
LET X(16)=P
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(16)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)-A(9)*B(9)-A(10)*B(10)-A(11)*B(11)-A(12)*B(12)-A(13)*B(13)-A(14)*B(14)-A(15)*B(15)+A(16)*B(16)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)+A(9)*B(10)-A(10)*B(9)-A(11)*B(12)+A(12)*B(11)-A(13)*B(14)+A(14)*B(13)+A(15)*B(16)-A(16)*B(15)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)+A(9)*B(11)+A(10)*B(12)-A(11)*B(9)-A(12)*B(10)-A(13)*B(15)-A(14)*B(16)+A(15)*B(13)+A(16)*B(14)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)+A(9)*B(12)-A(10)*B(11)+A(11)*B(10)-A(12)*B(9)-A(13)*B(16)+A(14)*B(15)-A(15)*B(14)+A(16)*B(13)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)+A(9)*B(13)+A(10)*B(14)+A(11)*B(15)+A(12)*B(16)-A(13)*B(9)-A(14)*B(10)-A(15)*B(11)-A(16)*B(12)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)+A(9)*B(14)-A(10)*B(13)+A(11)*B(16)-A(12)*B(15)+A(13)*B(10)-A(14)*B(9)+A(15)*B(12)-A(16)*B(11)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)+A(9)*B(15)-A(10)*B(16)-A(11)*B(13)+A(12)*B(14)+A(13)*B(11)-A(14)*B(12)-A(15)*B(9)+A(16)*B(10)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)+A(9)*B(16)+A(10)*B(15)-A(11)*B(14)-A(12)*B(13)+A(13)*B(12)+A(14)*B(11)-A(15)*B(10)-A(16)*B(9)
LET SS(9)=A(1)*B(9)-A(2)*B(10)-A(3)*B(11)-A(4)*B(12)-A(5)*B(13)-A(6)*B(14)-A(7)*B(15)-A(8)*B(16)+A(9)*B(1)+A(10)*B(2)+A(11)*B(3)+A(12)*B(4)+A(13)*B(5)+A(14)*B(6)+A(15)*B(7)+A(16)*B(8)
LET SS(10)=A(1)*B(10)+A(2)*B(9)-A(3)*B(12)+A(4)*B(11)-A(5)*B(14)+A(6)*B(13)+A(7)*B(16)-A(8)*B(15)-A(9)*B(2)+A(10)*B(1)-A(11)*B(4)+A(12)*B(3)-A(13)*B(6)+A(14)*B(5)+A(15)*B(8)-A(16)*B(7)
LET SS(11)=A(1)*B(11)+A(2)*B(12)+A(3)*B(9)-A(4)*B(10)-A(5)*B(15)-A(6)*B(16)+A(7)*B(13)+A(8)*B(14)-A(9)*B(3)+A(10)*B(4)+A(11)*B(1)-A(12)*B(2)-A(13)*B(7)-A(14)*B(8)+A(15)*B(5)+A(16)*B(6)
LET SS(12)=A(1)*B(12)-A(2)*B(11)+A(3)*B(10)+A(4)*B(9)-A(5)*B(16)+A(6)*B(15)-A(7)*B(14)+A(8)*B(13)-A(9)*B(4)-A(10)*B(3)+A(11)*B(2)+A(12)*B(1)-A(13)*B(8)+A(14)*B(7)-A(15)*B(6)+A(16)*B(5)
LET SS(13)=A(1)*B(13)+A(2)*B(14)+A(3)*B(15)+A(4)*B(16)+A(5)*B(9)-A(6)*B(10)-A(7)*B(11)-A(8)*B(12)-A(9)*B(5)+A(10)*B(6)+A(11)*B(7)+A(12)*B(8)+A(13)*B(1)-A(14)*B(2)-A(15)*B(3)-A(16)*B(4)
LET SS(14)=A(1)*B(14)-A(2)*B(13)+A(3)*B(16)-A(4)*B(15)+A(5)*B(10)+A(6)*B(9)+A(7)*B(12)-A(8)*B(11)-A(9)*B(6)-A(10)*B(5)+A(11)*B(8)-A(12)*B(7)+A(13)*B(2)+A(14)*B(1)+A(15)*B(4)-A(16)*B(3)
LET SS(15)=A(1)*B(15)-A(2)*B(16)-A(3)*B(13)+A(4)*B(14)+A(5)*B(11)-A(6)*B(12)+A(7)*B(9)+A(8)*B(10)-A(9)*B(7)-A(10)*B(8)-A(11)*B(5)+A(12)*B(6)+A(13)*B(3)-A(14)*B(4)+A(15)*B(1)+A(16)*B(2)
LET SS(16)=A(1)*B(16)+A(2)*B(15)-A(3)*B(14)-A(4)*B(13)+A(5)*B(12)+A(6)*B(11)-A(7)*B(10)+A(8)*B(9)-A(9)*B(8)+A(10)*B(7)-A(11)*B(6)-A(12)*B(5)+A(13)*B(4)+A(14)*B(3)-A(15)*B(2)+A(16)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
FOR I=2 TO 16
LET S(I)=-A(I)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(16),S1(16),S2(16)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(),A(),B())
MAT S=A-B
END SUB

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 16
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION

EXTERNAL SUB CHORNER(S(),X(),COEF(,),N) ! S=COEF(0)+COEF(1)*X+COEF(2)*X^2+...+COEF(N)*X^N
DIM SS(16),T(16),C(16)
CALL CSET(T,COEF(0,1),COEF(0,2),COEF(0,3),COEF(0,4),COEF(0,5),COEF(0,6),COEF(0,7),COEF(0,8),COEF(0,9),COEF(0,10),COEF(0,11),COEF(0,12),COEF(0,13),COEF(0,14),COEF(0,15),COEF(0,16))
FOR I=1 TO N
CALL CSET(C,COEF(I,1),COEF(I,2),COEF(I,3),COEF(I,4),COEF(I,5),COEF(I,6),COEF(I,7),COEF(I,8),COEF(I,9),COEF(I,10),COEF(I,11),COEF(I,12),COEF(I,13),COEF(I,14),COEF(I,15),COEF(I,16))
CALL CPOW(SS,X,I) ! SS=X^I
CALL CMUL(SS,C,SS)! SS=COEF(I)*X^I
CALL CADD(T,T,SS) ! T=T+SS
NEXT I
MAT S=T
END SUB

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

8元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:49:49

8元数マンデルブロ集合

https://ja.wikipedia.org/wiki/八元数

収束した部分は黒、発散した部分は黒以外の色になります。

次数Nを実数に拡張しています。


実行に時間がかかる場合はBASICAcc又はParactBASICを使用してください。

https://decimalbasic.web.fc2.com/BASICAccJa.htm
https://decimalbasic.web.fc2.com/BASICAcc2Ja.htm


DIM Z(8),A(8),ZZ(8)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
MAT Z=ZER
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
USE
END WHEN
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D,E,F,G,H)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
LET X(7)=G
LET X(8)=H
END SUB

EXTERNAL FUNCTION CABS(A())
LET CABS=SQR(DOT(A,A))
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(8)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CPOW(S(),A(),M) ! S=A^M
DIM Y(8)
IF M<0 THEN LET SIGN=-1
LET N=ABS(M)
LET NN=IP(N)
LET N=FP(N)
MAT Y=A
CALL CSET(S,1,0,0,0,0,0,0,0)
FOR I=1 TO NN
CALL CMUL(S,S,A)
NEXT I
DO WHILE N>0 AND C<50
LET N=N*2
CALL CSQR(Y,Y)
IF N>=1 THEN CALL CMUL(S,S,Y)
LET N=FP(N)
LET C=C+1
LOOP
IF SIGN<0 THEN
CALL CSET(Y,1,0,0,0,0,0,0,0)
CALL CDIV(S,Y,S)
END IF
END SUB

EXTERNAL SUB CSQR(X(),Y()) ! Y=SQR(X)
DIM A(8),B(8)
MAT A=ZER
CALL CSET(B,1,0,0,0,0,0,0,0)
FOR I=1 TO 100
CALL CADD(B,A,B)
MAT B=.5*B
CALL CDIV(A,X,B)
IF CABS2(A,B)<1E-8 THEN EXIT FOR
NEXT I
MAT Y=B
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
FOR I=2 TO 8
LET S(I)=-A(I)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(8),S1(8),S2(8)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 8
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION
****************************************************************
CMULルーチンを下記にすると2重4元数になります。


2重4元数 z=a+bi+cj+dk+ε(e+fi+gj+hk) i^2=j^2=k^2=-1 ε^2=0
https://en.wikipedia.org/wiki/Dual_quaternion


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(8)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)-A(6)*B(2)-A(7)*B(3)-A(8)*B(4)
LET SS(6)=A(1)*B(6)+A(2)*B(5)+A(3)*B(8)-A(4)*B(7)+A(5)*B(2)+A(6)*B(1)+A(7)*B(4)-A(8)*B(3)
LET SS(7)=A(1)*B(7)-A(2)*B(8)+A(3)*B(5)+A(4)*B(6)+A(5)*B(3)-A(6)*B(4)+A(7)*B(1)+A(8)*B(2)
LET SS(8)=A(1)*B(8)+A(2)*B(7)-A(3)*B(6)+A(4)*B(5)+A(5)*B(4)+A(6)*B(3)-A(7)*B(2)+A(8)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CPRINT(A())
DIM S$(8)
MAT READ S$
DATA "",i,j,k,ε,εi,εj,εk
FOR I=1 TO 8
IF A(I)<0 THEN
PRINT "-";
ELSE
IF I>1 THEN PRINT "+";
END IF
PRINT ABS(A(I));S$(I);
NEXT I
PRINT
END SUB
****************************************************************
CMULルーチンを下記にすると分解型8元数になります。


分解型8元数 z=a+bi+cj+dk+el+fli+glj+hlk
https://ja.wikipedia.org/wiki/分解型八元数


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(8)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)+A(5)*B(5)+A(6)*B(6)+A(7)*B(7)+A(8)*B(8)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)+A(7)*B(8)-A(8)*B(7)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)-A(6)*B(8)-A(7)*B(5)+A(8)*B(6)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)+A(6)*B(7)-A(7)*B(6)-A(8)*B(5)
LET SS(5)=A(1)*B(5)+A(2)*B(6)+A(3)*B(7)+A(4)*B(8)+A(5)*B(1)-A(6)*B(2)-A(7)*B(3)-A(8)*B(4)
LET SS(6)=A(1)*B(6)-A(2)*B(5)-A(3)*B(8)+A(4)*B(7)+A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)
LET SS(7)=A(1)*B(7)+A(2)*B(8)-A(3)*B(5)-A(4)*B(6)+A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)-A(4)*B(5)+A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CPRINT(A())
PRINT A(1);
IF A(2)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2));"i";
IF A(3)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(3));"j";
IF A(4)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(4));"k";
IF A(5)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(5));"l";
IF A(6)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(6));"li";
IF A(7)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(7));"lj";
IF A(8)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(8));"lk"
END SUB
----------------------------------------------------------------------------------------
8元数ジュリア集合

収束した部分は黒、発散した部分は黒以外の色になります。


RANDOMIZE
DIM Z(8),A(8),ZZ(8)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
CALL CSET(A,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1,2*RND-1)
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(Z,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y),WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS :WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D,E,F,G,H)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
LET X(7)=G
LET X(8)=H
END SUB

EXTERNAL SUB CPRINT(A())
DIM S$(8)
MAT READ S$
DATA "",i,j,k,l,m,n,o
FOR I=1 TO 8
IF A(I)<0 THEN
PRINT "-";
ELSE
IF I>1 THEN PRINT "+";
END IF
PRINT ABS(A(I));S$(I);
NEXT I
PRINT
END SUB

EXTERNAL FUNCTION CABS(A())
LET CABS=SQR(DOT(A,A))
END FUNCTION

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0,0,0,0,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(8)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)
MAT S=SS
END SUB
----------------------------------------------------------------------------------------
ニュートン法(x^3-1=0)の収束回数によるフラクタル


LET N=3 ! 次数
DIM S(8),X(8),XX(8),SS(8),T(8),COEF(0 TO N,8),DIFFCOEF(0 TO N-1,8)
FOR I=0 TO N
FOR J=1 TO 8
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 0,0,0,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0
FOR I=1 TO N
FOR J=1 TO 8
LET DIFFCOEF(I-1,J)=I*COEF(I,J)
NEXT J
NEXT I
SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J),WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(S,X,COEF,N) ! S=COEF(3)*X^3+COEF(2)*X^2+COEF(1)*X+COEF(0)
CALL CHORNER(SS,X,DIFFCOEF,N-1) ! SS=DIFFCOEF(2)*X^2+DIFFCOEF(1)*X+DIFFCOEF(0)
CALL CDIV(XX,S,SS) ! XX=S/SS
CALL CSUB(T,X,XX) ! T=X-S/SS
IF CABS2(T,X)<EPS THEN EXIT FOR
MAT X=T
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

EXTERNAL SUB CSET(X(),A,B,C,D,E,F,G,H)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
LET X(5)=E
LET X(6)=F
LET X(7)=G
LET X(8)=H
END SUB

EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(8)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)-A(5)*B(5)-A(6)*B(6)-A(7)*B(7)-A(8)*B(8)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)+A(5)*B(6)-A(6)*B(5)-A(7)*B(8)+A(8)*B(7)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)+A(5)*B(7)+A(6)*B(8)-A(7)*B(5)-A(8)*B(6)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)+A(5)*B(8)-A(6)*B(7)+A(7)*B(6)-A(8)*B(5)
LET SS(5)=A(1)*B(5)-A(2)*B(6)-A(3)*B(7)-A(4)*B(8)+A(5)*B(1)+A(6)*B(2)+A(7)*B(3)+A(8)*B(4)
LET SS(6)=A(1)*B(6)+A(2)*B(5)-A(3)*B(8)+A(4)*B(7)-A(5)*B(2)+A(6)*B(1)-A(7)*B(4)+A(8)*B(3)
LET SS(7)=A(1)*B(7)+A(2)*B(8)+A(3)*B(5)-A(4)*B(6)-A(5)*B(3)+A(6)*B(4)+A(7)*B(1)-A(8)*B(2)
LET SS(8)=A(1)*B(8)-A(2)*B(7)+A(3)*B(6)+A(4)*B(5)-A(5)*B(4)-A(6)*B(3)+A(7)*B(2)+A(8)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(S(),A())
LET S(1)=A(1)
FOR I=2 TO 8
LET S(I)=-A(I)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(8),S1(8),S2(8)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(),A(),B())
MAT S=A-B
END SUB

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 8
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION

EXTERNAL SUB CHORNER(S(),X(),COEF(,),N) ! S=COEF(0)+COEF(1)*X+COEF(2)*X^2+...+COEF(N)*X^N
DIM SS(8),T(8),C(8)
CALL CSET(T,COEF(0,1),COEF(0,2),COEF(0,3),COEF(0,4),COEF(0,5),COEF(0,6),COEF(0,7),COEF(0,8))
FOR I=1 TO N
CALL CSET(C,COEF(I,1),COEF(I,2),COEF(I,3),COEF(I,4),COEF(I,5),COEF(I,6),COEF(I,7),COEF(I,8))
CALL CPOW(SS,X,I) ! SS=X^I
CALL CMUL(SS,C,SS)! SS=COEF(I)*X^I
CALL CADD(T,T,SS) ! T=T+SS
NEXT I
MAT S=T
END SUB

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0,0,0,0,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

4元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:44:02

4元数マンデルブロ集合

https://ja.wikipedia.org/wiki/四元数

収束した部分は黒、発散した部分は黒以外の色になります。

次数Nを実数に拡張しています。


実行に時間がかかる場合はBASICAcc又はParactBASICを使用してください。

https://decimalbasic.web.fc2.com/BASICAccJa.htm
https://decimalbasic.web.fc2.com/BASICAcc2Ja.htm


DIM Z(4),A(4),ZZ(4)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
MAT Z=ZER
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
USE
END WHEN
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CADD(S(),A(),B()) ! S=A+B
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B()) ! S=A*B
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CPOW(S(),A(),M) ! S=A^M
DIM Y(4)
IF M<0 THEN LET SIGN=-1
LET N=ABS(M)
LET NN=IP(N)
LET N=FP(N)
MAT Y=A
CALL CSET(S,1,0,0,0)
FOR I=1 TO NN
CALL CMUL(S,S,A)
NEXT I
DO WHILE N>0 AND C<50
LET N=N*2
CALL CSQR(Y,Y)
IF N>=1 THEN CALL CMUL(S,S,Y)
LET N=FP(N)
LET C=C+1
LOOP
IF SIGN<0 THEN
CALL CSET(Y,1,0,0,0)
CALL CDIV(S,Y,S)
END IF
END SUB

EXTERNAL SUB CSQR(X(),Y()) ! Y=SQR(X)
DIM A(4),B(4)
MAT A=ZER
CALL CSET(B,1,0,0,0)
FOR I=1 TO 100
CALL CADD(B,A,B)
MAT B=.5*B
CALL CDIV(A,X,B)
IF CABS2(A,B)<1E-8 THEN EXIT FOR
NEXT I
MAT Y=B
END SUB

EXTERNAL SUB CCONJ(S(),A()) ! S=CONJ(A)
LET S(1)=A(1)
LET S(2)=-A(2)
LET S(3)=-A(3)
LET S(4)=-A(4)
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(4),S1(4),S2(4)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 4
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION
******************************************************
CMULルーチンを下記に変更すると分解型4元数になります。


分解型4元数 z=a+bi+cj+dk(i^2=-1 j^2=k^2=1)

https://7shi.hateblo.jp/entry/2019/11/25/044133
https://en.wikipedia.org/wiki/Split-quaternion


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)+A(3)*B(3)+A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)-A(3)*B(4)+A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB
******************************************************
CMULルーチンを下記に書き換えると双複素数になります。

https://ja.wikipedia.org/wiki/双複素数


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)+A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)+A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)-A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)+A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB
******************************************************
CMULルーチンを下記にすると双曲四元数になります。

https://en.wikipedia.org/wiki/Hyperbolic_quaternion


EXTERNAL SUB CMUL(S(),A(),B())
DIM SS(4)
LET SS(1)=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)+A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB
******************************************************
下記ルーチンに置き換えると上記とは異なる4元数になります。



EXTERNAL SUB SETPARA(Z(),R,TH())
LET Z(1)=R*SIN(TH(1))*SIN(TH(2))
LET Z(2)=R*SIN(TH(1))*COS(TH(2))
LET Z(3)=R*COS(TH(1))*SIN(TH(3))
LET Z(4)=R*COS(TH(1))*COS(TH(3))
END SUB

EXTERNAL SUB GETPARA(Z(),R,TH())
LET R=SQR(Z(1)*Z(1)+Z(2)*Z(2)+Z(3)*Z(3)+Z(4)*Z(4))
IF Z(1)=0 AND Z(2)=0 AND Z(3)=0 AND Z(4)=0 THEN LET TH(1)=0 ELSE LET TH(1)=ANGLE(SQR(Z(1)*Z(1)+Z(2)*Z(2)),SQR(Z(3)*Z(3)+Z(4)*Z(4)))
IF Z(1)=0 AND Z(2)=0 THEN LET TH(2)=0 ELSE LET TH(2)=ANGLE(Z(1),Z(2))
IF Z(3)=0 AND Z(4)=0 THEN LET TH(3)=0 ELSE LET TH(3)=ANGLE(Z(3),Z(4))
END SUB

EXTERNAL SUB CMUL(Z(),A(),B()) ! Z=A*B
DIM TH1(3),TH2(3)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1+TH2
CALL SETPARA(Z,R1*R2,TH1)
END SUB

EXTERNAL SUB CDIV(Z(),A(),B()) ! Z=A/B
DIM TH1(3),TH2(3)
CALL GETPARA(A,R1,TH1)
CALL GETPARA(B,R2,TH2)
MAT TH1=TH1-TH2
CALL SETPARA(Z,R1/R2,TH1)
END SUB

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
DIM TH(3)
CALL GETPARA(A,R,TH)
MAT TH=N*TH
CALL SETPARA(S,R^N,TH)
END SUB
-----------------------------------------------------------------------------------------------
4元数マンデルブロ集合

更に次数Nを4元数に拡張してみました。


PUBLIC NUMERIC MAXLEVEL
RANDOMIZE
LET MAXLEVEL=20 ! 最大項数
DIM Z(4),A(4),ZZ(4),N(4)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
CALL CSET(N,10*RND,10*RND-5,10*RND-5,10*RND-5) ! 次数
CALL CPRINT(N)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
MAT Z=ZER
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CPOWER(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CPRINT(A())
PRINT A(1);
IF A(2)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2));"i";
IF A(3)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(3));"j";
IF A(4)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(4));"k"
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B()) ! S=A*B
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(B(),A())
LET B(1)=A(1)
LET B(2)=-A(2)
LET B(3)=-A(3)
LET B(4)=-A(4)
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(4),S1(4),S2(4)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL SUB HORNER(X(),Y(),COEF())
MAT Y=ZER
LET Y(1)=COEF(MAXLEVEL)
FOR I=MAXLEVEL-1 TO 0 STEP-1
CALL CMUL(Y,Y,X)
LET Y(1)=Y(1)+COEF(I)
NEXT I
END SUB

EXTERNAL SUB CPOWER(Z(),X(),Y()) ! Z=X^Y
DIM XX(4),YY(4)
CALL CLOG(X,XX)
CALL CMUL(YY,Y,XX)
CALL CEXP(YY,Z)
END SUB

EXTERNAL SUB CLOG(X(),Y()) ! Y=LOG(X)
DIM V(0 TO MAXLEVEL),XA(4),XB(4)
CALL LN(V)
MAT XA=X
MAT XB=X
LET XA(1)=XA(1)-1
LET XB(1)=XB(1)+1
CALL CDIV(X,XA,XB) !'(X-1)/(X+1)
CALL HORNER(X,Y,V)
MAT Y=2*Y
END SUB

EXTERNAL SUB CEXP(X(),Y()) ! Y=EXP(X)
OPTION BASE 0
DIM V(MAXLEVEL)
CALL EXPON(V)
CALL HORNER(X,Y,V)
END SUB

EXTERNAL SUB EXPON(X())
!'EXP(X)
LET X(0)=1
LET T=1
FOR I=1 TO MAXLEVEL
LET T=T/I
LET X(I)=T
NEXT I
END SUB

EXTERNAL SUB LN(X())
!'LOG((X-1)/(X+1))
FOR I=1 TO MAXLEVEL
IF MOD(I,2)=1 THEN LET X(I)=1/I
NEXT I
END SUB
-----------------------------------------------------------------------------------------------
4元数マンデルブロ集合

多項式にしてみました。


LET N=3 ! 次数
DIM Z(4),A(4),ZZ(4),COEF(0 TO N,4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^0
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^1
DATA -2,0,0,0 ! (-2+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
MAT Z=ZER
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(ZZ,Z,COEF,N)
CALL CADD(Z,ZZ,A)
USE
END WHEN
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CHORNER(S(),X(),COEF(,),N) ! S=COEF(0)+COEF(1)*X+COEF(2)*X^2+...+COEF(N)*X^N
DIM SS(4),T(4),C(4)
CALL CSET(T,COEF(0,1),COEF(0,2),COEF(0,3),COEF(0,4))
FOR I=1 TO N
CALL CSET(C,COEF(I,1),COEF(I,2),COEF(I,3),COEF(I,4))
CALL CPOW(SS,X,I) ! SS=X^I
CALL CMUL(SS,C,SS)! SS=COEF(I)*X^I
CALL CADD(T,T,SS) ! T=T+SS
NEXT I
MAT S=T
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CMUL(S(),A(),B()) ! S=A*B
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(S(),A()) ! S=CONJ(A)
LET S(1)=A(1)
LET S(2)=-A(2)
LET S(3)=-A(3)
LET S(4)=-A(4)
END SUB

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(4),S1(4),S2(4)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

Re: 4元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:45:31

4元数ジュリア集合

https://ja.wikipedia.org/wiki/充填ジュリア集合

収束した部分は黒、発散した部分は黒以外の色になります。


RANDOMIZE
DIM Z(4),A(4),ZZ(4)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
CALL CSET(A,2*RND-1,2*RND-1,2*RND-1,2*RND-1) ! 初期値
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(Z,WORLDX(X),WORLDY(Y),WORLDY(X),WORLDX(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS :WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(),A(),B())
MAT S=A-B
END SUB

EXTERNAL SUB CPRINT(A())
PRINT A(1);
IF A(2)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2));"i";
IF A(3)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(3));"j";
IF A(4)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(4));"k"
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL SUB CPOW(S(),A(),N) ! S=A^N
CALL CSET(S,1,0,0,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CMUL(S(),A(),B()) ! S=A*B
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB

Re: 4元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:47:41

ニュートン法(x^3-1=0)の収束回数によるフラクタル

ニュートン法にパラメータR(Relaxation Factor)をランダムに掛けています。
R=1にすると本来のニュートン法によるフラクタルになります。


実行に時間がかかる場合はBASICAcc又はParactBASICを使用してください。

https://decimalbasic.web.fc2.com/BASICAccJa.htm
https://decimalbasic.web.fc2.com/BASICAcc2Ja.htm

RANDOMIZE
LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4),R(4)
DIM Y(4),DY(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

CALL DERIVATIVE(DIFFCOEF,COEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
CALL CSET(R,2*RND,2*RND-1,2*RND-1,2*RND-1) !'Relaxation Factor
CALL CPRINT(R)
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N-1)

CALL CDIV(A,Y,DY)
CALL CMUL(A,A,R)
CALL CSUB(XX,X,A)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

EXTERNAL SUB CPRINT(A())
PRINT A(1);
IF A(2)<0 THEN PRINT " -"; ELSE PRINT " +";
PRINT ABS(A(2));"i";
IF A(3)<0 THEN PRINT " -"; ELSE PRINT " +";
PRINT ABS(A(3));"j";
IF A(4)<0 THEN PRINT " -"; ELSE PRINT " +";
PRINT ABS(A(4));"k"
END SUB

EXTERNAL SUB DERIVATIVE(DIFFCOEF(,),COEF(,),ORDER) ! 微分
FOR I=1 TO ORDER
FOR J=1 TO 4
LET DIFFCOEF(I-1,J)=I*COEF(I,J)
NEXT J
NEXT I
END SUB

EXTERNAL SUB CSET(X(),A,B,C,D)
LET X(1)=A
LET X(2)=B
LET X(3)=C
LET X(4)=D
END SUB

EXTERNAL SUB CMUL(S(),A(),B()) ! S=A*B
DIM SS(4)
LET SS(1)=A(1)*B(1)-A(2)*B(2)-A(3)*B(3)-A(4)*B(4)
LET SS(2)=A(1)*B(2)+A(2)*B(1)+A(3)*B(4)-A(4)*B(3)
LET SS(3)=A(1)*B(3)-A(2)*B(4)+A(3)*B(1)+A(4)*B(2)
LET SS(4)=A(1)*B(4)+A(2)*B(3)-A(3)*B(2)+A(4)*B(1)
MAT S=SS
END SUB

EXTERNAL SUB CCONJ(S(),A()) ! S=CONJ(A)
LET S(1)=A(1)
LET S(2)=-A(2)
LET S(3)=-A(3)
LET S(4)=-A(4)
END SUB

EXTERNAL SUB CDIV(S(),A(),B()) ! S=A/B
DIM BB(4),S1(4),S2(4)
CALL CCONJ(BB,B) ! CONJ(B)
CALL CMUL(S1,A,BB) ! A*CONJ(B)
CALL CMUL(S2,B,BB) ! B*CONJ(B)
MAT S=(1/S2(1))*S1
END SUB

EXTERNAL SUB CADD(S(),A(),B())
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(),A(),B())
MAT S=A-B
END SUB

EXTERNAL FUNCTION CABS(A())
FOR I=1 TO 4
LET S=S+A(I)^2
NEXT I
LET CABS=SQR(S)
END FUNCTION

EXTERNAL FUNCTION CABS2(A(),B())
FOR I=1 TO 4
LET S=S+(A(I)-B(I))^2
NEXT I
LET CABS2=SQR(S)
END FUNCTION

EXTERNAL SUB CHORNER(Y(),X(),COEF(,),N) ! Y=COEF(0)+COEF(1)*X+COEF(2)*X^2+...+COEF(N)*X^N
DIM C(4)
CALL CSET(Y,COEF(N,1),COEF(N,2),COEF(N,3),COEF(N,4)) ! Y=COEF(N)
FOR I=N-1 TO 0 STEP -1
CALL CMUL(Y,Y,X) ! Y=Y*X
CALL CSET(C,COEF(I,1),COEF(I,2),COEF(I,3),COEF(I,4))
CALL CADD(Y,Y,C) ! Y=Y*X+COEF(I)
NEXT I
END SUB
------------------------------------------------------------------------------------------------------
ニュートン法(2次収束)をハリー法(3次収束)で
やってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4),DIFF2COEF(0 TO N,4)
DIM Y(4),DY(4),DY2(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

CALL DERIVATIVE(DIFFCOEF,COEF,N)
CALL DERIVATIVE(DIFF2COEF,DIFFCOEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N-1)
CALL CHORNER(DY2,X,DIFF2COEF,N-1)

CALL CMUL(A,Y,DY2)
MAT B=(2)*DY
CALL CDIV(A,A,B)
CALL CSUB(C,DY,A)
CALL CDIV(D,Y,C)
CALL CSUB(XX,X,D)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
キス法(4次収束)でもやってみた。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4),DIFF2COEF(0 TO N,4),DIFF3COEF(0 TO N,4)
DIM Y(4),DY(4),DY2(4),DY3(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

CALL DERIVATIVE(DIFFCOEF,COEF,N)
CALL DERIVATIVE(DIFF2COEF,DIFFCOEF,N)
CALL DERIVATIVE(DIFF3COEF,DIFF2COEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N)
CALL CHORNER(DY2,X,DIFF2COEF,N)
CALL CHORNER(DY3,X,DIFF3COEF,N)

CALL CPOW(A,Y,2)
CALL CMUL(A,A,DY3)
MAT A=(1/6)*A
CALL CPOW(B,DY,3)
CALL CMUL(C,Y,DY)
CALL CMUL(C,C,DY2)
CALL CSUB(B,B,C)
CALL CADD(A,A,B)

CALL CPOW(B,DY,2)
CALL CMUL(C,DY2,Y)
MAT C=.5*C
CALL CSUB(B,B,C)
CALL CMUL(B,B,Y)
CALL CDIV(C,B,A)
CALL CSUB(XX,X,C)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
5次収束式でやってみた。


LET N=5
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4),DIFF2COEF(0 TO N,4),DIFF3COEF(0 TO N,4),DIFF4COEF(0 TO N,4)
DIM Y(4),DY(4),DY2(4),DY3(4),DY4(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^3
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^4
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^5

CALL DERIVATIVE(DIFFCOEF,COEF,N)
CALL DERIVATIVE(DIFF2COEF,DIFFCOEF,N)
CALL DERIVATIVE(DIFF3COEF,DIFF2COEF,N)
CALL DERIVATIVE(DIFF4COEF,DIFF3COEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N)
CALL CHORNER(DY2,X,DIFF2COEF,N)
CALL CHORNER(DY3,X,DIFF3COEF,N)
CALL CHORNER(DY4,X,DIFF4COEF,N)

CALL CPOW(A,Y,3)
MAT A=4*A
CALL CMUL(A,A,DY3)
CALL CPOW(B,Y,2)
CALL CMUL(B,B,DY)
CALL CMUL(B,B,DY2)
MAT B=24*B
CALL CSUB(A,A,B)
CALL CPOW(B,DY,3)
CALL CMUL(B,B,Y)
MAT B=24*B
CALL CADD(A,A,B)

CALL CPOW(C,Y,3)
CALL CMUL(C,C,DY4)
CALL CPOW(D,Y,2)
CALL CMUL(D,D,DY)
CALL CMUL(D,D,DY3)
MAT D=8*D
CALL CSUB(C,C,D)
CALL CMUL(D,Y,DY2)
CALL CPOW(D,D,2)
MAT D=6*D
CALL CSUB(C,C,D)
CALL CPOW(D,DY,2)
CALL CMUL(D,D,Y)
CALL CMUL(D,D,DY2)
MAT D=36*D
CALL CADD(C,C,D)
CALL CPOW(D,DY,4)
MAT D=24*D
CALL CSUB(C,C,D)
CALL CDIV(A,A,C)
CALL CADD(XX,X,A)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
スラー法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4),DIFF2COEF(0 TO N,4)
DIM Y(4),DY(4),DY2(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

CALL DERIVATIVE(DIFFCOEF,COEF,N)
CALL DERIVATIVE(DIFF2COEF,DIFFCOEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N-1)
CALL CHORNER(DY2,X,DIFF2COEF,N-1)

CALL CPOW(A,DY,2)
CALL CMUL(B,DY2,Y)
CALL CSUB(A,A,B)
CALL CMUL(C,Y,DY)
CALL CDIV(A,C,A)
CALL CSUB(XX,X,A)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
リッチモンド法でやってみました。


LET N=3
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4),DIFF2COEF(0 TO N,4)
DIM Y(4),DY(4),DY2(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3
CALL DERIVATIVE(DIFFCOEF,COEF,N)
CALL DERIVATIVE(DIFF2COEF,DIFFCOEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N-1)
CALL CHORNER(DY2,X,DIFF2COEF,N-1)

CALL CMUL(A,Y,DY2)
MAT A=.5*A
CALL CMUL(B,DY,DY)
CALL CSUB(A,B,A)
CALL CMUL(C,Y,DY)
CALL CDIV(D,C,A)
CALL CSUB(XX,X,D)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
ステッフェッセン法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),COEF(0 TO N,4)
DIM Y(4),Y1(4),XX(4),X1(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CADD(X1,X,Y)
CALL CHORNER(Y1,X1,COEF,N)
CALL CSUB(A,Y1,Y)
CALL CDIV(B,A,Y)
CALL CDIV(C,Y,B)
CALL CSUB(XX,X,C)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
セカント法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X0(4),X1(4),COEF(0 TO N,1 TO 4)
DIM Y0(4),Y1(4),X2(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X0,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
CALL CSET(X1,WORLDX(I)+1,WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y0,X0,COEF,N)
CALL CHORNER(Y1,X1,COEF,N)
CALL CSUB(A,X1,X0)
CALL CSUB(B,Y1,Y0)
CALL CDIV(A,B,A)
CALL CDIV(C,Y1,A)
CALL CSUB(X2,X1,C)
IF CABS2(X2,X1)<EPS THEN EXIT FOR
MAT X0=X1
MAT X1=X2
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
オストロフスキー法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X0(4),X1(4),X2(4),X3(4),COEF(0 TO N,4)
DIM Y0(4),Y1(4),Y2(4),TT(4),Y(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X0,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
MAT X2=ZER
CALL CADD(X1,X0,X2)
MAT X1=.5*X1
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y0,X0,COEF,N)
CALL CHORNER(Y1,X1,COEF,N)
CALL CHORNER(Y2,X2,COEF,N)

CALL CSUB(A,X2,X1)
CALL CSUB(B,X2,X0)
CALL CDIV(TT,A,B)
CALL CSUB(A,Y2,Y0)
CALL CSUB(B,Y2,Y1)
CALL CDIV(A,A,B)
CALL CMUL(TT,TT,A)
CALL CDIV(A,Y1,Y0)
CALL CMUL(TT,TT,A)
CALL CMUL(C,X0,TT)
CALL CSUB(C,X1,C)
CALL CSET(A,1,0,0,0)
CALL CSUB(D,A,TT)
CALL CDIV(X3,C,D)
CALL CHORNER(Y,X3,COEF,N)
IF CABS(Y)<EPS THEN EXIT FOR
MAT X0=X1
MAT X1=X2
MAT X2=X3
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
原始反復法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),COEF(0 TO N,4)
DIM XX(4),Y(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET H=1
DO
LET H=H/2
CALL CHORNER(Y,X,COEF,N)
MAT Y=(H)*Y
LOOP UNTIL CABS(Y)<3
CALL CHORNER(Y,X,COEF,N)
MAT Y=(H)*Y
CALL CSUB(XX,X,Y)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
ウェグスティン法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),COEF(0 TO N,4)
DIM X2(4),X1(4),X0(4),Y0(4),Y1(4),Y(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

LET COEF(0,1)=COEF(0,1)+1
SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X0,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
CALL CHORNER(X1,X0,COEF,N)
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y0,X0,COEF,N)
CALL CHORNER(Y1,X1,COEF,N)
CALL CSUB(A,X0,Y0)
CALL CSUB(B,X1,Y1)
CALL CDIV(A,A,B)
CALL CSET(C,1,0,0,0)
CALL CSUB(A,A,C)
CALL CSUB(D,X1,X0)
CALL CDIV(A,D,A)
CALL CADD(X2,X1,A)
CALL CHORNER(Y,X2,COEF,N)
CALL CSUB(Y,Y,X2)
IF CABS(Y)<EPS THEN EXIT FOR
MAT X0=X1
MAT X1=X2
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
エイトケン法でやってみました。



LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),COEF(0 TO N,4)
DIM X2(4),X1(4),X0(4),X3(4),Y(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

LET COEF(0,1)=COEF(0,1)+1
SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X0,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(X1,X0,COEF,N)
CALL CHORNER(X2,X1,COEF,N)

CALL CSUB(A,X1,X0)
CALL CMUL(A,A,A)
MAT B=2*X1
CALL CSUB(B,X2,B)
CALL CADD(B,B,X0)
CALL CDIV(A,A,B)
CALL CSUB(X3,X0,A)
CALL CHORNER(Y,X3,COEF,N)
CALL CSUB(Y,Y,X3)
IF CABS(Y)<EPS THEN EXIT FOR
MAT X0=X3
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
改良ニュートン法でやってみました。


LET N=3 ! 次数
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4)
DIM Y(4),DY(4),YY(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3
CALL DERIVATIVE(DIFFCOEF,COEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(J),WORLDX(I))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N-1)

CALL CDIV(A,Y,DY)
CALL CSUB(A,X,A)
CALL CHORNER(YY,A,COEF,N)
CALL CSUB(B,Y,YY)
CALL CMUL(B,B,DY)
CALL CPOW(C,Y,2)
CALL CDIV(D,C,B)
CALL CSUB(XX,X,D)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

以下略

上記からコピペしてください
------------------------------------------------------------------------------------------------------
拡張ニュートン法でやってみました。


変数Qを変えると収束が変わります。
Q=1にすると本来のニュートン法になります。



LET N=3 ! 次数
LET Q=4
DIM A(4),B(4),C(4),D(4),X(4),XX(4),COEF(0 TO N,4),DIFFCOEF(0 TO N,4)
DIM Y(4),DY(4)
FOR I=0 TO N
FOR J=1 TO 4
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0,0,0 ! (-1+0i+0j+0k)*X^0
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^1
DATA 0,0,0,0 ! (0+0i+0j+0k)*X^2
DATA 1,0,0,0 ! (1+0i+0j+0k)*X^3

CALL DERIVATIVE(DIFFCOEF,COEF,N)

SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J),WORLDY(I),WORLDX(J))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(Y,X,COEF,N)
CALL CHORNER(DY,X,DIFFCOEF,N-1)

CALL CDIV(A,Y,DY)
CALL CPOW(B,X,Q-1)
MAT B=Q*B
CALL CMUL(B,B,A)
CALL CPOW(C,X,Q)
CALL CSUB(D,C,B)
CALL CPOW(XX,D,1/Q)
IF CABS2(XX,X)<EPS THEN EXIT FOR
MAT X=XX
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

EXTERNAL SUB CPOW(S(),A(),M) ! S=A^M
DIM Y(4)
IF M<0 THEN LET SIGN=-1
LET N=ABS(M)
LET NN=IP(N)
LET N=FP(N)
MAT Y=A
CALL CSET(S,1,0,0,0)
FOR I=1 TO NN
CALL CMUL(S,S,A)
NEXT I
DO WHILE N>0 AND C<50
LET N=N*2
CALL CSQR(Y,Y)
IF N>=1 THEN CALL CMUL(S,S,Y)
LET N=FP(N)
LET C=C+1
LOOP
IF SIGN<0 THEN
CALL CSET(Y,1,0,0,0)
CALL CDIV(S,Y,S)
END IF
END SUB

EXTERNAL SUB CSQR(X(),Y()) ! Y=SQR(X)
DIM A(4),B(4)
MAT A=ZER
CALL CSET(B,1,0,0,0)
FOR I=1 TO 100
CALL CADD(B,A,B)
MAT B=.5*B
CALL CDIV(A,X,B)
IF CABS2(A,B)<1E-8 THEN EXIT FOR
NEXT I
MAT Y=B
END SUB

以下略

上記からコピペしてください

2元数マンデルブロ集合 - しばっち

2023/10/08 (Sun) 13:41:50

2重数マンデルブロ集合


2重数 z=a+bε
※(a+bε)(c+dε)=ac+(bc+ad)ε εは2乗すると0になります(ε^2=0)

割り算(a+bε)/(c+dε)
=(a+bε)(c-dε)/{(c+dε)(c-dε)}
=(ac+bcε-adε)/c^2 となり
c=0では計算できません。


https://ja.wikipedia.org/wiki/二重数
https://7shi.hateblo.jp/entry/2019/11/24/044617

https://ja.wikipedia.org/wiki/マンデルブロ集合


サンプル画像は2重数マンデルブロ集合です。
収束した部分は黒、発散した部分は黒以外の色になります。


DIM A(2,2),Z(2,2),ZZ(2,2)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
MAT Z=ZER
CALL CSET(A,WORLDX(X),WORLDY(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS :WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL FUNCTION CABS(A(,))
LET CABS=SQR(A(1,1)^2+A(2,1)^2)
END FUNCTION

EXTERNAL SUB CSET(A(,),X,Y)
LET A(1,1)=X
LET A(1,2)=0
LET A(2,2)=X
LET A(2,1)=Y
END SUB

EXTERNAL SUB CADD(S(,),A(,),B(,)) ! S=A+B
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(,),A(,),B(,)) ! S=A-B
MAT S=A-B
END SUB

EXTERNAL SUB CMUL(S(,),A(,),B(,)) ! S=A*B
MAT S=A*B
END SUB

EXTERNAL SUB CPOW(S(,),A(,),N) ! S=A^N
CALL CSET(S,1,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(,),A(,),B(,)) ! S=A/B
DIM BB(2,2)
MAT BB=INV(B)
CALL CMUL(S,A,BB)
END SUB

EXTERNAL SUB CPRINT(A(,)) ! 二重数表示
PRINT A(1,1);
IF A(2,1)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2,1));"ε"
END SUB
**********************************************************************
CSETルーチンを下記に変更すると分解型複素数となります。

分解型複素数 z=a+bj
※(a+bj)(c+dj)=ac+bd+(bc+ad)j jは2乗すると1になります(j^2=1)
(※j^2=1 だから j=1,j=-1ということではありません)


割り算(a+bj)/(c+dj)
=(a+bj)(c-dj)/{(c+dj)(c-dj)}
=(ac-bd+bcj-adj)/(c^2-d^2) となります。
d=cの時は計算できません。


https://ja.wikipedia.org/wiki/分解型複素数


EXTERNAL SUB CSET(A(,),X,Y) ! 分解型複素数
LET A(1,1)=X
LET A(1,2)=Y
LET A(2,2)=X
LET A(2,1)=Y
END SUB

EXTERNAL SUB CPRINT(A(,)) ! 分解型複素数表示
PRINT A(1,1);
IF A(2,1)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2,1));"j"
END SUB
**********************************************************************
下記にすると複素数になります。

複素数 z=a+bi
※(a+bi)(c+di)=ac-bd+(bc+ad)i iは2乗すると-1になります(i^2=-1)

割り算(a+bi)/(c+di)
=(a+bi)(c-di)/{(c+di)(c-di)}
=(ac+bd+bci-adi)/(c^2+d^2) となります。


EXTERNAL SUB CSET(A(,),X,Y) ! 複素数
LET A(1,1)=X
LET A(1,2)=-Y
LET A(2,2)=X
LET A(2,1)=Y
END SUB

EXTERNAL SUB CPRINT(A(,)) ! 複素数表示
PRINT A(1,1);
IF A(2,1)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2,1));"i"
END SUB
--------------------------------------------------------------------------------------------------------
2重数ジュリア集合

https://ja.wikipedia.org/wiki/充填ジュリア集合

収束した部分は黒、発散した部分は黒以外の色になります。


RANDOMIZE
DIM A(2,2),Z(2,2),ZZ(2,2)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
CALL CSET(A,2*RND-1,2*RND-1) ! 初期値
CALL CPRINT(A)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(Z,WORLDX(X),WORLDY(Y))
FOR K=1 TO KMAX
CALL CPOW(ZZ,Z,N) ! ZZ=Z^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS :WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL FUNCTION CABS(A(,))
LET CABS=SQR(A(1,1)^2+A(2,1)^2)
END FUNCTION

EXTERNAL SUB CSET(A(,),X,Y)
LET A(1,1)=X
LET A(1,2)=0
LET A(2,2)=X
LET A(2,1)=Y
END SUB

EXTERNAL SUB CADD(S(,),A(,),B(,)) ! S=A+B
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(,),A(,),B(,)) ! S=A-B
MAT S=A-B
END SUB

EXTERNAL SUB CMUL(S(,),A(,),B(,)) ! S=A*B
MAT S=A*B
END SUB

EXTERNAL SUB CPOW(S(,),A(,),N) ! S=A^N
CALL CSET(S,1,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(,),A(,),B(,)) ! S=A/B
DIM BB(2,2)
MAT BB=INV(B)
CALL CMUL(S,A,BB)
END SUB

EXTERNAL SUB CPRINT(A(,)) ! 二重数表示
PRINT A(1,1);
IF A(2,1)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2,1));"ε"
END SUB
--------------------------------------------------------------------------------------------------------
ニュートン法(x^3-1=0)の収束回数によるフラクタル

https://en.wikipedia.org/wiki/Newton_fractal
https://fluid.mech.kogakuin.ac.jp/~minnie/for_students/engmath/NewtonFractal_190630.pdf
https://note.com/108hassium/n/n9e0be28a480b


2重数や分解型複素数において x^3-1=0の解はx=1だけです。
2重数、分解型複素数では x^2+1=0の解はありません。


LET N=3 ! 次数
DIM X(2,2),XX(2,2),S(2,2),SS(2,2),T(2,2)
DIM COEF(0 TO N,2),DIFFCOEF(0 TO N-1,2)
FOR I=0 TO N
FOR J=1 TO 2
READ COEF(I,J) ! X^3-1
NEXT J
NEXT I
DATA -1,0 ! (-1+0ε)*X^0
DATA 0,0 ! (0+0ε)*X^1
DATA 0,0 ! (0+0ε)*X^2
DATA 1,0 ! (1+0ε)*X^3
FOR I=1 TO N
FOR J=1 TO 2
LET DIFFCOEF(I-1,J)=I*COEF(I,J)
NEXT J
NEXT I
SET WINDOW -2,2,-2,2
ASK BITMAP SIZE XSIZE,YSIZE
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET EPS=1E-8
LET KMAX=50 ! 最大繰り返し数
FOR J=0 TO YSIZE
FOR I=0 TO XSIZE
CALL CSET(X,WORLDX(I),WORLDY(J))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
CALL CHORNER(S,X,COEF,N)
CALL CHORNER(SS,X,DIFFCOEF,N-1)
CALL CDIV(XX,S,SS) ! XX=S/SS
CALL CSUB(T,X,XX) ! T=X-S/SS
IF CABS2(T,X)<EPS THEN EXIT FOR
MAT X=T
USE
EXIT FOR
END WHEN
NEXT K
SET POINT COLOR MOD(K,7)+1
PLOT POINTS:WORLDX(I),WORLDY(J)
NEXT I
NEXT J
END

EXTERNAL FUNCTION CABS2(T(,),X(,))
LET CABS2=SQR((T(1,1)-X(1,1))^2+(T(2,1)-X(2,1))^2)
END FUNCTION

EXTERNAL SUB CHORNER(Y(,),X(,),COEF(,),N)
DIM C(2,2)
CALL CSET(Y,COEF(N,1),COEF(N,2)) ! Y=COEF(N)
FOR I=N-1 TO 0 STEP -1
CALL CMUL(Y,Y,X) ! Y=Y*X
CALL CSET(C,COEF(I,1),COEF(I,2))
CALL CADD(Y,Y,C) ! Y=Y*X+COEF(I)
NEXT I
END SUB

EXTERNAL SUB CSET(A(,),X,Y)
LET A(1,1)=X
LET A(1,2)=0
LET A(2,2)=X
LET A(2,1)=Y
END SUB

EXTERNAL SUB CADD(S(,),A(,),B(,)) ! S=A+B
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(,),A(,),B(,)) ! S=A-B
MAT S=A-B
END SUB

EXTERNAL SUB CMUL(S(,),A(,),B(,)) ! S=A*B
MAT S=A*B
END SUB

EXTERNAL SUB CPOW(S(,),A(,),N) ! S=A^N
CALL CSET(S,1,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(,),A(,),B(,)) ! S=A/B
DIM BB(2,2)
MAT BB=INV(B)
CALL CMUL(S,A,BB)
END SUB

EXTERNAL SUB CPRINT(A(,)) ! 二重数表示
PRINT A(1,1);
IF A(2,1)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2,1));"ε"
END SUB
--------------------------------------------------------------------------------------------------------
バーニングシップフラクタル

https://ja.wikipedia.org/wiki/バーニングシップ・フラクタル
https://paulbourke.net/fractals/burnship/


DIM A(2,2),Z(2,2),ZZ(2,2),S(2,2)
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LET XS=-2
LET YS=-2
LET XE=2
LET YE=2
SET WINDOW XS,XE,YE,YS
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
LET KMAX=50 ! 最大繰り返し数
LET N=2 ! 次数
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL CSET(A,WORLDX(X),WORLDY(Y))
MAT Z=ZER
FOR K=1 TO KMAX
CALL CSET(S,ABS(REAL(Z)),ABS(IMAG(Z)))
CALL CPOW(ZZ,S,N) ! ZZ=S^N
CALL CADD(Z,ZZ,A) ! Z=Z^N+A
IF CABS(Z)>2 THEN
SET POINT COLOR MOD(K,7)+1
PLOT POINTS :WORLDX(X),WORLDY(Y)
EXIT FOR
END IF
NEXT K
NEXT X
NEXT Y
END

EXTERNAL FUNCTION REAL(Z(,))
LET REAL=Z(1,1)
END FUNCTION

EXTERNAL FUNCTION IMAG(Z(,))
LET IMAG=Z(2,1)
END FUNCTION

EXTERNAL FUNCTION CABS(A(,))
LET CABS=SQR(A(1,1)^2+A(2,1)^2)
END FUNCTION

EXTERNAL SUB CSET(A(,),X,Y) ! 複素数
LET A(1,1)=X
LET A(1,2)=-Y
LET A(2,2)=X
LET A(2,1)=Y
END SUB

EXTERNAL SUB CPRINT(A(,))
PRINT A(1,1);
IF A(2,1)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(2,1));"i"
END SUB

EXTERNAL SUB CADD(S(,),A(,),B(,)) ! S=A+B
MAT S=A+B
END SUB

EXTERNAL SUB CSUB(S(,),A(,),B(,)) ! S=A-B
MAT S=A-B
END SUB

EXTERNAL SUB CMUL(S(,),A(,),B(,)) ! S=A*B
MAT S=A*B
END SUB

EXTERNAL SUB CPOW(S(,),A(,),N) ! S=A^N
CALL CSET(S,1,0)
FOR I=1 TO N
CALL CMUL(S,S,A)
NEXT I
END SUB

EXTERNAL SUB CDIV(S(,),A(,),B(,)) ! S=A/B
DIM BB(2,2)
MAT BB=INV(B)
CALL CMUL(S,A,BB)
END SUB

無題 - Twitter@hiro_1729

2023/10/05 (Thu) 15:44:11

https://www.vector.co.jp/soft/dl/mac/prog/se525597.html

こちらのサイトからダウンロードした十進BASICについて、開けないという表示が出ますが、どのようにして使えばいいですか?

Re: 無題 SHIRAISHI Kazuo

2023/10/05 (Thu) 18:16:50

BASICJaフォルダを右クリックして,「フォルダに新規ターミナル」を選択。
ターミナルで,xattr -rc BASIC.app を実行 (copy & paste して Returnキーを押す)
参照 https://decimalbasic.web.fc2.com/IntelMac.htm

Re: 無題 - Twitter@hiro_1729

2023/10/06 (Fri) 06:54:31

ありがとうございます

y=x^nのグラフ - しばっち

2023/09/03 (Sun) 08:58:12

y=x^nのグラフ


OPTION ARITHMETIC COMPLEX
RANDOMIZE
SET WINDOW -5,5,-5,5
DRAW GRID
LET A=RND*10
LET B=RND*10-5
PRINT A;B
LET N=COMPLEX(A,B)
FOR X=-5 TO 5 STEP 1/64
IF X<0 THEN
LET Y=SGN(X)*ABS(X)^N
ELSEIF X=0 THEN
LET Y=0
ELSE
LET Y=X^N ! y=x^(a+bi) i^2=-1
END IF
IF X>-5 THEN
SET LINE COLOR "BLACK"
PLOT LINES:X0,RE(Y0);X,RE(Y)
SET LINE COLOR "RED"
PLOT LINES:X0,IM(Y0);X,IM(Y)
SET LINE COLOR "BLUE"
PLOT LINES:X0,ABS(Y0);X,ABS(Y)
SET LINE COLOR "GREEN"
PLOT LINES:X0,Y0*CONJ(Y0);X,Y*CONJ(Y)
END IF
LET X0=X
LET Y0=Y
NEXT X
END
--------------------------------------------------------------------------------------------
X=COS(θ)^N Y=SIN(θ)^M のグラフ

RANDOMIZE
OPTION BASE 0
OPTION ANGLE DEGREES
OPTION ARITHMETIC COMPLEX
SET WINDOW -1,1,-1,1
DIM X(360),Y(360)
LET A1=RND*10
LET B1=RND*20-10
LET A2=RND*10
LET B2=RND*20-10
PRINT A1;B1
PRINT A2;B2
LET N=COMPLEX(A1,B1)
LET M=COMPLEX(A2,B2)
FOR I=0 TO 360
LET C=COS(I)
LET S=SIN(I)
IF C=0 THEN
LET X(I)=0
ELSE
LET X(I)=SGN(C)*ABS(C)^N ! x=cos(θ)^(a+bi)
END IF
IF S=0 THEN
LET Y(I)=0
ELSE
LET Y(I)=SGN(S)*ABS(S)^M ! y=sin(θ)^(c+di)
END IF
NEXT I
DRAW GRID(.1,.1)
FOR I=0 TO 359
LET C=COS(I)
LET S=SIN(I)
SET LINE COLOR "BLACK"
PLOT LINES:RE(X(I)),RE(Y(I));RE(X(I+1)),RE(Y(I+1))

SET LINE COLOR "RED"
PLOT LINES:IM(X(I)),IM(Y(I));IM(X(I+1)) ,IM(Y(I+1))

SET LINE COLOR "BLUE"
PLOT LINES:SGN(C)*ABS(X(I)),SGN(S)*ABS(Y(I));SGN(C)*ABS(X(I+1)),SGN(S)*ABS(Y(I+1))

SET LINE COLOR "GREEN"
PLOT LINES:SGN(C)*X(I)*CONJ(X(I)),SGN(S)*Y(I)*CONJ(Y(I));SGN(C)*X(I+1)*CONJ(X(I+1)),SGN(S)*Y(I+1)*CONJ(Y(I+1))
NEXT I
END

Re: y=x^nのグラフ - しばっち

2023/09/17 (Sun) 08:58:36

y=x^nのグラフ
https://ja.wikipedia.org/wiki/四元数



RANDOMIZE
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=20
DIM A(4,4),B(4,4),C(4,4)
LET XS=-5
LET XE=5
LET YS=-5
LET YE=5
CALL CSET(B,RND*10,RND*10-5,RND*10-5,RND*10-5)
CALL CPRINT(B)
SET WINDOW XS,XE,YS,YE
DRAW GRID
FOR X=XS TO XE STEP (XE-XS)/128
CALL CSET(A,ABS(X),0,0,0)
CALL CPOWER(A,B,C)
IF X>XS THEN
SET LINE COLOR "BLACK"
PLOT LINES:X0,Y0;X,C(1,1)
SET LINE COLOR "RED"
PLOT LINES:X0,Y1;X,C(1,2)
SET LINE COLOR "BLUE"
PLOT LINES:X0,Y2;X,C(1,3)
SET LINE COLOR "GREEN"
PLOT LINES:X0,Y3;X,C(1,4)
END IF
LET Y0=C(1,1)
LET Y1=C(1,2)
LET Y2=C(1,3)
LET Y3=C(1,4)
LET X0=X
NEXT X
END

EXTERNAL SUB CSET(X(,),A,B,C,D)
LET X(1,1)=A
LET X(1,2)=B
LET X(1,3)=C
LET X(1,4)=D
LET X(2,1)=-B
LET X(2,2)=A
LET X(2,3)=-D
LET X(2,4)=C
LET X(3,1)=-C
LET X(3,2)=D
LET X(3,3)=A
LET X(3,4)=-B
LET X(4,1)=-D
LET X(4,2)=-C
LET X(4,3)=B
LET X(4,4)=A
END SUB

EXTERNAL SUB CADD(A(,),B(,)) ! A=A+B
MAT A=A+B
END SUB

EXTERNAL SUB CSUB(A(,),B(,)) ! A=A-B
MAT A=A-B
END SUB

EXTERNAL SUB CMUL(A(,),B(,)) ! A=A*B
MAT A=A*B
END SUB

EXTERNAL SUB CDIV(A(,),B(,)) ! A=A/B
DIM BB(4,4)
MAT BB=INV(B)
CALL CMUL(A,BB)
END SUB

EXTERNAL SUB CPRINT(A(,))
PRINT A(1,1);
IF A(1,2)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(1,2));"i";
IF A(1,3)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(1,3));"j";
IF A(1,4)<0 THEN PRINT "-"; ELSE PRINT "+";
PRINT ABS(A(1,4));"k"
END SUB

EXTERNAL SUB HORNER(X(,),Y(,),COEF())
DIM C(4,4)
CALL CSET(Y,COEF(MAXLEVEL),0,0,0) ! Y=COEF(N)
FOR I=MAXLEVEL-1 TO 0 STEP -1
CALL CMUL(Y,X) ! Y=Y*X
CALL CSET(C,COEF(I),0,0,0)
CALL CADD(Y,C) ! Y=Y*X+COEF(I)
NEXT I
END SUB

EXTERNAL SUB CEXP(X(,),Y(,)) ! Y=EXP(X)
DIM V(0 TO MAXLEVEL)
CALL EXPON(V)
CALL HORNER(X,Y,V)
END SUB

EXTERNAL SUB CLOG(X(,),Y(,)) ! Y=LOG(X)
DIM V(0 TO MAXLEVEL),XA(4,4),XB(4,4),T(4,4)
CALL LN(V)
MAT XA=X
MAT XB=X
CALL CSET(T,1,0,0,0)
CALL CSUB(XA,T)
CALL CADD(XB,T)
CALL CDIV(XA,XB) !'(X-1)/(X+1)
CALL HORNER(XA,Y,V)
MAT Y=2*Y
END SUB

EXTERNAL SUB CPOWER(X(,),Y(,),Z(,)) ! Z=X^Y
DIM XX(4,4),YY(4,4)
MAT YY=Y
CALL CLOG(X,XX)
CALL CMUL(YY,XX)
CALL CEXP(YY,Z)
END SUB

EXTERNAL SUB EXPON(COEF())
!'EXP(X)
LET COEF(0)=1
LET T=1
FOR I=1 TO MAXLEVEL
LET T=T/I
LET COEF(I)=T
NEXT I
END SUB

EXTERNAL SUB LN(COEF())
!'LOG((X-1)/(X+1))
FOR I=1 TO MAXLEVEL
IF MOD(I,2)=1 THEN LET COEF(I)=1/I
NEXT I
END SUB
------------------------------------------------------------------------------------------
x=cos(θ)^n y=sin(θ)^m のグラフ


OPTION ANGLE DEGREES
RANDOMIZE
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=20
SET WINDOW -1,1,-1,1
DRAW GRID(.1,.1)
DIM N(4,4),M(4,4),C(4,4),S(4,4),X(4,4),Y(4,4)
CALL CSET(N,RND*10,RND*20-10,RND*20-10,RND*20-10)
CALL CSET(M,RND*10,RND*20-10,RND*20-10,RND*20-10)
CALL CPRINT(N)
CALL CPRINT(M)
FOR I=0 TO 359
LET CC=COS(I)
CALL CSET(X,ABS(CC),0,0,0) ! X=COS(I)
CALL CPOWER(X,N,C) ! C=COS(I)^N

LET SS=SIN(I)
CALL CSET(Y,ABS(SS),0,0,0) ! Y=SIN(I)
CALL CPOWER(Y,M,S) ! S=SIN(I)^M

IF I>0 THEN
SET LINE COLOR "BLACK"
PLOT LINES:C1,S1;SGN(CC)*ABS(C(1,1)),SGN(SS)*ABS(S(1,1))
SET LINE COLOR "RED"
PLOT LINES:C2,S2;SGN(CC)*ABS(C(1,2)),SGN(SS)*ABS(S(1,2))
SET LINE COLOR "BLUE"
PLOT LINES:C3,S3;SGN(CC)*ABS(C(1,3)),SGN(SS)*ABS(S(1,3))
SET LINE COLOR "GREEN"
PLOT LINES:C4,S4;SGN(CC)*ABS(C(1,4)),SGN(SS)*ABS(S(1,4))
END IF
LET C1=ABS(C(1,1))*SGN(CC)
LET S1=ABS(S(1,1))*SGN(SS)
LET C2=ABS(C(1,2))*SGN(CC)
LET S2=ABS(S(1,2))*SGN(SS)
LET C3=ABS(C(1,3))*SGN(CC)
LET S3=ABS(S(1,3))*SGN(SS)
LET C4=ABS(C(1,4))*SGN(CC)
LET S4=ABS(S(1,4))*SGN(SS)
NEXT I
END

以下略(上記からコピペしてください)

角の丸い多角形 - しばっち

2023/09/03 (Sun) 08:56:26

角の丸い多角形を描きます。


OPTION ANGLE DEGREES
DIM XX(360),YY(360)
SET WINDOW -2,2,2,-2
LOCATE VALUE NOWAIT(1) ,RANGE 3 TO 10,AT 3 :N
LOCATE VALUE NOWAIT(2) ,RANGE .05 TO 1,AT .5 :R
LOCATE VALUE NOWAIT(3) ,RANGE 0 TO 1,AT .3 :ROUNDING
LOCATE VALUE NOWAIT(4) ,RANGE -360 TO 360,AT 0 :TT
LOCATE VALUE NOWAIT(5) ,RANGE -1 TO 1,AT 0 :X0
LOCATE VALUE NOWAIT(6) ,RANGE -1 TO 1,AT 0 :Y0
DO
LOCATE VALUE NOWAIT(1):N
LOCATE VALUE NOWAIT(2):R
LOCATE VALUE NOWAIT(3):ROUNDING
LOCATE VALUE NOWAIT(4):TT
LOCATE VALUE NOWAIT(5):X0
LOCATE VALUE NOWAIT(6):Y0
LET N=INT(N)
LET A=360/N
LET C=0
FOR I=0 TO N-1
FOR T=-A/2 TO A/2-1
LET C=C+1
LET X=X0+R*COS(A*I+TT)
LET Y=Y0+R*SIN(A*I+TT)
LET XX(C)=X+ROUNDING*COS(T+A*I+TT)
LET YY(C)=Y+ROUNDING*SIN(T+A*I+TT)
NEXT T
NEXT I
MAT PLOT AREA:XX,YY
DRAW GRID(.2,.2)
SET DRAW MODE EXPLICIT
WAIT DELAY .1
SET DRAW MODE HIDDEN
CLEAR
LOOP
END

マンデルブロ集合 - しばっち

2023/09/03 (Sun) 08:55:02

マンデルブロ集合
http://paulbourke.net/fractals/
https://ja.wikipedia.org/wiki/マンデルブロ集合


OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET C=COMPLEX(WORLDX(CR),WORLDY(CI))
LET Z=0
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
LET Z=1
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
!LET F=Z*Z+1/Z/Z+C
LET F=Z*Z*Z+C
!LET F=Z*Z*Z*Z-C
!LET F=C*Z+1
!LET F=EXP(C/Z)+C
!LET F=1/Z+C
!LET F=1/Z/Z+1/C
!LET F=LOG(Z+Z*Z)/C
!LET F=EXP(1.7320508*LOG(Z))+C
!LET F=SQR(-1)*Z*Z+C*COMPLEX(1,1)
!LET F=EXP(Z*LOG(Z))+C
!LET F=Z^2+C/Z
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET C=COMPLEX(WORLDX(CR),WORLDY(CI))
LET Z=0
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
LET F=Z^3+(C-1)*Z-C
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z)
OPTION ARITHMETIC COMPLEX
LET R=1 - (SQR(2) - SQR(3) + SQR(5)) / 2
LET ZC=EXP(2*PI*R*SQR(-1))
LET F=ZC*Z+Z^2
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET C=COMPLEX(WORLDX(CR),WORLDY(CI))
LET Z=0
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
LET F=COMPLEX(RE(Z)^2-IM(Z)^2-RE(C),2*ABS(RE(Z)*IM(Z))-IM(C))
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=R(Z)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION R(Z)
OPTION ARITHMETIC COMPLEX
LET R=Z^2+F(Z)*SQR(-1)*G(Z)
END FUNCTION

EXTERNAL FUNCTION F(R)
OPTION ARITHMETIC COMPLEX
LET F=R*(1+2*R+R^2)*(R^2-1)/(1+R^3)^2
END FUNCTION

EXTERNAL FUNCTION G(R)
OPTION ARITHMETIC COMPLEX
LET G=R*(1-2*R+R^2)*(R^2-1)/(1+R^3)^2
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
!LET C=COMPLEX(.5,.05)
!LET C=COMPLEX(.5,.5)
!LET C=COMPLEX(.7,.5)
!LET C=COMPLEX(.53,.1)
!LET C=COMPLEX(.52,.1)
LET C=COMPLEX(.515,.1)
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
LET F=Z^3+C
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z)
OPTION ARITHMETIC COMPLEX
LET F=(COMPLEX(0,1)/Z^3+1010)/(C*COMPLEX(0,1)/Z^6+3301*Z)
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET C=COMPLEX(WORLDX(CR),WORLDY(CI))
LET Z=0
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
LET F=Z^3/(Z^3+1)+C
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-2.5,-2.5)
LET E=COMPLEX(2.5,2.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET C=COMPLEX(-2,0)
!LET C=COMPLEX(-1,0)
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
LET F=(Z^4+Z^2+1)/(Z^4-Z^2+1)+C
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET C=COMPLEX(WORLDX(CR),WORLDY(CI))
LET Z=1
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=F(Z,C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL FUNCTION F(Z,C)
OPTION ARITHMETIC COMPLEX
LET F=Z-(Z^3-1)/(3*Z^2)+C
END FUNCTION

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
!LET A=COMPLEX(.85,.6)
!LET A=COMPLEX(.7,.7)
!LET A=COMPLEX(.7,.725)
LET A=COMPLEX(.69,.725)
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=A*Z*(1-Z)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
!LET A=COMPLEX(.6,1.1)
!LET A=COMPLEX(1.5,.5)
!LET A=COMPLEX(1,.9)
LET A=COMPLEX(.6,1.2)
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=A*(Z-SGN(RE(Z)))
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-2.5,-2.5)
LET E=COMPLEX(2.5,2.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET C1=1.3
LET C2=0.11
LET C3=0.42457
LET C4=1.2
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=(EXP(C1*LOG(Z))-1/(LOG(Z)+C2)+C3)/(C4+1/K)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
!LET C=COMPLEX(2.0625,.1425)
!LET C=COMPLEX(2.2,.33)
!LET C=COMPLEX(-2.3,.1)
!LET C=COMPLEX(-2.4,.1)
!LET C=COMPLEX(-2.3,.35)
LET C=COMPLEX(1,-.38)
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=CTAN(Z^2+C)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB

EXTERNAL FUNCTION CTAN(Z) !'tangent
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET D=COS(2*X)+COSH(2*Y)
LET XR=SIN(2*X)/D
LET XI=SINH(2*Y)/D
LET CTAN=COMPLEX(XR,XI)
END FUNCTION
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET PHI=(1+SQR(5))/2
LET SIGMA=SQR(2)
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=(Z^2*(Z^2+SIGMA)*EXP(2*PI*PHI*SQR(-1)))/(SIGMA*Z^2+1)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET PHI=(SQR(5)-1)/2
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=(EXP(2*PI*PHI*SQR(-1))*Z^2*(Z-4))/(1-4*Z)
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET A=.5*(1+SQR(5))
LET B=.95
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=EXP(SQR(-1)*2*PI*(A-1))*Z^2*(Z-A)*(Z-B)/((1-A*Z)*(1-B*Z))
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET SIGMA=-1.7/3
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=(Z^3+SIGMA)/Z
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
LET SIGMA=-.7/5
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=(Z^7+SIGMA)/Z
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
-------------------------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
LET KMAX=200
LET S=COMPLEX(-1.5,-1.5)
LET E=COMPLEX(1.5,1.5)
SET WINDOW RE(S),RE(E),IM(E),IM(S)
ASK BITMAP SIZE XSIZE,YSIZE
FOR CI=0 TO YSIZE
FOR CR=0 TO XSIZE
LET Z=COMPLEX(WORLDX(CR),WORLDY(CI))
FOR K=1 TO KMAX
WHEN EXCEPTION IN
LET Z=Z^2+(ABS(Z)+SQR(-1))/(1+ABS(Z))
IF ABS(Z)>2 THEN
CALL PSET(WORLDX(CR),WORLDY(CI),MOD(7*K,256),MOD(5*K,256),MOD(128+K*11,256))
EXIT FOR
END IF
USE
END WHEN
NEXT K
NEXT CR
NEXT CI
END

EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB

プログラムのエラーの解決方法について 山岡伸嘉

2023/07/13 (Thu) 17:25:31

10進BASIC 御担当者

東京都八王子市在済の山岡です。
日頃、10進BASICを愛用しており、大変お世話になっております。

以下のURL
https://hp.vector.co.jp/authors/VA008683/QA_STAT.htm
のプログラムでエラーがありました。
[プログラム]
100 OPEN #1: NAME "ex1.txt"
110 LET n=0 ! 件数
120 LET s=0 ! 和
130 LET s2=0 ! 平方の和
140 DO
150 INPUT #1,IF MISSING THEN EXIT DO : x
160 LET n=n+1
170 LET s=s+x
180 LET s2=s2+x^2
190 LOOP
200 PRINT "件数",n
210 PRINT "平均",s/n
220 PRINT "標準偏差",SQR(s2/n-(s/n)^2)
230 CLOSE #1
240 END
[読み込みデータ] ex1.txt
60
44
24
70
36
80
28
76
54
48
この問題を解こうとしたところ、下記のメッセージが出ました。
150行目 「EXTYPE 8101 読み込もうとしたデータが数値乗数でなかった。」
このプログラムに続いて、同様のプログラムがあるので、早急に解決したいと考えております。
就きましては、解決方法について、ご教示願います。

誠にお手数ですが、以上、どうぞよろしくお願いいたします。

-以上-
-------------------------
山岡 伸嘉
090-9323-0670
n.yamaoka2021@gmail.com
-------------------------

Re: プログラムのエラーの解決方法について SHIRAISHI Kazuo

2023/07/14 (Fri) 09:12:15

ご面倒をおかけし申し訳ありません。
WEB上に掲載したex1.txtの行末がWindows対応のものでありませんでした。プログラムに
105 SET #1:endofline CHR$(10)
を追加するか,ex1.txtの行末コードをWindows標準のものに修正するかすれば動作します。

Re: プログラムのエラーの解決方法について SHIRAISHI Kazuo

2023/08/24 (Thu) 08:49:04

Ver.7.8.6.5で,狭義ファイル(普通のファイル)の行末を自動判定するように修正します。
ただし,COMMポートは従来通りSET ENDOFLINE文による行末の指定が必要です。

ペラン数 - しばっち

2023/08/11 (Fri) 13:40:06

ペラン数を計算します。

https://ja.wikipedia.org/wiki/ペラン数


OPTION BASE 0
OPTION ARITHMETIC RATIONAL
LET N=1000
DIM P(N)
LET P(0)=3
LET P(1)=0
LET P(2)=2
FOR I=3 TO N
LET P(I)=P(I-2)+P(I-3)
IF MOD(P(I),I)=0 THEN
PRINT I;
IF ISPRIME(I)=1 THEN PRINT "素数" ELSE PRINT "合成数(ペラン擬素数)"
END IF
NEXT I
END

EXTERNAL FUNCTION ISPRIME(N)
OPTION ARITHMETIC RATIONAL
FOR I=3 TO INTSQR(N) STEP 2
IF MOD(N,I)=0 THEN
LET ISPRIME=0
EXIT FUNCTION
END IF
NEXT I
LET ISPRIME=1
END FUNCTION
---------------------------------------------------------------------------------
メモリー対策版


OPTION ARITHMETIC RATIONAL
LET N=271500
LET A=3
LET B=0
LET C=2
FOR I=3 TO N
LET D=A+B
IF MOD(D,I)=0 THEN
PRINT I;
IF ISPRIME(I)=1 THEN PRINT "素数" ELSE PRINT "合成数(ペラン擬素数)"
END IF
LET A=B
LET B=C
LET C=D
NEXT I
END

以下省略
EXTERNAL FUNCTION ISPRIME(N)
END FUNCTION
---------------------------------------------------------------------------------
ペラン数を求めます。


OPTION ARITHMETIC RATIONAL
DIM M(3,3),A(3,3),P(3)
MAT READ M
DATA 0,1,1
DATA 1,0,0
DATA 0,1,0
MAT A=IDN
MAT READ P
DATA 2,0,3
INPUT N
DO
IF MOD(N,2)=1 THEN MAT A=A*M
LET N=INT(N/2)
MAT M=M*M
LOOP UNTIL N=0
MAT P=A*P
PRINT P(3)
END


※ペラン擬素数
271441, 904631, 16532714, 24658561, 27422714, 27664033, 46672291, 102690901, 130944133, 196075949, 214038533, 517697641, 545670533, 801123451, 855073301, 903136901, 970355431, 1091327579, 1133818561, 1235188597, 1389675541, 1502682721, 2059739221, 2304156469, 2976407809, 3273820903

DLA - しばっち

2023/07/30 (Sun) 14:37:25

DLA(拡散律速凝集)によるフラクタル画像を描きます。

http://paulbourke.net/fractals/dla/
https://ja.wikipedia.org/wiki/拡散律速凝集
https://www.ishikawa-lab.com/Cmontecarlo_11.html


RANDOMIZE
LET N=100
DIM M(-N TO N,-N TO N)
SET WINDOW -N,N,N,-N
LET M(0,0)=1
DO
LET TH=RND*2*PI
LET XX=N*COS(TH)
LET YY=N*SIN(TH)
DO
LET X=XX*.98+2*(RND-.5)
LET Y=YY*.98+2*(RND-.5)
IF ABS(X)<N AND ABS(Y)<N THEN
FOR Y0=-1 TO 1
FOR X0=-1 TO 1
IF M(X,Y)=0 AND M(X+X0,Y+Y0)=1 THEN
LET M(X,Y)=1
! PLOT LINES:X,Y;X+X0,Y+Y0
LET I=I+1
EXIT DO
END IF
NEXT X0
NEXT Y0
ELSE
EXIT DO
END IF
LET XX=X
LET YY=Y
LOOP
LOOP UNTIL I>10000
MAT PLOT CELLS ,IN -N,-N;N,N:M
END

Re: プログラムの意味合いについて 山岡伸嘉

2023/07/18 (Tue) 17:25:27

東京都八王子市在住の山岡です。
日頃、10進BASICを愛用しており、大変お世話になっております。

返信いただき、どうもありがとうございます。
理解できました。

今後ともどうぞよろしくお願いいたします。

-以上-
-------------------------
山岡 伸嘉
090-9323-0670
n.yamaoka2021@gmail.com
-------------------------

プログラムの意味合いについて 山岡伸嘉

2023/07/17 (Mon) 22:37:25

10進BASIC 御担当者様

東京都八王子市在住の山岡です。
日頃、10進BASICを愛用しており、大変お世話になっております。

プログラムの意味合いについて2点質問があります・
(1)以下のURL
https://hp.vector.co.jp/authors/VA008683/QA_STAT.htm
にあります
[プログラム]
110 OPTION ARITHMETIC NATIVE
120 SET WINDOW -1,49,-0.01,0.49
130 DRAW axes0
140 INPUT n
150 FOR k=0 TO n
160 LET p=Comb(n,k)/6^n*5^(n-k)
170 PLOT LINES: k-0.5,0 ; k-0.5,p ; k+0.5,p ; k+0.5,0
180 NEXT k
190 END
はうまく動作できましたが、Combの意味合いをご教示いただけないでしょうか?
(2)同様のURL
https://hp.vector.co.jp/authors/VA008683/QA_STAT.htm
にあります
[プログラム]
10 DECLARE EXTERNAL FUNCTION HyperGeomLCum
20 DECLARE NUMERIC NN,M,n,i
30 LET NN=18000
40 LET M=3000
50 LET n=6
60 FOR i=0 TO n
70 PRINT i,HyperGeomLCum(NN,M,n,i)
80 NEXT i
90 END
100 MERGE "discdist.lib"
はうまく動作できましたが、
1)HyperGeomLCumの意味合い
2)10進BASIC DECLARE NUMERICの意味合い
3)MERGEのの意味合
についてご教示いただけないでしょうか?

誠にお手数ですが、以上、どうぞよろしくお願いいたします。

-以上-
-------------------------
山岡 伸嘉
090-9323-0670
n.yamaoka2021@gmail.com
-------------------------

Re: プログラムの意味合いについて SHIRAISHI Kazuo

2023/07/18 (Tue) 08:28:43

COMB(n,r)はn個のものからr個選ぶ組合せの数です。
マウスカーソルをCOMBのどこかに合わせてF1キーを押すとヘルプを検索します。
DECLARE NUMERICは,数値変数名の宣言です。
オプション-文法で,「変数宣言を強要する」にチェックを入れると,宣言されていない変数名を検出することができます。
HyperGeomLCumは,ライブラリdiscdist.libで定義された外部関数です。
BASICのファイルメニューの「開く」で,ファイルの種類をライブラリに設定して開いて読むことができます。
discdist.libは,BASICがインストールされたフォルダのLibraryサブフォルダにあります。
BASICがインストールされているフォルダは,多分,C:\Program Files (x86)\Decimal BASIC\BASICw32 です。


Copyright © 1999- FC2, inc All Rights Reserved.