LET W=PrimeQ(P)
LET C=C+W
!PRINT N; P; W !debg
NEXT N
PRINT C/(M+1)*100;"%"
END
!試行割算法
EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!２以上の自然数なら
IF MOD(n,2)=0 THEN !２の倍数
IF n=2 THEN LET PrimeQ=1 !２は素数
ELSEIF MOD(n,3)=0 THEN !３の倍数
IF n=3 THEN LET PrimeQ=1 !３は素数
ELSE
LET k=5
DO WHILE k*k<=n !√nまで検証する
IF MOD(n,k)=0 THEN !5,11,17,23,29,…
EXIT FUNCTION
ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
LET k=k+6
LOOP
LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION
!!SET TEXT HEIGHT 0.0075
SET TEXT JUSTIFY "CENTER","HALF"
SET bitmap SIZE 600,600
SET WINDOW -M/2,M/2,-M/2,M/2
LET D=41 !中央の値
LET X=0
LET Y=0
SET TEXT COLOR 1+3*PrimeQ(D)
PLOT TEXT, AT X,Y: STR$(D)
LET DX=1 !移動方向
LET DY=1
FOR S=1 TO M !ステップ数
FOR L=1 TO S !x軸方向
LET D=D+1
LET X=X+DX
SET TEXT COLOR 1+3*PrimeQ(D)
PLOT TEXT, AT X,Y: STR$(D)
NEXT L
LET DX=-DX
FOR L=1 TO S !y軸方向
LET D=D+1
LET Y=Y+DY
SET TEXT COLOR 1+3*PrimeQ(D)
PLOT TEXT, AT X,Y: STR$(D)
NEXT L
LET DY=-DY
NEXT S
END
!試行割算法
EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!２以上の自然数なら
IF MOD(n,2)=0 THEN !２の倍数
IF n=2 THEN LET PrimeQ=1 !２は素数
ELSEIF MOD(n,3)=0 THEN !３の倍数
IF n=3 THEN LET PrimeQ=1 !３は素数
ELSE
LET k=5
DO WHILE k*k<=n !√nまで検証する
IF MOD(n,k)=0 THEN !5,11,17,23,29,…
EXIT FUNCTION
ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
LET k=k+6
LOOP
LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION
LET x=n !save it
DO UNTIL m=0
LET q=CEIL(n/m)
IF x>q THEN
LET s=s+(x-INT(x/q))
PRINT x/q;"本をそれぞれ";q;"等分して、";
ELSE
LET s=s+(x-1)
PRINT x/q;"本を";x;"等分して、";
END IF
PRINT "1/";STR$(q);" ずつ分ける"
SUB card_initialize(c(),N) !カードを整列する
FOR i=1 TO N
LET c(i)=i
NEXT i
END SUB
RANDOMIZE
CALL card_initialize(m1,N)
SUB shuffle_randomize(c(),N) !ランダムにシャッフルする
FOR i=N TO 2 STEP -1
LET j=INT(RND*(i-1))+1 !１～i-1
swap c(i),c(j)
NEXT i
END SUB
CALL shuffle_randomize(m1,N)
!DATA 1,2,3,4
!!DATA 4,3,1,2
!MAT READ m1
!!!MAT PRINT m1; !debug
MAT m2=ZER
MAT m3=ZER
LET c1=N
LET c2=0
LET c3=0
SUB card_display(c(),N)
PRINT "{";
IF N>0 THEN
PRINT STR$(c(N));
FOR i=N-1 TO 1 STEP -1
PRINT ",";STR$(c(i));
NEXT i
END IF
PRINT "}"
END SUB
CALL card_display(m1,c1)
CALL card_display(m2,c2)
CALL card_display(m3,c3)
PRINT
SUB move(x(),a,y(),b) !XからYへ移動させる
LET t=x(a)
LET a=a-1
LET b=b+1
LET y(b)=t
END SUB
LET S=0 !ステップ
DO
IF c1=N THEN !整列しているかどうか
FOR i=c1 TO 1 STEP -1
IF m1(i)<>N-i+1 THEN EXIT FOR
NEXT i
IF i<1 THEN EXIT DO !ＯＫ！
END IF
LET S=S+1
PRINT S;": ";
!ルール1
IF (c1>0 AND m1(c1)=2) AND (c2>0 AND m2(c2)=1) AND (c3=0) THEN !(2,1,_)なら
CALL move(m2,c2,m1,c1) !1を2の上にのせる
PRINT "ルール1"
ELSE
!ルール2
IF c1>0 AND c2>0 AND c3=0 THEN !3が空きなら
CALL move(m2,c2,m3,c3) !左隣のカードで空きを埋める
PRINT "ルール2"
ELSEIF c2>0 AND c3>0 AND c1=0 THEN !1が空きなら
CALL move(m3,c3,m1,c1)
PRINT "ルール2"
ELSEIF c3>0 AND c1>0 AND c2=0 THEN !2が空きなら
CALL move(m1,c1,m2,c2)
PRINT "ルール2"
ELSE
!ルール3
IF (c1>0 AND c2>0 AND c3>0) AND (m1(c1)-1=m3(c3) AND m2(c2)<m1(c1)) THEN !(k,j,k-1)
CALL move(m3,c3,m1,c1) !(k-1)のカードをkのカードの上にのせる
PRINT "ルール3"
ELSE
!ルール4
IF c1=N AND c2=0 AND c3=0 THEN !2,3が空きなら
CALL move(m1,c1,m3,c3) !左隣へ移動する
PRINT "ルール4"
ELSEIF c2=N AND c3=0 AND c1=0 THEN !3,1が空きなら
CALL move(m2,c2,m1,c1)
PRINT "ルール4"
ELSEIF c3=N AND c1=0 AND c3=0 THEN !1,2が空きなら
CALL move(m3,c3,m2,c2)
PRINT "ルール4"
ELSE
!ルール5
IF (c1>0 AND c2>0 AND c3>0) THEN !3枚のカードが見えるなら
LET t1=m1(c1)
LET t2=m2(c2)
LET t3=m3(c3)
LET t=MAX(MAX(t1,t2),t3)
IF t1=t THEN !1が最大なら
CALL move(m2,c2,m3,c3) !右隣のカードを右隣へ移動させる
ELSEIF t2=t THEN !2が最大なら
CALL move(m3,c3,m1,c1)
ELSE !3が最大なら
CALL move(m1,c1,m2,c2)
END IF
PRINT "ルール5"
LET N=9 !左辺の＋が5つ
LET R=4
CALL CombBit(N,R, 0) !2進法n桁、r個のビットが1
END
EXTERNAL SUB CombBit(N,R, Bit) !n個の中からr個を選ぶ組み合わせをビットで表す ※辞書式順序
IF N=R THEN
!!PRINT Bit+2^R-1 !ビットパターンを生成する
CALL stub(Bit+2^R-1)
ELSEIF N>0 THEN
CALL CombBit(N-1,R,Bit)
CALL CombBit(N-1,R-1,Bit+2^(N-1))
END IF
END SUB
!小町算「＋1±2±3±4±5±6±7±8±9±10=±11、左辺の＋と－の個数が同じもの」を解く
EXTERNAL SUB stub(Bit)
LET t=Bit !左辺を計算する
LET S=1 !1の前は+のみ
FOR K=10 TO 2 STEP -1 !進数変換でパターンを得る
IF MOD(t,2)=1 THEN LET S=S+K ELSE LET S=S-K !ビットが1なら和
LET t=INT(t/2)
NEXT K
IF ABS(S)=11 THEN PRINT BSTR$(2^9+Bit,2) !±11なら、条件を満たす
END SUB
FOR a=1 TO 22/5
FOR b=a+1 TO (22-a)/4
FOR c=b+1 TO (22-(a+b))/3
FOR d=c+1 TO (22-(a+b+c))/2
LET e=22-(a+b+c+d)
IF e>d AND e<=10 THEN PRINT a;b;c;d;e
NEXT d
NEXT c
NEXT b
NEXT a
END
PUBLIC NUMERIC S !手数 ※上限
LET S=20
DIM A(0 TO S),B(0 TO S),C(0 TO S) !バケツの水量
LET A(0)=6
LET B(0)=11
LET C(0)=14
CALL try(0,A,B,C)
PRINT S;"回"
END
EXTERNAL SUB try(p,A(),B(),C()) !バックトラック法で検索する
IF A(p)=0 OR B(p)=0 OR C(p)=0 THEN
IF p< S THEN
LET S=p !更新
FOR i=0 TO p !手順を表示する
PRINT STR$(i);": (";STR$(A(i));",";STR$(B(i));",";STR$(C(i));")"
NEXT i
PRINT
END IF
ELSE
IF p< S THEN !手数の上限以内なら、次の6通りを試す
IF A(p)>=B(p) THEN !A→Bとする
LET A(p+1)=A(p)-B(p)
LET B(p+1)=2*B(p)
LET C(p+1)=C(p)
CALL try(p+1,A,B,C)
END IF
IF A(p)>=C(p) THEN !A→Cとする
LET A(p+1)=A(p)-C(p)
LET C(p+1)=2*C(p)
LET B(p+1)=B(p)
CALL try(p+1,A,B,C)
END IF
IF B(p)>=C(p) THEN !B→Cとする
LET B(p+1)=B(p)-C(p)
LET C(p+1)=2*C(p)
LET A(p+1)=A(p)
CALL try(p+1,A,B,C)
END IF
IF B(p)>=A(p) THEN !B→Aとする
LET B(p+1)=B(p)-A(p)
LET A(p+1)=2*A(p)
LET C(p+1)=C(p)
CALL try(p+1,A,B,C)
END IF
IF C(p)>=A(p) THEN !C→Aとする
LET C(p+1)=C(p)-A(p)
LET A(p+1)=2*A(p)
LET B(p+1)=B(p)
CALL try(p+1,A,B,C)
END IF
IF C(p)>=B(p) THEN !C→Bとする
LET C(p+1)=C(p)-B(p)
LET B(p+1)=2*B(p)
LET A(p+1)=A(p)
CALL try(p+1,A,B,C)
END IF
END IF
END IF
END SUB
OPTION ARITHMETIC RATIONAL !有理数モード
FOR n=2 TO 20
LET s=0
FOR p=1 TO n-1 !1≦p＜q≦n
FOR q=p+1 TO n
IF gcd(p,q)=1 THEN !互いに素
IF p+q>n THEN
PRINT p;q; !debug
IF p+q=n+1 THEN PRINT "*" ELSE PRINT !debug
LET s=s+1/(p*q) !Σ1/(pq)
END IF
END IF
NEXT q
NEXT p
PRINT "n=";n; s !=1/2
PRINT
NEXT n
END
EXTERNAL FUNCTION gcd(a,b) !最大公約数
OPTION ARITHMETIC RATIONAL !有理数モード
DO UNTIL b=0
LET t=b
LET b=MOD(a,b)
LET a=t
LOOP
LET gcd=a
END FUNCTION
LET W=BIT2DEC(B) !2進法のビット列を10進法数値と解釈する
IF MOD(W,N)=0 THEN
LET C=C+1
PRINT N;"×";W/N;"=";W
END IF
LET B=B+1
LOOP
PRINT
NEXT n
END
EXTERNAL FUNCTION BIT2DEC(N) !2進法のビット列を10進法数値と解釈する
OPTION ARITHMETIC RATIONAL !多桁の整数
LET BIT2DEC=0
IF N>0 THEN LET BIT2DEC=BIT2DEC(INT(N/2))*10+MOD(N,2)
END FUNCTION
LET M=N
LET P=0
DO WHILE MOD(M,2)=0 !2^p
LET M=M/2
LET P=P+1
LOOP
LET Q=0
DO WHILE MOD(M,5)=0 !5^q
LET M=M/5
LET Q=Q+1
LOOP
LET R=0
DO WHILE MOD(M,3)=0 !3^r
LET M=M/3
LET R=R+1
LOOP
!!!PRINT P;Q;R;M !debug
FOR K=1 TO M-1 !1/Mの循環節の長さを求める 10^k≡1 mod mを満たす最小のk
IF modpow(10,K,M)=1 THEN EXIT FOR
NEXT K
LET W=(10^(lcm(K,3^R))-1)/9 *10^MAX(P,Q)
PRINT N; "×"; W/N; "="; W; "（";lcm(K,3^R);"個の1）"; " k=";K; "r=";R
!※同値
!IF M>1 THEN !n=2^p*5^q*3^r*Mの場合
! FOR K=1 TO M-1 !1/Mの循環節の長さを求める 10^k≡1 mod mを満たす最小のk
! IF modpow(10,K,M)=1 THEN EXIT FOR
! NEXT K
! LET W=(10^(K*3^R)-1)/9 *10^MAX(P,Q)
! PRINT N; "×"; W/N; "="; W; "（";K*3^R;"個の1）"; " k=";K; "r=";R
!ELSE !n=2^p*5^q*3^rの場合
! LET W=(10^(3^R)-1)/9 *10^MAX(P,Q)
! PRINT N; "×"; W/N; "="; W; "（";3^R;"個の1）"; " r=";R
!END IF
NEXT N
END
EXTERNAL FUNCTION modpow(a,n,b) !a^n≡x mod b のxを返す ※nは非負整数
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=MOD(1,b)
DO WHILE n>0 !べき乗nを２進展開する
IF MOD(n,2)=1 THEN LET S=MOD(S*a,b) !ビットが１なら計算する
LET a=MOD(a*a,b)
LET n=INT(n/2)
LOOP
LET modpow=S
END FUNCTION
EXTERNAL FUNCTION gcd(a,b) !最大公約数
OPTION ARITHMETIC RATIONAL !多桁の整数
DO UNTIL b=0
LET t=b
LET b=MOD(a,b)
LET a=t
LOOP
LET gcd=a
END FUNCTION
EXTERNAL FUNCTION lcm(a,b) !最小公倍数
OPTION ARITHMETIC RATIONAL !多桁の整数
IF a>b THEN !少しでも桁あふれを防止するために大きい方を先に割る
LET lcm=(a/gcd(a,b))*b
ELSE
LET lcm=a*(b/gcd(a,b))
END IF
END FUNCTION
LET t=9*n !10^0,10^1,10^2,…,10^9nとして、
FOR b=0 TO t-1 !9nで割った余りが等しいものを探す
LET W=modpow(10,b,t)
FOR a=b+1 TO t
IF modpow(10,a,t)=W THEN EXIT FOR
NEXT a
IF a<=t THEN EXIT FOR
NEXT b
IF b<=t-1 THEN !条件を満たすa,bで
EXTERNAL FUNCTION modpow(a,n,b) !a^n≡x mod b のxを返す ※nは非負整数
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=MOD(1,b)
DO WHILE n>0 !べき乗nを２進展開する
IF MOD(n,2)=1 THEN LET S=MOD(S*a,b) !ビットが１なら計算する
LET a=MOD(a*a,b)
LET n=INT(n/2)
LOOP
LET modpow=S
END FUNCTION
PRINT "2^1 ×";B/2;"=";B !n=1のとき
LET K=B !1,2からなるk桁の数
FOR N=2 TO 20 !nが2以上のとき
LET M=K+A*10^(N-1) !1{1,2からなるk桁の数}
IF MOD(M,2^N)=0 THEN
LET K=M
ELSE
LET M=K+B*10^(N-1) !2{1,2からなるk桁の数}
IF MOD(M,2^N)=0 THEN
LET K=M
ELSE
PRINT "論理エラー"
STOP
END IF
END IF
PRINT "2^";STR$(N); " ×";M/2^N; "=";M
CALL fvSEGMENT(-2,0,1,0) !AB
PLOT TEXT ,AT -2,0: "A"
CALL fvSEGMENT(1,0,1,4) !BC
PLOT TEXT ,AT 1,0: "B"
CALL fvSEGMENT(1,4,-2,0) !CA
PLOT TEXT ,AT 1,4: "C"
!折り返し
SET LINE COLOR 4
CALL fvSEGMENT(0,1,1,3) !P
CALL fvSYMMETRY2(1,1,2,1, xx,yy) !B'
PRINT xx;yy
SET LINE COLOR 2
CALL fvSEGMENT(0,0,0,1)
CALL fvSEGMENT(0,1,xx,yy)
CALL fvSEGMENT(xx,yy,1,3)
END
!●作図ルーチン
!直線
EXTERNAL SUB fvSEGMENT(x1,y1,x2,y2) !線分
PLOT LINES: x1,y1; x2,y2
END SUB
!●計算ルーチン
!点対称
!点(x,y)の原点に対称な点は、(-x,-y)より、点(a,b)に対しては、(-(x-a)+a,-(y-b)+b)=(2a-x,2b-y)
EXTERNAL SUB fvSYMMETRY(x,y,a,b, xx,yy) !点(a,b)に対称な点（点(a,b)を基準に180度回転した点）
LET xx=2*a-x
LET yy=2*b-y
END SUB
!線対称
EXTERNAL SUB fvSYMMETRY22(x,y,a, xx,yy) !直線Y=a*Xに対称な点
LET m1=1-a*a
LET m2=2*a
LET m3=1+a*a
LET xx=(m1*x+m2*y)/m3
LET yy=(m2*x-m1*y)/m3
END SUB
EXTERNAL SUB fvSYMMETRY2(x,y,a,b, xx,yy) !直線Y=a*X+bに対称な点
LET m1=1-a*a
LET m2=2*a
LET m3=1+a*a
LET xx=(m1*x+m2*y-2*b*a)/m3
LET yy=(m2*x-m1*y+2*b)/m3
END SUB
!点(x,y)のy軸に対称な点は、(-x,y)より、直線X=aについては、(-(x-a)+a,y)=(2a-x,y)
EXTERNAL SUB fvSYMMETRYh(x,y,a, xx,yy) !直線X=aに対称な点
LET xx=2*a-x
LET yy=y
END SUB
!点(x,y)のx軸に対称な点は、(x,-y)より、直線Y=bについては、(x,-(y-b)+b)=(x,2b-y)
EXTERNAL SUB fvSYMMETRYv(x,y,b, xx,yy) !直線Y=bに対称な点
LET xx=x
LET yy=2*b-y
END SUB
!回転
EXTERNAL SUB fvROTATE90(x,y,a,b, xx,yy) !点(a,b)を基準に90度回転した点
LET xx=-(y-b)+a
LET yy= (x-a)+b
END SUB
EXTERNAL SUB fvROTATEm90(x,y,a,b, xx,yy) !点(a,b)を基準に-90度回転した点
LET xx= (y-b)+a
LET yy=-(x-a)+b
END SUB
「〇〇ソフトを作る」という目的にFull BASICは適さないと思います。JavaのようにGUIが作れてイベント駆動ができるものがアプリケーション作成には適しているのではないでしょうか。
Full BASICが適するのは問題解決のための計算です。コンピュータの能力を限界まで引き出さなければ解決できないような本格的な応用には適しませんが，計算は瞬時に終わってしまうのにプログラムを書くのに手間がかかってしまうような場合にFull BASICが勧められます。計算プログラムを作るのにプロトタイプをFull BASICで書いて，本番はPascalとかCに書き直すというのも有効な手段です。また，BASICAccを利用すれば，実用上，十分な速さが得られることが多いと思います。そんな場合は，他の言語はいりません。
Full BASICでは書けない（あるいは書きにくい）アルゴリズムが存在するのも事実です。そういうアルゴリズムの記述の必要性を知れば他の言語を始めるきっかけになると思います。
答え
パチンコ玉をA,B,Cとして、その重さをa,b,cとする。
○は同じ重さ、●は少し違う重さを表すとして、
a b c
○○●
○●○
●○○
以上の3通りである。
手法A：それまでの測定結果によって、次の回のはかり方を決める方法
LET a=1
LET b=2
LET c=2
LET w1=a
LET w2=b
PRINT "w1=";w1; "w2=";w2 !debug
IF w1=w2 THEN !cが偽
LET w3=c
PRINT "w3=";w3 !debug
LET x=w1
LET y=w3
PRINT "x=";x; "y=";y; "偽C"
ELSE
LET w3=c
PRINT "w3=";w3 !debug
IF w3=w1 THEN !bが偽
LET x=w3
LET y=w2
PRINT "x=";x; "y=";y; "偽B"
ELSEIF w3=w2 THEN !aが偽
LET x=w2
LET y=w1
PRINT "x=";x; "y=";y; "偽A"
ELSE
PRINT "論理エラー"
END IF
END IF
END
手法B：最初にすべての回のはかり方を決め、全結果から答えを出す方法
LET a=1
LET b=2
LET c=2
LET w1=a
LET w2=b
LET w3=c
PRINT "w1=";w1; "w2=";w2; "w3=";w3 !debug
IF w1=w2 THEN !cが偽
LET x=w1
LET y=w3
PRINT "x=";x; "y=";y; "偽C"
ELSEIF w3=w1 THEN !aが偽
LET x=w3
LET y=w2
PRINT "x=";x; "y=";y; "偽B"
ELSEIF w2=w3 THEN !bが偽
LET x=w2
LET y=w1
PRINT "x=";x; "y=";y; "偽A"
ELSE
PRINT "論理エラー"
END IF
LET w1=a
LET w2=b+c
PRINT "w1=";w1; "w2=";w2 !debug
IF 2*w1=w2 THEN !dが偽 ※a=b=cより
LET w3=d
PRINT "w3=";w3 !debug
LET x=w1 !a
LET y=w3 !d
PRINT "x=";x; "y=";y; "偽D"
ELSE
LET w3=b
PRINT "w3=";w3 !debug
IF w3=w1 THEN !cが偽 ※a=bより
LET x=w1 !a
LET y=w2-w3 !(b+c)-b
PRINT "x=";x; "y=";y; "偽C"
ELSEIF 2*w3=w2 THEN !aが偽 ※b=cより、w3=w2-w3 ∴2*w3=w2
LET x=w3 !b
LET y=w1 !a
PRINT "x=";x; "y=";y; "偽A"
ELSEIF w1=w2-w3 THEN !bが偽 ※a=cより、w1=w2-w3
LET x=w1 !a
LET y=w3 !b
PRINT "x=";x; "y=";y; "偽B"
ELSE
PRINT "論理エラー"
END IF
END IF
END
●パチンコ玉が5個の場合
LET a=2
LET b=2
LET c=1
LET d=2
LET e=2
LET w1=a+b
LET w2=c+d
PRINT "w1=";w1; "w2=";w2 !debug
IF w1=w2 THEN !eが偽 ※a=b=c=dより
LET w3=e
PRINT "w3=";w3 !debug
LET x=w1/2 !x=w2/2
LET y=w3
PRINT "x=";x; "y=";y; "偽E"
ELSE
LET w3=a+c+e
PRINT "w3=";w3 !debug
IF 2*w3=3*w1 THEN !e=a=c=bより、w3=a+c+e=3e、w1=a+b=2e
LET x=w1/2 !x=w3/3
LET y=w2-x
PRINT "x=";x; "y=";y; "偽D"
ELSEIF 2*w3=3*w2 THEN !e=a=c=dより、w3=a+c+e=3e、w2=c+d=2e
LET x=w2/2 !x=w3/3
LET y=w1-x
PRINT "x=";x; "y=";y; "偽B"
ELSEIF 2*(w3-w2)=w1 THEN !e=b=d=aより、w3-w2=(a+c+e)-(c+d)=a+e-d=e、w1=a+b=2e
LET x=w1/2 !x=w3-w2
LET y=w2-x !y=w3-w1
PRINT "x=";x; "y=";y; "偽C"
ELSEIF 2*(w3-w1)=w2 THEN !e=b=d=cより、w3-w1=(a+c+e)-(a+b)=c+e-b=e、w2=c+d=2e
LET x=w2/2 !x=w3-w1
LET y=w1-x !y=w3-w2
PRINT "x=";x; "y=";y; "偽A"
ELSE
PRINT "論理エラー"
END IF
END IF
END
●パチンコ玉が6個の場合
LET a=2
LET b=2
LET c=2
LET d=2
LET e=3
LET f=2
LET w1=a+b+c+d
LET w2=a+b +e
PRINT "w1=";w1; "w2=";w2 !debug
IF 3*w1=4*w2 THEN !eが偽 ※a=b=c=d=eより
LET w3=f
PRINT "w3=";w3 !debug
LET x=w1/4 !x=w2/3
LET y=w3
PRINT "x=";x; "y=";y; "偽F"
ELSE
LET w3=a+c
PRINT "w3=";w3 !debug
LET p=w1-w2 !w1-w2=(a+b+c+d)-(a+b+e)=c+d-e
LET q=w2-w3 !w2-w3=(a+b+e)-(a+c)=b+e-c
LET r=w1-w3 !w1-w3=(a+b+c+d)-(a+c)=b+d
PRINT "p=";p; "q=";q; "r=";r !debug
IF p=q THEN !f=b=c=d=eより、p=c+d-e=f+f-f=f、q=b+e-c=f+f-f=f
LET x=p
LET y=w3-x
PRINT "x=";x; "y=";y; "偽A"
ELSEIF 2*p=w3 THEN !f=a=c=d=eより、p=c+d-e=f+f-f=f、w3=a+c=f+f=2f
LET x=p
LET y=r-x
PRINT "x=";x; "y=";y; "偽B"
ELSEIF 3*r=2*w2 THEN !f=a=b=d=eより、r=b+d=f+f=2f、w2=a+b+e=f+f+f=3f
LET x=r/2
LET y=w3-x
PRINT "x=";x; "y=";y; "偽C"
ELSEIF 2*w2=3*w3 THEN !f=a=b=c=eより、w2=a+b+e=f+f+f=3f、w3=a+c=f+f=2f
LET x=w3/2
LET y=r-x
PRINT "x=";x; "y=";y; "偽D"
ELSEIF 2*w1=4*w3 THEN !f=a=b=c=dより、w1=a+b+c+d=f+f+f+f=4f、w3=a+c=f+f=2f
LET x=w1/4
LET y=w2-2*x
PRINT "x=";x; "y=";y; "偽E"
ELSE
PRINT "論理エラー"
END IF
END IF
!1回目 差は1
LET P=1 !取る枚数
LET A=1 !持っている枚数
PRINT "1回: Aが取る枚数=";P; " 持っている枚数=";A
!2回目 差は2
LET Q=3
LET B=3
PRINT "2回: Bが取る枚数=";Q; " 持っている枚数=";B
!3回目以降
LET K=2 !回数
DO
LET K=K+1
IF MOD(K,2)=1 THEN !奇数回はAの番
LET P=P+4
LET A=A+P
PRINT STR$(K);"回: Aが取る枚数=";P; " 持っている枚数=";A
ELSE !Bの番
LET Q=Q+4
LET B=B+Q
PRINT STR$(K);"回: Bが取る枚数=";Q; " 持っている枚数=";B
END IF
LOOP UNTIL ABS(A-B)=31 !条件を満たすまで
PRINT K;"回"
PRINT "A=";P; "枚数="; A
PRINT "B=";Q; "枚数="; B
PRINT
!その２ シミュレーション
LET A=0 !1つ前の結果
LET B=0
LET K=0 !回数
DO
LET K=K+1
LET T=2*K-1 !取る枚数
IF MOD(K,2)=1 THEN !奇数回はAの番
LET A=T-B
PRINT STR$(K);"回: Aが取る枚数=";T; " 差=";A
ELSE !Bの番
LET B=T-A
PRINT STR$(K);"回: Bが取る枚数=";T; " 差=";B
END IF
LOOP UNTIL A=31 OR B=31 !条件を満たすまで
PRINT K;"回"
IF MOD(K,2)=1 THEN !奇数回はAの番
PRINT "A=";2*K-1; "枚数="; K*(K+1)/2
PRINT "B=";2*K-3; "枚数="; (K-1)*K/2
ELSE !Bの番
PRINT "A=";2*K-3; "枚数="; (K-1)*K/2
PRINT "B=";2*K-1; "枚数="; K*(K+1)/2
END IF
EXTERNAL SUB fvPOINT(x,y,S$) !点(x,y)
DRAW disk WITH SCALE(0.5)*SHIFT(x,y) !※大きさは調整が必要である
PLOT TEXT ,AT x+0.5,y+0.5: S$ !※位置は調整が必要である
END SUB
EXTERNAL SUB fvLINE(A,B, P,Q) !直線y=Ax+B, x∈[P,Q]
PLOT LINES: P,A*P+B; Q,A*Q+B
END SUB
!●計算ルーチン
EXTERNAL SUB fvINTERSECTION(A,B,C,D, x,y) !2直線y=Ax+Bとy=Cx+Dとの交点(x,y)を求める
IF A=C THEN
PRINT "2直線は平行です。"; A;C
ELSE
LET x=(D-B)/(A-C)
LET y=A*x+B
END IF
END SUB
EXTERNAL SUB cycle(m,n,k,L) !既約分数m/n（0＜m＜nを満たす整数）の有限小数の桁数kと循環節の長さLを求める
!n/m=0.ab…z{AB…Z} 有限小数0.ab…zはk桁 (k+1)桁からの循環節AB…Zの長さはL
LET x=n
LET p=0 !2^p
DO WHILE MOD(x,2)=0
LET x=x/2
LET p=p+1
LOOP
LET q=0 !5^q
DO WHILE MOD(x,5)=0
LET x=x/5
LET q=q+1
LOOP
LET k=MAX(p,q) !小数点以下k桁は循環しない
IF x=1 THEN !有限小数
LET L=0
ELSE !10^L≡1 MOD n/(2^p*5^q)を満たす最小のLより
LET L=1 !循環節の長さ
LET a=MOD(10,x)
DO WHILE a<>1
LET a=MOD(a*10,x)
LET L=L+1
LOOP
END IF
END SUB
EXTERNAL FUNCTION Num2CombBit(h,N,R) !番号から組合せビットパターンを生成する ※辞書式順序
LET v=h+1
LET j=R
LET A=0
FOR i=N-1 TO 0 STEP -1 !組合せをビット位置とする
LET t=COMB(i,j)
IF v>t THEN
LET A=A+2^i !ビット位置(N-i-1)を１とする
LET j=j-1
LET v=v-t
END IF
NEXT i
LET Num2CombBit=A
END FUNCTION
OPTION ARITHMETIC RATIONAL !有理数モード
DIM F(100),A(100),B(100)
MAT F=ZER
LET A(100)=1/100 !iの値、i以降の和
LET B(100)=A(100)
FOR i=99 TO 1 STEP -1
LET A(i)=1/i !減少列 1/1＞1/2＞1/3＞ … ＞1/100
LET B(i)=A(i)+B(i+1)
NEXT i
LET N=1
CALL try(N,1,A,B,F)
END
EXTERNAL SUB try(N,p,A(),B(),F()) !バックトラック法で検索する
OPTION ARITHMETIC RATIONAL !有理数モード
FOR i=p TO 100 !※cの上限
LET T=N-A(i) !残り
IF T>0 THEN
IF i<100 AND B(i+1)<T THEN EXIT FOR !全部を使って可能性があれば、その部分集合を考える
LET F(i)=1 !使用中とする
CALL try(T,i+1,A,B,F) !有理数tを(i+1)以降で表す
LET F(i)=0 !元に戻す
ELSEIF T=0 THEN !題意を満たすなら
LET k=0
FOR j=1 TO p-1 !式を表示する
IF F(j)=1 THEN
PRINT "1/";STR$(j);"+";
LET k=k+1
END IF
NEXT j
PRINT "1/";STR$(i);" 項数=";k+1
END IF
NEXT i
END SUB
DIM F(0 TO 9) !1から9までの数
FOR N=2 TO 20
PRINT "N=";N
FOR M=1234 TO 9876 !4桁の数
MAT F=ZER
LET F(0)=1 !使用中とする
LET t=M
FOR i=1 TO 4 !10進法4桁
LET w=MOD(t,10)
IF F(w)=1 THEN EXIT FOR !既に使用済み
LET F(w)=1 !使用中とする
LET t=INT(t/10)
NEXT i
IF i>4 THEN !各桁が異なる4桁の数なら
!!!PRINT M !debug
LET t=M*N
IF t>=12345 AND t<=98765 THEN !5桁の数なら
FOR i=1 TO 5
LET w=MOD(t,10)
IF F(w)=1 THEN EXIT FOR
LET F(w)=1
LET t=INT(t/10)
NEXT i
IF i>5 THEN !各桁が異なる5桁の数なら
SUB DEC1_NS
DO
IF BC< BST THEN CALL DEC1_IN
LET W=IP(Hx) ! bits width BST
!----
LET W=A(NA+W,J)
IF 32768<=W THEN EXIT DO
LET NA=W ! nest adr. W=0 table end
LET BC=BC-BST
LET Hx=MOD(Hx*SHb,SHb)
LOOP
LET NA=0 ! DU0L LLLL VVVV VVVV
LET L_=MOD(IP(W/256),128) ! U0L LLLL
LET V_=MOD(W,256) ! VVVV VVVV
IF 16< L_ THEN PRINT "unused code" !BREAK !unused code ! LET V_=BVAL("8000",16)
!----
LET W=MOD(L_,BST)
IF 0< W THEN
LET BC=BC-W
LET Hx=MOD(Hx*2^W,SHb)
ELSE
LET BC=BC-BST
LET Hx=MOD(Hx*SHb,SHb)
END IF
END SUB
SUB DEC1_IN
CALL RED_D
LET W=ORD(D$)
IF W=255 THEN
CALL RED_D
LET M=ORD(D$)
IF M<>0 THEN LET w=1/0 ! EXTYPE=3001, ffxx marker, abnormally break
END IF
LET Hx=Hx+W*2^(BST-8-BC)
LET BC=BC+8
END SUB
!-------
SUB DEC1_EX
LET V_=0
DO
IF L_< 1 THEN EXIT SUB
IF BC< L_ THEN CALL DEC1_IN
LET W=IP(Hx)
!----
IF BST>=L_ THEN EXIT DO
LET V_=V_*SHb+W
LET L_=L_-BST
LET BC=BC-BST
LET Hx=MOD(Hx*SHb,SHb)
LOOP
LET V_=V_*2^L_+IP(W*2^(L_-BST))
!----
LET BC=BC-L_
LET Hx=MOD(Hx*2^L_,SHb)
END SUB
!============
! B(,J)L(,J)<-- DH(,J) for decorder table A(,J)
!
SUB makeH0(J)
LET i=0 ! コード生成 順番(短い順)
LET Hx=0
LET Tx=BVAL("8000",16)
FOR L_=1 TO 16
FOR P=1 TO DH(L_,J)
LET L(i,J)=L_
LET B(i,J)=Hx ! コード(生成順), 座標DV(頻度降順) と同順。
LET i=i+1
LET Hx=Hx+Tx
NEXT P
LET Tx=Tx/2
NEXT L_
LET B(256,J)=0
FOR i=i TO 255
LET L(i,J)=0
LET B(i,J)=0
NEXT i
END SUB
!============
!A(,J)=output decorder table<-- B(,J) L(,J) DH(,J) DV(,J)
!
SUB makeD0(J)
FOR LH=16 TO 1 STEP -1
IF DH(LH,J)<>0 THEN EXIT FOR
NEXT LH !length max. in huffman table
LET LM=CEIL(LH/BST)*BST !length max. bound by BST
!---
LET I=0 !start huffman table adr.
LET LA=0 !line adr.
LET P=BST !start Decord code width
LET U_=2^(16-BST) !start Decord code step
LET NC=0 !next start Decord code
DO
LET D_=NC !start Decord code
LET NC=-1
LET LB=LA+(65536-D_)/U_ !1st nest adr.
DO
CALL SERCH
IF 0< L_ THEN
LET A(LA,J)= BVAL("8000",16)+L_*256+DV(I,J) !b15=end. +L.+V.
ELSEIF P=LM THEN
LET A(LA,J)= BVAL("C000",16)+LH*256 !b15=end. b14=Unused. +L.
ELSE
IF NC=-1 THEN LET NC=D_
LET A(LA,J)=LB !nest adr.
LET LB=LB+SHb !next nest adr.
END IF
LET D_=D_+U_
LET LA=LA+1
LOOP UNTIL IP(D_)=65536
LET P=P+BST
LET U_=U_/SHb !shr(U_,BST)
LOOP UNTIL P>LM
!---
FOR LA=LA TO 255
LET A(LA,J)=0 !(0),table stop mark
NEXT LA
END SUB
SUB SERCH
FOR I=I TO DH(0,J)-1
LET L_=L(I,J)
IF L_<=P THEN LET w=IP(D_/2^(16-L_))*2^(16-L_) ELSE EXIT FOR
IF w<=B(I,J) THEN
IF w=B(I,J) THEN EXIT SUB ELSE EXIT FOR
END IF
NEXT I
LET L_=-1
END SUB
!===========
! Inverse Fast Cosin Transform.( 8x8, iDCT-2 ) ← Inverse Quantization.DQ()
SUB IDDCT8X8
FOR P=0 TO CMO !(0=Y,1=Cb,2=Cr)
FOR V0=0 TO DV_-1 STEP 8*MV(0)/MV(P)
FOR U0=0 TO DU-1 STEP 8*MH(0)/MH(P)
!----decord one of MCU( Minimum Coded Unit)
FOR Y_=0 TO 7
FOR X_=0 TO 7
LET x(X_)=D2(U0+X_,V0+Y_,P)*DQ(X_,Y_,QS(P)) !Inverse Quantization
NEXT X_
CALL IWANG !inverse DCT horizontal_row_8
FOR X_=0 TO 7
LET T(X_,Y_)=x(X_)
NEXT X_
NEXT Y_
!---
FOR X_=0 TO 7
FOR Y_=0 TO 7
LET x(Y_)=T(X_,Y_)
NEXT Y_
CALL IWANG !inverse DCT vertical_column_8
LET i=X_*MH(0) !expand pt.X
FOR Y_=0 TO 7
IF P=0 THEN
LET D1(U0+X_,V0+Y_,P)=x(Y_)+128 !inverse level shift
ELSE
LET j=Y_*MV(0) !expand pt.Y
!----expand
FOR V_=j TO j+MV(0)-1
FOR U_=i TO i+MH(0)-1
LET D1(U0+U_,V0+V_,P)=x(Y_) !CbCr to MCU scale
NEXT U_
NEXT V_
!----expand
END IF
NEXT Y_
NEXT X_
!----
NEXT U0
NEXT V0
NEXT P
END SUB
!----inverse Wang.( 8, iDCT-2 )
SUB IWANG
LET xo(0)=SQR(2/8)*x(0)
LET xo(1)=SQR(2/8)*x(4)
LET xo(2)=SQR(2/8)*x(2)
LET xo(3)=SQR(2/8)*x(6)
LET xo(4)=SQR(1/8)*x(1)
LET xo(5)=SQR(1/8)*x(5)
LET xo(6)=SQR(1/8)*x(3)
LET xo(7)=SQR(1/8)*x(7)
!
LET x(4)=(COS(PI /16)*xo(4)+SIN(PI /16)*xo(7))
LET x(5)=(COS(PI*5/16)*xo(5)+SIN(PI*5/16)*xo(6))
LET x(6)=(SIN(PI*5/16)*xo(5)-COS(PI*5/16)*xo(6))
LET x(7)=(SIN(PI /16)*xo(4)-COS(PI /16)*xo(7))
!
LET xo(4)= x(4)+x(5)
LET xo(5)= x(4)-x(5)
LET xo(6)=-x(6)+x(7)
LET xo(7)= x(6)+x(7)
!
LET x(0)=(COS(PI/4)*xo(0)+COS(PI /4)*xo(1))
LET x(1)=(COS(PI/4)*xo(0)-COS(PI /4)*xo(1))
LET x(2)=(SIN(PI/8)*xo(2)-SIN(PI*3/8)*xo(3))
LET x(3)=(COS(PI/8)*xo(2)+COS(PI*3/8)*xo(3))
LET x(4)=xo(4)
LET x(5)=xo(6)
LET x(6)=xo(5)
LET x(7)=xo(7)
!
LET xo(0)=x(0)+x(3)
LET xo(1)=x(1)+x(2)
LET xo(2)=x(1)-x(2)
LET xo(3)=x(0)-x(3)
LET xo(4)=x(7)*SQR(2)
LET xo(5)=x(6)-x(5)
LET xo(6)=x(6)+x(5)
LET xo(7)=x(4)*SQR(2)
!
LET x(0)=xo(0)+xo(7)
LET x(1)=xo(1)+xo(6)
LET x(2)=xo(2)+xo(5)
LET x(3)=xo(3)+xo(4)
LET x(4)=xo(3)-xo(4)
LET x(5)=xo(2)-xo(5)
LET x(6)=xo(1)-xo(6)
LET x(7)=xo(0)-xo(7)
END SUB
!=============
SUB R_BIN31(M) ! decord(M) before new.search(M)
DO
IF M=BVAL("D8",16) THEN ! SOI
MAT DH=ZER ! clear Huffman Table
LET DRI=0 ! clear Restart Interval.value for RST0~7(restart marker)
LET rct=-1 ! Interval.counter, valid (0<=rct), invalid (rct< 0)
MAT M3=ZER ! clear scan band sum
ELSEIF M=BVAL("D9",16) THEN ! EOI
EXIT DO ! close & end_sub
ELSEIF BVAL("D0",16)<=M AND M<=BVAL("D7",16) THEN ! RST0~7( restart marker)
LET rct=DRI ! set counter with Restart Interval
EXIT SUB
ELSEIF 0< M THEN !M=0 is data"FF" in picture area
CALL RED_D
LET N=ORD(D$)*256
CALL RED_D
LET N=N+ORD(D$)-2 ! N=remain size
!---
IF BVAL("E0",16)<=M AND M<=BVAL("EF",16) THEN ! APP0~APP15
CALL FFE0
ELSEIF M=BVAL("DD",16) THEN
CALL FFDD ! DRI load DRI & rct=DRI
ELSEIF M=BVAL("FE",16) THEN
CALL FFFE ! COMMENT
ELSEIF M=BVAL("C4",16) THEN
CALL FFC4 ! DHT
ELSEIF M=BVAL("DB",16) THEN
CALL FFDB ! DQT
ELSEIF M=BVAL("C0",16) OR M=BVAL("C2",16) THEN
PRINT right$("000"& BSTR$(byt-4,16),4)
!---
CALL FFC0 ! SOF0 SOF2
!---
PRINT " SOF";STR$(MOD(M,16));" MCU_HV Ybr ";STR$(MH(0));STR$(MV(0));
PRINT " ";STR$(MH(1));STR$(MV(1));" ";STR$(MH(2));STR$(MV(2))
ELSEIF M=BVAL("DA",16) THEN
CALL FFDA ! SOS
EXIT SUB ! without close
ELSE
BREAK ! new marker
END IF
END IF
!---
DO
LET M=BVAL("D9",16) ! EOI, 256 ! end of file
CHARACTER INPUT #1,IF MISSING THEN EXIT DO :D$
LET byt=byt+1 !!!
LET M=ORD(D$)
LOOP UNTIL M=255 ! 1st.mark
IF M<>255 THEN EXIT DO ! close & end_sub
CALL RED_D
LET M=ORD(D$)
LOOP
CLOSE #1
END SUB
!DRI
SUB FFDD
CALL RED_D
LET DRI=ORD(D$)*256
CALL RED_D
LET DRI=DRI+ORD(D$)
LET rct=DRI
END SUB
!APP0
SUB FFE0
FOR W=1 TO N
CALL RED_D
NEXT W
END SUB
!COMMENT
SUB FFFE
FOR W=1 TO N
CALL RED_D
NEXT W
END SUB
!DQT
SUB FFDB
DO WHILE 0< N
CALL RED_D
LET w= IP(ORD(D$)/16) !p=0(byte) p=1(word)
LET J=MOD(ORD(D$),16) !J=0~3 (QT.number)
FOR i=0 TO 63
CALL RED_D
LET DQ(U(i),V(i),J)=ORD(D$)
IF w=1 THEN
CALL RED_D
LET DQ(U(i),V(i),J)=DQ(U(i),V(i),J)*256+ORD(D$)
END IF
NEXT i
LET N=N-65-64*w ! remain size
LOOP
END SUB
!SOF0 SOF2
SUB FFC0
CALL RED_D
IF ORD(D$)<>8 THEN BREAK ! 8bit( 24bitColor ) at RGB.dimension
CALL RED_D
LET W=ORD(D$)*256
CALL RED_D
LET DY=W+ORD(D$) !V.pix.
CALL RED_D
LET W=ORD(D$)*256
CALL RED_D
LET DX=W+ORD(D$) !H.pix.
CALL RED_D
FOR i=0 TO ORD(D$)-1 !1~3 フレーム数、続くID 配置は、暗黙に Y,Cb,Cr の順
CALL RED_D
LET CoID(ORD(D$))=i ! CoID( ID=0~255) <--(Y=0, Cb=1, Cr=2)
CALL RED_D
LET MH(i)= IP(ORD(D$)/16) ! HV Y=11,12,21,22,41 Cb=11,11,11,11,11 Cr=11,11,11,11,11
LET MV(i)=MOD(ORD(D$),16)
CALL RED_D
LET QS(i)=ORD(D$) ! QT.number0~3 <-- QS( Y=0, Cb=1, Cr=2)
NEXT i
IF i=1 THEN LET CMO=0 ELSE LET CMO=2
END SUB
!DHT
SUB FFC4
DO WHILE 0< N
CALL RED_D
LET J=ORD(D$) ! (DC=0 AC=1 | ID0_0~3)
LET J=2*MOD(J,16)+IP(J/16) ! 0~1=ID0.DC~AC 2~3=ID1.DC~AC 4~5=ID2.…
LET DH(0,J)=0 !!!for 2nd.use for clear
FOR i=1 TO 16
CALL RED_D
LET DH(i,J)=ORD(D$)
LET DH(0,J)=DH(0,J)+DH(i,J)
NEXT i
FOR i=0 TO DH(0,J)-1
CALL RED_D
LET DV(i,J)=ORD(D$)
NEXT i
!---
FOR i=i TO 255
LET DV(i,J)=0
NEXT i
CALL makeH0(J) ! make Huffman Code table B() L()
CALL makeD0(J) ! make Huffman Decorder table A()
!---
LET N=N-1-16-DH(0,J) ! remain size
LOOP
END SUB
!SOS
SUB FFDA
CALL RED_D
LET M2=ORD(D$)
MAT HDC=(-2)*CON
MAT HAC=(-2)*CON
FOR i=1 TO M2
CALL RED_D ! ID=0~255( defined by SOFx)
LET w=ORD(D$)
CALL RED_D ! (DC_0~3|AC_0~3) huffman table selection
LET HDC(CoID(w))= IP(ORD(D$)/16)*2 !DC 0~3-->0,2,4,6
LET HAC(CoID(w))=MOD(ORD(D$),16)*2+1 !AC 0~3-->1,3,5,7
NEXT i
CALL RED_D
LET Ss_=ORD(D$) ! low of spectral selection
CALL RED_D
LET Se_=ORD(D$) ! high of spectral selection
CALL RED_D
LET Al=MOD(ORD(D$),16) !successive approximation bit position low ( point transform )
LET Ah=IP(ORD(D$)/16) !successive approximation bit position high ( preceding "Al" )
!--- balance monitor M30 M3() for display timing.
LET w=Se_-Ss_+1
IF Ah<>Al THEN LET w=w*(Ah-Al) ! prog.sa
FOR i=0 TO 2
IF 0<=HAC(i) THEN LET M3(i)=M3(i)+w ! M3()= scan band sum
NEXT i
IF CMO=0 OR M3(0)=M3(1) AND M3(1)=M3(2) THEN LET M30=M3(0) ELSE LET M30=99 ! Ybr.balance
!--- next image data top
END SUB
!************************************************************
!訂正版：十進 BASIC による プログレッシブ JPG の展開と画像化。
!
!プログレッシブ JPG 再生過程の画像は、最初のＤＣ成分１枚だけ と、最終完成画、全２枚とした。
!Baseline JPG は、全１枚なので、画数で両者を区別できる。（ 描画倍率は、１又は、２倍拡大）
!（必要なら、再生過程 全ての画像も、表示できるよう、SUB IZZRL0 に注釈行がある）
!
!大きな再生画像でも、縮尺を止め、１倍又は、極小な場合の２倍拡大のみにした。
!色差成分 Cb Cr の間引き走査復元の塗潰しは、SUB IDDCT8X8 に組み込み。
!
!具体的、可視的なプログラムで、実行し画像化するので、詳細事項の追跡と御参考に。
!再生できるファイルは、1000x1000 までの JPG だけで、
! baseline , spectral selection , successive approximation の３種類( web 上の、ほぼ全種)
!
!
!１）successive approximation AC.subsequence（Y,Cb,Cr 別々、１bit づつの処理）
! 0 でない追加データ extend (1bit) が 1st.scan も 0 の初めてのデーターになるまで、
! Zero-RUN を続ける。
! その間の、上位桁<>0 の 1st.scan 値 追加データーは、その個数分が、
! extend. に後続している。Zero-RUN 個数 の 0 の次の 0 の位置に、extend.を置く。
! ここでの extend. は group 1 だけで、(0,1) → (-1,+1)
!
! 0 1 1 0 0 0 0 0 0 ？
! 0 0 0 0 0 1 0 0 0 ？
! 0 1 0 0 0 0 0 1 0 ？
! 0 1 1 0 0 1 0 1 0 ？
! 0 1 1 0 0 1 0 1 0 ？
! --------------------------------------------------------------------------
! ±1 b1 b2 0 0 b3 0 b4 ±1 ？
! 前の終り RRRR RRRR RRRR extend. 次の始め
!
! huffman.
! RRRRssss extend. b1 b2 b3 b4 … bit_stream=？何個になるかは、
! 3 1 (0 or 1) (0 or 1) 上位桁 =0 の係数が RRRR 個 になるまでに
! ↓ ↓ 通過した上位桁 <>0 の個数。上図では、４
!
! 新規(上位桁無) エンコーダー側ＡＣ処理 point transform は、
! の復号 0 → -1 "divide by 2^AL" なので
! 1 → +1 0 → 無変化。
! 1 → ±符号は上位桁に合せて加算。(絶対値が＋1)
!
!
!２）successive approximation DC.subsequence（Y,Cb,Cr 別々、１bit づつの処理）
! ハフマン・コード RRRRssss 部は、存在せず、
! 頭からの bit_stream.で、１bit づつ、全てのblock の DC係数 に加える。
!
! エンコーダー側ＤＣ処理 point transform は、
! "arithmetic-shift-right AL" なので
! 0 → 無変化。
! 1 → 上位桁符号に関らず、＋加算。(符号無し整数値が＋1)
!
!
! ※AL･･･ 係数などの数値が、2^AL のステップ幅で 量子化された値 になっている意。
! ※AH･･･ preceding AL. 同じ BAND で直前の AL 値 (AH=0 は、最初の AL に添える)
!
! (Ah|Al)
! ←──┐ 0 0 全bits のデータ。復元は、(･･･111111.)*2^( point transform =0)
! ･･･111111
!
! 以下３つを加算すると、上と同じになる。
! (Ah|Al)
! ←─┐ 0 2 上位bits のデータ。 復元は、(･･･1111 )*2^( point transform =2)
! ･･･1111xx
! 〟 2 1 1bitづつ、分けて追加。復元は、( 1 )*2^( point transform =1)
! ･･･xxxx1x
! 〟 1 0 復元は、( 1)*2^( point transform =0)
! ･･･xxxxx1
!
!------------------------
DEBUG ON
!------------------------
!JPG.decoder
! Baseline
! Progressive( spectral selection )( successive approximation )
!------------------------
OPTION ARITHMETIC NATIVE
OPTION BASE 0
OPTION CHARACTER byte
SET TEXT background "OPAQUE"
SET ECHO "OFF"
SET COLOR MODE "NATIVE"
!
DIM D8(1000,1000) !MAIN65
DIM D2(1000,1000,2) !Y=D2(,,0) Cb=D2(,,1) Cr=D2(,,2)
DIM D1(1000,1000,2) !Y=D2(,,0) Cb=D2(,,1) Cr=D2(,,2)
DIM MH(2),MV(2) !R_BIN31 SOF0 MCU.Ybr.H()V()
DIM HDC(2),HAC(2) !R_BIN31 hT.table selection
DIM QS(2),CoID(255) !R_BIN31 qT.table selection
DIM M3(2)
!
DIM U(63),V(63) !zigzag
DIM DQ(7,7,3) !blk8x8 DQT
DIM DH(16,7),DV(255,7) !DHT
DIM B(255+1,7),L(255,7) !encorder & decorder's pre_table, length, ( MAKE_H2,MAKE_H0)
DIM A(2000,7) !decorder
DIM B2(2) !Ybr D.C.成分 starting & back_level for difference
DIM T(7,7),x(7),xo(7) !DDCT8X8, IDDCT8X8
!
LET BST=2 !huffman decorder's bit step 1=8.5s 2=6.5s 4=8.0s 8=50.0s
LET SHb=2^BST !huffman decorder n*SHb=(shl n,BST) n/SHb=(shr n,BST)
!
!---zigzag table
FOR V_=0 TO 7
FOR U_=0 TO 7
READ i
LET U(i)=U_
LET V(i)=V_
NEXT U_
NEXT V_
DATA 0, 1, 5, 6,14,15,27,28
DATA 2, 4, 7,13,16,26,29,42
DATA 3, 8,12,17,25,30,41,43
DATA 9,11,18,24,31,40,44,53
DATA 10,19,23,32,39,45,52,54
DATA 20,22,33,38,46,51,55,60
DATA 21,34,37,47,50,56,59,61
DATA 35,36,48,49,57,58,62,63
!
DO
FILE GETNAME FL$, "jpg"
IF FL$="" THEN
PRINT "入力ファイル名無し"
EXIT DO
END IF
PRINT "入力ファイル："& FL$
!---
CLEAR
CALL IZZRL0 ! D2()<-- decord JPG
PRINT "次のファイル[ 左クリック ]"
beep
DO
MOUSE POLL j,i,mlb,mrb !CHARACTER INPUT CLEAR: w$
WAIT DELAY 0
LOOP UNTIL 0< mlb OR 0< mrb
LOOP UNTIL 0< mrb
PRINT "終了。"
!-------- IZZRL0 call here for display D2()
SUB MAIN65
LET tester=TIME
PRINT "画像の準備中、";
CALL IDDCT8X8 ! D1()<-- iDCT<-- iDQT<-- D2()
!------ JPG 色空間 ----------------------------
! | Y | | 0.2990 +0.5870 +0.1140 | | R |
! |B-Y| = |-0.1687 -0.3313 +0.5000 | | G |
! |R-Y| | 0.5000 -0.4187 -0.0813 | | B |
!
! | R | | 1 0 +1.40200 | | Y |
! | G | = | 1 -0.34414 -0.71414 | |B-Y|
! | B | | 1 +1.77200 0 | |R-Y|
!----------------------------------------------
FOR V0=0 TO DY-1
FOR U0=0 TO DX-1
!--- RGB<-- Ybr
LET w1=IP(D1(U0,V0,0) +1.40200*D1(U0,V0,2)) !R
LET w2=IP(D1(U0,V0,0) -0.34414*D1(U0,V0,1) -0.71414*D1(U0,V0,2)) !G
LET w3=IP(D1(U0,V0,0) +1.77200*D1(U0,V0,1)) !B
IF w1< 0 THEN
LET w1=0
ELSEIF 255< w1 THEN
LET w1=255
END IF
IF w2< 0 THEN
LET w2=0
ELSEIF 255< w2 THEN
LET w2=255
END IF
IF w3< 0 THEN
LET w3=0
ELSEIF 255< w3 THEN
LET w3=255
END IF
LET D8(U0,V0)=w3*65536+w2*256+w1 !（逆）BGR
NEXT U0
NEXT V0
PRINT TRUNCATE(TIME-tester,2);"秒"
!!! LET w=1 !等倍で描画、画素数どうり。
LET w=IP( MIN( 500/DX, 500/DY)) !整数倍拡大、１～２の何れかで描画。
IF 2< w THEN LET w=2
IF w< 1 THEN LET w=1
PRINT "描画の倍率=";w
CALL scrns(DX*w, DY*w)
MAT PLOT CELLS,IN 1,1; DX*w, DY*w :D8
END SUB
SUB scrns(px,py)
SET bitmap SIZE px+50,py+50
SET WINDOW 1-20,px+30, py+27,1-23
SET LINE COLOR "cyan"
SET LINE width 3
PLOT LINES:1-3,1-3;px+3,1-3;px+3,py+3;1-3,py+3;1-3,1-3
PLOT TEXT,AT -3,-4: "原画 "& STR$(px/w)& "x"& STR$(py/w)& " 倍率= "& STR$(w)
END SUB
!========================
!inverse haffman Transform.
SUB IZZRL0
LET byt=0 !!!
CALL ROPEN ! FL$
!---
CALL R_BIN31(0) !A() B(i,J)L(i,J)<-- DH(), return at img.top
PRINT right$("000"& BSTR$(byt,16),4) !!!
PRINT "(";STR$(DX);"x";STR$(DY);
!---
MAT D8=ZER(DX-1,DY-1) !MAIN65
LET i=8*MH(0) !MCU Y.Hsize
LET j=8*MV(0) !MCU Y.Vsize
LET DUM=CEIL(DX/i)*i !Uwidth=bound by MCU Y.Hsize
LET DVM=CEIL(DY/j)*j !Vwidth=bound by MCU Y.Vsize
MAT D1=ZER(DUM-1,DVM-1,2) !Y=D1(,,0) Cb=D1(,,1) Cr=D1(,,2)
MAT D2=ZER(DUM-1,DVM-1,2) !Y=D2(,,0) Cb=D2(,,1) Cr=D2(,,2)
LET MH_=MH(0)
LET MV_=MV(0)
LET DU =DUM !Uwidth=bound by MCU Y.Hsize
LET DV_=DVM !Vwidth=bound by MCU Y.Vsize
LET DU8=CEIL(DX/8)*8 !Uwidth=bound by block Y.Hsize
LET DV8=CEIL(DY/8)*8 !Vwidth=bound by block Y.Vsize
!---
PRINT "/ ";STR$(DU8);",";STR$(DV8);"/ ";STR$(DUM);",";STR$(DVM);")"
CALL frame
!---
PRINT "M3()=";M3(0);M3(1);M3(2)
CALL MAIN65 ! Baseline.最終、Progressive.1st.
!---
IF 0< M THEN PRINT " (";STR$(DX);"x";STR$(DY);"/";STR$(U0);",";STR$(V0);") ";debug$;" abort by ";BSTR$(M,16) !!!
PRINT right$("000"& BSTR$(byt-2*SGN(M),16),4) !!!
CALL R_BIN31(M) ! return at img.top, or EOI
!---
DO WHILE M=BVAL("DA",16) !SOS
IF 0<=HAC(0) THEN
LET MV(0)=1
LET MH(0)=1
LET DU=DU8
LET DV_=DV8
END IF
CALL frame
LET MV(0)=MV_
LET MH(0)=MH_
LET DU=DUM
LET DV_=DVM
!---
PRINT "M3()=";M3(0);M3(1);M3(2) !文末参照：M30<>99(balance), M30=99(un-balance)
IF M30=0 OR M30=64 THEN CALL MAIN65 !Progressive.最終スキャン後の画像
!IF M30<>99 THEN CALL MAIN65 !Progressive.各スキャン毎、Ybr 揃った画像のみ
!CALL MAIN65 !Progressive.各スキャン毎、全画像
!---
IF 0< M THEN PRINT " (";STR$(DX);"x";STR$(DY);"/";STR$(U0);",";STR$(V0);") ";debug$;" abort by ";BSTR$(M,16) !!!
PRINT right$("000"& BSTR$(byt-2*SGN(M),16),4)
CALL R_BIN31(M) ! return at img.top
LOOP
CLOSE #1 ! FL$
END SUB
SUB reset0
LET B2(0)=0 !ROUND( YDC0/DQ(0,0,QS(0)) ) !prediction YDC.( 1st.reference level)
LET B2(1)=0 !prediction CbDC.
LET B2(2)=0 !prediction CrDC.
LET Hx=0 !bits stream input buffer 0~(7+8)bits, use fraction
LET BC=0 !stored bits in Hx
LET NA=0 !nest adr. in A()
LET EOB=0 !counter( end_of_band)
LET M=0
LET ext=0
END SUB
SUB frame
PRINT " Ss Se AhAl: ";Ss_;Se_;STR$(Ah);STR$(Al)
PRINT " Y HDC HAC: ";IP(HDC(0)/2);IP(HAC(0)/2)
PRINT " Cb : ";IP(HDC(1)/2);IP(HAC(1)/2)
PRINT " Cr : ";IP(HDC(2)/2);IP(HAC(2)/2)
CALL reset0
!---
FOR V09=0 TO DV_-1 STEP 8*MV(0)
FOR U09=0 TO DU-1 STEP 8*MH(0)
IF rct=0 THEN
CALL R_BIN31(0) ! read marker
IF rct<>DRI THEN BREAK ! not RST0~7
CALL reset0 ! Restart
END IF
CALL MCUxx11 ! read picture data
LET rct=rct-1
!---
IF 0< ext THEN
IF ext=103001 THEN
PRINT "abort marker ";BSTR$(M,16)
IF BVAL("D0",16)<=M AND M<=BVAL("D7",16) THEN ! RST0~7( restart marker)
LET rct=DRI ! set counter
CALL reset0 ! Restart
ELSE
EXIT SUB ! others marker
END IF
ELSE
PRINT "file error. display fragment"
LET M=BVAL("D9",16) ! EOI
EXIT SUB
END IF
END IF
NEXT U09
NEXT V09
IF 0< EOB THEN PRINT "EOBn over frame";EOB !!!
END SUB
SUB MCUxx11
!---read MCU
FOR P=0 TO CMO
IF 0<=HDC(P) OR 0<=HAC(P) THEN
FOR V0=V09 TO V09+8*MV(P)-1 STEP 8
FOR U0=U09 TO U09+8*MH(P)-1 STEP 8
WHEN EXCEPTION IN
IF EOB=0 THEN CALL R_BLK0 ELSE LET EOB=EOB-1
USE
LET ext=EXTYPE
EXIT SUB
END WHEN
!---extend bitmap
IF 0< Ah AND 0< Se_ THEN
FOR i=A_ TO Se_
IF D2(U0+U(i),V0+V(i),P)<>0 THEN
LET L_=1
WHEN EXCEPTION IN
CALL DEC1_EX
USE
LET ext=EXTYPE
EXIT SUB
END WHEN
LET V_=SGN(D2(U0+U(i),V0+V(i),P))*V_
LET D2(U0+U(i),V0+V(i),P)=D2(U0+U(i),V0+V(i),P) +V_*2^Al
END IF
NEXT i
LET A_=Ss_
END IF
!---
NEXT U0
NEXT V0
END IF
NEXT P
END SUB
!------
SUB R_BLK0
IF Ss_=0 THEN
!===D.C.part
LET debug$="DC.huffman" !!!
IF Ah=0 THEN
!-----baseline.progSS.progSA(1st.scan).
LET J=HDC(P) !huffman D.C.table selection P( 0=Y 1=Cb 2=Cr)
CALL DEC1_NS
LET EL=V_ !extent length
!---D.C.extent
LET debug$="DC.huffman extend" !!!
IF 0< EL THEN
LET L_=EL
CALL DEC1_EX !keep EL, V_=extent value( length EL bits)
LET W=2^(EL-1) !minimum in EL bits length
IF V_< W THEN LET V_=V_-W*2+1 !restore signed value
LET B2(P)=B2(P)+V_*2^Al !point transform, integrate to D.C.
END IF
LET D2(U0+U(0),V0+V(0),P)=B2(P)
ELSE
!-----progSA(2st.scan).
LET L_=1
CALL DEC1_EX
!!! LET V_=SGN(D2(U0+U(0),V0+V(0),P))*V_
LET D2(U0+U(0),V0+V(0),P)=D2(U0+U(0),V0+V(0),P) +V_*2^Al
END IF
!===A.C.parts
LET Sa_=1
ELSE
!===A.C.parts
LET Sa_=Ss_
END IF
IF Se_=0 THEN EXIT SUB !band Ss_~Se_
LET J=HAC(P) !huffman A.C.table selection P( 0=Y 1=Cb 2=Cr)
LET debug$="AC.huffman" !!!
FOR A_=Sa_ TO Se_
CALL DEC1_NS
LET EL=MOD(V_,16) !extent length
LET RL= IP(V_/16) !run length
!---
IF RL<=14 AND EL=0 THEN !End Of Block(00). End Of Band n(10,20,,E0)
!---EOBn extend
LET debug$="EOBn extend"& STR$(RL) !!!
IF 0< RL THEN
LET L_=RL !RL= 1,2,,E (EOB1, EOB2, ･･･, EOB14)
CALL DEC1_EX !keep RL, run_length= V_+2^RL
LET EOB=V_+2^RL -1 !※-1 (1st.count)
END IF
EXIT SUB
!---
END IF
!---RL=(0~15)EL=(1~10), RL=(15)EL=(0)
LET debug$="AC.huffman extend" !!!
IF Ah=0 THEN
!-----baseline.progSS.progSA(1st.scan).
LET A_=A_+RL !skip zero_run_length 0~15
!---A.C.extent
IF 0< EL THEN !ZRL(16) only skip
LET L_=EL
CALL DEC1_EX !keep EL, V_=extent value( length EL bits)
LET w=2^(EL-1) !minimum in EL bits length
IF V_< w THEN LET V_=V_-w*2+1 !restore signed value
LET D2(U0+U(A_),V0+V(A_),P)=V_*2^Al !point transform
END IF
ELSE
!-----progSA(2st.scan).
IF 0< EL THEN !ZRL(16) only skip
LET L_=EL
CALL DEC1_EX !keep EL, V_=extent value( length EL bits)
IF EL<>1 THEN PRINT "AC.2nd.=";EL;V_ !!!
LET V01=V_
END IF
FOR i=A_ TO Se_
IF D2(U0+U(i),V0+V(i),P)<>0 THEN !zz(k)=xxx_1?/0?
LET L_=1
CALL DEC1_EX
LET V_=SGN(D2(U0+U(i),V0+V(i),P))*V_
LET D2(U0+U(i),V0+V(i),P)=D2(U0+U(i),V0+V(i),P) +V_*2^Al
ELSEIF RL=0 THEN !zz(k)=000_V01
EXIT FOR
ELSE !zz(k)=000_0 ,zero run
LET RL=RL-1
END IF
NEXT i
IF 0< EL THEN !ZRL(16) skip
IF V01=0 THEN LET V01=-1 !group1( -1, 1)
LET D2(U0+U(i),V0+V(i),P)=V01*2^Al
END IF
LET A_=i
END IF
NEXT A_
END SUB
FOR n=1 TO 60
PRINT n;":"; F2(n,INT(n/3)); F3(n,INT(n/6)); F4(n,INT(n/10)); F5(n,INT(n/15))
NEXT n
END
!a+2b=n、a≧b≧0、Σab=Σ[b=1,[n/3]]b*(n-2b)
EXTERNAL FUNCTION F2(n,k) !Σ[i=1,k]i(n-2i)
LET S=0
FOR i=1 TO k
LET S=S+i*(n-2*i)
NEXT i
LET F2=S
END FUNCTION
!a+2b+3c=n、a≧b≧c≧0、Σabc=Σ[c=1,[n/6]] c*{ Σ[b=c,[(n-3c)/3]] b*((n-3c)-2b) }
EXTERNAL FUNCTION F3(n,k)
LET S=0
FOR i=1 TO k
LET x=n-3*i
LET S=S+i*(F2(x,INT(x/3)) - F2(x,i-1))
NEXT i
LET F3=S
END FUNCTION
EXTERNAL FUNCTION F4(n,k)
LET S=0
FOR i=1 TO k
LET x=n-4*i
LET S=S+i*(F3(x,INT(x/6)) - F3(x,i-1))
NEXT i
LET F4=S
END FUNCTION
EXTERNAL FUNCTION F5(n,k)
LET S=0
FOR i=1 TO k
LET x=n-5*i
LET S=S+i*(F4(x,INT(x/10)) - F4(x,i-1))
NEXT i
LET F5=S
END FUNCTION
LET S=0 !a≧b≧c≧1として考える
FOR C=1 TO INT( N/(1+2+3) ) !n=a+2b+3c≧(1+2+3)cより
FOR B=C TO INT( (N-3*C)/(1+2) ) !n-3c=a+2b≧(1+2)bより
LET A=N-3*C-2*B
IF A< B THEN STOP !論理エラー
PRINT A;B;C !題意を満たす
LET S=S+A*B*C
NEXT B
NEXT C
PRINT "積="; S
LET y=INT(N/6) !f(n)
LET x=INT(N/3)
PRINT y*(y+1)* ( 16*y^3 +3*(5*x-2)*y^2 +(10*x^2 +5*(5-4*N)*x -14)*y -5*x*(4*x^2 +(5-3*N)*x -N+1) +4 )/60
!変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
!「dim a(0 to n) !係数」で定義する
DIM P(0 TO N)
DIM F(0 TO N),G(0 TO N) !p=f/g
MAT F=ZER
MAT G=ZER
DATA 6 !次数 f=x^3(2x^3+x^2+x+1)=2*x^6+x^5+x^4+x^3 ※
DATA 0,0,0,1,1,1,2 !係数 ※展開して次数が小さい方から
READ R
FOR i=0 TO R
READ F(i)
NEXT i
!!!MAT PRINT F; !debug
CALL poly_disp(F) !多項式を表示する
PRINT
DATA 10 !次数 g=(1-x)(1-x^3)^3=x^10-x^9-3x^7+3x^6+3x^4-3x^3-x+1 ※
DATA 1,-1,0,-3,3,0,3,-3,0,-1,1 !係数 ※展開して次数が小さい方から
READ R
FOR i=0 TO R
READ G(i)
NEXT i
!!!MAT PRINT G; !debug
CALL poly_disp(G) !多項式を表示する
PRINT
LET P(0)=F(0)/G(0)/FACT(0) !定数項
PRINT 0; P(0) !debug
DIM F1(0 TO N),G1(0 TO N), W1(0 TO N),W2(0 TO N),W3(0 TO N) !作業用
FOR i=1 TO N !i階微分
LET P(i)=F1(0)/G1(0)/FACT(i) !x^iの係数
PRINT i; P(i) !debug
MAT F=F1 !次へ
MAT G=G1
NEXT i
CALL poly_disp(P) !多項式を表示する
PRINT
END
!変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
!「dim a(0 to n) !係数」で定義する
!演算関連
EXTERNAL SUB poly_add(v1(),v2(), v()) !加算 v=v1+v2
OPTION ARITHMETIC RATIONAL !有理数モード
MAT v=v1+v2
END SUB
EXTERNAL SUB poly_sub(v1(),v2(), v()) !減算 v=v1-v2
OPTION ARITHMETIC RATIONAL !有理数モード
MAT v=v1-v2
END SUB
EXTERNAL SUB poly_mul(v1(),v2(), v()) !乗算 v=v1*v2
OPTION ARITHMETIC RATIONAL !有理数モード
DIM w(0 TO 2*N) !桁数は2倍になる
MAT w=ZER
FOR i=0 TO N !係数
FOR j=0 TO N
LET w(i+j)=w(i+j)+v1(i)*v2(j) !畳み込み
NEXT j
NEXT i
FOR i=0 TO N !※下n桁をコピーする ※オーバーフローは考慮していない
LET v(i)=w(i)
NEXT i
END SUB
EXTERNAL SUB poly_diff(v1(), v()) !微分 v=v1'
OPTION ARITHMETIC RATIONAL !有理数モード
FOR i=1 TO N
LET v(i-1)=v1(i)*i
NEXT i
LET v(N)=0
END SUB
!表示関連
EXTERNAL SUB poly_disp(A()) !多項式を表示する a(X)=ΣAkX^k=AnX^n+An-1X^n-1+…+A1X+A0
OPTION ARITHMETIC RATIONAL !有理数モード
CALL mono_disp(A(N),N)
FOR i=N-1 TO 0 STEP -1 !次項
LET w=A(i)
IF w>0 THEN PRINT "+";
IF w<>0 OR N=0 THEN CALL mono_disp(w,i)
NEXT i
END SUB
EXTERNAL SUB mono_disp(ak,k) !単項式を表示する Ak*X^k
OPTION ARITHMETIC RATIONAL !有理数モード
IF k<>0 THEN !x^nで
IF ak=0 OR ak=1 THEN !係数が0,1なら
ELSEIF ak=-1 THEN !係数が－１なら
PRINT "-"; !符号
ELSE
PRINT STR$(ak);"*";
END IF
END IF
IF k=0 THEN !次数が０なら
PRINT STR$(ak);
ELSEIF k=1 THEN !次数が１なら
PRINT "X";
ELSE
IF ak<>0 THEN PRINT "X^";STR$(k); !係数が0以外なら
END IF
END SUB
DATA 20 !次数 f=6x^20+8x^19+10x^18+12x^17+13x^16+14x^15+17x^14+16x^13+15x^12+8x^11+7x^10+6x^9+3x^8+2x^7+x^6
DATA 0,0,0,0,0,0,1,2,3,6,7,8,15,16,17,14,13,12,10,8,6 !係数 ※展開して次数が小さい方から
DATA 30 !次数 g=x^30-2x^27-3x^24+8x^21+2x^18-12x^15+2x^12+8x^9-3x^6-2x^3+1
DATA 1,0,0,-2,0,0,-3,0,0,8,0,0,2,0,0,-12,0,0,2,0,0,8,0,0,-3,0,0,-2,0,0,1 !係数 ※展開して次数が小さい方から
> !マクローリン展開
> ! P(x)=P(0)+{P'(0)/1!}x+{P''(0)/2!}x^2+{P'''(0)/3!}x^3+ …
> !例
> !P(x)=1/(1-x)=1+x+x^2+x^3+x^4+ …
> !
> !考察
> !P(0)は、x=0を代入して、1/(1-0)=1
> !P'(0)は、
> ! P(x)=f(x)/g(x)より、P'=(f'g-fg')/g^2なので、
> ! 1'(1-x)-1(1-x)'/(1-x)^2=1/(1-x)^2
> ! x=0を代入して、1
> !P''(0)は、
> ! P''(x)=(P'(x))'なので、
> ! 上記の結果をあらためて、f(x)=f'g-fg'、g(x)=g^2と考える。上記と同じ議論を繰り返す。
> !（終り）
>
> OPTION ARITHMETIC RATIONAL !有理数モード
>
> PUBLIC NUMERIC N !次数
> LET N=50
>
> !変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
> !「dim a(0 to n) !係数」で定義する
> DIM P(0 TO N)
> DIM F(0 TO N),G(0 TO N) !p=f/g
> MAT F=ZER
> MAT G=ZER
>
> DATA 6 !次数 f=x^3(2x^3+x^2+x+1)=2*x^6+x^5+x^4+x^3 ※
> DATA 0,0,0,1,1,1,2 !係数 ※展開して次数が小さい方から
> READ R
> FOR i=0 TO R
> READ F(i)
> NEXT i
> !!!MAT PRINT F; !debug
> CALL poly_disp(F) !多項式を表示する
> PRINT
>
> DATA 10 !次数 g=(1-x)(1-x^3)^3=x^10-x^9-3x^7+3x^6+3x^4-3x^3-x+1 ※
> DATA 1,-1,0,-3,3,0,3,-3,0,-1,1 !係数 ※展開して次数が小さい方から
> READ R
> FOR i=0 TO R
> READ G(i)
> NEXT i
> !!!MAT PRINT G; !debug
> CALL poly_disp(G) !多項式を表示する
> PRINT
>
>
> LET P(0)=F(0)/G(0)/FACT(0) !定数項
> PRINT 0; P(0) !debug
>
> DIM F1(0 TO N),G1(0 TO N), W1(0 TO N),W2(0 TO N),W3(0 TO N) !作業用
> FOR i=1 TO N !i階微分
>
> CALL poly_diff(F,W3) !f'g
> CALL poly_mul(W3,G, W1)
> !!!MAT PRINT W1; !debug
>
> CALL poly_diff(G,W3) !fg'
> CALL poly_mul(F,W3, W2)
> !!!MAT PRINT W2; !debug
>
> CALL poly_sub(W1,W2, F1) !分子 f'g-fg'
> !!!MAT PRINT F1; !debug
>
>
> CALL poly_mul(G,G, G1) !分母 g^2
> !!!MAT PRINT G1; !debug
>
>
> LET P(i)=F1(0)/G1(0)/FACT(i) !x^iの係数
> PRINT i; P(i) !debug
>
>
> MAT F=F1 !次へ
> MAT G=G1
> NEXT i
>
> CALL poly_disp(P) !多項式を表示する
> PRINT
>
> END
>
>
> !変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
> !「dim a(0 to n) !係数」で定義する
>
> !演算関連
>
> EXTERNAL SUB poly_add(v1(),v2(), v()) !加算 v=v1+v2
> OPTION ARITHMETIC RATIONAL !有理数モード
> MAT v=v1+v2
> END SUB
>
> EXTERNAL SUB poly_sub(v1(),v2(), v()) !減算 v=v1-v2
> OPTION ARITHMETIC RATIONAL !有理数モード
> MAT v=v1-v2
> END SUB
>
> EXTERNAL SUB poly_mul(v1(),v2(), v()) !乗算 v=v1*v2
> OPTION ARITHMETIC RATIONAL !有理数モード
> DIM w(0 TO 2*N) !桁数は2倍になる
> MAT w=ZER
> FOR i=0 TO N !係数
> FOR j=0 TO N
> LET w(i+j)=w(i+j)+v1(i)*v2(j) !畳み込み
> NEXT j
> NEXT i
> FOR i=0 TO N !※下n桁をコピーする ※オーバーフローは考慮していない
> LET v(i)=w(i)
> NEXT i
> END SUB
>
> EXTERNAL SUB poly_diff(v1(), v()) !微分 v=v1'
> OPTION ARITHMETIC RATIONAL !有理数モード
> FOR i=1 TO N
> LET v(i-1)=v1(i)*i
> NEXT i
> LET v(N)=0
> END SUB
>
>
> !表示関連
>
> EXTERNAL SUB poly_disp(A()) !多項式を表示する a(X)=ΣAkX^k=AnX^n+An-1X^n-1+…+A1X+A0
> OPTION ARITHMETIC RATIONAL !有理数モード
> CALL mono_disp(A(N),N)
> FOR i=N-1 TO 0 STEP -1 !次項
> LET w=A(i)
> IF w>0 THEN PRINT "+";
> IF w<>0 OR N=0 THEN CALL mono_disp(w,i)
> NEXT i
> END SUB
>
> EXTERNAL SUB mono_disp(ak,k) !単項式を表示する Ak*X^k
> OPTION ARITHMETIC RATIONAL !有理数モード
> IF k<>0 THEN !x^nで
> IF ak=0 OR ak=1 THEN !係数が0,1なら
> ELSEIF ak=-1 THEN !係数が－１なら
> PRINT "-"; !符号
> ELSE
> PRINT STR$(ak);"*";
> END IF
> END IF
> IF k=0 THEN !次数が０なら
> PRINT STR$(ak);
> ELSEIF k=1 THEN !次数が１なら
> PRINT "X";
> ELSE
> IF ak<>0 THEN PRINT "X^";STR$(k); !係数が0以外なら
> END IF
> END SUB
>
>
EXTERNAL FUNCTION DF(X,K)
LET H=1/1024
FOR J=0 TO K
LET S=S+(-1)^J*COMB(K,J)*F(X+(K/2-J)*H)
NEXT J
LET DF=S/(H^K)
END FUNCTION
また1000桁モードを使用して、下記のようにすればある程度は使えそうです
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC H
LET X=0
LET N=9
LET EPS=1E-10 !'計算精度
FOR I=0 TO N
LET H=1/128
DO
LET H=H/2
LET A=DF1(X,I)
LET B=DF2(X,I)
LOOP UNTIL ABS(A - B) < EPS
LET DF=(A+B)/2
PRINT DF/FACT(I)
NEXT I
END
EXTERNAL FUNCTION F(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET F=X/(1-X)^2
END FUNCTION
EXTERNAL FUNCTION DF1(X,N)
OPTION ARITHMETIC DECIMAL_HIGH
IF N>0 THEN
LET DF1=(DF1(X-2*H,N-1)-4*DF1(X-H,N-1)+3*DF1(X,N-1))/(2*H) !'3点前進法
!'LET DF1=(3*DF1(X-4*H,N-1)-16*DF1(X-3*H,N-1)+36*DF1(X-2*H,N-1)-48*DF1(X-H,N-1)+25*DF1(X,N-1))/(12*H) !'5点前進法
ELSE
LET DF1=F(X)
END IF
END FUNCTION
EXTERNAL FUNCTION DF2(X,N)
OPTION ARITHMETIC DECIMAL_HIGH
IF N>0 THEN
LET DF2=(-3*DF2(X,N-1)+4*DF2(X+H,N-1)-DF2(X+2*H,N-1))/(2*H) !'3点後退法
!'LET DF2=(-25*DF2(X,N-1)+48*DF2(X+H,N-1)-36*DF2(X+2*H,N-1)+16*DF2(X+3*H,N-1)-3*DF2(X+4*H,N-1))/(12*H) !'5点後退法
ELSE
LET DF2=F(X)
END IF
END FUNCTION
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC H
LET X=0
LET EPS=1E-20 !'精度
FOR I=1 TO 10
LET H=1/2^10
DO
LET H=H/2
SELECT CASE I
CASE 1
LET A=(-25*F(X)+48*F(X+H)-36*F(X+2*H)+16*F(X+3*H)-3*F(X+4*H))/(12*H)
LET B=(3*F(X-4*H)-16*F(X-3*H)+36*F(X-2*H)-48*F(X-H)+25*F(X))/(12*H)
CASE 2
LET A=(F(X)-2*F(X+H)+F(X+2*H))/(H^2)
LET B=(F(X-2*H)-2*F(X-H)+F(X))/(H^2)
CASE 3
LET A=(-49*F(X)+232*F(X+H)-461*F(X+2*H)+496*F(X+3*H)-307*F(X+4*H)+104*F(X+5*H)-15*F(X+6*H))/(8*H^3)
LET B=(15*F(X-6*H)-104*F(X-5*H)+307*F(X-4*H)-496*F(X-3*H)+461*F(X-2*H)-232*F(X-H)+49*F(X))/(8*H^3)
CASE 4
LET A=(F(X)-4*F(X+H)+6*F(X+2*H)-4*F(X+3*H)+F(X+4*H))/(H^4)
LET B=(F(X-4*H)-4*F(X-3*H)+6*F(X-2*H)-4*F(X-H)+F(X))/(H^4)
CASE 5
LET A=(-81*F(X)+575*F(X+H)-1790*F(X+2*H)+3195*F(X+3*H)-3580*F(X+4*H)+2581*F(X+5*H)-1170*F(X+6*H)+305*F(X+7*H)-35*F(X+8*H))/(6*H^5)
LET B=(35*F(X-8*H)-305*F(X-7*H)+1170*F(X-6*H)-2581*F(X-5*H)+3580*F(X-4*H)-3195*F(X-3*H)+1790*F(X-2*H)-575*F(X-H)+81*F(X))/(6*H^5)
CASE 6
LET A=(F(X)-6*F(X+H)+15*F(X+2*H)-20*F(X+3*H)+15*F(X+4*H)-6*F(X+5*H)+F(X+6*H))/(H^6)
LET B=(F(X-6*H)-6*F(X-5*H)+15*F(X-4*H)-20*F(X-3*H)+15*F(X-2*H)-6*F(X-H)+F(X))/(H^6)
CASE 7
LET A=(-605*F(X)+5628*F(X+H)-23583*F(X+2*H)+58632*F(X+3*H)-95802*F(X+4*H)+107520*F(X+5*H)-83958*F(X+6*H)+45048*F(X+7*H)-15897*F(X+8*H)+3332*F(X+9*H)-315*F(X+10*H))/(24*H^7)
LET B=(315*F(X-10*H)-3332*F(X-9*H)+15897*F(X-8*H)-45048*F(X-7*H)+83958*F(X-6*H)-107520*F(X-5*H)+95802*F(X-4*H)-58632*F(X-3*H)+23583*F(X-2*H)-5628*F(X-H)+605*F(X))/(24*H^7)
CASE 8
LET A=(F(X)-8*F(X+H)+28*F(X+2*H)-56*F(X+3*H)+70*F(X+4*H)-56*F(X+5*H)+28*F(X+6*H)-8*F(X+7*H)+F(X+8*H))/(H^8)
LET B=(F(X-8*H)-8*F(X-7*H)+28*F(X-6*H)-56*F(X-5*H)+70*F(X-4*H)-56*F(X-3*H)+28*F(X-2*H)-8*F(X-H)+F(X))/(H^8)
CASE 9
LET A=(-169*F(X)+1932*F(X+H)-10128*F(X+2*H)+32196*F(X+3*H)-69129*F(X+4*H)+105624*F(X+5*H)-117768*F(X+6*H)+96552*F(X+7*H)-57771*F(X+8*H)+24604*F(X+9*H)-7080*F(X+10*H)+1236*F(X+11*H)-99*F(X+12*H))/(4*H^9)
LET B=(99*F(X-12*H)-1236*F(X-11*H)+7080*F(X-10*H)-24604*F(X-9*H)+57771*F(X-8*H)-96552*F(X-7*H)+117768*F(X-6*H)-105624*F(X-5*H)+69129*F(X-4*H)-32196*F(X-3*H)+10128*F(X-2*H)-1932*F(X-H)+169*F(X))/(4*H^9)
CASE 10
LET A=(F(X)-10*F(X+H)+45*F(X+2*H)-120*F(X+3*H)+210*F(X+4*H)-252*F(X+5*H)+210*F(X+6*H)-120*F(X+7*H)+45*F(X+8*H)-10*F(X+9*H)+F(X+10*H))/(H^10)
LET B=(F(X-10*H)-10*F(X-9*H)+45*F(X-8*H)-120*F(X-7*H)+210*F(X-6*H)-252*F(X-5*H)+210*F(X-4*H)-120*F(X-3*H)+45*F(X-2*H)-10*F(X-H)+F(X))/(H^10)
END SELECT
LOOP UNTIL ABS(A - B) < EPS
LET DF=(A+B)/2
PRINT DF/FACT(I)
NEXT I
END
EXTERNAL FUNCTION F(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET F=X/(1-X)^2
END FUNCTION
PUBLIC NUMERIC HEIGHT !段数
FOR HEIGHT=1 TO N
CALL print_young(HEIGHT,N,N)
NEXT HEIGHT
END
EXTERNAL SUB print_young(d,n,c) !ヤング図形を表示する
IF d>0 THEN
LET upper=n-d+1
LET lower=INT((n-1)/d)+1
FOR i=MIN(c,upper) TO lower STEP -1
LET A(HEIGHT-d+1)=i
CALL print_young(d-1,n-i,i) !次へ
NEXT i
ELSE !揃ったら
MAT PRINT A; !debug
CALL connect(1,A)
END IF
END SUB
EXTERNAL SUB connect(P,A()) !p段目を表示する
!左端の分岐
LET W=A(P+1) !次の段の有無
IF P=1 THEN !1段目なら
IF W>0 THEN PRINT "┬"; ELSE PRINT "─";
ELSE !2段目以降
IF W>0 THEN PRINT "├"; ELSE PRINT "└";
END IF
FOR i=1 TO A(P) !各抵抗への接続位置
IF W=0 AND (P=1 OR i=A(P)) THEN PRINT "R─"; ELSE PRINT "R┬";
NEXT i
PRINT
PUBLIC NUMERIC C !場合の数
LET C=0
CALL try(2,M,B,1,N)
END
EXTERNAL SUB try(P,M,B(),R,L)
FOR i=R TO L !配置位置の候補 ※ひとつ上の段の右側へ
LET B(P)=i
IF P<M THEN !次の段があれば
CALL try(P+1,M,B,i,L)
ELSE !結果を表示する
LET C=C+1
PRINT "No."; C
PRINT "┬"; !1段目
FOR J=1 TO L
IF B(2)>J THEN PRINT "R─"; ELSE PRINT "R┬";
NEXT J
PRINT
!!!MAT PRINT B; !debug
FOR J=2 TO M !2段目以降
IF J=M THEN PRINT "└"; ELSE PRINT "├"; !左端
PRINT REPEAT$(" ",3*(B(J)-1));
IF B(J+1)>B(J) THEN PRINT "R┘" ELSE PRINT "R┤"
NEXT J
PRINT
END IF
NEXT i
END SUB
LET W=PrimeQ(P)
LET C=C+W
!PRINT N; P; W !debg
NEXT N
PRINT C/(M+1)*100;"%"
END
!試行割算法
EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!２以上の自然数なら
IF MOD(n,2)=0 THEN !２の倍数
IF n=2 THEN LET PrimeQ=1 !２は素数
ELSEIF MOD(n,3)=0 THEN !３の倍数
IF n=3 THEN LET PrimeQ=1 !３は素数
ELSE
LET k=5
DO WHILE k*k<=n !√nまで検証する
IF MOD(n,k)=0 THEN !5,11,17,23,29,…
EXIT FUNCTION
ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
LET k=k+6
LOOP
LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION
!!SET TEXT HEIGHT 0.0075
SET TEXT JUSTIFY "CENTER","HALF"
SET bitmap SIZE 600,600
SET WINDOW -M/2,M/2,-M/2,M/2
LET D=41 !中央の値
LET X=0
LET Y=0
SET TEXT COLOR 1+3*PrimeQ(D)
PLOT TEXT, AT X,Y: STR$(D)
LET DX=1 !移動方向
LET DY=1
FOR S=1 TO M !ステップ数
FOR L=1 TO S !x軸方向
LET D=D+1
LET X=X+DX
SET TEXT COLOR 1+3*PrimeQ(D)
PLOT TEXT, AT X,Y: STR$(D)
NEXT L
LET DX=-DX
FOR L=1 TO S !y軸方向
LET D=D+1
LET Y=Y+DY
SET TEXT COLOR 1+3*PrimeQ(D)
PLOT TEXT, AT X,Y: STR$(D)
NEXT L
LET DY=-DY
NEXT S
END
!試行割算法
EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!２以上の自然数なら
IF MOD(n,2)=0 THEN !２の倍数
IF n=2 THEN LET PrimeQ=1 !２は素数
ELSEIF MOD(n,3)=0 THEN !３の倍数
IF n=3 THEN LET PrimeQ=1 !３は素数
ELSE
LET k=5
DO WHILE k*k<=n !√nまで検証する
IF MOD(n,k)=0 THEN !5,11,17,23,29,…
EXIT FUNCTION
ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
LET k=k+6
LOOP
LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION
LET x=n !save it
DO UNTIL m=0
LET q=CEIL(n/m)
IF x>q THEN
LET s=s+(x-INT(x/q))
PRINT x/q;"本をそれぞれ";q;"等分して、";
ELSE
LET s=s+(x-1)
PRINT x/q;"本を";x;"等分して、";
END IF
PRINT "1/";STR$(q);" ずつ分ける"
SUB card_initialize(c(),N) !カードを整列する
FOR i=1 TO N
LET c(i)=i
NEXT i
END SUB
RANDOMIZE
CALL card_initialize(m1,N)
SUB shuffle_randomize(c(),N) !ランダムにシャッフルする
FOR i=N TO 2 STEP -1
LET j=INT(RND*(i-1))+1 !１～i-1
swap c(i),c(j)
NEXT i
END SUB
CALL shuffle_randomize(m1,N)
!DATA 1,2,3,4
!!DATA 4,3,1,2
!MAT READ m1
!!!MAT PRINT m1; !debug
MAT m2=ZER
MAT m3=ZER
LET c1=N
LET c2=0
LET c3=0
SUB card_display(c(),N)
PRINT "{";
IF N>0 THEN
PRINT STR$(c(N));
FOR i=N-1 TO 1 STEP -1
PRINT ",";STR$(c(i));
NEXT i
END IF
PRINT "}"
END SUB
CALL card_display(m1,c1)
CALL card_display(m2,c2)
CALL card_display(m3,c3)
PRINT
SUB move(x(),a,y(),b) !XからYへ移動させる
LET t=x(a)
LET a=a-1
LET b=b+1
LET y(b)=t
END SUB
LET S=0 !ステップ
DO
IF c1=N THEN !整列しているかどうか
FOR i=c1 TO 1 STEP -1
IF m1(i)<>N-i+1 THEN EXIT FOR
NEXT i
IF i<1 THEN EXIT DO !ＯＫ！
END IF
LET S=S+1
PRINT S;": ";
!ルール1
IF (c1>0 AND m1(c1)=2) AND (c2>0 AND m2(c2)=1) AND (c3=0) THEN !(2,1,_)なら
CALL move(m2,c2,m1,c1) !1を2の上にのせる
PRINT "ルール1"
ELSE
!ルール2
IF c1>0 AND c2>0 AND c3=0 THEN !3が空きなら
CALL move(m2,c2,m3,c3) !左隣のカードで空きを埋める
PRINT "ルール2"
ELSEIF c2>0 AND c3>0 AND c1=0 THEN !1が空きなら
CALL move(m3,c3,m1,c1)
PRINT "ルール2"
ELSEIF c3>0 AND c1>0 AND c2=0 THEN !2が空きなら
CALL move(m1,c1,m2,c2)
PRINT "ルール2"
ELSE
!ルール3
IF (c1>0 AND c2>0 AND c3>0) AND (m1(c1)-1=m3(c3) AND m2(c2)<m1(c1)) THEN !(k,j,k-1)
CALL move(m3,c3,m1,c1) !(k-1)のカードをkのカードの上にのせる
PRINT "ルール3"
ELSE
!ルール4
IF c1=N AND c2=0 AND c3=0 THEN !2,3が空きなら
CALL move(m1,c1,m3,c3) !左隣へ移動する
PRINT "ルール4"
ELSEIF c2=N AND c3=0 AND c1=0 THEN !3,1が空きなら
CALL move(m2,c2,m1,c1)
PRINT "ルール4"
ELSEIF c3=N AND c1=0 AND c3=0 THEN !1,2が空きなら
CALL move(m3,c3,m2,c2)
PRINT "ルール4"
ELSE
!ルール5
IF (c1>0 AND c2>0 AND c3>0) THEN !3枚のカードが見えるなら
LET t1=m1(c1)
LET t2=m2(c2)
LET t3=m3(c3)
LET t=MAX(MAX(t1,t2),t3)
IF t1=t THEN !1が最大なら
CALL move(m2,c2,m3,c3) !右隣のカードを右隣へ移動させる
ELSEIF t2=t THEN !2が最大なら
CALL move(m3,c3,m1,c1)
ELSE !3が最大なら
CALL move(m1,c1,m2,c2)
END IF
PRINT "ルール5"
LET N=9 !左辺の＋が5つ
LET R=4
CALL CombBit(N,R, 0) !2進法n桁、r個のビットが1
END
EXTERNAL SUB CombBit(N,R, Bit) !n個の中からr個を選ぶ組み合わせをビットで表す ※辞書式順序
IF N=R THEN
!!PRINT Bit+2^R-1 !ビットパターンを生成する
CALL stub(Bit+2^R-1)
ELSEIF N>0 THEN
CALL CombBit(N-1,R,Bit)
CALL CombBit(N-1,R-1,Bit+2^(N-1))
END IF
END SUB
!小町算「＋1±2±3±4±5±6±7±8±9±10=±11、左辺の＋と－の個数が同じもの」を解く
EXTERNAL SUB stub(Bit)
LET t=Bit !左辺を計算する
LET S=1 !1の前は+のみ
FOR K=10 TO 2 STEP -1 !進数変換でパターンを得る
IF MOD(t,2)=1 THEN LET S=S+K ELSE LET S=S-K !ビットが1なら和
LET t=INT(t/2)
NEXT K
IF ABS(S)=11 THEN PRINT BSTR$(2^9+Bit,2) !±11なら、条件を満たす
END SUB
FOR a=1 TO 22/5
FOR b=a+1 TO (22-a)/4
FOR c=b+1 TO (22-(a+b))/3
FOR d=c+1 TO (22-(a+b+c))/2
LET e=22-(a+b+c+d)
IF e>d AND e<=10 THEN PRINT a;b;c;d;e
NEXT d
NEXT c
NEXT b
NEXT a
END
PUBLIC NUMERIC S !手数 ※上限
LET S=20
DIM A(0 TO S),B(0 TO S),C(0 TO S) !バケツの水量
LET A(0)=6
LET B(0)=11
LET C(0)=14
CALL try(0,A,B,C)
PRINT S;"回"
END
EXTERNAL SUB try(p,A(),B(),C()) !バックトラック法で検索する
IF A(p)=0 OR B(p)=0 OR C(p)=0 THEN
IF p< S THEN
LET S=p !更新
FOR i=0 TO p !手順を表示する
PRINT STR$(i);": (";STR$(A(i));",";STR$(B(i));",";STR$(C(i));")"
NEXT i
PRINT
END IF
ELSE
IF p< S THEN !手数の上限以内なら、次の6通りを試す
IF A(p)>=B(p) THEN !A→Bとする
LET A(p+1)=A(p)-B(p)
LET B(p+1)=2*B(p)
LET C(p+1)=C(p)
CALL try(p+1,A,B,C)
END IF
IF A(p)>=C(p) THEN !A→Cとする
LET A(p+1)=A(p)-C(p)
LET C(p+1)=2*C(p)
LET B(p+1)=B(p)
CALL try(p+1,A,B,C)
END IF
IF B(p)>=C(p) THEN !B→Cとする
LET B(p+1)=B(p)-C(p)
LET C(p+1)=2*C(p)
LET A(p+1)=A(p)
CALL try(p+1,A,B,C)
END IF
IF B(p)>=A(p) THEN !B→Aとする
LET B(p+1)=B(p)-A(p)
LET A(p+1)=2*A(p)
LET C(p+1)=C(p)
CALL try(p+1,A,B,C)
END IF
IF C(p)>=A(p) THEN !C→Aとする
LET C(p+1)=C(p)-A(p)
LET A(p+1)=2*A(p)
LET B(p+1)=B(p)
CALL try(p+1,A,B,C)
END IF
IF C(p)>=B(p) THEN !C→Bとする
LET C(p+1)=C(p)-B(p)
LET B(p+1)=2*B(p)
LET A(p+1)=A(p)
CALL try(p+1,A,B,C)
END IF
END IF
END IF
END SUB
OPTION ARITHMETIC RATIONAL !有理数モード
FOR n=2 TO 20
LET s=0
FOR p=1 TO n-1 !1≦p＜q≦n
FOR q=p+1 TO n
IF gcd(p,q)=1 THEN !互いに素
IF p+q>n THEN
PRINT p;q; !debug
IF p+q=n+1 THEN PRINT "*" ELSE PRINT !debug
LET s=s+1/(p*q) !Σ1/(pq)
END IF
END IF
NEXT q
NEXT p
PRINT "n=";n; s !=1/2
PRINT
NEXT n
END
EXTERNAL FUNCTION gcd(a,b) !最大公約数
OPTION ARITHMETIC RATIONAL !有理数モード
DO UNTIL b=0
LET t=b
LET b=MOD(a,b)
LET a=t
LOOP
LET gcd=a
END FUNCTION
LET W=BIT2DEC(B) !2進法のビット列を10進法数値と解釈する
IF MOD(W,N)=0 THEN
LET C=C+1
PRINT N;"×";W/N;"=";W
END IF
LET B=B+1
LOOP
PRINT
NEXT n
END
EXTERNAL FUNCTION BIT2DEC(N) !2進法のビット列を10進法数値と解釈する
OPTION ARITHMETIC RATIONAL !多桁の整数
LET BIT2DEC=0
IF N>0 THEN LET BIT2DEC=BIT2DEC(INT(N/2))*10+MOD(N,2)
END FUNCTION
LET M=N
LET P=0
DO WHILE MOD(M,2)=0 !2^p
LET M=M/2
LET P=P+1
LOOP
LET Q=0
DO WHILE MOD(M,5)=0 !5^q
LET M=M/5
LET Q=Q+1
LOOP
LET R=0
DO WHILE MOD(M,3)=0 !3^r
LET M=M/3
LET R=R+1
LOOP
!!!PRINT P;Q;R;M !debug
FOR K=1 TO M-1 !1/Mの循環節の長さを求める 10^k≡1 mod mを満たす最小のk
IF modpow(10,K,M)=1 THEN EXIT FOR
NEXT K
LET W=(10^(lcm(K,3^R))-1)/9 *10^MAX(P,Q)
PRINT N; "×"; W/N; "="; W; "（";lcm(K,3^R);"個の1）"; " k=";K; "r=";R
!※同値
!IF M>1 THEN !n=2^p*5^q*3^r*Mの場合
! FOR K=1 TO M-1 !1/Mの循環節の長さを求める 10^k≡1 mod mを満たす最小のk
! IF modpow(10,K,M)=1 THEN EXIT FOR
! NEXT K
! LET W=(10^(K*3^R)-1)/9 *10^MAX(P,Q)
! PRINT N; "×"; W/N; "="; W; "（";K*3^R;"個の1）"; " k=";K; "r=";R
!ELSE !n=2^p*5^q*3^rの場合
! LET W=(10^(3^R)-1)/9 *10^MAX(P,Q)
! PRINT N; "×"; W/N; "="; W; "（";3^R;"個の1）"; " r=";R
!END IF
NEXT N
END
EXTERNAL FUNCTION modpow(a,n,b) !a^n≡x mod b のxを返す ※nは非負整数
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=MOD(1,b)
DO WHILE n>0 !べき乗nを２進展開する
IF MOD(n,2)=1 THEN LET S=MOD(S*a,b) !ビットが１なら計算する
LET a=MOD(a*a,b)
LET n=INT(n/2)
LOOP
LET modpow=S
END FUNCTION
EXTERNAL FUNCTION gcd(a,b) !最大公約数
OPTION ARITHMETIC RATIONAL !多桁の整数
DO UNTIL b=0
LET t=b
LET b=MOD(a,b)
LET a=t
LOOP
LET gcd=a
END FUNCTION
EXTERNAL FUNCTION lcm(a,b) !最小公倍数
OPTION ARITHMETIC RATIONAL !多桁の整数
IF a>b THEN !少しでも桁あふれを防止するために大きい方を先に割る
LET lcm=(a/gcd(a,b))*b
ELSE
LET lcm=a*(b/gcd(a,b))
END IF
END FUNCTION
LET t=9*n !10^0,10^1,10^2,…,10^9nとして、
FOR b=0 TO t-1 !9nで割った余りが等しいものを探す
LET W=modpow(10,b,t)
FOR a=b+1 TO t
IF modpow(10,a,t)=W THEN EXIT FOR
NEXT a
IF a<=t THEN EXIT FOR
NEXT b
IF b<=t-1 THEN !条件を満たすa,bで
EXTERNAL FUNCTION modpow(a,n,b) !a^n≡x mod b のxを返す ※nは非負整数
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=MOD(1,b)
DO WHILE n>0 !べき乗nを２進展開する
IF MOD(n,2)=1 THEN LET S=MOD(S*a,b) !ビットが１なら計算する
LET a=MOD(a*a,b)
LET n=INT(n/2)
LOOP
LET modpow=S
END FUNCTION
PRINT "2^1 ×";B/2;"=";B !n=1のとき
LET K=B !1,2からなるk桁の数
FOR N=2 TO 20 !nが2以上のとき
LET M=K+A*10^(N-1) !1{1,2からなるk桁の数}
IF MOD(M,2^N)=0 THEN
LET K=M
ELSE
LET M=K+B*10^(N-1) !2{1,2からなるk桁の数}
IF MOD(M,2^N)=0 THEN
LET K=M
ELSE
PRINT "論理エラー"
STOP
END IF
END IF
PRINT "2^";STR$(N); " ×";M/2^N; "=";M
CALL fvSEGMENT(-2,0,1,0) !AB
PLOT TEXT ,AT -2,0: "A"
CALL fvSEGMENT(1,0,1,4) !BC
PLOT TEXT ,AT 1,0: "B"
CALL fvSEGMENT(1,4,-2,0) !CA
PLOT TEXT ,AT 1,4: "C"
!折り返し
SET LINE COLOR 4
CALL fvSEGMENT(0,1,1,3) !P
CALL fvSYMMETRY2(1,1,2,1, xx,yy) !B'
PRINT xx;yy
SET LINE COLOR 2
CALL fvSEGMENT(0,0,0,1)
CALL fvSEGMENT(0,1,xx,yy)
CALL fvSEGMENT(xx,yy,1,3)
END
!●作図ルーチン
!直線
EXTERNAL SUB fvSEGMENT(x1,y1,x2,y2) !線分
PLOT LINES: x1,y1; x2,y2
END SUB
!●計算ルーチン
!点対称
!点(x,y)の原点に対称な点は、(-x,-y)より、点(a,b)に対しては、(-(x-a)+a,-(y-b)+b)=(2a-x,2b-y)
EXTERNAL SUB fvSYMMETRY(x,y,a,b, xx,yy) !点(a,b)に対称な点（点(a,b)を基準に180度回転した点）
LET xx=2*a-x
LET yy=2*b-y
END SUB
!線対称
EXTERNAL SUB fvSYMMETRY22(x,y,a, xx,yy) !直線Y=a*Xに対称な点
LET m1=1-a*a
LET m2=2*a
LET m3=1+a*a
LET xx=(m1*x+m2*y)/m3
LET yy=(m2*x-m1*y)/m3
END SUB
EXTERNAL SUB fvSYMMETRY2(x,y,a,b, xx,yy) !直線Y=a*X+bに対称な点
LET m1=1-a*a
LET m2=2*a
LET m3=1+a*a
LET xx=(m1*x+m2*y-2*b*a)/m3
LET yy=(m2*x-m1*y+2*b)/m3
END SUB
!点(x,y)のy軸に対称な点は、(-x,y)より、直線X=aについては、(-(x-a)+a,y)=(2a-x,y)
EXTERNAL SUB fvSYMMETRYh(x,y,a, xx,yy) !直線X=aに対称な点
LET xx=2*a-x
LET yy=y
END SUB
!点(x,y)のx軸に対称な点は、(x,-y)より、直線Y=bについては、(x,-(y-b)+b)=(x,2b-y)
EXTERNAL SUB fvSYMMETRYv(x,y,b, xx,yy) !直線Y=bに対称な点
LET xx=x
LET yy=2*b-y
END SUB
!回転
EXTERNAL SUB fvROTATE90(x,y,a,b, xx,yy) !点(a,b)を基準に90度回転した点
LET xx=-(y-b)+a
LET yy= (x-a)+b
END SUB
EXTERNAL SUB fvROTATEm90(x,y,a,b, xx,yy) !点(a,b)を基準に-90度回転した点
LET xx= (y-b)+a
LET yy=-(x-a)+b
END SUB
「〇〇ソフトを作る」という目的にFull BASICは適さないと思います。JavaのようにGUIが作れてイベント駆動ができるものがアプリケーション作成には適しているのではないでしょうか。
Full BASICが適するのは問題解決のための計算です。コンピュータの能力を限界まで引き出さなければ解決できないような本格的な応用には適しませんが，計算は瞬時に終わってしまうのにプログラムを書くのに手間がかかってしまうような場合にFull BASICが勧められます。計算プログラムを作るのにプロトタイプをFull BASICで書いて，本番はPascalとかCに書き直すというのも有効な手段です。また，BASICAccを利用すれば，実用上，十分な速さが得られることが多いと思います。そんな場合は，他の言語はいりません。
Full BASICでは書けない（あるいは書きにくい）アルゴリズムが存在するのも事実です。そういうアルゴリズムの記述の必要性を知れば他の言語を始めるきっかけになると思います。
答え
パチンコ玉をA,B,Cとして、その重さをa,b,cとする。
○は同じ重さ、●は少し違う重さを表すとして、
a b c
○○●
○●○
●○○
以上の3通りである。
手法A：それまでの測定結果によって、次の回のはかり方を決める方法
LET a=1
LET b=2
LET c=2
LET w1=a
LET w2=b
PRINT "w1=";w1; "w2=";w2 !debug
IF w1=w2 THEN !cが偽
LET w3=c
PRINT "w3=";w3 !debug
LET x=w1
LET y=w3
PRINT "x=";x; "y=";y; "偽C"
ELSE
LET w3=c
PRINT "w3=";w3 !debug
IF w3=w1 THEN !bが偽
LET x=w3
LET y=w2
PRINT "x=";x; "y=";y; "偽B"
ELSEIF w3=w2 THEN !aが偽
LET x=w2
LET y=w1
PRINT "x=";x; "y=";y; "偽A"
ELSE
PRINT "論理エラー"
END IF
END IF
END
手法B：最初にすべての回のはかり方を決め、全結果から答えを出す方法
LET a=1
LET b=2
LET c=2
LET w1=a
LET w2=b
LET w3=c
PRINT "w1=";w1; "w2=";w2; "w3=";w3 !debug
IF w1=w2 THEN !cが偽
LET x=w1
LET y=w3
PRINT "x=";x; "y=";y; "偽C"
ELSEIF w3=w1 THEN !aが偽
LET x=w3
LET y=w2
PRINT "x=";x; "y=";y; "偽B"
ELSEIF w2=w3 THEN !bが偽
LET x=w2
LET y=w1
PRINT "x=";x; "y=";y; "偽A"
ELSE
PRINT "論理エラー"
END IF
LET w1=a
LET w2=b+c
PRINT "w1=";w1; "w2=";w2 !debug
IF 2*w1=w2 THEN !dが偽 ※a=b=cより
LET w3=d
PRINT "w3=";w3 !debug
LET x=w1 !a
LET y=w3 !d
PRINT "x=";x; "y=";y; "偽D"
ELSE
LET w3=b
PRINT "w3=";w3 !debug
IF w3=w1 THEN !cが偽 ※a=bより
LET x=w1 !a
LET y=w2-w3 !(b+c)-b
PRINT "x=";x; "y=";y; "偽C"
ELSEIF 2*w3=w2 THEN !aが偽 ※b=cより、w3=w2-w3 ∴2*w3=w2
LET x=w3 !b
LET y=w1 !a
PRINT "x=";x; "y=";y; "偽A"
ELSEIF w1=w2-w3 THEN !bが偽 ※a=cより、w1=w2-w3
LET x=w1 !a
LET y=w3 !b
PRINT "x=";x; "y=";y; "偽B"
ELSE
PRINT "論理エラー"
END IF
END IF
END
●パチンコ玉が5個の場合
LET a=2
LET b=2
LET c=1
LET d=2
LET e=2
LET w1=a+b
LET w2=c+d
PRINT "w1=";w1; "w2=";w2 !debug
IF w1=w2 THEN !eが偽 ※a=b=c=dより
LET w3=e
PRINT "w3=";w3 !debug
LET x=w1/2 !x=w2/2
LET y=w3
PRINT "x=";x; "y=";y; "偽E"
ELSE
LET w3=a+c+e
PRINT "w3=";w3 !debug
IF 2*w3=3*w1 THEN !e=a=c=bより、w3=a+c+e=3e、w1=a+b=2e
LET x=w1/2 !x=w3/3
LET y=w2-x
PRINT "x=";x; "y=";y; "偽D"
ELSEIF 2*w3=3*w2 THEN !e=a=c=dより、w3=a+c+e=3e、w2=c+d=2e
LET x=w2/2 !x=w3/3
LET y=w1-x
PRINT "x=";x; "y=";y; "偽B"
ELSEIF 2*(w3-w2)=w1 THEN !e=b=d=aより、w3-w2=(a+c+e)-(c+d)=a+e-d=e、w1=a+b=2e
LET x=w1/2 !x=w3-w2
LET y=w2-x !y=w3-w1
PRINT "x=";x; "y=";y; "偽C"
ELSEIF 2*(w3-w1)=w2 THEN !e=b=d=cより、w3-w1=(a+c+e)-(a+b)=c+e-b=e、w2=c+d=2e
LET x=w2/2 !x=w3-w1
LET y=w1-x !y=w3-w2
PRINT "x=";x; "y=";y; "偽A"
ELSE
PRINT "論理エラー"
END IF
END IF
END
●パチンコ玉が6個の場合
LET a=2
LET b=2
LET c=2
LET d=2
LET e=3
LET f=2
LET w1=a+b+c+d
LET w2=a+b +e
PRINT "w1=";w1; "w2=";w2 !debug
IF 3*w1=4*w2 THEN !eが偽 ※a=b=c=d=eより
LET w3=f
PRINT "w3=";w3 !debug
LET x=w1/4 !x=w2/3
LET y=w3
PRINT "x=";x; "y=";y; "偽F"
ELSE
LET w3=a+c
PRINT "w3=";w3 !debug
LET p=w1-w2 !w1-w2=(a+b+c+d)-(a+b+e)=c+d-e
LET q=w2-w3 !w2-w3=(a+b+e)-(a+c)=b+e-c
LET r=w1-w3 !w1-w3=(a+b+c+d)-(a+c)=b+d
PRINT "p=";p; "q=";q; "r=";r !debug
IF p=q THEN !f=b=c=d=eより、p=c+d-e=f+f-f=f、q=b+e-c=f+f-f=f
LET x=p
LET y=w3-x
PRINT "x=";x; "y=";y; "偽A"
ELSEIF 2*p=w3 THEN !f=a=c=d=eより、p=c+d-e=f+f-f=f、w3=a+c=f+f=2f
LET x=p
LET y=r-x
PRINT "x=";x; "y=";y; "偽B"
ELSEIF 3*r=2*w2 THEN !f=a=b=d=eより、r=b+d=f+f=2f、w2=a+b+e=f+f+f=3f
LET x=r/2
LET y=w3-x
PRINT "x=";x; "y=";y; "偽C"
ELSEIF 2*w2=3*w3 THEN !f=a=b=c=eより、w2=a+b+e=f+f+f=3f、w3=a+c=f+f=2f
LET x=w3/2
LET y=r-x
PRINT "x=";x; "y=";y; "偽D"
ELSEIF 2*w1=4*w3 THEN !f=a=b=c=dより、w1=a+b+c+d=f+f+f+f=4f、w3=a+c=f+f=2f
LET x=w1/4
LET y=w2-2*x
PRINT "x=";x; "y=";y; "偽E"
ELSE
PRINT "論理エラー"
END IF
END IF
!1回目 差は1
LET P=1 !取る枚数
LET A=1 !持っている枚数
PRINT "1回: Aが取る枚数=";P; " 持っている枚数=";A
!2回目 差は2
LET Q=3
LET B=3
PRINT "2回: Bが取る枚数=";Q; " 持っている枚数=";B
!3回目以降
LET K=2 !回数
DO
LET K=K+1
IF MOD(K,2)=1 THEN !奇数回はAの番
LET P=P+4
LET A=A+P
PRINT STR$(K);"回: Aが取る枚数=";P; " 持っている枚数=";A
ELSE !Bの番
LET Q=Q+4
LET B=B+Q
PRINT STR$(K);"回: Bが取る枚数=";Q; " 持っている枚数=";B
END IF
LOOP UNTIL ABS(A-B)=31 !条件を満たすまで
PRINT K;"回"
PRINT "A=";P; "枚数="; A
PRINT "B=";Q; "枚数="; B
PRINT
!その２ シミュレーション
LET A=0 !1つ前の結果
LET B=0
LET K=0 !回数
DO
LET K=K+1
LET T=2*K-1 !取る枚数
IF MOD(K,2)=1 THEN !奇数回はAの番
LET A=T-B
PRINT STR$(K);"回: Aが取る枚数=";T; " 差=";A
ELSE !Bの番
LET B=T-A
PRINT STR$(K);"回: Bが取る枚数=";T; " 差=";B
END IF
LOOP UNTIL A=31 OR B=31 !条件を満たすまで
PRINT K;"回"
IF MOD(K,2)=1 THEN !奇数回はAの番
PRINT "A=";2*K-1; "枚数="; K*(K+1)/2
PRINT "B=";2*K-3; "枚数="; (K-1)*K/2
ELSE !Bの番
PRINT "A=";2*K-3; "枚数="; (K-1)*K/2
PRINT "B=";2*K-1; "枚数="; K*(K+1)/2
END IF
EXTERNAL SUB fvPOINT(x,y,S$) !点(x,y)
DRAW disk WITH SCALE(0.5)*SHIFT(x,y) !※大きさは調整が必要である
PLOT TEXT ,AT x+0.5,y+0.5: S$ !※位置は調整が必要である
END SUB
EXTERNAL SUB fvLINE(A,B, P,Q) !直線y=Ax+B, x∈[P,Q]
PLOT LINES: P,A*P+B; Q,A*Q+B
END SUB
!●計算ルーチン
EXTERNAL SUB fvINTERSECTION(A,B,C,D, x,y) !2直線y=Ax+Bとy=Cx+Dとの交点(x,y)を求める
IF A=C THEN
PRINT "2直線は平行です。"; A;C
ELSE
LET x=(D-B)/(A-C)
LET y=A*x+B
END IF
END SUB
EXTERNAL SUB cycle(m,n,k,L) !既約分数m/n（0＜m＜nを満たす整数）の有限小数の桁数kと循環節の長さLを求める
!n/m=0.ab…z{AB…Z} 有限小数0.ab…zはk桁 (k+1)桁からの循環節AB…Zの長さはL
LET x=n
LET p=0 !2^p
DO WHILE MOD(x,2)=0
LET x=x/2
LET p=p+1
LOOP
LET q=0 !5^q
DO WHILE MOD(x,5)=0
LET x=x/5
LET q=q+1
LOOP
LET k=MAX(p,q) !小数点以下k桁は循環しない
IF x=1 THEN !有限小数
LET L=0
ELSE !10^L≡1 MOD n/(2^p*5^q)を満たす最小のLより
LET L=1 !循環節の長さ
LET a=MOD(10,x)
DO WHILE a<>1
LET a=MOD(a*10,x)
LET L=L+1
LOOP
END IF
END SUB
EXTERNAL FUNCTION Num2CombBit(h,N,R) !番号から組合せビットパターンを生成する ※辞書式順序
LET v=h+1
LET j=R
LET A=0
FOR i=N-1 TO 0 STEP -1 !組合せをビット位置とする
LET t=COMB(i,j)
IF v>t THEN
LET A=A+2^i !ビット位置(N-i-1)を１とする
LET j=j-1
LET v=v-t
END IF
NEXT i
LET Num2CombBit=A
END FUNCTION
OPTION ARITHMETIC RATIONAL !有理数モード
DIM F(100),A(100),B(100)
MAT F=ZER
LET A(100)=1/100 !iの値、i以降の和
LET B(100)=A(100)
FOR i=99 TO 1 STEP -1
LET A(i)=1/i !減少列 1/1＞1/2＞1/3＞ … ＞1/100
LET B(i)=A(i)+B(i+1)
NEXT i
LET N=1
CALL try(N,1,A,B,F)
END
EXTERNAL SUB try(N,p,A(),B(),F()) !バックトラック法で検索する
OPTION ARITHMETIC RATIONAL !有理数モード
FOR i=p TO 100 !※cの上限
LET T=N-A(i) !残り
IF T>0 THEN
IF i<100 AND B(i+1)<T THEN EXIT FOR !全部を使って可能性があれば、その部分集合を考える
LET F(i)=1 !使用中とする
CALL try(T,i+1,A,B,F) !有理数tを(i+1)以降で表す
LET F(i)=0 !元に戻す
ELSEIF T=0 THEN !題意を満たすなら
LET k=0
FOR j=1 TO p-1 !式を表示する
IF F(j)=1 THEN
PRINT "1/";STR$(j);"+";
LET k=k+1
END IF
NEXT j
PRINT "1/";STR$(i);" 項数=";k+1
END IF
NEXT i
END SUB
DIM F(0 TO 9) !1から9までの数
FOR N=2 TO 20
PRINT "N=";N
FOR M=1234 TO 9876 !4桁の数
MAT F=ZER
LET F(0)=1 !使用中とする
LET t=M
FOR i=1 TO 4 !10進法4桁
LET w=MOD(t,10)
IF F(w)=1 THEN EXIT FOR !既に使用済み
LET F(w)=1 !使用中とする
LET t=INT(t/10)
NEXT i
IF i>4 THEN !各桁が異なる4桁の数なら
!!!PRINT M !debug
LET t=M*N
IF t>=12345 AND t<=98765 THEN !5桁の数なら
FOR i=1 TO 5
LET w=MOD(t,10)
IF F(w)=1 THEN EXIT FOR
LET F(w)=1
LET t=INT(t/10)
NEXT i
IF i>5 THEN !各桁が異なる5桁の数なら
SUB DEC1_NS
DO
IF BC< BST THEN CALL DEC1_IN
LET W=IP(Hx) ! bits width BST
!----
LET W=A(NA+W,J)
IF 32768<=W THEN EXIT DO
LET NA=W ! nest adr. W=0 table end
LET BC=BC-BST
LET Hx=MOD(Hx*SHb,SHb)
LOOP
LET NA=0 ! DU0L LLLL VVVV VVVV
LET L_=MOD(IP(W/256),128) ! U0L LLLL
LET V_=MOD(W,256) ! VVVV VVVV
IF 16< L_ THEN PRINT "unused code" !BREAK !unused code ! LET V_=BVAL("8000",16)
!----
LET W=MOD(L_,BST)
IF 0< W THEN
LET BC=BC-W
LET Hx=MOD(Hx*2^W,SHb)
ELSE
LET BC=BC-BST
LET Hx=MOD(Hx*SHb,SHb)
END IF
END SUB
SUB DEC1_IN
CALL RED_D
LET W=ORD(D$)
IF W=255 THEN
CALL RED_D
LET M=ORD(D$)
IF M<>0 THEN LET w=1/0 ! EXTYPE=3001, ffxx marker, abnormally break
END IF
LET Hx=Hx+W*2^(BST-8-BC)
LET BC=BC+8
END SUB
!-------
SUB DEC1_EX
LET V_=0
DO
IF L_< 1 THEN EXIT SUB
IF BC< L_ THEN CALL DEC1_IN
LET W=IP(Hx)
!----
IF BST>=L_ THEN EXIT DO
LET V_=V_*SHb+W
LET L_=L_-BST
LET BC=BC-BST
LET Hx=MOD(Hx*SHb,SHb)
LOOP
LET V_=V_*2^L_+IP(W*2^(L_-BST))
!----
LET BC=BC-L_
LET Hx=MOD(Hx*2^L_,SHb)
END SUB
!============
! B(,J)L(,J)<-- DH(,J) for decorder table A(,J)
!
SUB makeH0(J)
LET i=0 ! コード生成 順番(短い順)
LET Hx=0
LET Tx=BVAL("8000",16)
FOR L_=1 TO 16
FOR P=1 TO DH(L_,J)
LET L(i,J)=L_
LET B(i,J)=Hx ! コード(生成順), 座標DV(頻度降順) と同順。
LET i=i+1
LET Hx=Hx+Tx
NEXT P
LET Tx=Tx/2
NEXT L_
LET B(256,J)=0
FOR i=i TO 255
LET L(i,J)=0
LET B(i,J)=0
NEXT i
END SUB
!============
!A(,J)=output decorder table<-- B(,J) L(,J) DH(,J) DV(,J)
!
SUB makeD0(J)
FOR LH=16 TO 1 STEP -1
IF DH(LH,J)<>0 THEN EXIT FOR
NEXT LH !length max. in huffman table
LET LM=CEIL(LH/BST)*BST !length max. bound by BST
!---
LET I=0 !start huffman table adr.
LET LA=0 !line adr.
LET P=BST !start Decord code width
LET U_=2^(16-BST) !start Decord code step
LET NC=0 !next start Decord code
DO
LET D_=NC !start Decord code
LET NC=-1
LET LB=LA+(65536-D_)/U_ !1st nest adr.
DO
CALL SERCH
IF 0< L_ THEN
LET A(LA,J)= BVAL("8000",16)+L_*256+DV(I,J) !b15=end. +L.+V.
ELSEIF P=LM THEN
LET A(LA,J)= BVAL("C000",16)+LH*256 !b15=end. b14=Unused. +L.
ELSE
IF NC=-1 THEN LET NC=D_
LET A(LA,J)=LB !nest adr.
LET LB=LB+SHb !next nest adr.
END IF
LET D_=D_+U_
LET LA=LA+1
LOOP UNTIL IP(D_)=65536
LET P=P+BST
LET U_=U_/SHb !shr(U_,BST)
LOOP UNTIL P>LM
!---
FOR LA=LA TO 255
LET A(LA,J)=0 !(0),table stop mark
NEXT LA
END SUB
SUB SERCH
FOR I=I TO DH(0,J)-1
LET L_=L(I,J)
IF L_<=P THEN LET w=IP(D_/2^(16-L_))*2^(16-L_) ELSE EXIT FOR
IF w<=B(I,J) THEN
IF w=B(I,J) THEN EXIT SUB ELSE EXIT FOR
END IF
NEXT I
LET L_=-1
END SUB
!===========
! Inverse Fast Cosin Transform.( 8x8, iDCT-2 ) ← Inverse Quantization.DQ()
SUB IDDCT8X8
FOR P=0 TO CMO !(0=Y,1=Cb,2=Cr)
FOR V0=0 TO DV_-1 STEP 8*MV(0)/MV(P)
FOR U0=0 TO DU-1 STEP 8*MH(0)/MH(P)
!----decord one of MCU( Minimum Coded Unit)
FOR Y_=0 TO 7
FOR X_=0 TO 7
LET x(X_)=D2(U0+X_,V0+Y_,P)*DQ(X_,Y_,QS(P)) !Inverse Quantization
NEXT X_
CALL IWANG !inverse DCT horizontal_row_8
FOR X_=0 TO 7
LET T(X_,Y_)=x(X_)
NEXT X_
NEXT Y_
!---
FOR X_=0 TO 7
FOR Y_=0 TO 7
LET x(Y_)=T(X_,Y_)
NEXT Y_
CALL IWANG !inverse DCT vertical_column_8
LET i=X_*MH(0) !expand pt.X
FOR Y_=0 TO 7
IF P=0 THEN
LET D1(U0+X_,V0+Y_,P)=x(Y_)+128 !inverse level shift
ELSE
LET j=Y_*MV(0) !expand pt.Y
!----expand
FOR V_=j TO j+MV(0)-1
FOR U_=i TO i+MH(0)-1
LET D1(U0+U_,V0+V_,P)=x(Y_) !CbCr to MCU scale
NEXT U_
NEXT V_
!----expand
END IF
NEXT Y_
NEXT X_
!----
NEXT U0
NEXT V0
NEXT P
END SUB
!----inverse Wang.( 8, iDCT-2 )
SUB IWANG
LET xo(0)=SQR(2/8)*x(0)
LET xo(1)=SQR(2/8)*x(4)
LET xo(2)=SQR(2/8)*x(2)
LET xo(3)=SQR(2/8)*x(6)
LET xo(4)=SQR(1/8)*x(1)
LET xo(5)=SQR(1/8)*x(5)
LET xo(6)=SQR(1/8)*x(3)
LET xo(7)=SQR(1/8)*x(7)
!
LET x(4)=(COS(PI /16)*xo(4)+SIN(PI /16)*xo(7))
LET x(5)=(COS(PI*5/16)*xo(5)+SIN(PI*5/16)*xo(6))
LET x(6)=(SIN(PI*5/16)*xo(5)-COS(PI*5/16)*xo(6))
LET x(7)=(SIN(PI /16)*xo(4)-COS(PI /16)*xo(7))
!
LET xo(4)= x(4)+x(5)
LET xo(5)= x(4)-x(5)
LET xo(6)=-x(6)+x(7)
LET xo(7)= x(6)+x(7)
!
LET x(0)=(COS(PI/4)*xo(0)+COS(PI /4)*xo(1))
LET x(1)=(COS(PI/4)*xo(0)-COS(PI /4)*xo(1))
LET x(2)=(SIN(PI/8)*xo(2)-SIN(PI*3/8)*xo(3))
LET x(3)=(COS(PI/8)*xo(2)+COS(PI*3/8)*xo(3))
LET x(4)=xo(4)
LET x(5)=xo(6)
LET x(6)=xo(5)
LET x(7)=xo(7)
!
LET xo(0)=x(0)+x(3)
LET xo(1)=x(1)+x(2)
LET xo(2)=x(1)-x(2)
LET xo(3)=x(0)-x(3)
LET xo(4)=x(7)*SQR(2)
LET xo(5)=x(6)-x(5)
LET xo(6)=x(6)+x(5)
LET xo(7)=x(4)*SQR(2)
!
LET x(0)=xo(0)+xo(7)
LET x(1)=xo(1)+xo(6)
LET x(2)=xo(2)+xo(5)
LET x(3)=xo(3)+xo(4)
LET x(4)=xo(3)-xo(4)
LET x(5)=xo(2)-xo(5)
LET x(6)=xo(1)-xo(6)
LET x(7)=xo(0)-xo(7)
END SUB
!=============
SUB R_BIN31(M) ! decord(M) before new.search(M)
DO
IF M=BVAL("D8",16) THEN ! SOI
MAT DH=ZER ! clear Huffman Table
LET DRI=0 ! clear Restart Interval.value for RST0~7(restart marker)
LET rct=-1 ! Interval.counter, valid (0<=rct), invalid (rct< 0)
MAT M3=ZER ! clear scan band sum
ELSEIF M=BVAL("D9",16) THEN ! EOI
EXIT DO ! close & end_sub
ELSEIF BVAL("D0",16)<=M AND M<=BVAL("D7",16) THEN ! RST0~7( restart marker)
LET rct=DRI ! set counter with Restart Interval
EXIT SUB
ELSEIF 0< M THEN !M=0 is data"FF" in picture area
CALL RED_D
LET N=ORD(D$)*256
CALL RED_D
LET N=N+ORD(D$)-2 ! N=remain size
!---
IF BVAL("E0",16)<=M AND M<=BVAL("EF",16) THEN ! APP0~APP15
CALL FFE0
ELSEIF M=BVAL("DD",16) THEN
CALL FFDD ! DRI load DRI & rct=DRI
ELSEIF M=BVAL("FE",16) THEN
CALL FFFE ! COMMENT
ELSEIF M=BVAL("C4",16) THEN
CALL FFC4 ! DHT
ELSEIF M=BVAL("DB",16) THEN
CALL FFDB ! DQT
ELSEIF M=BVAL("C0",16) OR M=BVAL("C2",16) THEN
PRINT right$("000"& BSTR$(byt-4,16),4)
!---
CALL FFC0 ! SOF0 SOF2
!---
PRINT " SOF";STR$(MOD(M,16));" MCU_HV Ybr ";STR$(MH(0));STR$(MV(0));
PRINT " ";STR$(MH(1));STR$(MV(1));" ";STR$(MH(2));STR$(MV(2))
ELSEIF M=BVAL("DA",16) THEN
CALL FFDA ! SOS
EXIT SUB ! without close
ELSE
BREAK ! new marker
END IF
END IF
!---
DO
LET M=BVAL("D9",16) ! EOI, 256 ! end of file
CHARACTER INPUT #1,IF MISSING THEN EXIT DO :D$
LET byt=byt+1 !!!
LET M=ORD(D$)
LOOP UNTIL M=255 ! 1st.mark
IF M<>255 THEN EXIT DO ! close & end_sub
CALL RED_D
LET M=ORD(D$)
LOOP
CLOSE #1
END SUB
!DRI
SUB FFDD
CALL RED_D
LET DRI=ORD(D$)*256
CALL RED_D
LET DRI=DRI+ORD(D$)
LET rct=DRI
END SUB
!APP0
SUB FFE0
FOR W=1 TO N
CALL RED_D
NEXT W
END SUB
!COMMENT
SUB FFFE
FOR W=1 TO N
CALL RED_D
NEXT W
END SUB
!DQT
SUB FFDB
DO WHILE 0< N
CALL RED_D
LET w= IP(ORD(D$)/16) !p=0(byte) p=1(word)
LET J=MOD(ORD(D$),16) !J=0~3 (QT.number)
FOR i=0 TO 63
CALL RED_D
LET DQ(U(i),V(i),J)=ORD(D$)
IF w=1 THEN
CALL RED_D
LET DQ(U(i),V(i),J)=DQ(U(i),V(i),J)*256+ORD(D$)
END IF
NEXT i
LET N=N-65-64*w ! remain size
LOOP
END SUB
!SOF0 SOF2
SUB FFC0
CALL RED_D
IF ORD(D$)<>8 THEN BREAK ! 8bit( 24bitColor ) at RGB.dimension
CALL RED_D
LET W=ORD(D$)*256
CALL RED_D
LET DY=W+ORD(D$) !V.pix.
CALL RED_D
LET W=ORD(D$)*256
CALL RED_D
LET DX=W+ORD(D$) !H.pix.
CALL RED_D
FOR i=0 TO ORD(D$)-1 !1~3 フレーム数、続くID 配置は、暗黙に Y,Cb,Cr の順
CALL RED_D
LET CoID(ORD(D$))=i ! CoID( ID=0~255) <--(Y=0, Cb=1, Cr=2)
CALL RED_D
LET MH(i)= IP(ORD(D$)/16) ! HV Y=11,12,21,22,41 Cb=11,11,11,11,11 Cr=11,11,11,11,11
LET MV(i)=MOD(ORD(D$),16)
CALL RED_D
LET QS(i)=ORD(D$) ! QT.number0~3 <-- QS( Y=0, Cb=1, Cr=2)
NEXT i
IF i=1 THEN LET CMO=0 ELSE LET CMO=2
END SUB
!DHT
SUB FFC4
DO WHILE 0< N
CALL RED_D
LET J=ORD(D$) ! (DC=0 AC=1 | ID0_0~3)
LET J=2*MOD(J,16)+IP(J/16) ! 0~1=ID0.DC~AC 2~3=ID1.DC~AC 4~5=ID2.…
LET DH(0,J)=0 !!!for 2nd.use for clear
FOR i=1 TO 16
CALL RED_D
LET DH(i,J)=ORD(D$)
LET DH(0,J)=DH(0,J)+DH(i,J)
NEXT i
FOR i=0 TO DH(0,J)-1
CALL RED_D
LET DV(i,J)=ORD(D$)
NEXT i
!---
FOR i=i TO 255
LET DV(i,J)=0
NEXT i
CALL makeH0(J) ! make Huffman Code table B() L()
CALL makeD0(J) ! make Huffman Decorder table A()
!---
LET N=N-1-16-DH(0,J) ! remain size
LOOP
END SUB
!SOS
SUB FFDA
CALL RED_D
LET M2=ORD(D$)
MAT HDC=(-2)*CON
MAT HAC=(-2)*CON
FOR i=1 TO M2
CALL RED_D ! ID=0~255( defined by SOFx)
LET w=ORD(D$)
CALL RED_D ! (DC_0~3|AC_0~3) huffman table selection
LET HDC(CoID(w))= IP(ORD(D$)/16)*2 !DC 0~3-->0,2,4,6
LET HAC(CoID(w))=MOD(ORD(D$),16)*2+1 !AC 0~3-->1,3,5,7
NEXT i
CALL RED_D
LET Ss_=ORD(D$) ! low of spectral selection
CALL RED_D
LET Se_=ORD(D$) ! high of spectral selection
CALL RED_D
LET Al=MOD(ORD(D$),16) !successive approximation bit position low ( point transform )
LET Ah=IP(ORD(D$)/16) !successive approximation bit position high ( preceding "Al" )
!--- balance monitor M30 M3() for display timing.
LET w=Se_-Ss_+1
IF Ah<>Al THEN LET w=w*(Ah-Al) ! prog.sa
FOR i=0 TO 2
IF 0<=HAC(i) THEN LET M3(i)=M3(i)+w ! M3()= scan band sum
NEXT i
IF CMO=0 OR M3(0)=M3(1) AND M3(1)=M3(2) THEN LET M30=M3(0) ELSE LET M30=99 ! Ybr.balance
!--- next image data top
END SUB
!************************************************************
!訂正版：十進 BASIC による プログレッシブ JPG の展開と画像化。
!
!プログレッシブ JPG 再生過程の画像は、最初のＤＣ成分１枚だけ と、最終完成画、全２枚とした。
!Baseline JPG は、全１枚なので、画数で両者を区別できる。（ 描画倍率は、１又は、２倍拡大）
!（必要なら、再生過程 全ての画像も、表示できるよう、SUB IZZRL0 に注釈行がある）
!
!大きな再生画像でも、縮尺を止め、１倍又は、極小な場合の２倍拡大のみにした。
!色差成分 Cb Cr の間引き走査復元の塗潰しは、SUB IDDCT8X8 に組み込み。
!
!具体的、可視的なプログラムで、実行し画像化するので、詳細事項の追跡と御参考に。
!再生できるファイルは、1000x1000 までの JPG だけで、
! baseline , spectral selection , successive approximation の３種類( web 上の、ほぼ全種)
!
!
!１）successive approximation AC.subsequence（Y,Cb,Cr 別々、１bit づつの処理）
! 0 でない追加データ extend (1bit) が 1st.scan も 0 の初めてのデーターになるまで、
! Zero-RUN を続ける。
! その間の、上位桁<>0 の 1st.scan 値 追加データーは、その個数分が、
! extend. に後続している。Zero-RUN 個数 の 0 の次の 0 の位置に、extend.を置く。
! ここでの extend. は group 1 だけで、(0,1) → (-1,+1)
!
! 0 1 1 0 0 0 0 0 0 ？
! 0 0 0 0 0 1 0 0 0 ？
! 0 1 0 0 0 0 0 1 0 ？
! 0 1 1 0 0 1 0 1 0 ？
! 0 1 1 0 0 1 0 1 0 ？
! --------------------------------------------------------------------------
! ±1 b1 b2 0 0 b3 0 b4 ±1 ？
! 前の終り RRRR RRRR RRRR extend. 次の始め
!
! huffman.
! RRRRssss extend. b1 b2 b3 b4 … bit_stream=？何個になるかは、
! 3 1 (0 or 1) (0 or 1) 上位桁 =0 の係数が RRRR 個 になるまでに
! ↓ ↓ 通過した上位桁 <>0 の個数。上図では、４
!
! 新規(上位桁無) エンコーダー側ＡＣ処理 point transform は、
! の復号 0 → -1 "divide by 2^AL" なので
! 1 → +1 0 → 無変化。
! 1 → ±符号は上位桁に合せて加算。(絶対値が＋1)
!
!
!２）successive approximation DC.subsequence（Y,Cb,Cr 別々、１bit づつの処理）
! ハフマン・コード RRRRssss 部は、存在せず、
! 頭からの bit_stream.で、１bit づつ、全てのblock の DC係数 に加える。
!
! エンコーダー側ＤＣ処理 point transform は、
! "arithmetic-shift-right AL" なので
! 0 → 無変化。
! 1 → 上位桁符号に関らず、＋加算。(符号無し整数値が＋1)
!
!
! ※AL･･･ 係数などの数値が、2^AL のステップ幅で 量子化された値 になっている意。
! ※AH･･･ preceding AL. 同じ BAND で直前の AL 値 (AH=0 は、最初の AL に添える)
!
! (Ah|Al)
! ←──┐ 0 0 全bits のデータ。復元は、(･･･111111.)*2^( point transform =0)
! ･･･111111
!
! 以下３つを加算すると、上と同じになる。
! (Ah|Al)
! ←─┐ 0 2 上位bits のデータ。 復元は、(･･･1111 )*2^( point transform =2)
! ･･･1111xx
! 〟 2 1 1bitづつ、分けて追加。復元は、( 1 )*2^( point transform =1)
! ･･･xxxx1x
! 〟 1 0 復元は、( 1)*2^( point transform =0)
! ･･･xxxxx1
!
!------------------------
DEBUG ON
!------------------------
!JPG.decoder
! Baseline
! Progressive( spectral selection )( successive approximation )
!------------------------
OPTION ARITHMETIC NATIVE
OPTION BASE 0
OPTION CHARACTER byte
SET TEXT background "OPAQUE"
SET ECHO "OFF"
SET COLOR MODE "NATIVE"
!
DIM D8(1000,1000) !MAIN65
DIM D2(1000,1000,2) !Y=D2(,,0) Cb=D2(,,1) Cr=D2(,,2)
DIM D1(1000,1000,2) !Y=D2(,,0) Cb=D2(,,1) Cr=D2(,,2)
DIM MH(2),MV(2) !R_BIN31 SOF0 MCU.Ybr.H()V()
DIM HDC(2),HAC(2) !R_BIN31 hT.table selection
DIM QS(2),CoID(255) !R_BIN31 qT.table selection
DIM M3(2)
!
DIM U(63),V(63) !zigzag
DIM DQ(7,7,3) !blk8x8 DQT
DIM DH(16,7),DV(255,7) !DHT
DIM B(255+1,7),L(255,7) !encorder & decorder's pre_table, length, ( MAKE_H2,MAKE_H0)
DIM A(2000,7) !decorder
DIM B2(2) !Ybr D.C.成分 starting & back_level for difference
DIM T(7,7),x(7),xo(7) !DDCT8X8, IDDCT8X8
!
LET BST=2 !huffman decorder's bit step 1=8.5s 2=6.5s 4=8.0s 8=50.0s
LET SHb=2^BST !huffman decorder n*SHb=(shl n,BST) n/SHb=(shr n,BST)
!
!---zigzag table
FOR V_=0 TO 7
FOR U_=0 TO 7
READ i
LET U(i)=U_
LET V(i)=V_
NEXT U_
NEXT V_
DATA 0, 1, 5, 6,14,15,27,28
DATA 2, 4, 7,13,16,26,29,42
DATA 3, 8,12,17,25,30,41,43
DATA 9,11,18,24,31,40,44,53
DATA 10,19,23,32,39,45,52,54
DATA 20,22,33,38,46,51,55,60
DATA 21,34,37,47,50,56,59,61
DATA 35,36,48,49,57,58,62,63
!
DO
FILE GETNAME FL$, "jpg"
IF FL$="" THEN
PRINT "入力ファイル名無し"
EXIT DO
END IF
PRINT "入力ファイル："& FL$
!---
CLEAR
CALL IZZRL0 ! D2()<-- decord JPG
PRINT "次のファイル[ 左クリック ]"
beep
DO
MOUSE POLL j,i,mlb,mrb !CHARACTER INPUT CLEAR: w$
WAIT DELAY 0
LOOP UNTIL 0< mlb OR 0< mrb
LOOP UNTIL 0< mrb
PRINT "終了。"
!-------- IZZRL0 call here for display D2()
SUB MAIN65
LET tester=TIME
PRINT "画像の準備中、";
CALL IDDCT8X8 ! D1()<-- iDCT<-- iDQT<-- D2()
!------ JPG 色空間 ----------------------------
! | Y | | 0.2990 +0.5870 +0.1140 | | R |
! |B-Y| = |-0.1687 -0.3313 +0.5000 | | G |
! |R-Y| | 0.5000 -0.4187 -0.0813 | | B |
!
! | R | | 1 0 +1.40200 | | Y |
! | G | = | 1 -0.34414 -0.71414 | |B-Y|
! | B | | 1 +1.77200 0 | |R-Y|
!----------------------------------------------
FOR V0=0 TO DY-1
FOR U0=0 TO DX-1
!--- RGB<-- Ybr
LET w1=IP(D1(U0,V0,0) +1.40200*D1(U0,V0,2)) !R
LET w2=IP(D1(U0,V0,0) -0.34414*D1(U0,V0,1) -0.71414*D1(U0,V0,2)) !G
LET w3=IP(D1(U0,V0,0) +1.77200*D1(U0,V0,1)) !B
IF w1< 0 THEN
LET w1=0
ELSEIF 255< w1 THEN
LET w1=255
END IF
IF w2< 0 THEN
LET w2=0
ELSEIF 255< w2 THEN
LET w2=255
END IF
IF w3< 0 THEN
LET w3=0
ELSEIF 255< w3 THEN
LET w3=255
END IF
LET D8(U0,V0)=w3*65536+w2*256+w1 !（逆）BGR
NEXT U0
NEXT V0
PRINT TRUNCATE(TIME-tester,2);"秒"
!!! LET w=1 !等倍で描画、画素数どうり。
LET w=IP( MIN( 500/DX, 500/DY)) !整数倍拡大、１～２の何れかで描画。
IF 2< w THEN LET w=2
IF w< 1 THEN LET w=1
PRINT "描画の倍率=";w
CALL scrns(DX*w, DY*w)
MAT PLOT CELLS,IN 1,1; DX*w, DY*w :D8
END SUB
SUB scrns(px,py)
SET bitmap SIZE px+50,py+50
SET WINDOW 1-20,px+30, py+27,1-23
SET LINE COLOR "cyan"
SET LINE width 3
PLOT LINES:1-3,1-3;px+3,1-3;px+3,py+3;1-3,py+3;1-3,1-3
PLOT TEXT,AT -3,-4: "原画 "& STR$(px/w)& "x"& STR$(py/w)& " 倍率= "& STR$(w)
END SUB
!========================
!inverse haffman Transform.
SUB IZZRL0
LET byt=0 !!!
CALL ROPEN ! FL$
!---
CALL R_BIN31(0) !A() B(i,J)L(i,J)<-- DH(), return at img.top
PRINT right$("000"& BSTR$(byt,16),4) !!!
PRINT "(";STR$(DX);"x";STR$(DY);
!---
MAT D8=ZER(DX-1,DY-1) !MAIN65
LET i=8*MH(0) !MCU Y.Hsize
LET j=8*MV(0) !MCU Y.Vsize
LET DUM=CEIL(DX/i)*i !Uwidth=bound by MCU Y.Hsize
LET DVM=CEIL(DY/j)*j !Vwidth=bound by MCU Y.Vsize
MAT D1=ZER(DUM-1,DVM-1,2) !Y=D1(,,0) Cb=D1(,,1) Cr=D1(,,2)
MAT D2=ZER(DUM-1,DVM-1,2) !Y=D2(,,0) Cb=D2(,,1) Cr=D2(,,2)
LET MH_=MH(0)
LET MV_=MV(0)
LET DU =DUM !Uwidth=bound by MCU Y.Hsize
LET DV_=DVM !Vwidth=bound by MCU Y.Vsize
LET DU8=CEIL(DX/8)*8 !Uwidth=bound by block Y.Hsize
LET DV8=CEIL(DY/8)*8 !Vwidth=bound by block Y.Vsize
!---
PRINT "/ ";STR$(DU8);",";STR$(DV8);"/ ";STR$(DUM);",";STR$(DVM);")"
CALL frame
!---
PRINT "M3()=";M3(0);M3(1);M3(2)
CALL MAIN65 ! Baseline.最終、Progressive.1st.
!---
IF 0< M THEN PRINT " (";STR$(DX);"x";STR$(DY);"/";STR$(U0);",";STR$(V0);") ";debug$;" abort by ";BSTR$(M,16) !!!
PRINT right$("000"& BSTR$(byt-2*SGN(M),16),4) !!!
CALL R_BIN31(M) ! return at img.top, or EOI
!---
DO WHILE M=BVAL("DA",16) !SOS
IF 0<=HAC(0) THEN
LET MV(0)=1
LET MH(0)=1
LET DU=DU8
LET DV_=DV8
END IF
CALL frame
LET MV(0)=MV_
LET MH(0)=MH_
LET DU=DUM
LET DV_=DVM
!---
PRINT "M3()=";M3(0);M3(1);M3(2) !文末参照：M30<>99(balance), M30=99(un-balance)
IF M30=0 OR M30=64 THEN CALL MAIN65 !Progressive.最終スキャン後の画像
!IF M30<>99 THEN CALL MAIN65 !Progressive.各スキャン毎、Ybr 揃った画像のみ
!CALL MAIN65 !Progressive.各スキャン毎、全画像
!---
IF 0< M THEN PRINT " (";STR$(DX);"x";STR$(DY);"/";STR$(U0);",";STR$(V0);") ";debug$;" abort by ";BSTR$(M,16) !!!
PRINT right$("000"& BSTR$(byt-2*SGN(M),16),4)
CALL R_BIN31(M) ! return at img.top
LOOP
CLOSE #1 ! FL$
END SUB
SUB reset0
LET B2(0)=0 !ROUND( YDC0/DQ(0,0,QS(0)) ) !prediction YDC.( 1st.reference level)
LET B2(1)=0 !prediction CbDC.
LET B2(2)=0 !prediction CrDC.
LET Hx=0 !bits stream input buffer 0~(7+8)bits, use fraction
LET BC=0 !stored bits in Hx
LET NA=0 !nest adr. in A()
LET EOB=0 !counter( end_of_band)
LET M=0
LET ext=0
END SUB
SUB frame
PRINT " Ss Se AhAl: ";Ss_;Se_;STR$(Ah);STR$(Al)
PRINT " Y HDC HAC: ";IP(HDC(0)/2);IP(HAC(0)/2)
PRINT " Cb : ";IP(HDC(1)/2);IP(HAC(1)/2)
PRINT " Cr : ";IP(HDC(2)/2);IP(HAC(2)/2)
CALL reset0
!---
FOR V09=0 TO DV_-1 STEP 8*MV(0)
FOR U09=0 TO DU-1 STEP 8*MH(0)
IF rct=0 THEN
CALL R_BIN31(0) ! read marker
IF rct<>DRI THEN BREAK ! not RST0~7
CALL reset0 ! Restart
END IF
CALL MCUxx11 ! read picture data
LET rct=rct-1
!---
IF 0< ext THEN
IF ext=103001 THEN
PRINT "abort marker ";BSTR$(M,16)
IF BVAL("D0",16)<=M AND M<=BVAL("D7",16) THEN ! RST0~7( restart marker)
LET rct=DRI ! set counter
CALL reset0 ! Restart
ELSE
EXIT SUB ! others marker
END IF
ELSE
PRINT "file error. display fragment"
LET M=BVAL("D9",16) ! EOI
EXIT SUB
END IF
END IF
NEXT U09
NEXT V09
IF 0< EOB THEN PRINT "EOBn over frame";EOB !!!
END SUB
SUB MCUxx11
!---read MCU
FOR P=0 TO CMO
IF 0<=HDC(P) OR 0<=HAC(P) THEN
FOR V0=V09 TO V09+8*MV(P)-1 STEP 8
FOR U0=U09 TO U09+8*MH(P)-1 STEP 8
WHEN EXCEPTION IN
IF EOB=0 THEN CALL R_BLK0 ELSE LET EOB=EOB-1
USE
LET ext=EXTYPE
EXIT SUB
END WHEN
!---extend bitmap
IF 0< Ah AND 0< Se_ THEN
FOR i=A_ TO Se_
IF D2(U0+U(i),V0+V(i),P)<>0 THEN
LET L_=1
WHEN EXCEPTION IN
CALL DEC1_EX
USE
LET ext=EXTYPE
EXIT SUB
END WHEN
LET V_=SGN(D2(U0+U(i),V0+V(i),P))*V_
LET D2(U0+U(i),V0+V(i),P)=D2(U0+U(i),V0+V(i),P) +V_*2^Al
END IF
NEXT i
LET A_=Ss_
END IF
!---
NEXT U0
NEXT V0
END IF
NEXT P
END SUB
!------
SUB R_BLK0
IF Ss_=0 THEN
!===D.C.part
LET debug$="DC.huffman" !!!
IF Ah=0 THEN
!-----baseline.progSS.progSA(1st.scan).
LET J=HDC(P) !huffman D.C.table selection P( 0=Y 1=Cb 2=Cr)
CALL DEC1_NS
LET EL=V_ !extent length
!---D.C.extent
LET debug$="DC.huffman extend" !!!
IF 0< EL THEN
LET L_=EL
CALL DEC1_EX !keep EL, V_=extent value( length EL bits)
LET W=2^(EL-1) !minimum in EL bits length
IF V_< W THEN LET V_=V_-W*2+1 !restore signed value
LET B2(P)=B2(P)+V_*2^Al !point transform, integrate to D.C.
END IF
LET D2(U0+U(0),V0+V(0),P)=B2(P)
ELSE
!-----progSA(2st.scan).
LET L_=1
CALL DEC1_EX
!!! LET V_=SGN(D2(U0+U(0),V0+V(0),P))*V_
LET D2(U0+U(0),V0+V(0),P)=D2(U0+U(0),V0+V(0),P) +V_*2^Al
END IF
!===A.C.parts
LET Sa_=1
ELSE
!===A.C.parts
LET Sa_=Ss_
END IF
IF Se_=0 THEN EXIT SUB !band Ss_~Se_
LET J=HAC(P) !huffman A.C.table selection P( 0=Y 1=Cb 2=Cr)
LET debug$="AC.huffman" !!!
FOR A_=Sa_ TO Se_
CALL DEC1_NS
LET EL=MOD(V_,16) !extent length
LET RL= IP(V_/16) !run length
!---
IF RL<=14 AND EL=0 THEN !End Of Block(00). End Of Band n(10,20,,E0)
!---EOBn extend
LET debug$="EOBn extend"& STR$(RL) !!!
IF 0< RL THEN
LET L_=RL !RL= 1,2,,E (EOB1, EOB2, ･･･, EOB14)
CALL DEC1_EX !keep RL, run_length= V_+2^RL
LET EOB=V_+2^RL -1 !※-1 (1st.count)
END IF
EXIT SUB
!---
END IF
!---RL=(0~15)EL=(1~10), RL=(15)EL=(0)
LET debug$="AC.huffman extend" !!!
IF Ah=0 THEN
!-----baseline.progSS.progSA(1st.scan).
LET A_=A_+RL !skip zero_run_length 0~15
!---A.C.extent
IF 0< EL THEN !ZRL(16) only skip
LET L_=EL
CALL DEC1_EX !keep EL, V_=extent value( length EL bits)
LET w=2^(EL-1) !minimum in EL bits length
IF V_< w THEN LET V_=V_-w*2+1 !restore signed value
LET D2(U0+U(A_),V0+V(A_),P)=V_*2^Al !point transform
END IF
ELSE
!-----progSA(2st.scan).
IF 0< EL THEN !ZRL(16) only skip
LET L_=EL
CALL DEC1_EX !keep EL, V_=extent value( length EL bits)
IF EL<>1 THEN PRINT "AC.2nd.=";EL;V_ !!!
LET V01=V_
END IF
FOR i=A_ TO Se_
IF D2(U0+U(i),V0+V(i),P)<>0 THEN !zz(k)=xxx_1?/0?
LET L_=1
CALL DEC1_EX
LET V_=SGN(D2(U0+U(i),V0+V(i),P))*V_
LET D2(U0+U(i),V0+V(i),P)=D2(U0+U(i),V0+V(i),P) +V_*2^Al
ELSEIF RL=0 THEN !zz(k)=000_V01
EXIT FOR
ELSE !zz(k)=000_0 ,zero run
LET RL=RL-1
END IF
NEXT i
IF 0< EL THEN !ZRL(16) skip
IF V01=0 THEN LET V01=-1 !group1( -1, 1)
LET D2(U0+U(i),V0+V(i),P)=V01*2^Al
END IF
LET A_=i
END IF
NEXT A_
END SUB
FOR n=1 TO 60
PRINT n;":"; F2(n,INT(n/3)); F3(n,INT(n/6)); F4(n,INT(n/10)); F5(n,INT(n/15))
NEXT n
END
!a+2b=n、a≧b≧0、Σab=Σ[b=1,[n/3]]b*(n-2b)
EXTERNAL FUNCTION F2(n,k) !Σ[i=1,k]i(n-2i)
LET S=0
FOR i=1 TO k
LET S=S+i*(n-2*i)
NEXT i
LET F2=S
END FUNCTION
!a+2b+3c=n、a≧b≧c≧0、Σabc=Σ[c=1,[n/6]] c*{ Σ[b=c,[(n-3c)/3]] b*((n-3c)-2b) }
EXTERNAL FUNCTION F3(n,k)
LET S=0
FOR i=1 TO k
LET x=n-3*i
LET S=S+i*(F2(x,INT(x/3)) - F2(x,i-1))
NEXT i
LET F3=S
END FUNCTION
EXTERNAL FUNCTION F4(n,k)
LET S=0
FOR i=1 TO k
LET x=n-4*i
LET S=S+i*(F3(x,INT(x/6)) - F3(x,i-1))
NEXT i
LET F4=S
END FUNCTION
EXTERNAL FUNCTION F5(n,k)
LET S=0
FOR i=1 TO k
LET x=n-5*i
LET S=S+i*(F4(x,INT(x/10)) - F4(x,i-1))
NEXT i
LET F5=S
END FUNCTION
LET S=0 !a≧b≧c≧1として考える
FOR C=1 TO INT( N/(1+2+3) ) !n=a+2b+3c≧(1+2+3)cより
FOR B=C TO INT( (N-3*C)/(1+2) ) !n-3c=a+2b≧(1+2)bより
LET A=N-3*C-2*B
IF A< B THEN STOP !論理エラー
PRINT A;B;C !題意を満たす
LET S=S+A*B*C
NEXT B
NEXT C
PRINT "積="; S
LET y=INT(N/6) !f(n)
LET x=INT(N/3)
PRINT y*(y+1)* ( 16*y^3 +3*(5*x-2)*y^2 +(10*x^2 +5*(5-4*N)*x -14)*y -5*x*(4*x^2 +(5-3*N)*x -N+1) +4 )/60
!変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
!「dim a(0 to n) !係数」で定義する
DIM P(0 TO N)
DIM F(0 TO N),G(0 TO N) !p=f/g
MAT F=ZER
MAT G=ZER
DATA 6 !次数 f=x^3(2x^3+x^2+x+1)=2*x^6+x^5+x^4+x^3 ※
DATA 0,0,0,1,1,1,2 !係数 ※展開して次数が小さい方から
READ R
FOR i=0 TO R
READ F(i)
NEXT i
!!!MAT PRINT F; !debug
CALL poly_disp(F) !多項式を表示する
PRINT
DATA 10 !次数 g=(1-x)(1-x^3)^3=x^10-x^9-3x^7+3x^6+3x^4-3x^3-x+1 ※
DATA 1,-1,0,-3,3,0,3,-3,0,-1,1 !係数 ※展開して次数が小さい方から
READ R
FOR i=0 TO R
READ G(i)
NEXT i
!!!MAT PRINT G; !debug
CALL poly_disp(G) !多項式を表示する
PRINT
LET P(0)=F(0)/G(0)/FACT(0) !定数項
PRINT 0; P(0) !debug
DIM F1(0 TO N),G1(0 TO N), W1(0 TO N),W2(0 TO N),W3(0 TO N) !作業用
FOR i=1 TO N !i階微分
LET P(i)=F1(0)/G1(0)/FACT(i) !x^iの係数
PRINT i; P(i) !debug
MAT F=F1 !次へ
MAT G=G1
NEXT i
CALL poly_disp(P) !多項式を表示する
PRINT
END
!変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
!「dim a(0 to n) !係数」で定義する
!演算関連
EXTERNAL SUB poly_add(v1(),v2(), v()) !加算 v=v1+v2
OPTION ARITHMETIC RATIONAL !有理数モード
MAT v=v1+v2
END SUB
EXTERNAL SUB poly_sub(v1(),v2(), v()) !減算 v=v1-v2
OPTION ARITHMETIC RATIONAL !有理数モード
MAT v=v1-v2
END SUB
EXTERNAL SUB poly_mul(v1(),v2(), v()) !乗算 v=v1*v2
OPTION ARITHMETIC RATIONAL !有理数モード
DIM w(0 TO 2*N) !桁数は2倍になる
MAT w=ZER
FOR i=0 TO N !係数
FOR j=0 TO N
LET w(i+j)=w(i+j)+v1(i)*v2(j) !畳み込み
NEXT j
NEXT i
FOR i=0 TO N !※下n桁をコピーする ※オーバーフローは考慮していない
LET v(i)=w(i)
NEXT i
END SUB
EXTERNAL SUB poly_diff(v1(), v()) !微分 v=v1'
OPTION ARITHMETIC RATIONAL !有理数モード
FOR i=1 TO N
LET v(i-1)=v1(i)*i
NEXT i
LET v(N)=0
END SUB
!表示関連
EXTERNAL SUB poly_disp(A()) !多項式を表示する a(X)=ΣAkX^k=AnX^n+An-1X^n-1+…+A1X+A0
OPTION ARITHMETIC RATIONAL !有理数モード
CALL mono_disp(A(N),N)
FOR i=N-1 TO 0 STEP -1 !次項
LET w=A(i)
IF w>0 THEN PRINT "+";
IF w<>0 OR N=0 THEN CALL mono_disp(w,i)
NEXT i
END SUB
EXTERNAL SUB mono_disp(ak,k) !単項式を表示する Ak*X^k
OPTION ARITHMETIC RATIONAL !有理数モード
IF k<>0 THEN !x^nで
IF ak=0 OR ak=1 THEN !係数が0,1なら
ELSEIF ak=-1 THEN !係数が－１なら
PRINT "-"; !符号
ELSE
PRINT STR$(ak);"*";
END IF
END IF
IF k=0 THEN !次数が０なら
PRINT STR$(ak);
ELSEIF k=1 THEN !次数が１なら
PRINT "X";
ELSE
IF ak<>0 THEN PRINT "X^";STR$(k); !係数が0以外なら
END IF
END SUB
DATA 20 !次数 f=6x^20+8x^19+10x^18+12x^17+13x^16+14x^15+17x^14+16x^13+15x^12+8x^11+7x^10+6x^9+3x^8+2x^7+x^6
DATA 0,0,0,0,0,0,1,2,3,6,7,8,15,16,17,14,13,12,10,8,6 !係数 ※展開して次数が小さい方から
DATA 30 !次数 g=x^30-2x^27-3x^24+8x^21+2x^18-12x^15+2x^12+8x^9-3x^6-2x^3+1
DATA 1,0,0,-2,0,0,-3,0,0,8,0,0,2,0,0,-12,0,0,2,0,0,8,0,0,-3,0,0,-2,0,0,1 !係数 ※展開して次数が小さい方から
> !マクローリン展開
> ! P(x)=P(0)+{P'(0)/1!}x+{P''(0)/2!}x^2+{P'''(0)/3!}x^3+ …
> !例
> !P(x)=1/(1-x)=1+x+x^2+x^3+x^4+ …
> !
> !考察
> !P(0)は、x=0を代入して、1/(1-0)=1
> !P'(0)は、
> ! P(x)=f(x)/g(x)より、P'=(f'g-fg')/g^2なので、
> ! 1'(1-x)-1(1-x)'/(1-x)^2=1/(1-x)^2
> ! x=0を代入して、1
> !P''(0)は、
> ! P''(x)=(P'(x))'なので、
> ! 上記の結果をあらためて、f(x)=f'g-fg'、g(x)=g^2と考える。上記と同じ議論を繰り返す。
> !（終り）
>
> OPTION ARITHMETIC RATIONAL !有理数モード
>
> PUBLIC NUMERIC N !次数
> LET N=50
>
> !変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
> !「dim a(0 to n) !係数」で定義する
> DIM P(0 TO N)
> DIM F(0 TO N),G(0 TO N) !p=f/g
> MAT F=ZER
> MAT G=ZER
>
> DATA 6 !次数 f=x^3(2x^3+x^2+x+1)=2*x^6+x^5+x^4+x^3 ※
> DATA 0,0,0,1,1,1,2 !係数 ※展開して次数が小さい方から
> READ R
> FOR i=0 TO R
> READ F(i)
> NEXT i
> !!!MAT PRINT F; !debug
> CALL poly_disp(F) !多項式を表示する
> PRINT
>
> DATA 10 !次数 g=(1-x)(1-x^3)^3=x^10-x^9-3x^7+3x^6+3x^4-3x^3-x+1 ※
> DATA 1,-1,0,-3,3,0,3,-3,0,-1,1 !係数 ※展開して次数が小さい方から
> READ R
> FOR i=0 TO R
> READ G(i)
> NEXT i
> !!!MAT PRINT G; !debug
> CALL poly_disp(G) !多項式を表示する
> PRINT
>
>
> LET P(0)=F(0)/G(0)/FACT(0) !定数項
> PRINT 0; P(0) !debug
>
> DIM F1(0 TO N),G1(0 TO N), W1(0 TO N),W2(0 TO N),W3(0 TO N) !作業用
> FOR i=1 TO N !i階微分
>
> CALL poly_diff(F,W3) !f'g
> CALL poly_mul(W3,G, W1)
> !!!MAT PRINT W1; !debug
>
> CALL poly_diff(G,W3) !fg'
> CALL poly_mul(F,W3, W2)
> !!!MAT PRINT W2; !debug
>
> CALL poly_sub(W1,W2, F1) !分子 f'g-fg'
> !!!MAT PRINT F1; !debug
>
>
> CALL poly_mul(G,G, G1) !分母 g^2
> !!!MAT PRINT G1; !debug
>
>
> LET P(i)=F1(0)/G1(0)/FACT(i) !x^iの係数
> PRINT i; P(i) !debug
>
>
> MAT F=F1 !次へ
> MAT G=G1
> NEXT i
>
> CALL poly_disp(P) !多項式を表示する
> PRINT
>
> END
>
>
> !変数xの多項式 Σ[k=0,n]a(k)*x^k=a(n)*x^n+a(n-1)*x^(n-1)+ … +a(1)*x+a(0)
> !「dim a(0 to n) !係数」で定義する
>
> !演算関連
>
> EXTERNAL SUB poly_add(v1(),v2(), v()) !加算 v=v1+v2
> OPTION ARITHMETIC RATIONAL !有理数モード
> MAT v=v1+v2
> END SUB
>
> EXTERNAL SUB poly_sub(v1(),v2(), v()) !減算 v=v1-v2
> OPTION ARITHMETIC RATIONAL !有理数モード
> MAT v=v1-v2
> END SUB
>
> EXTERNAL SUB poly_mul(v1(),v2(), v()) !乗算 v=v1*v2
> OPTION ARITHMETIC RATIONAL !有理数モード
> DIM w(0 TO 2*N) !桁数は2倍になる
> MAT w=ZER
> FOR i=0 TO N !係数
> FOR j=0 TO N
> LET w(i+j)=w(i+j)+v1(i)*v2(j) !畳み込み
> NEXT j
> NEXT i
> FOR i=0 TO N !※下n桁をコピーする ※オーバーフローは考慮していない
> LET v(i)=w(i)
> NEXT i
> END SUB
>
> EXTERNAL SUB poly_diff(v1(), v()) !微分 v=v1'
> OPTION ARITHMETIC RATIONAL !有理数モード
> FOR i=1 TO N
> LET v(i-1)=v1(i)*i
> NEXT i
> LET v(N)=0
> END SUB
>
>
> !表示関連
>
> EXTERNAL SUB poly_disp(A()) !多項式を表示する a(X)=ΣAkX^k=AnX^n+An-1X^n-1+…+A1X+A0
> OPTION ARITHMETIC RATIONAL !有理数モード
> CALL mono_disp(A(N),N)
> FOR i=N-1 TO 0 STEP -1 !次項
> LET w=A(i)
> IF w>0 THEN PRINT "+";
> IF w<>0 OR N=0 THEN CALL mono_disp(w,i)
> NEXT i
> END SUB
>
> EXTERNAL SUB mono_disp(ak,k) !単項式を表示する Ak*X^k
> OPTION ARITHMETIC RATIONAL !有理数モード
> IF k<>0 THEN !x^nで
> IF ak=0 OR ak=1 THEN !係数が0,1なら
> ELSEIF ak=-1 THEN !係数が－１なら
> PRINT "-"; !符号
> ELSE
> PRINT STR$(ak);"*";
> END IF
> END IF
> IF k=0 THEN !次数が０なら
> PRINT STR$(ak);
> ELSEIF k=1 THEN !次数が１なら
> PRINT "X";
> ELSE
> IF ak<>0 THEN PRINT "X^";STR$(k); !係数が0以外なら
> END IF
> END SUB
>
>
EXTERNAL FUNCTION DF(X,K)
LET H=1/1024
FOR J=0 TO K
LET S=S+(-1)^J*COMB(K,J)*F(X+(K/2-J)*H)
NEXT J
LET DF=S/(H^K)
END FUNCTION
また1000桁モードを使用して、下記のようにすればある程度は使えそうです
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC H
LET X=0
LET N=9
LET EPS=1E-10 !'計算精度
FOR I=0 TO N
LET H=1/128
DO
LET H=H/2
LET A=DF1(X,I)
LET B=DF2(X,I)
LOOP UNTIL ABS(A - B) < EPS
LET DF=(A+B)/2
PRINT DF/FACT(I)
NEXT I
END
EXTERNAL FUNCTION F(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET F=X/(1-X)^2
END FUNCTION
EXTERNAL FUNCTION DF1(X,N)
OPTION ARITHMETIC DECIMAL_HIGH
IF N>0 THEN
LET DF1=(DF1(X-2*H,N-1)-4*DF1(X-H,N-1)+3*DF1(X,N-1))/(2*H) !'3点前進法
!'LET DF1=(3*DF1(X-4*H,N-1)-16*DF1(X-3*H,N-1)+36*DF1(X-2*H,N-1)-48*DF1(X-H,N-1)+25*DF1(X,N-1))/(12*H) !'5点前進法
ELSE
LET DF1=F(X)
END IF
END FUNCTION
EXTERNAL FUNCTION DF2(X,N)
OPTION ARITHMETIC DECIMAL_HIGH
IF N>0 THEN
LET DF2=(-3*DF2(X,N-1)+4*DF2(X+H,N-1)-DF2(X+2*H,N-1))/(2*H) !'3点後退法
!'LET DF2=(-25*DF2(X,N-1)+48*DF2(X+H,N-1)-36*DF2(X+2*H,N-1)+16*DF2(X+3*H,N-1)-3*DF2(X+4*H,N-1))/(12*H) !'5点後退法
ELSE
LET DF2=F(X)
END IF
END FUNCTION
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC H
LET X=0
LET EPS=1E-20 !'精度
FOR I=1 TO 10
LET H=1/2^10
DO
LET H=H/2
SELECT CASE I
CASE 1
LET A=(-25*F(X)+48*F(X+H)-36*F(X+2*H)+16*F(X+3*H)-3*F(X+4*H))/(12*H)
LET B=(3*F(X-4*H)-16*F(X-3*H)+36*F(X-2*H)-48*F(X-H)+25*F(X))/(12*H)
CASE 2
LET A=(F(X)-2*F(X+H)+F(X+2*H))/(H^2)
LET B=(F(X-2*H)-2*F(X-H)+F(X))/(H^2)
CASE 3
LET A=(-49*F(X)+232*F(X+H)-461*F(X+2*H)+496*F(X+3*H)-307*F(X+4*H)+104*F(X+5*H)-15*F(X+6*H))/(8*H^3)
LET B=(15*F(X-6*H)-104*F(X-5*H)+307*F(X-4*H)-496*F(X-3*H)+461*F(X-2*H)-232*F(X-H)+49*F(X))/(8*H^3)
CASE 4
LET A=(F(X)-4*F(X+H)+6*F(X+2*H)-4*F(X+3*H)+F(X+4*H))/(H^4)
LET B=(F(X-4*H)-4*F(X-3*H)+6*F(X-2*H)-4*F(X-H)+F(X))/(H^4)
CASE 5
LET A=(-81*F(X)+575*F(X+H)-1790*F(X+2*H)+3195*F(X+3*H)-3580*F(X+4*H)+2581*F(X+5*H)-1170*F(X+6*H)+305*F(X+7*H)-35*F(X+8*H))/(6*H^5)
LET B=(35*F(X-8*H)-305*F(X-7*H)+1170*F(X-6*H)-2581*F(X-5*H)+3580*F(X-4*H)-3195*F(X-3*H)+1790*F(X-2*H)-575*F(X-H)+81*F(X))/(6*H^5)
CASE 6
LET A=(F(X)-6*F(X+H)+15*F(X+2*H)-20*F(X+3*H)+15*F(X+4*H)-6*F(X+5*H)+F(X+6*H))/(H^6)
LET B=(F(X-6*H)-6*F(X-5*H)+15*F(X-4*H)-20*F(X-3*H)+15*F(X-2*H)-6*F(X-H)+F(X))/(H^6)
CASE 7
LET A=(-605*F(X)+5628*F(X+H)-23583*F(X+2*H)+58632*F(X+3*H)-95802*F(X+4*H)+107520*F(X+5*H)-83958*F(X+6*H)+45048*F(X+7*H)-15897*F(X+8*H)+3332*F(X+9*H)-315*F(X+10*H))/(24*H^7)
LET B=(315*F(X-10*H)-3332*F(X-9*H)+15897*F(X-8*H)-45048*F(X-7*H)+83958*F(X-6*H)-107520*F(X-5*H)+95802*F(X-4*H)-58632*F(X-3*H)+23583*F(X-2*H)-5628*F(X-H)+605*F(X))/(24*H^7)
CASE 8
LET A=(F(X)-8*F(X+H)+28*F(X+2*H)-56*F(X+3*H)+70*F(X+4*H)-56*F(X+5*H)+28*F(X+6*H)-8*F(X+7*H)+F(X+8*H))/(H^8)
LET B=(F(X-8*H)-8*F(X-7*H)+28*F(X-6*H)-56*F(X-5*H)+70*F(X-4*H)-56*F(X-3*H)+28*F(X-2*H)-8*F(X-H)+F(X))/(H^8)
CASE 9
LET A=(-169*F(X)+1932*F(X+H)-10128*F(X+2*H)+32196*F(X+3*H)-69129*F(X+4*H)+105624*F(X+5*H)-117768*F(X+6*H)+96552*F(X+7*H)-57771*F(X+8*H)+24604*F(X+9*H)-7080*F(X+10*H)+1236*F(X+11*H)-99*F(X+12*H))/(4*H^9)
LET B=(99*F(X-12*H)-1236*F(X-11*H)+7080*F(X-10*H)-24604*F(X-9*H)+57771*F(X-8*H)-96552*F(X-7*H)+117768*F(X-6*H)-105624*F(X-5*H)+69129*F(X-4*H)-32196*F(X-3*H)+10128*F(X-2*H)-1932*F(X-H)+169*F(X))/(4*H^9)
CASE 10
LET A=(F(X)-10*F(X+H)+45*F(X+2*H)-120*F(X+3*H)+210*F(X+4*H)-252*F(X+5*H)+210*F(X+6*H)-120*F(X+7*H)+45*F(X+8*H)-10*F(X+9*H)+F(X+10*H))/(H^10)
LET B=(F(X-10*H)-10*F(X-9*H)+45*F(X-8*H)-120*F(X-7*H)+210*F(X-6*H)-252*F(X-5*H)+210*F(X-4*H)-120*F(X-3*H)+45*F(X-2*H)-10*F(X-H)+F(X))/(H^10)
END SELECT
LOOP UNTIL ABS(A - B) < EPS
LET DF=(A+B)/2
PRINT DF/FACT(I)
NEXT I
END
EXTERNAL FUNCTION F(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET F=X/(1-X)^2
END FUNCTION
PUBLIC NUMERIC HEIGHT !段数
FOR HEIGHT=1 TO N
CALL print_young(HEIGHT,N,N)
NEXT HEIGHT
END
EXTERNAL SUB print_young(d,n,c) !ヤング図形を表示する
IF d>0 THEN
LET upper=n-d+1
LET lower=INT((n-1)/d)+1
FOR i=MIN(c,upper) TO lower STEP -1
LET A(HEIGHT-d+1)=i
CALL print_young(d-1,n-i,i) !次へ
NEXT i
ELSE !揃ったら
MAT PRINT A; !debug
CALL connect(1,A)
END IF
END SUB
EXTERNAL SUB connect(P,A()) !p段目を表示する
!左端の分岐
LET W=A(P+1) !次の段の有無
IF P=1 THEN !1段目なら
IF W>0 THEN PRINT "┬"; ELSE PRINT "─";
ELSE !2段目以降
IF W>0 THEN PRINT "├"; ELSE PRINT "└";
END IF
FOR i=1 TO A(P) !各抵抗への接続位置
IF W=0 AND (P=1 OR i=A(P)) THEN PRINT "R─"; ELSE PRINT "R┬";
NEXT i
PRINT
PUBLIC NUMERIC C !場合の数
LET C=0
CALL try(2,M,B,1,N)
END
EXTERNAL SUB try(P,M,B(),R,L)
FOR i=R TO L !配置位置の候補 ※ひとつ上の段の右側へ
LET B(P)=i
IF P<M THEN !次の段があれば
CALL try(P+1,M,B,i,L)
ELSE !結果を表示する
LET C=C+1
PRINT "No."; C
PRINT "┬"; !1段目
FOR J=1 TO L
IF B(2)>J THEN PRINT "R─"; ELSE PRINT "R┬";
NEXT J
PRINT
!!!MAT PRINT B; !debug
FOR J=2 TO M !2段目以降
IF J=M THEN PRINT "└"; ELSE PRINT "├"; !左端
PRINT REPEAT$(" ",3*(B(J)-1));
IF B(J+1)>B(J) THEN PRINT "R┘" ELSE PRINT "R┤"
NEXT J
PRINT
END IF
NEXT i
END SUB
答え 高校生
一般に、
階差数列を考える。
a[0] a[1] a[2] a[3] a[4] a[5] a[6] …
b[0] b[1] b[2] b[3] b[4] b[5] … 第1階差が等差数列
c c c c c …
a[n]=pn^2+qn+r、n≧0とすると、
a[0]=r
b[0]=a[1]-a[0]=(p+q+r)-r=p+q
c=b[1]-b[0]=(a[2]-a[1])-b[0]={(4p+2q+r)-(p+q+r)}-(p+q)=2p
なので、
1=r
2=p+q
2=2p
から、p=1、q=1、r=1
よって、a[n]=n^2+n+1（n≧0） ∴a[n]=(n-1)^2+(n-1)+1=n^2-n+1（n≧1）
（終り）
OPTION ARITHMETIC RATIONAL !有理数
DATA 1,2,2
DIM P(0 TO 2,0 TO 2),Q(0 TO 2) !連立方程式Px=qを解く
MAT READ Q
DATA 0,0,1 !r
DATA 1,1,0 !p+q
DATA 2,0,0 !2p
MAT READ P
DIM W(3,3),x(0 TO 2)
MAT W=INV(P)
MAT x=W*Q
MAT PRINT x; !n^2,n,1の係数 ※n≧0
FOR n=0 TO 10 !検算
PRINT n; poly_val(2,x,n) !第n項
NEXT n
DIM y(0 TO 2) !nにn-1を代入して、展開する ※a[n]、n≧1
LET y(0)= x(0)
LET y(1)=2*x(0)*(-1) +x(1)
LET y(2)= x(0)*(-1)^2 +x(1)*(-1) +x(2)
FOR n=1 TO 10 !検算
PRINT n; poly_val(2,y,n) !第n項
NEXT n
END
EXTERNAL FUNCTION poly_val(k,c(),x) !関数値 f(x)=c[0]x^k+c[1]x^(k-1)+ … +c[n-2]x^2+c[n-1]x+c[n]
OPTION ARITHMETIC RATIONAL !有理数モード
LET f=c(0) !ホーナー法による
FOR i=1 TO k
LET f=f*x+c(i)
NEXT i
LET poly_val=f
END FUNCTION
!階差数列を考える。
! a[0] a[1] a[2] a[3] a[4] a[5] a[6] …
! b[0] b[1] b[2] b[3] b[4] b[5] … 第1階差
! c[0] c[1] c[2] c[3] c[4] … 第2階差が等差数列
! d d d d …
!a[n]=pn^3+qn^2+rn+s、n≧0とすると、
!a[0]=s
!b[0]=a[1]-a[0]=(p+q+r+s)-s=p+q+r
!c[0]=b[1]-b[0]=(a[2]-a[1])-b[0]={(8p+4q+2r+s)-(p+q+r+s)}-(p+q+r)=6p+2q
!d=c[1]-c[0]
! =(b[2]-b[1])-c[0]
! ={(a[3]-a[2])-(a[2]-a[1])}-c[0]
! ={(a[3]-2a[2]+a[1])}-c[0]
! ={(27p+9q+3r+s)-2(8p+4q+2r+s)+(p+q+r+s)}-(6p+2q)
! =6p
DATA 0,0,0,1 !s
DATA 1,1,1,0 !p+q+r
DATA 6,2,0,0 !6p+2q
DATA 6,0,0,0 !6p
MAT READ P
DIM W(4,4),x(0 TO 3)
MAT W=INV(P)
MAT x=W*Q
MAT PRINT x; !n^3,n^2,n,1の係数 ※n≧0
FOR n=0 TO 10 !検算
PRINT n; poly_val(3,x,n) !第n項
NEXT n
DIM y(0 TO 3) !n-1を代入して、展開する ※a[n]、n≧1
LET y(0)=x(0)
LET y(1)=3*x(0)*(-1) +x(1)
LET y(2)=3*x(0)*(-1)^2+2*x(1)*(-1) +x(2)
LET y(3)= x(0)*(-1)^3 +x(1)*(-1)^2+x(2)*(-1)+x(3)
FOR n=1 TO 10 !検算
PRINT n; poly_val(3,y,n) !第n項
NEXT n
END
EXTERNAL FUNCTION poly_val(k,c(),x) !関数値 f(x)=c[0]x^k+c[1]x^(k-1)+ … +c[n-2]x^2+c[n-1]x+c[n]
OPTION ARITHMETIC RATIONAL !有理数モード
LET f=c(0) !ホーナー法による
FOR i=1 TO k
LET f=f*x+c(i)
NEXT i
LET poly_val=f
END FUNCTION
!'シュヴァルツシルト半径
!'LET M=5.9723E+24 !'地球の重量(Kg)
!'LET M=1.9884E+30 !'太陽の重量(Kg)
INPUT PROMPT "重量(Kg)=":M
LET G=6.673848E-11 !'万有引力定数
LET C=299792458 !'光速度(m/s)
LET R=2*M*G/C/C
PRINT "ブラックホールの半径 ";R;"m"
END
-----------------------------------------------------------
!'プランク時間
LET C=299792458 !'光速度(m/s)
LET H=1.054571726E-34 !'ディラック定数
LET G=6.673848E-11 !'万有引力定数
PRINT SQR(H*G/C^5);"秒"
END
-----------------------------------------------------------
!'レムニスケート周率
LET S=1
FOR I=20000 TO 1 STEP -1
LET S=(2+(2*I)*(2*I+1)/S)
NEXT I
LET W=2*(1+1/S)
PRINT W
LET S=0
FOR R=0 TO 1-1/2^18 STEP 1/2^18
LET S=S+1/SQR(1-R^4)
NEXT R
PRINT 2*S/2^18
LET W=1
FOR N=10000 TO 1 STEP -1
LET W=1-W*(2*N-3)^2/(2*N)^2
NEXT N
LET W=W/2
PRINT 1/W
END
-----------------------------------------------------------
!'預金
INPUT PROMPT "預金 =": X
INPUT PROMPT "預け入れ年数=": N
INPUT PROMPT "利率 =": R
PRINT "単利法 "; INT(X * (1 + N * R / 100))
PRINT "年複利法 "; INT(X * (1 + R / 100)^N)
PRINT "半年複利法 "; INT(X * (1 + R / 200)^(2 * N))
PRINT "複利法 "; INT(X * EXP(N * R / 100))
END
-----------------------------------------------------------
!'ローン返済
INPUT PROMPT "借入金 =": A
INPUT PROMPT "年利 (%)=": R
INPUT PROMPT "返還年数=": N
LET R = R / 100
LET X1 = A * R * (1 + R)^ N / ((1 + R)^N - 1)
PRINT "元利均等返済方式 "; INT(X1);"円"
PRINT "元金均等返済方式"
FOR I = 1 TO N
LET X2=A/N*(1+(N-I+1)*R)
PRINT "No.";I; INT(X2);"円"
NEXT I
END
-----------------------------------------------------------
!'遠心力
!'F=質量*速度^2/半径
!'F=質量*半径*角速度^2
!'LET M=5.9723E+24 !'地球の重量(Kg)
!'LET G=6.673848E-11 !'万有引力定数
!'LET R=6.378E+6 !' 地球の半径(m)
!'PRINT G*M/R^2;"N"
INPUT PROMPT "半径(m)=":R
INPUT PROMPT "回転数(秒)=":L
!'INPUT PROMPT "回転速度(m/s)=":LL
!'LET L=LL/(2*PI*R)
INPUT PROMPT "重量(Kg)=":M
!'LET V=2*PI*L*R !'角速度
LET W=2*PI*L
LET V=W*R !'速度
!'LET F=M*V^2/R
LET F=M*R*W^2
PRINT F;"N" !'!遠心力
PRINT V^2/R/9.80665;"G" !'G=V^2(m/s)/R(m)/g(9.80665)
PRINT F/M/9.80665;"G"
LET RPM=L*60 !'毎分回転
LET RCF= 11.1824395816324*(RPM/1000)^2*R*100 !'R(cm) RPM(回転/分)
PRINT RCF;"G"
PRINT 299.041677197263*SQR(RCF/R/100)/60;"回転/秒"
PRINT L;"回転/秒"
END
-----------------------------------------------------------
!'長生き
INPUT PROMPT "移動速度(Km/h)=":V
INPUT PROMPT "移動し続けた時間(秒)=":S
LET V=V/3.6
LET C=299792458 !'光速度(m/s)
IF V>=C THEN
PRINT"光速を超えています"
STOP
END IF
LET A=S*SQR(1-V*V/C/C)
PRINT"時間 ";A;"秒"
PRINT"遅れた時間 ";S-A;"秒"
END
-----------------------------------------------------------
!'長生き
INPUT PROMPT "高さ(m)=":H
INPUT PROMPT "時間(秒)=":S
LET C=299792458 !'光速度(m/s)
LET G=9.80665 !' 重力加速度
LET A=G*H/C/C
PRINT"地上より";S*A;"秒 時間が進む"
END
-----------------------------------------------------------
!'質量増加
INPUT PROMPT "質量 Kg=":G
INPUT PROMPT "移動速度(Km/h)=":V
LET V=V/3.6
LET C=299792458 !'光速度(m/s)
IF V>=C THEN
PRINT"光速を超えています"
STOP
END IF
LET A=G/SQR(1-V*V/C/C)
PRINT"質量 ";A;"Kg"
PRINT"増えた質量 ";A-G;"Kg"
END
-----------------------------------------------------------
!'水平投射
SET BITMAP SIZE 600,300
SET WINDOW 0 , 299 ,20,-279
DRAW AXES(20,20)
INPUT PROMPT "初速度(m/s)=":V0
INPUT PROMPT "高さ=":H
LET G=9.80665 !'重力加速度
PLOT LINES: 0,-H;
DO
LET T=T+1/128
LET X=V0*T
LET Y=-H+G*T^2/2
PLOT LINES: X,Y;
LOOP UNTIL Y>=0
PRINT"水平到達距離(m)";X;V0*SQR(2*H/G)
PRINT "到達時間(秒)";SQR(2*H/G)
END
-----------------------------------------------------------
!'斜方投射
LET XSIZE=800
LET YSIZE=600
LET RATE=5
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0 , (XSIZE-1)/RATE , -20/RATE,(YSIZE-21)/RATE
DRAW AXES(10,20)
INPUT PROMPT "初速度(m/s)=":V0
LET G=9.80665
INPUT PROMPT "角度=":TT
LET TH=TT*PI/180
PLOT LINES: 0,0;
LET YY=0
LET T=0
DO
LET T=T+1/128
LET X=V0*COS(TH)*T
LET Y=V0*SIN(TH)*T-G*T^2/2
PLOT LINES: X,Y;
LET YY=MAX(YY,Y)
LOOP UNTIL Y=<0
PRINT "距離(m)";X;"到達高度(m)";YY;"到達時間(秒)";T;V0*SIN(TH)*2/G
PRINT "距離(m)";V0^2/G*SIN(2*TH);"到達高度(m)";(V0*SIN(TH))^2/2/G;"最高点到達時間(秒)";V0*SIN(TH)/G
END
-----------------------------------------------------------
!'十二支
OPTION BASE 0
DIM A$(11)
FOR I=0 TO 11
READ A$(I)
NEXT I
DATA "申(さる)","酉(とり)","戌(いぬ)","亥(い)","子(ね)","丑(うし)"
DATA "寅(とら)","卯(う)","辰(たつ)","巳(み)","午(うま)","未(ひつじ)"
INPUT PROMPT "西暦=":Y
PRINT "十二支=";A$(MOD(Y,12))
END
-----------------------------------------------------------
!'重力加速度
LET R=6378137 !' 地球の半径(m)
LET G0=9.80665 !'高度0での重力加速度
INPUT PROMPT "高さ(m) H=":H
LET G=G0*(R/(R+H))^2
PRINT "高度Hでの重力加速度";G;"m/s^2"
LET M=5.9723E+24 !'地球の重量(Kg)
LET G=6.673848E-11 !'万有引力定数
LET GG=G*M/(R+h)^2
PRINT "高度Hでの重力加速度";GG;"m/s^2"
END
-----------------------------------------------------------
!'星座
DIM NISU(12), D$(13), N1(13), N2(13)
DO
INPUT PROMPT "月,日 =": M, D
LOOP WHILE M < 1 OR M > 12 OR D < 1 OR D > 31
FOR I = 1 TO 12
READ NISU(I)
NEXT I
FOR I = 1 TO 13
READ M1, D1, M2, D2, D$(I)
LET N1(I) = NISU(M1) + D1
LET N2(I) = NISU(M2) + D2
NEXT I
LET N = NISU(M) + D
LET I = 0
DO
LET I = I + 1
LOOP UNTIL N1(I) <= N AND N2(I) >= N
PRINT M; "月"; D; "日は"; D$(I); "です"
DATA 0,31,59,90,120,151,181,212,242,273,304,334
DATA 1,1,1,19,山羊座
DATA 1,20,2,18,水瓶座
DATA 2,19,3,20,魚座
DATA 3,21,4,19,牡羊座
DATA 4,20,5,20,牡牛座
DATA 5,21,6,21,双子座
DATA 6,22,7,22,蟹座
DATA 7,23,8,22,獅子座
DATA 8,23,9,22,乙女座
DATA 9,23,10,23,天秤座
DATA 10,24,11,22,さそり座
DATA 11,23,12,21,射手座
DATA 12,22,12,31,山羊座
END
-----------------------------------------------------------
!'太陽質量
LET R=1.4959E+11 !'地球との平均距離
LET G=6.673848E-11 !'万有引力定数
LET T=365.24*24*60*60 !'秒
PRINT 4*PI^2*R^3/(G*T^2);"Kg"
LET K=3E-19 !'s2/m^3
PRINT 4*PI^2/(G*K);"Kg"
END
-----------------------------------------------------------
!'地球質量
LET G0=9.80665 !'重力加速度
LET R=6378137 !'地球の半径(m)
LET G=6.673848E-11 !'万有引力定数
PRINT G0*R^2/G;"Kg"
END
!'天文単位
LET AU=149597870700 !'(m) 天文単位
LET D=86400 !'(日/秒)
LET K=0.01720209895 !'ガウス引力定数
LET MS=1.9884E30 !'太陽質量(Kg)
LET G=6.673848E-11 !'m^3/s^2/Kg 万有引力定数
LET A=((D/K)^2*G*MS)^(1/3)
PRINT INT(A);"m"
PRINT AU;"m"
END
-----------------------------------------------------------
!'半減期
INPUT PROMPT "年数=":T
INPUT PROMPT "半減期(年)=":TT
PRINT 100-.5^(T/TT)*100;"% 減少"
END
-----------------------------------------------------------
!'卵のゆで時間
INPUT PROMPT "卵 短直径(mm)=":D !'D=50
INPUT PROMPT "黄身の最終温度=":TY !'TY=73
INPUT PROMPT "初期温度=":T0 !'T0=20
INPUT PROMPT "お湯の温度=":TH !'TH=100
LET T=0.0015*D^2*LOG(2*(TH-T0)/(TH-TY))
PRINT "茹時間(分)=";INT(T);"分";INT((T-INT(T))*60);"秒"
END
-----------------------------------------------------------
!'速度合成
INPUT PROMPT "(1)速度 時速(Km/h)=":V1
INPUT PROMPT "(2)速度 時速(Km/h)=":V2
LET V1=V1/3.6
LET V2=V2/3.6
LET C=299792458
IF V1>=C OR V2>=C THEN
PRINT"光速を超えています"
STOP
END IF
LET A=(V1+V2)/(1+V1*V2/C/C)*3.6
LET B=(V1-V2)/(1-V1*V2/C/C)*3.6
PRINT"速度の和 ";A;"(Km/h)"
PRINT"速度の差 ";B;"(Km/h)"
END
-----------------------------------------------------------
!'相性占い
OPTION CHARACTER KANJI
DIM WORD$(100)
DO
LET N=N+1
READ WORD$(N)
LOOP UNTIL WORD$(N)="END"
INPUT PROMPT "NAME1=": AA$ !'平仮名で入力
INPUT PROMPT "NAME2=": BB$
FOR I = 1 TO LEN(AA$ & BB$)
FOR A=1 TO N
IF WORD$(A) = MID$(AA$ & BB$, I, 1) THEN EXIT FOR
NEXT A
LET A = MOD(A,5)
IF A = 0 THEN LET A = 5
LET A$ = A$ & LTRIM$(STR$(A))
NEXT I
LET C$ = A$
CALL DISPLAY(C$,0)
LET C$ = ""
LET D = 1
DO
FOR I = 1 TO LEN(A$) - 1
LET A = VAL(MID$(A$, I, 1))
LET B = VAL(MID$(A$, I + 1, 1))
LET C = A + B
IF C > 9 THEN LET C = C - 10
LET C$ = C$ & LTRIM$(STR$(C))
NEXT I
CALL DISPLAY(C$,D)
LET D = D + 1
IF C$ = "100" THEN
PRINT "100 % ダヨーン"
STOP
END IF
IF LEN(C$) = 2 THEN
PRINT C$; "% デース"
STOP
END IF
LET A$ = C$
LET C$ = ""
LOOP
DATA あ,い,う,え,お,か,き,く,け,こ
DATA さ,し,す,せ,そ,た,ち,つ,て,と
DATA な,に,ぬ,ね,の,は,ひ,ふ,へ,ほ
DATA ま,み,む,め,も,や,"",ゆ,"",よ
DATA ら,り,る,れ,ろ,わ,"","","",を
DATA "","",っ,"",ん
DATA が,ぎ,ぐ,げ,ご,ざ,じ,ず,ぜ,ぞ
DATA だ,ぢ,づ,で,ど,ば,び,ぶ,べ,ぼ
DATA ぱ,ぴ,ぷ,ぺ,ぽ
DATA ぁ,ぃ,ぅ,ぇ,ぉ,ゃ,"",ゅ,"",ょ
DATA "END"
END
EXTERNAL SUB DISPLAY(C$,D)
FOR I = 1 TO LEN(C$)
LET D$ = D$ & MID$(C$, I, 1) & " "
NEXT I
IF D <> 0 THEN LET D$ = REPEAT$(" ",D) & D$ & REPEAT$(" ",D - 1)
PRINT D$
END SUB
-----------------------------------------------------------
!'脱出速度
LET G=6.673848E-11 !'万有引力定数
LET M=5.972E+24 !'地球質量(Kg)
LET R=6378137 !'地球半径(m)
LET RE=1.5E+11 !'公転半径(m)
LET Msun=1.9884E+30 !'太陽質量(Kg)
LET V1=SQR(G*M/R)
LET V2=SQR(2*G*M/R)
LET VS=SQR(2*G*Msun/RE)
LET VE=SQR(G*Msun/RE)
LET VEO=VS-VE
LET V3=SQR(2*G*M/R+VEO^2)
PRINT "第一脱出速度";V1;"m/s"
PRINT "第二脱出速度";V2;"m/s"
PRINT "第三脱出速度";V3;"m/s"
END
-----------------------------------------------------------
!'振り子周期
INPUT PROMPT "長さ(m)=":L
LET G=9.80665 !'重力加速度
LET T=2*PI*SQR(L/G)
INPUT PROMPT "角度=":THETA
LET THETA=THETA*PI/180
LET A=1
FOR N=0 TO 100
IF N>0 THEN LET A=A*((2*N-1)/(2*N))^2*SIN(THETA/2)^2
LET S=S+A
NEXT N
PRINT "周期(秒)=";T*S
!'LET M=1000 !'(g)
!'PRINT "位置エネルギー";M*G*L*(1-COS(THETA))
END
-----------------------------------------------------------
!'万有引力
LET G=6.673848E-11 !'万有引力定数
INPUT PROMPT "あなたの体重を入れて下さい (Kg)": M1
INPUT PROMPT "相手の体重を入れて下さい (Kg)": M2
INPUT PROMPT "２人の間の距離を入れて下さい (m)": R
LET F = G * ((M1 * M2) / (R * R))
PRINT "２人の間にはたらく引力は"; F; "Ｎ です"
END
-----------------------------------------------------------
!'等加速度運動
INPUT PROMPT "初速度(Km/h)=":V0
LET V0=V0/3.6
INPUT PROMPT "加速度(m/s^2)=":A
INPUT PROMPT "時間(秒)=":T
LET V=V0+A*T
PRINT "速度(Km/h)=";V*3.6
LET X=V0*T+A*T^2/2
!'X=(V^2-V0^2)/(2*A)
!'G=9.80665
!'X=V0*COS(TH*PI/180)*V0*2*SIN(TH*PI/180)/G
PRINT"進んだ距離(m)";X
INPUT PROMPT "進んだ距離(m)":X
INPUT PROMPT "初速度(Km/h)=":V0
LET V0=V0/3.6
INPUT PROMPT "加速度(m/s^2)=":A
!'A/2*T^2+V0*T-X=0
LET D=V0^2+4*A/2*X
IF D<0 THEN STOP
LET T=(-V0+SQR(D))/A
!'IF T<0 THEN LET T=(-V0-SQR(D))/A
PRINT T;"秒"
END
-----------------------------------------------------------
!'等級
INPUT PROMPT "恒星の見かけの等級=":MM
INPUT PROMPT "絶対等級=":M
LET R=10*10^(0.2*(MM-M))
LET RR=3.26*R
PRINT "距離";R;"パーセク"
PRINT RR;"光年" !'1パーセク=3.26光年
PRINT RR*299792.458*60*60*24*365;"Km"
!'M=MM+5-5*LOG(R)/LOG(10)
END
100 !x^2+2y^2=z^2
110 FOR m=-10 TO 10
120 FOR n=-10 TO 10
130 LET z=m^2+2*n^2
140 LET x=m^2-2*n^2
150 LET y=2*m*n
160 IF x^2+2*y^2=z^2 THEN PRINT m;n; x;y;z
170 NEXT n
180 NEXT m
190 END
100 !x^2+y^2=z^3
110 FOR m=-10 TO 10
120 FOR n=-10 TO 10
130 LET z=m^2+n^2
140 LET x=(m^2-3*n^2)*m
150 LET y=(3*m^2-n^2)*n
160 IF x^2+y^2=z^3 THEN PRINT m;n; x;y;z
170 NEXT n
180 NEXT m
190 END
100 !x^2+y^3=z^2
110 FOR m=-10 TO 10
120 FOR n=-10 TO 10
130 LET y=m^2-n^2
140 LET z=(m^2+3*n^2)*m
150 LET x=(3*m^2+n^2)*n
160 IF x^2+y^3=z^2 THEN PRINT m;n; x;y;z
170 NEXT n
180 NEXT m
190 END
LET x=2
DO
LET y=x+1
DO
LET z=y+1
DO
LET f=(x+y-1)*(y+z-1)*(z+x-1)-6*x*y*z
PRINT x;y;z; f
IF f>=0 THEN EXIT DO !f(x,y,z)≧0になるまで
LET z=z+1 !昇順に調べる
LOOP
PRINT
IF z=y+1 THEN EXIT DO !f(x,y,y+1)＞0なら可能性がない
LET y=y+1
LOOP
IF y=x+1 THEN EXIT DO !f(x,x+1,x+2)＞0なら可能性がない
LET x=x+1
LOOP
FOR x=2 TO 4
FOR y=x+1 TO 5
LET A=x+y-1 !2次方程式 Az^2+Bz+C=0
LET B=(x+y-1)*(x+y-2)-6*x*y
LET C=(x+y-1)*(x-1)*(y-1)
LET D=B^2-4*A*C !判別式
IF D>=0 THEN
LET z=(-B+SQR(D))/(2*A)
IF z>y AND z=INT(z) THEN PRINT x;y;z
LET z=(-B-SQR(D))/(2*A)
IF z>y AND z=INT(z) THEN PRINT x;y;z
END IF
NEXT y
NEXT x
LET left=-1 !表示範囲
LET right=8
LET bottom=-1
LET top=8
SET WINDOW left,right,bottom,top
DRAW grid
SET POINT STYLE 1
FOR ZZ=4 TO 10 !z=Zとする
SET POINT COLOR ZZ-3
FOR y=bottom TO top STEP (top-bottom)/2000 !y方向への走査
LET x=left
LET z0=f(x,y)
FOR x=left TO right STEP (right-left)/2000 !x方向への走査
LET z=f(x,y)
IF z0*z<0 THEN PLOT POINTS: x,y
LET z0=z
NEXT x
NEXT y
このプログラム中の「SUB newton(fc,x,y, fx,fy,grad2) !ニュートン法」に記述されている
LET t=(fc-ff)/grad2
LET x=x+t*fx
LET y=y+t*fy
のgrad2は、ヤコビ行列の逆行列作成で生じる行列式と推測されます。
電位ff=f(x,y)は２変数関数なので、ニュートン法でヤコビ行列を作成する為には、x,yに関するもう１個別の関数g(x,y)=kが必要と思うのですが、その関数はどのように考えればよいのでしょうか？
!**************************************************************
! 1個の点電荷と接地導体球が存在する電場の等電位曲線作図プログラム
! <山中和義氏作の描画手法を利用>
!**************************************************************
!----描画座標・条件設定
LET Xa=-10
LET Xb=-Xa+4
LET Ya=Xa-2
LET Yb=-Ya+2
SET WINDOW Xa,Xb,Ya,Yb !描画範囲
DRAW grid
LET cEps=1E-3 !誤差精度設定
!----電荷位置設定と描画
LET r=1 !導体球の半径
LET a1=4 !点電荷のｘ座標
LET a2=r^2/a1 !影像電荷のx座標
LET q1=1 !点電荷の大きさ
LET q2=-r/a1*q1 !影像電荷の大きさ
DEF f(x,y)=q1/SQR((x-a1)^2+y^2)+q2/SQR((x-a2)^2+y^2) !合成電位関数
SET AREA COLOR "red" !点電荷の位置に赤丸印を表示
DRAW disk WITH SCALE(0.1)*SHIFT(a1,0)
SET AREA COLOR "green" !接地導体球の位置に緑丸印を表示
DRAW disk WITH SCALE(r)*SHIFT(0,0)
!---等電位分布作図(関数f(x,y)の等高線)-----
SET LINE COLOR "red"
LET h=0.001 !増分（偏微分係数）
LET d=0.015 !増分
FOR fc=0 TO 0.5 STEP d !等高線の関数値
CALL contour(fc,1,1,d)
NEXT fc
FOR fc=0 TO 0.06 STEP d !※左端
CALL contour(fc,-10,1,d)
NEXT fc
!--以下はSUB_routine------
SUB newton(fc,x,y, fx,fy,grad2) !ニュートン法
DO
LET ff=f(x,y) !∇f
LET fx=(f(x+h,y)-ff)/h
LET fy=(f(x,y+h)-ff)/h
LET grad2=fx*fx+fy*fy
IF grad2<1e-10 THEN
LET x=1e30
EXIT SUB
END IF
LET t=(fc-ff)/grad2
LET x=x+t*fx
LET y=y+t*fy
LOOP WHILE t*t*grad2>cEps*cEps
END SUB
SUB contour(fc,x,y,d) !等高線を描く
LET i=0
DO
CALL newton(fc,x,y, fx,fy,grad2)
IF ABS(x)+ABS(y)>1e10 THEN EXIT SUB
IF i=0 THEN
PLOT LINES: x,y; !始点
LET x0=x
LET y0=y
ELSE
PLOT LINES: x,y; !折れ線でつなげる
END IF
IF i>2 AND (x-x0)^2+(y-y0)^2<d*d THEN EXIT DO !始点近傍なら、終了
!' 原始反復法
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET X=T
LET H=1
DO
LET H=H/2
LOOP UNTIL ABS(H*F(X))<3
DO
LET X=X-H*F(X)
PRINT X
LOOP UNTIL ABS(F(X))<EPS
PRINT X;X*X
END
!' 逐次代入法
!'(X+1)^2=T
!'X^2+2*X=T-1
!'X*(X+2)=T-1
!'X=(T-1)/(X+2)
PUBLIC NUMERIC T,N
INPUT PROMPT "n乗根=":N
INPUT PROMPT "X=": T
LET EPS=1E-8
LET XX = T
DO
LET X=XX
LET XX = F(X)
PRINT XX + 1
LOOP UNTIL ABS(X-XX)<EPS
PRINT XX + 1;(XX+1)^N
END
EXTERNAL FUNCTION F(X)
!'LET F=(T-1)/(X+2)
!'LET F=(T-1)/(X^2+3*X+3)
!'LET F=(T-1)/(X^3+4*X^2+6*X+4)
!'LET F=(T-1)/(X^4+5*X^3+10*X^2+10*X+5)
!'LET F=(T-1)/(((X+1)^N)/X-1/X)
FOR I=0 TO N-1
LET S=S*X+COMB(N,I)
NEXT I
LET F=(T-1)/S
END FUNCTION
!' 相加平均代入法
PUBLIC NUMERIC T,N
LET N=2
INPUT PROMPT "X=": T
LET EPS=1E-8
LET X = T
DO WHILE ABS(F(X) - X) > EPS
LET X = (F(X) + X) / 2
PRINT X
LOOP
PRINT X;X^N
END
EXTERNAL FUNCTION F(X)
LET F=T/X^(N-1)
END FUNCTION
!' １０分法
PUBLIC NUMERIC T,N
INPUT PROMPT "n乗根 =": N
INPUT PROMPT "X=": T
FOR KETA = 4 TO -15 STEP -1
LET A = 10 ^ KETA
FOR I = 1 TO 10
IF F(X + A * I) > 0 THEN
LET X = X + A * (I - 1)
EXIT FOR
END IF
NEXT I
PRINT X
NEXT KETA
PRINT X;X^N
END
!' 割線法 (SECANT法)
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET EPS=1E-8
LET X0 = T + 1
LET X1 = T
DO WHILE ABS(X0 - X1) > EPS
LET X = X0 - F(X0) / G(X0, X1)
PRINT X
LET X0 = X1
LET X1 = X
LOOP
PRINT X;X*X
END
EXTERNAL FUNCTION F(X)
LET F=X*X-T
END FUNCTION
EXTERNAL FUNCTION G(X0,X1) !' f'(x)の代用
LET G=(F(X0) - F(X1)) / (X0 - X1)
END FUNCTION
!' ステッフェッセン法(STEFFENSEN法)
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET X=T
DO
LET X=X-F(X)/G(X)
PRINT X
LOOP UNTIL ABS(F(X))<EPS
PRINT X;X*X
END
EXTERNAL FUNCTION F(X)
LET F=X*X-T
END FUNCTION
EXTERNAL FUNCTION G(X) !' f'(x)の代用
LET G=(F(F(X)+X)-F(X))/F(X)
END FUNCTION
!' 線形逆補間法
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET EPS=1E-8
LET X2= T
LET X1= 1
DO
LET X3 = X2 - (X2 - X1) / (F(X2) - F(X1)) * F(X2)
IF F(X1)*F(X3)<0 THEN LET X2=X3 ELSE LET X1=X3
PRINT X3
LOOP WHILE ABS(F(X3)) > EPS
PRINT X3;X3^3
END
EXTERNAL FUNCTION F(X)
LET F=X * X * X - T
END FUNCTION
!' はさみうち法(REGULA-FALSI法)
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET A = 0
LET B = T
LET EPS=1E-8
DO WHILE ABS(A - B) > EPS
LET C = (A * F(B) - B * F(A)) / (F(B) - F(A))
IF F(C) < 0 THEN LET A = C ELSE LET B = C
PRINT C
LOOP
PRINT C;C*C
END
!' 拡張ニュートン法
OPTION ARITHMETIC DECIMAL_HIGH
PUBLIC NUMERIC T,N
INPUT PROMPT "n乗根=":N
INPUT PROMPT "X=":T
LET XX=T
DO
LET X=XX
SELECT CASE N
CASE 2
LET XX=X-F(X)/DF(X,1)
CASE 3
LET XX=X-F(X)/(DF(X,1)-DF(X,2)/FACT(2)*(F(X)/DF(X,1)))
CASE 4
LET XX=X-F(X)/(DF(X,1)-DF(X,2)/FACT(2)*(F(X)/DF(X,1))-DF(X,3)/FACT(3)*(F(X)/DF(X,1))^2)
CASE 5
LET XX=X-F(X)/(DF(X,1)-DF(X,2)/FACT(2)*(F(X)/DF(X,1))-DF(X,3)/FACT(3)*(F(X)/DF(X,1))^2-DF(X,4)/FACT(4)*(F(X)/DF(X,1))^3)
CASE ELSE
LET S=0
FOR I=2 TO N-1
LET S=S+DF(X,I)/FACT(I)*(F(X)/DF(X,1))^(I-1)
NEXT I
LET XX=X-F(X)/(DF(X,1)-S)
END SELECT
PRINT XX
LOOP UNTIL X=XX
PRINT XX
END
EXTERNAL FUNCTION F(X)
OPTION ARITHMETIC DECIMAL_HIGH
LET F=X^N-T
END FUNCTION
EXTERNAL FUNCTION DF(X,NN)
OPTION ARITHMETIC DECIMAL_HIGH
LET S=N
FOR I=1 TO NN-1
LET S=S*(N-I)
NEXT I
LET DF=S*X^(N-NN)
END FUNCTION
!' 改良ニュートン法
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET XX=T
DO
LET X=XX
LET L=DF(X)*(F(X)-F(X-F(X)/DF(X)))
IF L=0 THEN
LET XX=X
EXIT DO
END IF
LET XX=X-F(X)^2/L
PRINT XX
LOOP UNTIL ABS(X-XX)<EPS
PRINT XX;XX^3
END
EXTERNAL FUNCTION F(X)
LET F=X*X*X-T
END FUNCTION
EXTERNAL FUNCTION DF(X)!' f'(x)
LET DF=3*X^2
END FUNCTION
!' ウェグスティン法(WEGSTEIN法)
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET EPS=1E-8
LET X0 = T
LET X1 = F(X0)
DO WHILE ABS(F(X2) - X2) > EPS
LET X2 = X1 + (X1 - X0) / ((X0 - F(X0)) / (X1 - F(X1)) - 1)
PRINT X2
LET X0 = X1
LET X1 = X2
LOOP
PRINT X2;X2*X2
END
EXTERNAL FUNCTION F(X) !' X=F(X) F(X)-X=0
LET F=X * X + X - T
END FUNCTION
!' エイトケン法(AITKEN法)
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET EPS=1E-8
LET X0 = T
DO WHILE ABS(F(X0) - X0) > EPS
LET X1 = F(X0)
LET X2 = F(X1)
LET X3 = X0 - (X1 - X0) * (X1 - X0) / (X2 - 2 * X1 + X0)
LET X0 = X3
PRINT X0
LOOP
PRINT X0;X0*X0
END
EXTERNAL FUNCTION F(X) !' X=F(X) F(X)-X=0
LET F=X * X + X - T
END FUNCTION
!' スラー法
PUBLIC NUMERIC N,T
INPUT PROMPT "n乗根=":N
INPUT PROMPT "X=": T
LET EPS=1E-8
LET XX = T
DO
LET X=XX
LET XX = X - G(X) / DG(X) !' f(x)=x^n-t g(x)=f(x)/f'(x) x=x-g(x)/g'(x)
PRINT XX
LOOP UNTIL ABS(X-XX)<EPS
PRINT XX;XX^N
END
EXTERNAL FUNCTION F(X)
LET F=X^N-T
END FUNCTION
EXTERNAL FUNCTION DF(X)!' f'(x)
LET DF=N*X^(N-1)
END FUNCTION
EXTERNAL FUNCTION DF2(X)!' f''(x)
LET DF2=N*(N-1)*X^(N-2)
END FUNCTION
EXTERNAL FUNCTION G(X)
LET G=F(X)/DF(X)
END FUNCTION
EXTERNAL FUNCTION DG(X)!' (f(x)/f'(x))'
LET DG=(DF(X)^2-DF2(X)*F(X))/DF(X)^2
END FUNCTION
!' ？？？(不明です)
PUBLIC NUMERIC N,T
INPUT PROMPT "n乗根=":N
INPUT PROMPT "X=": T
LET XX = T
LET EPS=1E-8
!' XA=X-F(X)/F'(X) G(X)=F(X)/F'(X)
!' XB=X-G(X)/G'(X)
!' X=(XA+XB)/2
DO
LET X=XX
LET X1 = X - F(X)/DF(X)
LET X2 = X - G(X)/DG(X)
LET XX = (X1 + X2)/2
PRINT XX
LOOP UNTIL ABS(X-XX)<EPS
PRINT XX;XX^N
END
EXTERNAL FUNCTION F(X)
LET F=X^N-T
END FUNCTION
EXTERNAL FUNCTION DF(X)!' f'(X)
LET DF=N*X^(N-1)
END FUNCTION
EXTERNAL FUNCTION DF2(X)!' f''(X)
LET DF2=N*(N-1)*X^(N-2)
END FUNCTION
EXTERNAL FUNCTION G(X)
LET G=F(X)/DF(X)
END FUNCTION
EXTERNAL FUNCTION DG(X)!' (f(x)/f'(x))'
LET DG=(DF(X)^2-DF2(X)*F(X))/DF(X)^2
END FUNCTION
!' ラゲール法(LAGUERRE法)
PUBLIC NUMERIC T,N
INPUT PROMPT "n乗根=":N
INPUT PROMPT "X=":T
LET EPS=1E-8
LET X=T
DO
LET XX=X-N*F(X)/(DF(X)+SGN(DF(X))*SQR(H(X)))
PRINT XX
LET X=XX
LOOP UNTIL ABS(F(X))<EPS
PRINT X;X^N
END
EXTERNAL FUNCTION H(X)
LET H=(N-1)^2*DF(X)^2-N*(N-1)*F(X)*DF2(X)
END FUNCTION
EXTERNAL FUNCTION F(X)
LET F=X^N-T
END FUNCTION
EXTERNAL FUNCTION DF(X)
LET DF=N*X^(N-1)
END FUNCTION
EXTERNAL FUNCTION DF2(X)
LET DF2=N*(N-1)*X^(N-2)
END FUNCTION
!' ハリー無理法
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET XX=T
DO
LET X=XX
LET H=DF(X)^2-2*F(X)*DF2(X)
IF H>0 THEN
LET XX=X-(DF(X)-SQR(H))/DF2(X)
ELSE
LET XX=X-DF(X)/DF2(X)
END IF
PRINT XX
LOOP UNTIL ABS(XX-X)<EPS
PRINT XX;XX^3
END
!' マラー法(MULLER法)
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET X2=T
LET X0=1
LET X1=(X0+X2)/2
DO
LET A=((X1-X2)*F(X0)+(X2-X0)*F(X1)+(X0-X1)*F(X2))/((X0-X1)*(X1-X2)^2)
LET B=((X1-X2)*(2*X0-X1-X2)*F(X0)-(X0-X2)^2*F(X1)+(X0-X1)^2*F(X2))/((X0-X1)*(X1-X2)^2)
LET C=(X0-X2)*F(X0)/(X1-X2)
LET D=B*B-4*A*C
IF D>0 THEN
LET XA=(-B+SQR(D))/(2*A)
LET XB=(-B-SQR(D))/(2*A)
IF ABS(F(X0-XA))<ABS(F(X0)) THEN
LET XX=X0-XA
ELSEIF ABS(F(X0+XA))<ABS(F(X0)) THEN
LET XX=X0+XA
ELSEIF ABS(F(X0-XB))<ABS(F(X0)) THEN
LET XX=X0-XB
ELSEIF ABS(F(X0+XB))<ABS(F(X0)) THEN
LET XX=X0+XB
END IF
ELSE
LET XA=-B/(2*A)
IF ABS(F(X0-XA))<ABS(F(X0)) THEN
LET XX=X0-XA
ELSEIF ABS(F(X0+XA))<ABS(F(X0)) THEN
LET XX=X0+XA
END IF
END IF
PRINT XX
LET X2=X1
LET X1=X0
LET X0=XX
LOOP UNTIL ABS(F(XX))<EPS
PRINT XX;XX^4
END
EXTERNAL FUNCTION F(X)
LET F=X*X*X*X-T
END FUNCTION
!' トラウブ法(TRAUB法)
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET EPS=1E-8
LET X0=T
LET X2=1
LET X1=(X0+X2)/2
LET Y0=F(X0)
LET Y1=F(X1)
LET Y2=F(X2)
LET DX=(X0-X2)/2
LET D1=(Y0-Y1)/DX
DO
LET D2=D1
LET D1=(Y0-Y1)/DX
LET H=(D1-D2)/(X0-X2)
LET OME=D1+(X0-X1)*H
LET S=OME*OME-4*Y0*H
IF S>0 THEN
LET SQ=SQR(S)
IF OME<0 THEN LET SQ=-SQ
LET DX=-2*Y0/(OME+SQ)
ELSE
LET DX=-.5*OME/EPS
END IF
LET X=X0+DX
LET Y=F(X)
LET X2=X1
LET Y2=Y1
LET X1=X0
LET Y1=Y0
LET X0=X
LET Y0=Y
IF ABS(F(X))<EPS THEN EXIT DO
PRINT X
LOOP
PRINT X;X*X
END
!' オストロフスキー法(OSTROWSKI法)
PUBLIC NUMERIC T
INPUT PROMPT "X=": T
LET X0=T
LET X2=1
LET X1=(X0+X2)/2
LET EPS=1E-8
DO
LET TT=(X2-X1)/(X2-X0)*(F(X2)-F(X0))/(F(X2)-F(X1))*F(X1)/F(X0)
LET X3=(X1-X0*TT)/(1-TT)
LET X0=X1
LET X1=X2
LET X2=X3
PRINT X3
LOOP UNTIL ABS(F(X3))<EPS
PRINT X3;X3*X3
END
!' 逆2次関数法
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET XMIN=1
LET XMAX=T
DO
LET XMID=(XMIN+XMAX)/2
LET YMIN=F(XMIN)
LET YMAX=F(XMAX)
LET YMID=F(XMID)
LET XNEW=XMIN*YMID*YMAX/(YMIN-YMID)/(YMIN-YMAX)+XMID*YMAX*YMIN/(YMID-YMAX)/(YMID-YMIN)+XMAX*YMIN*YMID/(YMAX-YMIN)/(YMAX-YMID)
IF XNEW>XMID THEN
LET XMIN=XMID
LET YMIN=YMID
ELSE
LET XMAX=XMID
LET YMAX=YMID
END IF
LET XMID=XNEW
LET YMID=F(XNEW)
PRINT XMID
LOOP UNTIL ABS(YMID)<EPS
PRINT XMID;XMID^3
END
!' ブレント法(BRENT法)
PUBLIC NUMERIC T
INPUT PROMPT "X=":T
LET EPS=1E-8
LET A=1
LET B=T
LET C=A
LET FLG=0
DO UNTIL F(B)=0 OR F(S)=0 OR ABS(B-A)<EPS
IF F(A)<>F(C) AND F(B)<>F(C) THEN
LET S=A*F(B)*F(C)/(F(A)-F(B))/(F(A)-F(C))+B*F(A)*F(C)/(F(B)-F(A))/(F(B)-F(C))+C*F(A)*F(B)/(F(C)-F(A))/(F(C)-F(B))
ELSE
LET S=B-F(B)*(B-A)/(F(B)-F(A))
END IF
IF (S<(3*A+B)/4 OR S>B) OR (FLG=1 AND ABS(S-B)>=ABS(B-C)/2) OR (FLG=0 AND ABS(S-B)>=ABS(C-D)/2) OR (FLG=1 AND ABS(B-C)<EPS) OR (FLG=0 AND ABS(C-D)<EPS) THEN
LET S=(A+B)/2
LET FLG=1
ELSE
LET FLG=0
END IF
LET D=C
LET C=B
IF F(A)*F(S)<0 THEN LET B=S ELSE LET A=S
IF ABS(F(A))<ABS(F(B)) THEN SWAP A,B
PRINT B;S
LOOP
PRINT B;S;B*B*B;S*S*S
END
!' 高次収束式
OPTION ARITHMETIC DECIMAL_HIGH
OPTION BASE 0
PUBLIC NUMERIC N
INPUT PROMPT "n乗根=":N
INPUT PROMPT "X=":T
LET MODE=3
DIM A(N)
LET A(N)=1 !' A(N)*X^N+A(N-1)*X^(N-1)+...A(1)*X+A(0)=0
LET A(0)=-T
LET XX=T
DO
LET X=XX
CALL HORNER(A,X,Y,DY,DY2,DY3,DY4,DY5)
SELECT CASE MODE
CASE 2
LET XX=X-Y/DY !'NEWTON法
CASE 3
LET XX=X-Y/(DY-Y*DY2/(2*DY)) !'BAILEY法
CASE 4
LET XX=X-Y*(DY^2-DY2*Y/2)/(DY^3-Y*DY*DY2+DY3*Y^2/6) !'KISS法
CASE 5
LET XX=X+(4*Y^3*DY3-24*Y^2*DY*DY2+24*Y*DY^3)/(Y^3*DY4-8*Y^2*DY*DY3-6*Y^2*DY2^2+36*Y*DY^2*DY2-24*DY^4)
CASE 6
LET XX=X+(5*Y^4*DY4-40*Y^3*DY*DY3-30*Y^3*DY2^2+180*Y^2*DY^2*DY2-120*Y*DY^4)/(Y^4*DY5-10*Y^3*DY*DY4+(60*Y^2*DY^2-20*Y^3*DY2)*DY3+90*Y^2*DY*DY2^2-240*Y*DY^3*DY2+120*DY^5)
END SELECT
PRINT XX
LOOP UNTIL X=XX
PRINT X
END
EXTERNAL SUB HORNER(A(),X,Y,DY,DY2,DY3,DY4,DY5)
OPTION ARITHMETIC DECIMAL_HIGH
LET Y=A(N)
LET DY=Y
LET DY2=Y
LET DY3=Y
LET DY4=Y
LET DY5=Y
FOR I=N-1 TO 0 STEP -1
LET Y=Y*X+A(I)
IF I>0 THEN LET DY=DY*X+Y
IF I>1 THEN LET DY2=DY2*X+DY
IF I>2 THEN LET DY3=DY3*X+DY2
IF I>3 THEN LET DY4=DY4*X+DY3
IF I>4 THEN LET DY5=DY5*X+DY4
NEXT I
LET DY2=DY2*FACT(2)
LET DY3=DY3*FACT(3)
LET DY4=DY4*FACT(4)
LET DY5=DY5*FACT(5)
END SUB
!' アーバス法(Aberth法)
OPTION ARITHMETIC COMPLEX
OPTION BASE 0
PUBLIC NUMERIC N,EPS
LET N=10 !'次数
LET EPS=1E-8
DIM Z(N),A(N)
LET A(N)=1 !' A(N)*X^N+A(N-1)*X^(N-1)+...A(1)*X+A(0)=0
LET A(0)=-1
CALL HORNER(A,-A(N-1)/(N*A(N))/A(N),Y,DY)
FOR I=1 TO N
LET Z(I)=-A(N-1)/(N*A(N))+ABS(Y)^(1/N)*EXP(SQR(-1)*2*PI*(I-1)/N+3/(2*N))
NEXT I
DO
FOR I=1 TO N
LET S=0
FOR J=1 TO N
IF I<>J THEN LET S=S+1/(Z(I)-Z(J))
NEXT J
CALL HORNER(A,Z(I),Y,DY)
LET Z(I)=Z(I)-Y/(DY-Y*S)
NEXT I
LET FL=0
FOR I=1 TO N
CALL HORNER(A,Z(I),Y,DY)
IF ABS(RE(Y))>EPS OR ABS(IM(Y))>EPS THEN
LET FL=1
EXIT FOR
END IF
NEXT I
LOOP UNTIL FL=0
FOR I=1 TO N
PRINT "ANSWER";I;":";
CALL DISPLAY(Z(I))
NEXT I
END
EXTERNAL SUB DISPLAY(Z)
OPTION ARITHMETIC COMPLEX
IF ABS(RE(Z))>EPS THEN PRINT RE((Z));
IF ABS(IM(Z))>EPS THEN
IF IM(Z)<0 THEN
PRINT "-";
ELSE
IF ABS(RE(Z))>EPS THEN PRINT "+";
END IF
PRINT ABS(IM(Z));"i";
END IF
PRINT
END SUB
EXTERNAL SUB HORNER(A(),X,Y,DY)
OPTION ARITHMETIC COMPLEX
LET Y=A(N)
LET DY=Y
FOR I=N-1 TO 0 STEP -1
LET Y=Y*X+A(I)
IF I>0 THEN LET DY=DY*X+Y
NEXT I
END SUB
!' 商差法(QD法)
OPTION ARITHMETIC COMPLEX
PUBLIC NUMERIC EPS
OPTION BASE 0
INPUT PROMPT "次数=": N
DIM D(N), A(N), Q(N)
LET EPS=1E-8
!' X^N+A(1)*X^(N-1)+A(2)*X^(N-2)+...A(N-1)*X+A(N)=0
FOR I = 0 TO N
DO
PRINT N - I;"次の複素係数 A+Bi A,B=";
INPUT RR,II
LET A(I)=COMPLEX(RR,II)
LOOP WHILE A(I) = 0 !'各係数は0でない
IF I>0 THEN LET A(I)=A(I)/A(0)
NEXT I
LET A(0)=1
LET Q(1)=-A(1)
FOR I = 1 TO N - 1
LET D(I) = A(I + 1) / A(I)
NEXT I
DO
FOR I = 1 TO N
LET Q(I) = Q(I) + D(I) - D(I - 1)
NEXT I
FOR I = 1 TO N - 1
LET D(I) = D(I) * Q(I + 1) / Q(I)
NEXT I
LET FL=0
FOR I = 1 TO N
IF ABS(D(I)) >= EPS THEN
LET FL=1
EXIT FOR
END IF
NEXT I
LOOP UNTIL FL=0
FOR I=1 TO N
PRINT "X(";STR$(I); ")=";
CALL DISPLAY(Q(I))
NEXT I
END
EXTERNAL SUB DISPLAY(Z)
OPTION ARITHMETIC COMPLEX
IF ABS(RE(Z))>EPS THEN PRINT RE((Z));
IF ABS(IM(Z))>EPS THEN
IF IM(Z)<0 THEN
PRINT "-";
ELSE
IF ABS(RE(Z))>EPS THEN PRINT "+";
END IF
PRINT ABS(IM(Z));"i";
END IF
PRINT
END SUB
!' 減速ニュートン法
LET X=3 !'初期値
LET EPS=1E-8
DO
LET U=2
DO
LET U=U/2
LET Y=X-U*F(X)/DF(X) !'減速ニュートン法
LOOP UNTIL ABS(F(Y))<(1-U/2)*ABS(F(X))
LET X=Y
LOOP UNTIL ABS(F(X))<EPS
PRINT X;F(X)
LET X=3 !'初期値
LET I=0
DO
LET X=X-F(X)/DF(X) !'ニュートン法
LET I=I+1
IF I>100 THEN
PRINT"収束しません"
STOP
END IF
LOOP UNTIL ABS(F(X))<EPS
PRINT X;F(X)
END
EXTERNAL FUNCTION F(X)
LET F=3*ATN(X-1)+X/4
END FUNCTION
EXTERNAL FUNCTION DF(X)
LET DF=3/((X-1)^2+1)+1/4
END FUNCTION
LET t0=TIME
RANDOMIZE
DECLARE EXTERNAL FUNCTION AP
DECLARE EXTERNAL FUNCTION TOP
DIM IN(1 TO 18,1 TO 10) !10個体を準備11から18は子孫
DIM CIN(1 TO 18,1 TO 10)
DIM INA(1 TO 18) !個体の評価値
FOR i=1 TO 10 !20個体をランダムに作成
FOR n=1 TO 10
LET IN(i,n)=INT(RND*2)
NEXT N
LET INA(i)=AP(IN,i)
NEXT i
FOR i=1 TO 10000 !世代数
!交叉
LET A=INT((TOP(INA)/100))
LET B=TOP(INA)-INT((TOP(INA)/100))*100
FOR t=1 TO 4
FOR n=1 TO 10
LET IN(10+2*t-1,n)=IN(A,n)
LET IN(10+2*t,n)=IN(B,n)
NEXT n
FOR n=1 TO 10
IF RND>0.9 THEN
LET IN(10+2*t-1,n)=IN(10+2*t-1,n)+IN(10+2*t,n)
LET IN(10+2*t,n)=IN(10+2*t-1,n)-IN(10+2*t,n)
LET IN(10+2*t-1,n)=IN(10+2*t-1,n)-IN(10+2*t,n)
END IF
NEXT n
NEXT t
FOR n=1 TO 10
LET CIN(1,n)=IN(A,n)
LET CIN(2,n)=IN(B,n)
NEXT n
FOR t=3 TO 10
FOR n=1 TO 10
LET CIN(t,n)=IN(t+8,n)
NEXT n
NEXT t
FOR t=1 TO 10 !IN書き出し＆突然変異
FOR n=1 TO 10
IF RND>0.05 THEN
LET IN(t,n)=CIN(t,n)
ELSE
LET IN(t,n)=1-CIN(t,n)
END IF
NEXT n
NEXT t
FOR t=1 TO 10
LET INA(t)=AP(IN,t)
NEXT t
NEXT i
LET P1=INT((TOP(INA)/100))
PRINT INA(P1)
PRINT time-t0
END
EXTERNAL FUNCTION AP(IN(,),i) !個体評価
DEF f(x)=SIN(3*x)+0.5*SIN(9*x)+SIN(15*x+50)
FOR n=0 TO 9
LET T=IN(i,n+1)
LET m=m+T*2^n
NEXT n
LET AP=f(m/1023)
END FUNCTION
EXTERNAL FUNCTION TOP(INA()) !優秀な個体の検索,返り値は配列番号0102見たいに上位２桁から一番
LET NO1=-10 !評価値の最低値以下の値
LET NO2=-10 !評価値の最低値以下の値
FOR i=1 TO 10
IF NO1<INA(i) THEN
LET NO1=INA(i)
LET TNO1=i
END IF
NEXT i
FOR i=1 TO 10
IF NO2<INA(i) AND i<>TNO1 THEN
LET NO2=INA(i)
LET TNO2=i
END IF
NEXT I
LET TOP=TNO1*100+TNO2
END FUNCTION
DEF F(x)=SIN(3*x)+0.5*SIN(9*x)+SIN(15*x+50) !適応度
LET N=10 !染色体の長さ
LET M=9 !個体数 ※Mは3以上
DIM X(M) !個体
FOR i=1 TO M !第0世代
LET X(i)=INT(RND*2^N) !x=[0,1)を2^N分割
NEXT i
MAT PRINT x; !debug
DIM NX(M) !次の世代
FOR t=1 TO 2000 !世代交代を進めて進化させる
!選択淘汰（Selection）
!※エリート選択による適応度がベスト1,2,3（一番大きな数から順に3つ）の3個体
LET A=-99999 !1番目 値は-∞
LET B=A !2番目
LET C=A !3番目
FOR i=1 TO M
LET W=F(X(i)/2^N) !関数f(x)の値
IF W>A THEN
LET C=B !降格
LET XC=XB
LET B=A
LET XB=XA
LET A=W !ベスト1
LET XA=i
ELSE
IF W>B THEN
LET C=B !降格
LET XC=XB
LET B=W !ベスト2
LET XB=i
ELSE
IF W>C THEN
LET C=W !ベスト3
LET XC=i
END IF
END IF
END IF
NEXT i
!!!PRINT XA;A; XB;B XC;C !debug
LET NX(1)=X(XA)
LET NX(2)=X(XB)
LET NX(3)=X(XC)
!上記の3個体を親として、各々の染色体について交叉（Cross Over）させた6個体
!※親Aa,Bb → 子Ab,Ba 親Aa,Cc → 子Ac,Ca 親Bb,Cc → 子Bc,Cb
LET p=2^INT(N/2) !1点交叉法（上位と下位）
LET NX(4)=INT(NX(1)/p)*p+MOD(NX(2),p) !Ab
LET NX(5)=INT(NX(2)/p)*p+MOD(NX(1),p) !Ba
LET NX(6)=INT(NX(1)/p)*p+MOD(NX(3),p) !Ac
LET NX(7)=INT(NX(3)/p)*p+MOD(NX(1),p) !Ca
LET NX(8)=INT(NX(2)/p)*p+MOD(NX(3),p) !Bc
LET NX(9)=INT(NX(3)/p)*p+MOD(NX(2),p) !Cb
FOR i=1 TO M !次の世代へ
LET X(i)=NX(i)
!各々の染色体について0.01の確率で遺伝子を変異させる
!※1つのビットの0,1を反転させる
IF RND<0.01 THEN LET X(i)=bitreverse(INT(RND*N),X(i)) !突然変異（Mutation）
NEXT i
NEXT t
MAT PRINT x; !debug
LET x0=X(1)/2^N !進化の結果
PRINT "x=";x0; " f(x)=";f(x0) !検算 x=.140792279664446 f(x)=1.84931356430434
END
!UBASIC ビット演算関連より
EXTERNAL FUNCTION bitreverse(n,x) !n番目のビットを反転する ※n,xは非負整数
LET d=2^n !n桁
LET a=INT(x/d)
LET bitreverse=(INT(a/2)*4-a+1)*d+MOD(x,d) !大きい桁＋NOT＋小さい桁
END FUNCTION
FUNCTION find_max(a,b) !区間[a,b]でf(x)が最大値を示すxの値
LET r=2/(3+SQR(5))
LET c=a+r*(b-a) !a＜c＜d＜b
LET d=b-r*(b-a)
LET fc=F(c)
LET fd=F(d)
DO WHILE d-c>1E-14 !d=cまで
IF fc<fd THEN !f(c)＜f(d)なら
LET a=c !区間を狭める a＜a'=c＜c'=d＜d'＜b
LET c=d
LET d=b-r*(b-a)
LET fc=fd
LET fd=F(d)
ELSE
LET b=d !a＜c'＜d'=c＜b'=d＜b
LET d=c
LET c=a+r*(b-a)
LET fd=fc
LET fc=F(c)
END IF
LOOP
LET find_max=c
END FUNCTION
LET N=8 !種類
DATA 7,3,2,6,1,5,10,3 !重さ
DATA 8,4,3,10,7,9,5,2 !価値
LET A=20
DIM W(N),V(N)
MAT READ W
MAT READ V
LET VMAX=0
FOR P=0 TO 2^N-1 !全パターン
LET WW=0
LET VV=0
LET B=P
LET i=1
DO WHILE B>0
LET WW=WW+MOD(B,2)*W(i)
LET VV=VV+MOD(B,2)*V(i)
LET B=INT(B/2)
LET i=i+1
LOOP
IF WW<=A AND VV>VMAX THEN LET VMAX=VV
NEXT P
PRINT "価値=";VMAX
END
●貧欲法
「その場での最善」を選択することを繰り返す。シンプルで高速である。
LET N=8 !種類
DATA 7,3,2,6,1,5,10,3 !重さ
DATA 8,4,3,10,7,9,5,2 !価値
LET A=20
DIM W(N),V(N)
MAT READ W
MAT READ V
LET VMAX=0
DO WHILE A>0
LET Vi=0
FOR i=1 TO N
IF W(i)<=A AND V(i)>Vi THEN !価値が最も大きいもの
LET Vi=V(i)
EXIT FOR !最初に見つかったもの
END IF
NEXT i
IF i>N THEN EXIT DO !条件を満たすものが既にない場合
LET VMAX=VMAX+Vi
LET A=A-W(i) !除外して次へ
LET V(i)=0 !※最小値
LOOP
PRINT "価値=";VMAX
END
●動的計画法（Dynamic Programming、DP）
LET N=8 !種類
DATA 7,3,2,6,1,5,10,3 !重さ
DATA 8,4,3,10,7,9,5,2 !価値
LET A=20
DIM W(N),V(N)
MAT READ W
MAT READ V
DIM DP(0 TO A)
FOR i=1 TO N
LET j=A
DO WHILE j>=W(i)
LET DP(j)=MAX(DP(j),DP(j-W(i))+V(i))
LET j=j-1
LOOP
NEXT i
MAT PRINT DP; !DP(A)
END
●遺伝的アルゴリズム
RANDOMIZE
LET N=8 !種類
DATA 7,3,2,6,1,5,10,3 !重さ
DATA 8,4,3,10,7,9,5,2 !価値
LET A=20
DIM W(N),V(N)
MAT READ W
MAT READ V
FUNCTION F(X,W()) !適応度
LET FF=0
LET ii=1
LET XX=X
DO WHILE XX>0 !10進法から2進法へ
LET FF=FF+MOD(XX,2)*W(ii)
LET XX=INT(XX/2)
LET ii=ii+1
LOOP
LET F=FF
END FUNCTION
LET M=4 !個体数 ※Mは2以上
DIM X(M) !個体
FOR i=1 TO M !第0世代
LET X(i)=INT(RND*2^N) !0から2^N-1まで
NEXT i
MAT PRINT X; !debug
DIM NX(M) !次の世代
FOR t=1 TO 10 !世代交代によって進化させる
!選択淘汰（Selection）
!※エリート選択による適応度がベスト1,2（一番大きな数から順に2つ）の2個体
LET T1=-999 !1番目 値は-∞
LET T2=T1
FOR i=1 TO M
LET WK=F(X(i),V)
IF F(X(i),W)>A THEN LET WK=0 !制限を越えるなら解ではないので、0とする
IF WK>T1 THEN
LET T2=T1 !降格
LET X2=X1
LET T1=WK !ベスト1
LET X1=i
ELSE
IF WK>T2 THEN
LET T2=WK !ベスト2
LET X2=i
END IF
END IF
NEXT i
LET NX(1)=X(X1)
LET NX(2)=X(X2)
!上記の2個体を親として、各々の染色体について交叉（Cross Over）させた2個体
!※親Aa,Bb → 子Ab,Ba
LET P=2^INT(N/2)
LET NX(3)=INT(NX(1)/P)*P+MOD(NX(2),P)
LET NX(4)=INT(NX(2)/P)*P+MOD(NX(1),P)
FOR i=1 TO M !次の世代へ
LET X(i)=NX(i)
!各々の染色体について0.05の確率で遺伝子を変異させる
!※上位と下位を入れ替える（1点逆位） Aa → aA
IF RND<0.05 THEN
LET P=3 ! !突然変異（Mutation） 1～[N/2]
LET X(i)=INT(X(i)/2^P)+MOD(X(i),2^P)*2^(N-P)
END IF
NEXT i
NEXT t
MAT PRINT X; !debug
LET N=8 !種類
DATA 7,3,2,6,1,5,10,3 !重さ
DATA 8,4,3,10,7,9,5,2 !価値
LET A=20
DIM W(N),V(N)
MAT READ W
MAT READ V
PUBLIC NUMERIC VMAX
LET VMAX=0
CALL try(1,A, 0, N,A,W,V)
END
EXTERNAL SUB try(P,R, V0, N,A,W(),V()) !バックトラック法で検索する
FOR i=0 TO MIN(1,INT(R/W(P))) !詰め込む（枝刈り） ※ビットパターン
LET RR=R-W(P)*i !残り
LET VV=V0+V(P)*i !価値
IF RR>0 AND P<N THEN !n種類まで（深さ優先）
CALL try(P+1,RR, VV, N,A,W,V)
ELSE
IF VV>=VMAX THEN !ここまでの結果を得る
LET VMAX=VV
PRINT "価値=";VMAX
END IF
END IF
NEXT i
END SUB
OPTION ARITHMETIC RATIONAL !有理数モード
LET N=4 !変数の個数
PUBLIC NUMERIC C !解の個数
LET C=0
DIM D(N)
CALL try(1,D, 1,1,N) !1≦x≦y≦z≦w、1/x+1/y+1/z+1/w=1
!!!PRINT C
END
EXTERNAL SUB try(P,D(), A,B,N)
OPTION ARITHMETIC RATIONAL !有理数モード
IF P=N THEN !最後の変数wなら
LET W=1/B
!!IF W=INT(W) AND W>=A THEN
IF W=INT(W) THEN
LET D(N)=W
LET C=C+1 !個数
PRINT C
MAT PRINT D; !解
END IF
ELSE
FOR i=MAX(A,INT(1/B)+1) TO INT((N-P+1)/B) !x
LET D(P)=i
LET BB=B-1/i !1-1/x
IF BB>0 THEN CALL try(P+1,D, i,BB,N) !次の変数yへ
NEXT i
END IF
END SUB
DIM F(0 TO X) !出現回数
MAT F=ZER
FOR P=2 TO 2^32-1 !組み合わせ（ビットパターン）
LET R=0 !最上位の1の位置
LET w=P
LET A=0 !n=±1^m±2^m±3^m± … ±k^m
LET B=0
LET K=1 !10進法から2進法へ
DO WHILE w>0
LET s=MOD(w,2)
IF s=1 THEN LET R=K
LET A=A+(2*s-1)*K^M !0,1 → -1,1
LET B=B+(1-2*s)*K^M !0,1 → 1,-1
LET w=INT(w/2) !次の桁へ
LET K=K+1
LOOP
IF (A>=0 AND A<=X) THEN CALL PrintOut(A,P,1) !範囲内なら結果を表示する
IF (B>=0 AND B<=X) THEN CALL PrintOut(B,P,-1)
IF P=2^R-1 THEN !2のべき乗でひと区切りする
FOR i=0 TO X !すべてが見つかったなら
IF F(i)=0 THEN EXIT FOR
NEXT i
IF i>X THEN EXIT FOR !終了!!!
END IF
NEXT P
PRINT P; 2^R !debug
MAT PRINT F; !debug
SUB PrintOut(N,P,S) !式 n=±1^m±2^m±3^m± … ±k^m を表示する
LET F(N)=F(N)+1 !出現回数
IF F(N)=1 THEN !最初なら、式を表示する
PRINT STR$(N);"=";
LET w=P !ビットパターン
LET K=1
DO WHILE w>0 !10進法から2進法へ
IF MOD(w,2)=0 THEN !±
IF S=1 THEN PRINT "-"; ELSE PRINT "+";
ELSE
IF S=1 THEN PRINT "+"; ELSE PRINT "-";
END IF
PRINT STR$(K); !k^m
IF M>1 THEN PRINT "^";STR$(M);
LET w=INT(w/2) !次の桁へ
LET K=K+1
LOOP
PRINT
END IF
END SUB
PUBLIC NUMERIC xSIZE,ySIZE !盤の大きさ
LET xSIZE=7
LET ySIZE=2
DECLARE STRING INIT$ !初期の状態
LET INIT$="飛銀金 金銀角×銀金玉金銀×"
PUBLIC STRING GOAL$ !完成の状態
LET GOAL$="角銀金 金銀飛×銀金玉金銀×"
PUBLIC NUMERIC LIM !手数の上限 →最少手数
LET LIM=52
!---------- ↓↓↓↓↓ ---------- 盤面の正当性を確認する
IF LEN(INIT$)<>ySIZE*xSIZE THEN
PRINT "盤の大きさ（xSIZE,ySIZE）と駒の数（INIT$）が合いません。"
STOP
END IF
IF LEN(GOAL$)<>ySIZE*xSIZE THEN
PRINT "盤の大きさ（xSIZE,ySIZE）と駒の数（GOAL$）が合いません。"
STOP
END IF
FOR p=1 TO ySIZE*xSIZE !盤を走査して空白を見つける
IF INIT$(p:p)=" " THEN EXIT FOR
NEXT p
IF p>ySIZE*xSIZE THEN
PRINT "空白がありません。"
STOP
END IF
!---------- ↑↑↑↑↑ ----------
PUBLIC STRING KO$(5) !駒の種類と移動可能範囲 ※８近傍 動きは将棋と同じ
!DATA "×○××歩××××"
DATA "○○○×銀×○×○"
DATA "○○○○金○×○×"
DATA "○○○○玉○○○○"
DATA "×○×○飛○×○×"
DATA "○×○×角×○×○"
FOR i=1 TO UBOUND(KO$)
READ KO$(i)
NEXT i
PUBLIC STRING STK$(0 TO 200) !局面の記録 ※スタック
FOR i=0 TO 200
LET STK$(i)=""
NEXT i
PUBLIC NUMERIC C !解の個数
LET C=0
LET STK$(0)=INIT$
CALL backtrack(1,p) !１手目
IF C=0 THEN PRINT "解なし"
PRINT "計算時間=";TIME-t0;"秒"
END
EXTERNAL SUB backtrack(L,p) !１手ずつ打っていき、行き詰まれば元に戻ってやり直す
LET bd$=stk$(L-1) !現在の局面
!---------- ↓↓↓↓↓ ---------- 枝刈り
IF L<=30 THEN !飛車の移動
FOR i=1 TO ySIZE*xSIZE !誘導
IF bd$(i:i)="角" THEN EXIT FOR
NEXT i
IF L>15 AND (i=13 OR i=7) THEN EXIT SUB
IF L>20 AND (i=5 OR i=13 OR i=7) THEN EXIT SUB
IF L>24 AND NOT(i=1 OR i=9 OR i=3 OR i=11) THEN EXIT SUB
IF L>27 AND NOT(i=1 OR i=9) THEN EXIT SUB
IF bd$(9:9)="角" AND bd$(1:1)="銀" THEN EXIT SUB !禁じ手
IF bd$(1:1)="角" THEN !決り手
PRINT L
IF NOT(bd$(6:7)="銀金" AND bd$(13:13)="金") THEN EXIT SUB !決り手
END IF
ELSE !角の移動
IF NOT(bd$(1:1)="角") THEN EXIT SUB
FOR i=1 TO ySIZE*xSIZE !誘導
IF bd$(i:i)="飛" THEN EXIT FOR
NEXT i
IF L>35 AND (i=1 OR i=2 OR i=9 OR i=3 OR i=10) THEN EXIT SUB
IF L>40 AND NOT(bd$(2:3)="銀金" AND bd$(9:10)="銀金") THEN EXIT SUB !決り手
IF bd$(6:6)="飛" AND bd$(7:7)="金" THEN EXIT SUB !禁じ手
END IF
!---------- ↑↑↑↑↑ ----------
LET px=MOD(p-1,xSIZE)+1 !水平・垂直の座標へ
LET py=INT((p-1)/xSIZE)+1
FOR d=1 TO 9 !隣接する駒を探す
IF d=5 THEN
ELSE
LET mx=px + MOD(d-1,3)-1 !移動元の座標 ※dを水平・垂直の差分dx,dyへ
LET my=py + INT((d-1)/3)-1
IF (mx>=1 AND mx<=xSIZE) AND (my>=1 AND my<=ySIZE) THEN !盤内か確認する
LET mp=(my-1)*xSIZE + mx !連番へ
LET t$=bd$(mp:mp)
IF t$="×" OR t$=" " THEN
ELSE
FOR a=1 TO UBOUND(KO$) !駒の属性を得る
IF t$=KO$(a)(5:5) THEN EXIT FOR
NEXT a
IF KO$(a)(10-d:10-d)="×" THEN !移動可能範囲なら
ELSE
LET w$=bd$
LET w$(p:p)=t$ !移動させる
LET w$(mp:mp)=" "
IF w$=GOAL$ THEN !完成なら、手順を記録しておく
LET C=C+1
PRINT L;"手"
FOR i=0 TO L-1
PRINT STR$(i);": ";STK$(i)
NEXT i
PRINT STR$(L);": ";w$
LET LIM=L !上限を狭める
ELSE
FOR t=L TO 0 STEP -1 !最近の局面から順に新しい手かどうか確認する
IF STK$(t)=w$ THEN EXIT FOR
NEXT t
IF t<0 THEN
LET STK$(L)=w$ !記録して、次の局面へ
IF L<LIM THEN CALL backtrack(L+1,mp) !上限まで
END IF
END IF
DIM A(100)
FOR M=1 TO 10
FOR N=M TO M !n×n
!!FOR N=1 TO M
PRINT "m*n="; M;N
CALL try(1,M,N,M*N,A)
PRINT
NEXT N
NEXT M
END
EXTERNAL SUB try(K,M,N,R,A()) !バックトラック法で検索する
FOR i=0 TO INT(R/K^2) !k^2の候補
LET A(K)=i !a[k]*k^2
LET W=R-i*K^2
IF W=0 THEN !残りがない場合
IF A(1)>0 THEN !※最小正方形（1^2）を含むもの
LET S=0 !結果を表示する
FOR J=1 TO K
LET S=S+A(J)
IF A(J)>0 THEN PRINT "+";STR$(A(J));"*";STR$(J);"^2"; !※係数0は除く
!!PRINT "+";STR$(A(J));"*";STR$(J);"^2";
NEXT J
PRINT " (";STR$(S);")"
END IF
ELSE
IF K<=N THEN CALL try(K+1,M,N,W,A) !次へ
END IF
NEXT i
END SUB
MAT A=ZER
FOR i=1 TO N !左側の括弧
FOR J=1 TO S !右側の括弧
LET w=R(i)*RR(J) !展開する
CALL SqNormalize(w, p,q) !√wをp√qと変形する
FOR K=1 TO S !√qの位置を探す
IF q=RR(K) THEN EXIT FOR
NEXT K
IF K>S THEN
PRINT "論理エラー"; i;J; w; p;q
STOP
ELSE !見つかったなら
LET A(K,J)=A(K,J)+C(i)*p
END IF
NEXT J
NEXT i
MAT PRINT A; !debug
MAT b=ZER
LET b(1)=1 !( … )√1の係数を1と仮定する
DIM iA(S,S) !連立方程式を解く
MAT iA=INV(A)
MAT x=iA*b
MAT PRINT x; !debug
!結果を表示する
LET G=1
FOR i=1 TO S
IF x(i)<>0 THEN LET G=GCD(G,x(i))
NEXT i
PRINT G !分母
FOR i=1 TO S !√の項
IF x(i)<>0 THEN PRINT x(i)/G; "√";STR$(RR(i))
NEXT i
END
EXTERNAL SUB SqNormalize(n, p,q) !平方根の中をできるだけ小さな正の整数に直す
!※n=p^2*q、n,p,q≧0とすると、√n=p*√qと変形できる。
OPTION ARITHMETIC RATIONAL !有理数モード
LET q=1 !※√0=0*√1とする ※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INTSQR(n) TO 1 STEP -1 !約数p^2の候補を大きい方から
LET q=n/p^2
IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB
EXTERNAL SUB PolynomialExtendedGCD(aa,A(),bb,B(), ss,S(),tt,T(),cc,C()) !拡張ユークリッド互除法
OPTION ARITHMETIC RATIONAL !有理数モード
IF bb=0 AND B(0)=0 THEN !!--- IF b=0 THEN
!!--- s=1 ※f(x)*1+0*0=f(x)とする
LET S(0)=1
LET ss=0
!!--- t=0
LET T(0)=0
LET tt=0
!!--- c=a
MAT C=A
LET cc=aa
ELSE
!!--- q=INT(a/b), r=MOD(a,b)
DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE)
IF aa=0 AND bb=0 THEN !定数項のみ
LET Q(0)=INT(A(0)/B(0))
LET qq=0
LET R(0)=MOD(A(0),B(0))
LET rr=0
ELSE
CALL PolynomialQuotientRemainder(aa,A,bb,B, qq,Q,rr,R)
END IF
!!--- t=u-v*q
DIM W(0 TO MAX_DEGREE)
CALL PolynomialMultiply(ss,S,qq,Q, ww,W)
MAT T=T-W
LET tt=ww
END IF
END SUB
!補助ルーチン
!演算関連
EXTERNAL SUB PolynomialMultiply(aa,A(),bb,B(), ss,S()) !乗算 S=A*B ※S≠A、S≠B
OPTION ARITHMETIC RATIONAL !有理数モード
MAT S=ZER
FOR i=aa TO 0 STEP -1
LET k=A(i)
IF k=0 THEN !係数が0以外なら
ELSE
FOR j=bb TO 0 STEP -1
LET S(i+j)=S(i+j)+k*B(j) !すべての係数をかける
NEXT j
END IF
NEXT i
LET ss=aa+bb!次数 ※その補正
END SUB
EXTERNAL SUB PolynomialQuotientRemainder(aa,A(),bb,B(), qq,Q(),rr,R()) !除算 ※被除数=商*除数+余り
OPTION ARITHMETIC RATIONAL !有理数モード
IF bb=0 AND B(0)=0 THEN !除数が0なら
PRINT "0で割ることはできません。"
STOP
ELSE
MAT Q=ZER !商
MAT R=A !余り
FOR t=aa TO bb STEP -1 !被除数の次数が除数のより大きいなら
IF R(t)=0 THEN !係数が0以外なら
ELSE
LET k=R(t)/B(bb) !商の係数、その次数
LET w=t-bb
LET Q(w)=k !商
FOR i=bb TO 0 STEP -1 !余り ※R=A-k*B
LET R(w+i)=R(w+i)-k*B(i)
NEXT i
END IF
NEXT t
LET qq=MAX(aa-bb,0) !次数
IF aa>=bb THEN LET i=MAX(bb-1,0) ELSE LET i=aa !次数
FOR rr=i TO 1 STEP -1 !※その補正
IF R(rr)<>0 THEN EXIT FOR
NEXT rr
END IF
END SUB
!表示関連
EXTERNAL SUB PolynomialDisplay(aa,A()) !多項式を表示する a(X)=ΣAkX^k=AnX^n+An-1X^n-1+…+A1X+A0
OPTION ARITHMETIC RATIONAL !有理数モード
CALL mono_disp(A(aa),aa) !最初の項
FOR i=aa-1 TO 0 STEP -1 !次項
LET w=A(i)
IF w>0 THEN PRINT "+";
IF w<>0 OR aa=0 THEN CALL mono_disp(w,i)
NEXT i
END SUB
EXTERNAL SUB mono_disp(ak,k) !単項式を表示する Ak*X^k
OPTION ARITHMETIC RATIONAL !有理数モード
IF k<>0 THEN !x^nで
IF ak=0 OR ak=1 THEN !係数が0,1なら
ELSEIF ak=-1 THEN !係数が－１なら
PRINT "-"; !符号
ELSE
PRINT STR$(ak);"*";
END IF
END IF
IF k=0 THEN !次数が0なら
PRINT STR$(ak);
ELSE
IF ak<>0 THEN !係数が0以外なら
PRINT "X";
IF k<>1 THEN PRINT "^";STR$(k); !次数が1以外なら
END IF
END IF
END SUB
実行結果
+2/11*X^2+3/11*X-1/11
-2/11*X-5/11
1
数値計算による検算
PRINT 1/(4^(1/3)+2^(1/3)-1)
LET X=2^(1/3)
PRINT (2*X^2+3*X-1)/11
END
DIM R(N),C(N) !√a、√b、√c、… のn個
MAT READ R
MAT READ C
!分子の計算
DIM R1(2^N),C1(2^N) !√a、√b、√c、√ab、√bc、√ca、√abc、… の高々2^n個
LET R1(1)=1 !定数1
LET C1(1)=1
LET S1=1 !個数
LET F=0 !元の分母の符号パターン
FOR i=1 TO N
LET F=F*2+(SGN(C(i))+1)/2
NEXT i
PRINT F !debug
DIM P(N)
FOR i=0 TO 2^N-1 !符号パターン（共役な数）を発生させる
IF i=F THEN !同じならスキップする
ELSE
LET t=i
FOR J=N TO 1 STEP -1 !2進法n桁
LET P(J)=MOD(t,2)*2-1
LET t=INT(t/2)
NEXT J
!!!MAT PRINT P; !debug
DIM WW(2^N),W(2^N) !積 (+√a+√b+√c)(+√a+√b-√c)(+√a-√b+√c) …
DIM WC(N) !共役な数の係数
FOR J=1 TO N
LET WC(J)=ABS(C(J))*P(J)
NEXT J
CALL SqMultiply(S1,R1,C1,N,R,WC, M,WW,W) !乗算
MAT R1=WW !次へ
MAT C1=W
LET S1=M
END IF
NEXT i
PRINT S1 !debug
MAT PRINT R1; !debug
MAT PRINT C1; !debug
!分母の計算
DIM R2(2^N),C2(2^N) !√a、√b、√c、√ab、√bc、√ca、√abc、… の高々2^n個
MAT R2=R1 !分子の値
MAT C2=C1
LET S2=S1
CALL SqMultiply(S2,R2,C2,N,R,C, M,WW,W) !乗算
MAT R2=WW
MAT C2=W
LET S2=M
PRINT S2 !debug
MAT PRINT R2; !debug
MAT PRINT C2; !debug
!結果を表示する
LET G=C1(1) !分母
FOR i=2 TO S1
IF C1(i)<>0 THEN LET G=GCD(G,C1(i))
NEXT i
FOR i=1 TO N !√1の位置を探す
IF R2(i)=1 THEN EXIT FOR
NEXT i
LET G=GCD(G,C2(i))*SGN(C2(i)) !既約分数
PRINT C2(i)/G
FOR i=1 TO S1 !分子
IF C1(i)<>0 THEN PRINT C1(i)/G; "√";STR$(R1(i)) !√の項
NEXT i
END
!補助ルーチン
!演算関連
!積 (p√a+q√b+ … +r√c)(s√x+t√y+ … +u√z) を求める
! aa個の平方根、ar[]=a,b,…c、a[]=p,q,…r
! bb個の平方根、br[]=x,y,…z、b[]=s,t,…u
EXTERNAL SUB SqMultiply(aa,AR(),A(),bb,BR(),B(), cc,CR(),C()) !乗算 C=A*B ※A≠C、B≠C
OPTION ARITHMETIC RATIONAL !有理数モード
LET cc=0 !個数
FOR x=1 TO aa
FOR y=1 TO bb
LET K=A(x)*B(y) !係数の部分
CALL SqNormalize(AR(x)*BR(y), P,Q) !平方根の中の部分
FOR J=1 TO cc !新しい値なら
IF Q=CR(J) THEN EXIT FOR
NEXT J
IF J>cc THEN !リストに登録する
LET cc=cc+1
LET CR(cc)=Q !√q
LET C(cc)=P*K
ELSE !既出なら、和を求める（同類項をまとめる）
LET C(J)=C(J)+P*K
END IF
NEXT y
NEXT x
END SUB
EXTERNAL SUB SqNormalize(n, p,q) !平方根の中をできるだけ小さな正の整数に直す
!※n=p^2*q、n,p,q≧0とすると、√n=p*√qと変形できる。
OPTION ARITHMETIC RATIONAL !有理数モード
LET q=1 !※√0=0*√1とする ※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INTSQR(n) TO 1 STEP -1 !約数p^2の候補を大きい方から
LET q=n/p^2
IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB
LET N=4
DATA 2,3,5,6 !x=√2+√3+√5+√6
DATA 1,1,1,1
DATA 8 !f(x)=x^8-64x^6-96x^5+808x^4+1152x^3-2304x^2-1152x+144
DATA 144,-1152,-2304,1152,808,-96,-64,0,1
DIM R(N),C(N) !xを読み込む
MAT READ R
MAT READ C
READ M !f(x)の次数
READ B !分子Rを読み込む
DIM A(0 TO M-1) !分母Q(x)を読み込む
MAT READ A
DIM RR(2^N),CC(2^N) !高々2^n個
CALL SqValueOfFunction(N,R,C, M-1,A, S,RR,CC) !関数Q(x)の値
!結果を表示する
FOR i=1 TO S !√の項
IF CC(i)<>0 THEN PRINT -CC(i)/B; "√";STR$(RR(i)) !-Q(x)/R
NEXT i
END
!補助ルーチン
!演算関連
!x=αのとき、f(α)の値を求める
! x=p√a+q√b+ … +r√c ※n個の平方根、r[]=a,b,…c、c[]=p,q,…r
! f(x)=A[m]x^m+A[m-1]x^(m-1)+ … +A[2]x^2+A[1]x+A[0]
EXTERNAL SUB SqValueOfFunction(N,R(),C(), M,A(), S,RR(),CC())
OPTION ARITHMETIC RATIONAL !有理数モード
LET RR(1)=1 !f=a[m]
LET CC(1)=A(M)
LET S=1
DIM WW(2^N),W(2^N)
FOR i=M-1 TO 0 STEP -1 !ホーナー法
CALL SqMultiply(S,RR,CC,N,R,C, T,WW,W) !f=f*x+a[i]
FOR J=1 TO T !√1を探す
IF WW(J)=1 THEN EXIT FOR
NEXT J
IF J>T THEN LET T=T+1
LET W(J)=W(J)+A(i)
MAT RR=WW !次へ
MAT CC=W
LET S=T
NEXT i
END SUB
!積 (p√a+q√b+ … +r√c)(s√x+t√y+ … +u√z) を求める
! aa個の平方根、ar[]=a,b,…c、a[]=p,q,…r
! bb個の平方根、br[]=x,y,…z、b[]=s,t,…u
EXTERNAL SUB SqMultiply(aa,AR(),A(),bb,BR(),B(), cc,CR(),C()) !乗算 C=A*B ※A≠C、B≠C
OPTION ARITHMETIC RATIONAL !有理数モード
LET cc=0 !個数
FOR x=1 TO aa
IF A(x)=0 THEN !係数が0以外なら
ELSE
FOR y=1 TO bb
LET K=A(x)*B(y) !係数
CALL SqNormalize(AR(x)*BR(y), P,Q) !√wをp√qと変形する
FOR J=1 TO cc !新しい値なら
IF Q=CR(J) THEN EXIT FOR
NEXT J
IF J>cc THEN !リストに登録する
LET cc=cc+1
LET CR(cc)=Q !√q
LET C(cc)=P*K
ELSE !既出なら、和を求める（同類項をまとめる）
LET C(J)=C(J)+P*K
END IF
NEXT y
END IF
NEXT x
END SUB
EXTERNAL SUB SqNormalize(n, p,q) !平方根の中をできるだけ小さな正の整数に直す
!※n=p^2*q、n,p,q≧0とすると、√n=p*√qと変形できる。
OPTION ARITHMETIC RATIONAL !有理数モード
LET q=1 !※√0=0*√1とする ※n=0なら、１行下のFOR文でp=0は設定される
FOR p=INTSQR(n) TO 1 STEP -1 !約数p^2の候補を大きい方から
LET q=n/p^2
IF q=INT(q) THEN EXIT FOR !qは自然数より
NEXT p
END SUB
!********************************************
! Encorder side R/W file
!********************************************
! read origin data with bits L
FUNCTION INP_E( L)
DO WHILE By< L
IF siz<=i9 THEN
LET INP_E=Hy
LET Hy=0
LET By=0
EXIT FUNCTION
END IF
LET i9=i9+1
LET Hy=Hy+ORD(db$(i9:i9))*2^By
LET By=By+8
LOOP
!----
LET INP_E=bitand(Hy,2^L-1)
LET Hy=IP(Hy*2^(-L))
LET By=By-L
END FUNCTION
! write huffman code with byte
SUB WRT_D( D)
LET huf$=huf$& CHR$(D)
IF D=255 THEN LET huf$=huf$& CHR$(0)
END SUB
!********************************************
! Decorder Side R/W file
!********************************************
! read huffman code with byte
FUNCTION INP_D
IF LEN(huf$)<=i9 THEN EXIT FUNCTION
LET i9=i9+1
LET INP_D=ORD(huf$(i9:i9))
END FUNCTION
! write origin data with bits L
SUB OUT_D( D, L)
LET Hy=Hy+D*2^By !By: staying bits in register Hy
LET By=By+L
DO WHILE 8<=By
IF siz<=o9 THEN EXIT SUB
LET o9=o9+1
LET out$=out$& CHR$(bitand(Hy,255))
LET Hy=IP(Hy*2^(-8))
LET By=By-8
LOOP
END SUB
!********************************************
SUB Decode0
LET i9=0 !input byte pointer
!
!---read tree =DHT( Define Huffman Table)
MAT DH=ZER
MAT DV=ZER
LET lmx=INP_D !huffman code max.length
FOR i=1 TO lmx
LET DH(i)=INP_D !DH(i) 各コード長の数( tree 各階層の終端数)
LET DH(0)=DH(0)+DH(i) !DH(0) 全コードの数( tree 分岐路の総数)
NEXT i
FOR i=0 TO DH(0)-1
LET DV(i)=INP_D
NEXT i
!
!---make huffman.code table & decorder table
MAT B=ZER !code table
MAT L=ZER !code length
CALL makeH0 !Code table B() L()<-- DH()
CALL makeD0 !Decorder table A()<-- B() L() DH() DV()
CALL list_DHT
CALL list_HT
CALL list_A
!
!---read huffman code
LET siz=INP_D+256*INP_D+65536*INP_D+16777216*INP_D !output data size
LET o9=0 !output byte pointer
LET out$="" !output byte buffer
LET By=0 !remainder in output bit register
LET Hy=0 !output bit register
!---
LET BC=0 !remainder in input register
LET Hx=0 !input register
CALL R_BLK0
END SUB
SUB R_BLK0
DO WHILE o9< siz
CALL DEC1_NS
CALL OUT_D(V_,xL)
LOOP
END SUB
!==========================================================
! decorder
! 区切れなく連続する bit の流れから、A() で復号。
! L_ ← 検出された登録ハフマンコードの bit長
! V_ ← 検出された登録ハフマンコードに対応する座標( 8bit値)
!----------------------------------------------------------
SUB DEC1_NS
LET NA=0
DO
IF BC< BST THEN CALL DEC1_IN
LET W=Hx*SHb !bits width BST
!----
LET NA=A(NA+IP(W)) !line adr. NA=0 table end
IF 32768<=NA THEN EXIT DO !DU0L LLLL VVVV VVVV
LET BC=BC-BST
LET Hx=FP(W)
LOOP
LET L_=MOD(IP(NA/256),128) ! U0L LLLL
LET V_=MOD(NA,256) ! VVVV VVVV
IF lmx< L_ THEN PRINT "unused code"
!----
LET W=MOD(L_,BST)
IF W=0 THEN LET W=BST
LET BC=BC-W
LET Hx=FP(Hx*2^W)
END SUB
SUB DEC1_IN
LET W=INP_D
IF W=255 THEN
LET M=INP_D
IF M<>0 THEN LET w=1/0 !EXTYPE=3001, ffxx marker, abnormally break
END IF !BC: ┌┐buffer remain
LET Hx=Hx+W*2^(-8-BC) !Hw: xx.xxxxxxxxx bits(BST).～b(-?)
LET BC=BC+8 !W: └──→ next input space
END SUB !BST:└┘decord pitch
!======================================
! B()L()<-- DH() for decorder table A()
!--------------------------------------
SUB makeH0
LET i=0 !コード生成 順番(短い順)
LET Hx=0
FOR L_=1 TO lmx !lmx= 最大 bit 長
FOR P=1 TO DH(L_)
LET L(i)=L_
LET B(i)=Hx !コード(生成順), 座標DV(頻度降順) と同順。
LET i=i+1
LET Hx=Hx+1
NEXT P
LET Hx=Hx*2
NEXT L_
LET B(256)=0
END SUB
!=============================================
! make decorder table A()<-- B() L() DH() DV()
!---------------------------------------------
SUB makeD0
FOR LH=lmx TO 1 STEP -1
IF DH(LH)<>0 THEN EXIT FOR
NEXT LH !bit length max. in huffman table
LET LM=CEIL(LH/BST)*BST !bit length max. bound by BST
!---
LET i=0 !start huffman table adr.
LET LA=0 !line adr.
LET NC=0 !next start Decord code
LET P=BST !start Decord code width
DO
LET D_=NC !start Decord code
LET D_=D_*SHb !shr(U_,BST)
LET D9=2^P ! over Decord code
LET NC=-1
LET LB=LA+(D9-D_) !1st nest adr.
DO
CALL SERCH
IF 0< L_ THEN
LET A(LA)= BVAL("8000",16)+L_*256+DV(i) !D00L LLLL VVVV VVVV !b15=end. +L.+V.
ELSEIF P=LM THEN
LET A(LA)= BVAL("C000",16)+LH*256 !DU0L LLLL VVVV VVVV !b15=end. b14=Unused. +L.
ELSE
IF NC=-1 THEN LET NC=D_
LET A(LA)=LB !0nnn nnnn nnnn nnnn !nest adr.
LET LB=LB+SHb !next nest adr.
END IF
LET D_=D_+1
LET LA=LA+1
LOOP UNTIL D9<=D_
LET P=P+BST
LOOP UNTIL LM< P
!---
LET A(LA)=0 !(0),table stop mark
END SUB
SUB SERCH
FOR i=i TO DH(0)-1
LET L_=L(i)
IF L_<=P THEN LET w=IP( D_*2^(L_-P)) ELSE EXIT FOR
IF w<=B(i) THEN
IF w=B(i) THEN EXIT SUB ELSE EXIT FOR
END IF
NEXT i
LET L_=-1
END SUB
!=========================================
! print Decoder table. Process_list<-- A()
!-----------------------------------------
SUB list_A
PRINT
PRINT "****** Decoder table A() ******"
PRINT "下表は、BST 幅( 現在は "& STR$(BST)& "bit)づつ区切って読込み"
PRINT "配列 A() をたどって、不明な長さ(len.)の Code を、"
PRINT "特定( 復号)していく仕組み。 座標<>""--"" で終点。"
PRINT "----------------------------------------------"
LET L4=MAX(LM,4)
PRINT "Line A() Code"& REPEAT$(" ",L4-4)& " len. 座標"
!---
LET LA=0 !line adr.
LET NC=0
LET P=BST
DO
LET D_=NC !next start Decord code
LET D_=D_*SHb
LET D9=2^P !over Decord code
LET NC=-1
DO
LET W=A(LA)
!! IF W=0 THEN EXIT DO
IF 32768<=W THEN !DU0L LLLL VVVV VVVV
LET L_=MOD( IP(W/256),128) ! U0L LLLL
LET V_=MOD(W,256) ! VVVV VVVV
LET w1$=USING$("##",MOD(L_,32))& " "& RIGHT$("0"& BSTR$(V_,16),2)
IF 64< L_ THEN LET w1$(3:6)=" -- Unused"
ELSE !0nnn nnnn nnnn nnnn
IF NC=-1 THEN LET NC=D_
LET L_=0
LET V_=0
LET w1$=" - -- Line"& STR$(W)
END IF
LET w$=USING$( "####",LA)& right$(" "& BSTR$(W,16),6)& " "
LET w$=w$& right$("0000000"& BSTR$(D_,2),P)& REPEAT$(" ",L4+2-P)& w1$
PRINT w$
!---
LET D_=D_+1
LET LA=LA+1
LOOP UNTIL D9<=D_
LET P=P+BST !next Decord code width
LOOP UNTIL LM< P !W=0
!---
PRINT USING$( "####",LA)& right$(" "& BSTR$( A(LA),16),6) !verify end
PRINT "decoder table end"
END SUB
!=========================
! print huffman code table
!-------------------------
SUB list_HT
PRINT
PRINT "huffman code"
PRINT " 頻度 座標 len. コード(";
IF MOD(B(256),2)=1 THEN PRINT "座標順)" ELSE PRINT "生成順、頻度降順)"
LET sum=0
FOR i=0 TO 255
IF L(i)<>0 THEN
IF MOD(B(256),2)=1 THEN !1=Sort at value. Encorder 用
LET V_=i
LET w$=RIGHT$(" "& BSTR$(SV(i),16),5)& " " !times
LET sum=sum+L(i)*SV(i)
ELSE !0=Sort at length. Decorder 用
LET V_=DV(i)
LET w$=RIGHT$(" "& BSTR$(S_(i),16),5)& " " !times
LET sum=sum+L(i)*S_(i)
END IF
LET w$=w$& right$("0"& BSTR$(V_,16),2)& " " !value
LET w$=w$& right$(" "& STR$(L(i)),2)& " " !huffman code length
LET w$=w$& right$("0000000"& BSTR$(B(i),2),L(i)) !huffman code
PRINT w$
END IF
NEXT i
PRINT " 合計( 頻度 * bit)=";sum
END SUB
!===================
! print huffman tree
!-------------------
SUB list_TREE
PRINT
PRINT "huffman tree ****１行が長い時( ～ 数1000桁 )、右端で折り返さない注意！****"
PRINT " 0,00: 7,01 などの意味 → 縦0階,横00番：縦7階,横01番 に２分岐"
!---disp.nest
FOR Le=Le0 TO 0 STEP -1
LET w$=right$(" "& BSTR$(Le,16),2)& "|"
FOR Ad=0 TO SE+1
IF Tr(Le,Ad,1)>0 OR Tr(Le,Ad,3)>0 THEN
LET w$=w$&
&& right$(" "& BSTR$(Tr(Le,Ad,0),16),2)& ","& right$("0"& BSTR$(Tr(Le,Ad,1),16),2)& ":"&
&& right$(" "& BSTR$(Tr(Le,Ad,2),16),2)& ","& right$("0"& BSTR$(Tr(Le,Ad,3),16),2)& "|"
ELSE
LET w$=w$& "----"& right$(" "& BSTR$(Le,16),2)& "-----|"
END IF
NEXT Ad
PRINT w$
NEXT Le
!---hor.scale
LET w$=""
FOR Ad=0 TO SE+1
LET w$=w$& " "& right$("0"& BSTR$(Ad,16),2)& " " !Care tail SP.
NEXT Ad
!---hor.frequency
LET w$=w$& crlf$& "頻度 "
FOR Ad=0 TO SE+1
IF 0< S_(Ad) THEN LET w1$=left$( BSTR$(S_(Ad),16)& " ",6) ELSE LET w1$="unused "
LET w$=w$& w1$& " "
NEXT Ad
!---hor.value
LET w$=w$& crlf$& "座標 "
FOR Ad=0 TO SE+1
IF 0< S_(Ad) THEN LET w1$=right$("0"& BSTR$(DV(Ad),16),2)& " " ELSE LET w1$="unused"
LET w$=w$& w1$& " "
NEXT Ad
!---hor.rank
LET w$=w$& crlf$& "len. "
FOR Ad=0 TO SE+1
LET w$=w$& right$(" "& BSTR$(Tr(0,Ad,0),16),2)& " "
NEXT Ad
PRINT w$
END SUB
!------- full write binary
SUB save(f$,d$) !d$ → 全ファイル
OPEN #1: NAME f$
ERASE#1
PRINT #1: d$;
CLOSE #1
END SUB
!------- full read binary
SUB load(f$,d$) !d$ ← 全ファイル
OPTION CHARACTER BYTE
OPEN #1: NAME f$, ACCESS INPUT
SET #1: ENDOFLINE CHR$(13)
ASK #1: FILESIZE s9
LET d$=""
DO
LINE INPUT #1,IF MISSING THEN EXIT DO :w9$
LET d$=d$& w9$& CHR$(13)
LOOP
CLOSE #1
IF s9< LEN(d$) THEN LET d$=d$(1:LEN(d$)-1)
END SUB
!==================
SUB Encode0
LET siz=LEN(db$) !source DATA length
! ---analize source, --> frequency= SV( each data )
MAT SV=ZER
CALL F_BLK0
!
!---make tree =DHT( Define Huffman Table )
MAT DH=ZER
MAT DV=ZER
CALL MAKE_DHT !lmx DH() <-- S_() DV() <-- SV()
CALL list_TREE
CALL list_DHT
!
!---make huffman encorder table
MAT B=ZER !huffman.code table
MAT L=ZER !huffman.code length
CALL MAKE_H2 !huffman.code table B()L() <-- DH()DV()
CALL list_HT !listing huffman.code table B()L()
!
!---output DHT( Define Huffman Table)
LET huf$=CHR$(lmx) !huffman code max.length
FOR i=1 TO lmx
LET huf$=huf$& CHR$( DH(i)) !DH(i) 各コード長の数( tree 各階層の終端数)
NEXT i
FOR i=0 TO DH(0)-1 !DH(0) 全コードの数( tree 分岐路の総数)
LET huf$=huf$& CHR$( DV(i))
NEXT i
!
!---output huffman coded source
LET huf$=huf$& dword$(siz) !source DATA length
LET Hw=0 !output bit_stream_buffer
LET BC=0 !remainder bits in Hw
CALL W_BLK0
CALL W_FLUSH
END SUB
!---------
SUB F_BLK0
LET i9=0 !input buffer pointer
LET By=0 !input register remainder bit
LET Hy=0 !input register
DO WHILE i9< siz OR 0< By
LET V_=INP_E(xL)
LET SV(V_)=SV(V_)+1
LOOP
END SUB
!---------
SUB W_BLK0
LET i9=0 !input buffer pointer
LET By=0 !input register remainder bit
LET Hy=0 !input register
DO WHILE i9< siz OR 0< By
LET V_=INP_E(xL)
CALL W_HUFF( L(V_),B(V_)) !L() huffman bit length, B() huffman code
LOOP
END SUB
!=============================================
! write bit stream
! L= データーのbit長、W= データー値(may be 0)
! 一定幅でない 入力データーを、
! 区切れのない連続の
! bit の流れ( MSB~LSB, MSB~LSB,,) にして出力
!---------------------------------------------
SUB W_HUFF( L, W )
LET Hw=Hw+W*2^(8-BC-L) !Hw: b7～b(-?) 左詰め bit_stream buffer < 100h
LET BC=BC+L
DO WHILE 8<=BC !BC:┌─────┐ stored data width b7～b(-?)
CALL WRT_D( IP(Hw)) !Hw: xxxxxxxx.xxx
LET Hw=FP(Hw)*256 ! └───┘ output parts b7～b0
LET BC=BC-8 !BC:┌ ┐
LOOP !Hw: xxx00000.0・・・
END SUB ! └───→ next data space
!---------------------------------------------
! write flush
! write bit stream の後、バッファ:Hx 内の残存
! bit を、byte 境界に合わせるため、不足 bit を
! "1" で埋めて書き出し、Hx を空にする。
!---------------------------------------------
SUB W_FLUSH
IF 0< BC THEN CALL W_HUFF( 8-BC, 2^(8-BC)-1) !write flush
END SUB
!======================================================
! DHT( Define Huffman Table segmet)
! 復号側に、符号化側で使用した符号木を、再現させる数表
! 構成：
! DH()= 符号木の 階層ごとの枝の数
! DV()= 出現頻度順に並べた 座標
!------------------------------------------------------
SUB MAKE_DHT
! --- monitor SV()
PRINT
PRINT "頻度表"
PRINT "座標= 横から縦の順。0～0xff データー値"
CALL msg_x( SV, 0,255, ""," ") !SV( 0~255)
PRINT "total=";Tx
!
!--- make S_()DV()<-- SV()
LET SE=-1
FOR i=0 TO 255
IF SV(i)<>0 THEN
LET SE=SE+1
LET S_(SE)=SV(i)
LET DV(SE)=i
END IF
NEXT i
PRINT
PRINT "上の表を、頻度数と、座標の２つの表に分解し、同順の対にする。"
PRINT "---------------------------------"
PRINT "表中、頻度数０を外して詰めたもの"
CALL msg_x( S_, 0,SE, ""," ") !S_(0~SE)
PRINT "座標"
CALL msg_x( DV, 0,SE, " ","00") !DV(0~SE)
!
!--- sort DV() by S_()
CALL Qsort(0,SE)
PRINT "---------------------------------"
PRINT "頻度の多い順に置換え (座標と対)"
CALL msg_x( S_, 0,SE, ""," ") !S_(0~SE)
PRINT "座標"
CALL msg_x( DV, 0,SE, " ","00") !DV(0~SE)
!
!--- make huffman tree, DH()
CALL TREE3
END SUB
SUB msg_x( M(), S,E, s$,n$) !16 進数 表示
LET Tx=0
LET w$=""
FOR i=S TO E
LET Tx=Tx+M(i)
LET w$=w$& s$& RIGHT$(n$& BSTR$(M(i),16), LEN(n$))
IF MOD(i-S,16)=15 THEN LET w$=w$& crlf$
NEXT i
IF MOD(i-S,16)=0 THEN PRINT w$; ELSE PRINT w$
END SUB
!プログラムは、出来た枝から、直接、ハフマン符号を作らず、
!各層における枝の数を、収めた 配列テーブル DH() を作成して終っている。
!
!SUB MAKE_H2 で、DH() から、ココで作成された木構造を、011・・の形(ハフマン符号)
!へ再生する事で、符号化に使用している。復号側も、SUB makeH0 で、DH() から再生。
!
!プログラムは、ハフマン符号木の最後尾に、使わない枝( 空席)も、１つ追加している。
!下の文中、 !←(+1) 符号木の最下に、空席を１つ作る。 …の行、２つ。
! SE+1 を、SE にすると、空席は無くなる。
!---------------------------------------------------------------------------
SUB TREE3
MAT Tr=ZER
FOR i=0 TO SE
LET F_(i)=S_(i) !数値を壊すので、コピー F_(i)で実行
NEXT i
LET F_(SE+1)=0 !← 空席用
!---minimum pair
DO
LET w=1e10
FOR i=0 TO SE+1 !←(+1) 符号木の最下に、空席を１つ作る。
IF F_(i)< w THEN
LET w=F_(i)
LET Ad1=i !minimum1 !頻度最小の分岐アドレスAd1
END IF
NEXT i
LET w=1e10
FOR i=0 TO SE+1 !←(+1) 符号木の最下に、空席を１つ作る。
IF F_(i)< w AND i<>Ad1 THEN
LET w=F_(i)
LET Ad2=i !minimum2 !頻度最小の分岐アドレスAd2
END IF
NEXT i
IF w=1e10 THEN EXIT DO !分岐の組が無くなるまで
!---
LET F_(Ad1)=F_(Ad1)+F_(Ad2) !次の頻度最小の組探しは、２分岐合計を１つにし、
LET F_(Ad2)=2e10 !他方を外して行なう
!---
FOR Le1=lmx TO 1 STEP -1 !アドレスAd1の最上 節点レベルLe1 を探す(最初のLe1=0)
IF Tr(Le1,Ad1,1)>0 OR Tr(Le1,Ad1,3)>0 THEN EXIT FOR
NEXT Le1
FOR Le2=lmx TO 1 STEP -1 !アドレスAd2の最上 節点レベルLe2 を探す(最初のLe2=0)
IF Tr(Le2,Ad2,1)>0 OR Tr(Le2,Ad2,3)>0 THEN EXIT FOR
NEXT Le2
LET Le0=MAX( Le1,Le2 )+1 !両者何れよりも１つ上の節点レベル(Le0,Ad1)に、
!---
LET Tr(Le0,Ad1,0)=Le1 !分岐先( 節点レベル,アドレス)として２組記入
LET Tr(Le0,Ad1,1)=Ad1
LET Tr(Le0,Ad1,2)=Le2
LET Tr(Le0,Ad1,3)=Ad2
IF lmx< Le0 THEN LET lmx=Le0 !最大段数 lmx の設定、更新
LOOP
!---make DH()
LET k=0
CALL bitl(Le0,Ad1) !全分岐路の 分岐段数 を求める。
FOR Ad=0 TO SE
LET DH(Tr(0,Ad,0))=DH(Tr(0,Ad,0))+1 !分岐段数 が同じ Tr(0,Ad,0) の
NEXT Ad !総数を、段数毎に、DH() に集計
LET DH(0)=Ad
END SUB
SUB bitl(Le,Ad) !最上 節点(Le0,Ad1)より全分岐路を、底まで辿る
IF 0< Le THEN
LET k=k+1
CALL bitl( Tr(Le,Ad,0), Tr(Le,Ad,1) ) !分岐先 1
CALL bitl( Tr(Le,Ad,2), Tr(Le,Ad,3) ) !分岐先 2
LET k=k-1
ELSE
LET Tr(0,Ad,0)=k !最上 節点から底までの 分岐段数 kを書く
END IF
END SUB
!-----------------------------
! Quick Sort S_() DV() by S_()
!-----------------------------
SUB Qsort(L,R) !降順にセット。
local i,j
LET i=L
LET j=R
LET Tx=S_(IP((L+R)/2))
DO
DO WHILE S_(i) >Tx ![>]降順 [< ]昇順
LET i=i+1
LOOP
DO WHILE Tx >S_(j) ![>]降順 [< ]昇順
LET j=j-1
LOOP
IF j< i THEN EXIT DO !等号付 j<=i は、暴走。
SWAP S_(i),S_(j)
SWAP DV(i),DV(j)
LET i=i+1
LET j=j-1
LOOP UNTIL j< i !等号付 j<=i は、低速。
IF L< j THEN CALL Qsort(L,j)
IF i< R THEN CALL Qsort(i,R)
END SUB
!===================================
! make encorder table B()L()<-- DH()
!-----------------------------------
SUB MAKE_H2
LET i=0 !コード生成 順番(短い順)
LET Hx=0
FOR L_=1 TO lmx !lmx= 最大 bit 長
FOR N=1 TO DH(L_)
LET V_=DV(i) !座標DV(頻度降順)
LET L(V_)=L_
LET B(V_)=Hx !コード(座標V_)
LET i=i+1
LET Hx=Hx+1
NEXT N
LET Hx=Hx*2
NEXT L_
LET B(256)=1
END SUB
LET N=2^M !共役の個数
DIM A(N)
LET A(1)= SQR(2)+SQR(3)+SQR(5) +SQR(6) !√6の符号 ∵√6=√2√3より
LET A(2)= SQR(2)+SQR(3)-SQR(5) +SQR(6)
LET A(3)= SQR(2)-SQR(3)+SQR(5) -SQR(6)
LET A(4)= SQR(2)-SQR(3)-SQR(5) -SQR(6)
LET A(5)=-SQR(2)+SQR(3)+SQR(5) -SQR(6)
LET A(6)=-SQR(2)+SQR(3)-SQR(5) -SQR(6)
LET A(7)=-SQR(2)-SQR(3)+SQR(5) +SQR(6)
LET A(8)=-SQR(2)-SQR(3)-SQR(5) +SQR(6)
DIM c(0 TO N) !係数 ※基本対称式
MAT c=ZER
FOR p=0 TO 2^N-1 !組み合わせで「解の積」を機械的に生成する
LET t=p
LET r=0 !ビット列の1の個数
LET W=1 !r個の積、C(n,r)通り
LET K=1
DO WHILE t>0
IF MOD(t,2)=1 THEN
LET r=r+1
LET W=W*(-A(K))
END IF
LET t=INT(t/2)
LET K=K+1
LOOP
LET c(N-r)=c(N-r)+W !x^(N-r)の係数
NEXT p
MAT PRINT c; !1,x,…,x^(n-1),x^nの係数
OPTION ARITHMETIC COMPLEX !複素数モード
LET i=COMPLEX(0,1) !虚数単位
DEF G(y)=y^2+y-1
LET y=2^(1/3)
LET w=EXP(2*PI*i/3) !y^3-1=0（y≠1）の解のひとつ
LET N=3 !共役の個数
DIM A(N)
LET A(1)=G(y)
LET A(2)=G(w*y)
LET A(3)=G(w^2*y)
DIM c(0 TO N) !係数 ※基本対称式
MAT c=ZER
FOR p=0 TO 2^N-1 !組み合わせで「解の積」を機械的に生成する
LET R=0 !ビット列の1の個数
LET S=1 !r個の積、C(n,r)通り
LET t=p !ビットパターン ※2進法n桁
LET K=1
DO WHILE t>0
IF MOD(t,2)=1 THEN !ビットが1なら
LET R=R+1
LET S=S*(-A(K))
END IF
LET t=INT(t/2) !次へ
LET K=K+1
LOOP
LET c(N-R)=c(N-R)+S !x^(n-r)の係数
NEXT p
MAT PRINT c; !1,x,…,x^(n-1),x^nの係数
OPTION ARITHMETIC COMPLEX !複素数モード
LET i=COMPLEX(0,1) !虚数単位
DEF G(x1,x2,x3)=x1+x2+x3+x1*x2 !∵√6=√2√3より、√6は除く
LET x1=SQR(2)
LET x2=SQR(3)
LET x3=SQR(5)
LET w=EXP(2*PI*i/2) !x^2-1=0（x≠1）の解のひとつ、すなわちω=-1
LET N=2^3 !共役の個数
DIM A(N)
LET A(1)=G( x1, x2, x3)
LET A(2)=G( x1, x2, w*x3)
LET A(3)=G( x1, w*x2, x3)
LET A(4)=G( x1, w*x2, w*x3)
LET A(5)=G(w*x1, x2, x3)
LET A(6)=G(w*x1, x2, w*x3)
LET A(7)=G(w*x1, w*x2, x3)
LET A(8)=G(w*x1, w*x2, w*x3)
DIM c(0 TO N) !係数 ※基本対称式
MAT c=ZER
FOR p=0 TO 2^N-1 !組み合わせで「解の積」を機械的に生成する
LET R=0 !ビット列の1の個数
LET S=1 !r個の積、C(n,r)通り
LET t=p !ビットパターン ※2進法n桁
LET K=1
DO WHILE t>0
IF MOD(t,2)=1 THEN !ビットが1なら
LET R=R+1
LET S=S*(-A(K))
END IF
LET t=INT(t/2) !次へ
LET K=K+1
LOOP
LET c(N-R)=c(N-R)+S !x^(n-r)の係数
NEXT p
MAT PRINT c; !1,x,…,x^(n-1),x^nの係数
EXTERNAL SUB PolynomialMultiply(aa,A(),bb,B(), ss,S()) !乗算 S=A*B ※S≠A、S≠B
OPTION ARITHMETIC COMPLEX !複素数モード
MAT S=ZER
FOR i=aa TO 0 STEP -1
LET k=A(i)
FOR j=bb TO 0 STEP -1
LET S(i+j)=S(i+j)+k*B(j) !すべての係数をかける
NEXT j
NEXT i
LET ss=aa+bb!次数 ※その補正
END SUB
EXTERNAL SUB PolynomialQuotientRemainder(aa,A(),bb,B(), qq,Q(),rr,R()) !除算 ※被除数=商*除数+余り
OPTION ARITHMETIC COMPLEX !複素数モード
IF bb=0 AND ABS(B(0))<1E-12 THEN !除数が0なら ※※複素数による近似
PRINT "0で割ることはできません。"
STOP
ELSE
MAT Q=ZER !商
MAT R=A !余り
FOR t=aa TO bb STEP -1 !被除数の次数が除数のより大きいなら
IF ABS(R(t))<1E-12 THEN !係数が0以外なら ※※複素数による近似
ELSE
LET k=R(t)/B(bb) !商の係数、その次数
LET w=t-bb
LET Q(w)=k !商
FOR i=bb TO 0 STEP -1 !余り ※R=A-k*B
LET R(w+i)=R(w+i)-k*B(i)
NEXT i
END IF
NEXT t
LET qq=MAX(aa-bb,0) !次数
IF aa>=bb THEN LET t=MAX(bb-1,0) ELSE LET t=aa !次数
FOR rr=t TO 1 STEP -1 !※その補正
IF ABS(R(rr))>=1E-12 THEN EXIT FOR ! ※※複素数による近似
LET R(rr)=0 ! ※※複素数による近似
NEXT rr
END IF
END SUB
LET gg=2 !解と係数の関係より、a,bを解とする2次方程式を得る
DIM G(0 TO gg)
LET a=-1 !2点A,B
LET b=2
LET G(2)=1
LET G(1)=-(a+b)
LET G(0)=a*b
DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE)
CALL PolynomialQuotientRemainder(ff,F,gg,G, qq,Q,rr,R)
PRINT qq !点C x+2=0
MAT PRINT Q;
PRINT rr !直線L y=-x-3
MAT PRINT R;
EXTERNAL FUNCTION PolynomialValue(a,ff,F()) !多項式の値 f(a)
OPTION ARITHMETIC RATIONAL !有理数モード
LET t=F(ff)
FOR i=ff-1 TO 0 STEP -1 !ホーナー法
LET t=t*a+F(i)
NEXT i
LET PolynomialValue=t
END FUNCTION
EXTERNAL SUB PolynomialDifferential(K,ff,F(), cc,C()) !k階微分
OPTION ARITHMETIC RATIONAL !有理数モード
MAT C=ZER
FOR i=K TO ff
LET C(i-K)=PERM(i,K)*F(i)
NEXT i
LET cc=MAX(ff-K,0)
END SUB
EXTERNAL SUB PolynomialPowerN(aa,A(), N, bb,B()) !べき乗展開（多項定理による）
OPTION ARITHMETIC RATIONAL !有理数モード
DIM P(aa+1) !{p,q,…,r}の並び
MAT B=ZER
CALL PolyPowN(N,aa+1,1,P, aa,A,N, B)
LET bb=aa*N
END SUB
EXTERNAL SUB PolyPowN(m,d,s,P(), aa,A(),N, B()) !自然数mをd分割する
OPTION ARITHMETIC RATIONAL !有理数モード
IF d=1 THEN
LET P(s)=m
!{p,q,…,r}で多項式を展開する
LET c=PermFactorialM(P,aa+1) !前半部分 (p+q+ … +r)!/(p!*q!* … *r!)
LET x=0 !後半部分を加味する
FOR i=0 TO aa
LET c=c*A(i)^P(i+1) !係数
LET x=x+i*P(i+1) !べき乗
NEXT i
LET B(x)=B(x)+c !記録する
ELSEIF d>1 THEN
FOR i=0 TO m
LET P(s)=m-i
CALL PolyPowN(i,d-1,s+1,P, aa,A,N, B) !次へ
NEXT i
END IF
END SUB
EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」
OPTION ARITHMETIC RATIONAL !有理数モード
LET s=B(M) !総数 r, … ,q+ … +r,p+q+ … +r
LET t=1 !組合せ comb(r,r), … ,comb(q+ … +r,q),comb(p+q+ … +r,p)
FOR i=M-1 TO 1 STEP -1
LET s=s+B(i)
LET t=t*COMB(s,B(i)) !組合せ順列
NEXT i
LET PermFactorialM=t
END FUNCTION
EXTERNAL SUB PolynomialComposition(aa,A(),bb,B(), ss,S()) !合成関数 f(g(x))
OPTION ARITHMETIC RATIONAL !有理数モード
DIM W(0 TO aa*bb)
LET S(0)=A(aa) !s=a[aa]
LET ss=0
FOR i=aa-1 TO 0 STEP -1 !ホーナー法
CALL PolynomialMultiply(ss,S,bb,B, ww,W) !s=s*X+a[i]
LET W(0)=W(0)+A(i)
MAT S=W !次へ
LET ss=ww
NEXT i
END SUB
EXTERNAL SUB PolynomialGCD(aa,A(),bb,B(), cc,C()) !最大公約数
OPTION ARITHMETIC RATIONAL !有理数モード
IF aa=0 AND bb=0 THEN !定数項のみなら
MAT C=ZER
LET C(0)=GCD(A(0),B(0))
LET cc=0
ELSE
DIM TA(0 TO MAX_DEGREE),TB(0 TO MAX_DEGREE) !作業変数
MAT TA=A
LET taa=aa
MAT TB=B
LET tbb=bb
DO WHILE NOT(tbb=0 AND TB(0)=0) !--- DO WHILE b<>0
DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE)
CALL PolynomialQuotientRemainder(taa,TA,tbb,TB, qq,Q,rr,R) !--- LET R=MOD(a,b)
MAT TA=TB !--- LET a=b
LET taa=tbb
MAT TB=R !--- LET b=R
LET tbb=rr
LOOP !--- LOOP
LET G=TA(0) !既約
FOR i=1 TO taa
LET G=GCD(G,TA(i))
NEXT i
MAT C=(1/G)*TA !--- LET GCD=a
LET cc=taa
END IF
END SUB
EXTERNAL SUB PolynomialLCM(aa,A(),bb,B(), cc,C()) !最小公倍数
OPTION ARITHMETIC RATIONAL !有理数モード
DIM G(0 TO MAX_DEGREE)
CALL PolynomialGCD(aa,A,bb,B, gg,G) !LCM=A*B/Gより
DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE)
CALL PolynomialQuotientRemainder(bb,B,gg,G, qq,Q,rr,R)
IF NOT(rr=0 AND R(0)=0) THEN !余りが0以外なら
PRINT "論理エラー"
STOP
END IF
CALL PolynomialMultiply(aa,A,qq,Q, cc,C)
END SUB
!拡張ユークリッド互除法
! f(x)=A[m]x^m+ … +A[1]x+A[0]、g(x)=B[n]x^n+ … +B[1]x+B[0]、m≧nとして、
! f(x)S(x)+g(x)T(x)=gcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。
EXTERNAL SUB PolynomialExtendedGCD(aa,A(),bb,B(), ss,S(),tt,T(),cc,C()) !拡張ユークリッド互除法
OPTION ARITHMETIC RATIONAL !有理数モード
CALL Poly_ExGCD(aa,A,bb,B, ss,S,tt,T,cc,C)
LET G=C(0) !既約
FOR i=1 TO cc
LET G=GCD(G,C(i))
NEXT i
LET G=G*SGN(C(cc)) !C(x)の最高次数の係数は正とする
MAT S=(1/G)*S
MAT T=(1/G)*T
MAT C=(1/G)*C
END SUB
!f(x)S(x)+g(x)T(x)=k*gcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。
EXTERNAL SUB Poly_ExGCD(aa,A(),bb,B(), ss,S(),tt,T(),cc,C()) !拡張ユークリッド互除法
OPTION ARITHMETIC RATIONAL !有理数モード
IF bb=0 AND B(0)=0 THEN !!--- IF b=0 THEN
!!--- s=1 !※f(x)*1+0*0=f(x)とする
MAT S=ZER
LET S(0)=1
LET ss=0
!!--- t=0
MAT T=ZER
LET T(0)=0
LET tt=0
!!--- c=a
MAT C=A
LET cc=aa
ELSE
!!--- q=INT(a/b), r=MOD(a,b)
DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE)
IF aa=0 AND bb=0 THEN !定数項のみ
MAT Q=ZER
LET Q(0)=INT(A(0)/B(0))
LET qq=0
MAT R=ZER
LET R(0)=MOD(A(0),B(0))
LET rr=0
ELSE
CALL PolynomialQuotientRemainder(aa,A,bb,B, qq,Q,rr,R)
END IF
!!--- t=u-v*q
DIM W(0 TO MAX_DEGREE)
CALL PolynomialMultiply(ss,S,qq,Q, ww,W)
MAT T=T-W
LET tt=ww
END IF
END SUB
!補助ルーチン
!演算関連
EXTERNAL SUB PolynomialMultiply(aa,A(),bb,B(), ss,S()) !乗算 S=A*B ※S≠A、S≠B
OPTION ARITHMETIC RATIONAL !有理数モード
MAT S=ZER
FOR i=aa TO 0 STEP -1
LET k=A(i)
IF k=0 THEN !係数が0以外なら
ELSE
FOR j=bb TO 0 STEP -1
LET S(i+j)=S(i+j)+k*B(j) !すべての係数をかける
NEXT j
END IF
NEXT i
LET ss=aa+bb!次数 ※その補正
END SUB
EXTERNAL SUB PolynomialQuotientRemainder(aa,A(),bb,B(), qq,Q(),rr,R()) !除算 ※被除数=商*除数+余り
OPTION ARITHMETIC RATIONAL !有理数モード
IF bb=0 AND B(0)=0 THEN !除数が0なら
PRINT "0で割ることはできません。"
STOP
ELSE
MAT Q=ZER !商
MAT R=A !余り
FOR t=aa TO bb STEP -1 !被除数の次数が除数のより大きいなら
IF R(t)=0 THEN !係数が0以外なら
ELSE
LET k=R(t)/B(bb) !商の係数、その次数
LET w=t-bb
LET Q(w)=k !商
FOR i=bb TO 0 STEP -1 !余り ※R=A-k*B
LET R(w+i)=R(w+i)-k*B(i)
NEXT i
END IF
NEXT t
LET qq=MAX(aa-bb,0) !次数
IF aa>=bb THEN LET t=MAX(bb-1,0) ELSE LET t=aa !次数
FOR rr=t TO 1 STEP -1 !※その補正
IF R(rr)<>0 THEN EXIT FOR
NEXT rr
END IF
END SUB
!表示関連
EXTERNAL SUB PolynomialDisplay(aa,A()) !多項式を表示する a(X)=ΣAkX^k=AnX^n+An-1X^n-1+…+A1X+A0
OPTION ARITHMETIC RATIONAL !有理数モード
CALL mono_disp(A(aa),aa) !最初の項
FOR i=aa-1 TO 0 STEP -1 !次項
LET w=A(i)
IF w>0 THEN PRINT "+";
IF w<>0 OR aa=0 THEN CALL mono_disp(w,i)
NEXT i
END SUB
EXTERNAL SUB mono_disp(ak,k) !単項式を表示する Ak*X^k
OPTION ARITHMETIC RATIONAL !有理数モード
IF k<>0 THEN !x^nで
IF ak=0 OR ak=1 THEN !係数が0,1なら
ELSEIF ak=-1 THEN !係数が－１なら
PRINT "-"; !符号
ELSE
PRINT STR$(ak);"*";
END IF
END IF
IF k=0 THEN !次数が0なら
PRINT STR$(ak);
ELSE
IF ak<>0 THEN !係数が0以外なら
PRINT "X";
IF k<>1 THEN PRINT "^";STR$(k); !次数が1以外なら
END IF
END IF
END SUB
DATA 3 !f(x)=x^3+x^2-4x+1=0
DATA 1,-4,1,1
DATA 2 !-α^2-2α+2
DATA 2,-2,-1
DATA 2 !α^2+α-3
DATA -3,1,1
READ ff !f(x)を読み込む
DIM F(0 TO ff)
MAT READ F
READ gg !g(α)を読み込む
DIM G(0 TO gg)
MAT READ G
DIM S(0 TO MAX_DEGREE)
CALL PolynomialComposition(ff,F,gg,G, ss,S) !f(-α^2-2α+2)を求める
PRINT ss
MAT PRINT S;
DIM Q(0 TO MAX_DEGREE),R(0 TO MAX_DEGREE)
CALL PolynomialQuotientRemainder(ss,S,ff,F, qq,Q,rr,R) !f(α)=0を考慮する
PRINT qq
MAT PRINT Q;
PRINT rr !余りが0となる
MAT PRINT R;
PRINT
!-------------------------------
READ hh !h(α)を読み込む
DIM H(0 TO hh)
MAT READ H
CALL PolynomialComposition(ff,F,hh,H, ss,S) !f(α^2+α-3)を求める
PRINT ss
MAT PRINT S;
CALL PolynomialQuotientRemainder(ss,S,ff,F, qq,Q,rr,R) !f(α)=0を考慮する
PRINT qq
MAT PRINT Q;
PRINT rr !余りが0となる
MAT PRINT R;
DATA 3 !x^3+3x-1
DATA -1,3,0,1
READ ff
DIM F(0 TO ff)
MAT READ F
DATA 2 !x^2+x+2
DATA 2,1,1
READ gg
DIM G(0 TO gg)
MAT READ G
DIM S(0 TO MAX_DEGREE),T(0 TO MAX_DEGREE),C(0 TO MAX_DEGREE)
CALL PolynomialExtendedGCD(ff,F,gg,G, ss,S,tt,T,cc,C) !sf+tg=(f,g)
PRINT ss
MAT PRINT S;
PRINT tt
MAT PRINT T; !s*0+tg=(f,g)より、1/g=t/(f,g)
PRINT cc !(f,g)
MAT PRINT C;
DATA 5 !n個の点
DATA 0, 1, 3, 6, 7 !X座標
DATA 0.8, 3.1, 4.5, 3.9, 2.8 !Y座標
READ N
DIM X(0 TO N-1),Y(0 TO N-1) !(x[i],y[i])
MAT READ X
MAT READ Y
DIM P(0 TO N-1) !（展開された）多項式
CALL PolynomialInterpolationL(N,X,Y, pp,P)
PRINT pp
MAT PRINT P;
FOR t=0 TO 7 STEP 0.5
LET s=P(N-1) !ホーナー法
FOR i=N-2 TO 0 STEP -1
LET s=s*t+P(i)
NEXT i
PRINT USING "-%.## -##.##########": t, s
NEXT t
END
!POLY.LIB
!多項式補間
EXTERNAL SUB PolynomialInterpolationN(N,X(),Y(), pp,P()) !ニュートン補間
OPTION ARITHMETIC RATIONAL !有理数モード
!f(x)=a[0]+a[1](x-x[0])+a[2](x-x[0])(x-x[1])+ … +a[n-2](x-x[0])(x-x[1]) … (x-x[n-2])
DIM A(0 TO N-1) !係数
DIM W(0 TO N-1)
FOR i=0 TO N-1
LET W(i)=Y(i)
FOR J=i-1 TO 0 STEP -1
LET W(J)=(W(J+1)-W(J))/(X(i)-X(J))
NEXT J
LET A(i)=W(0)
NEXT i
!!!MAT PRINT A; !debug
MAT P=ZER !f(x)=(…((a[n-1](x-x[n-2])+a[n-2])(x-x[n-3))+a[n-3]) … +a[1])(x-x[0])+a[0]
LET P(0)=A(N-1)
LET pp=0
FOR i=N-2 TO 0 STEP -1 !ホーナー法 s=s*(X-x[i])+a[i]
FOR J=pp TO 0 STEP -1
LET P(J+1)=P(J+1)+P(J) !s*X
LET P(J)=-P(J)*X(i) !-s*x[i]
NEXT J
LET P(0)=P(0)+A(i) !+a[i]
LET pp=pp+1
NEXT i
CALL Poly_DegUpdt(pp,P) !※その補正
END SUB
EXTERNAL SUB PolynomialInterpolationL(N,X(),Y(), pp,P()) !ラグランジュ補間
OPTION ARITHMETIC RATIONAL !有理数モード
MAT P=ZER
DIM W(0 TO N-1)
FOR i=0 TO N-1 !Σy[i]Π{(X-x[j])/(x[i]-x[j])}
MAT W=ZER !分子側
LET W(0)=1
LET ww=0
FOR J=0 TO N-1
IF i<>J THEN
FOR K=ww TO 0 STEP -1 !展開する w=w*(X-x[j])
LET W(K+1)=W(K+1)+W(K) !w*X
LET W(K)=-W(K)*X(J) !-w*x[j]
NEXT K
LET ww=ww+1
END IF
NEXT J
LET s=1 !分母側
FOR J=0 TO N-1
IF i<>J THEN LET s=s*(X(i)-X(J))
NEXT J
MAT W=(Y(i)/s)*W !Σ
MAT P=P+W
NEXT i
LET pp=N-1 !次数
CALL Poly_DegUpdt(pp,P) !※その補正
END SUB
EXTERNAL SUB Poly_DegUpdt(aa,A()) !次数を補正する
OPTION ARITHMETIC RATIONAL !有理数モード
FOR i=aa TO 1 STEP -1
IF A(i)<>0 THEN EXIT FOR
NEXT i
LET aa=i
END SUB
DATA 2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97 !素数
DIM P(20)
MAT READ P
FOR C=1 TO 1000 !個数
LET N=2^(C-1) !仮の最小
CALL try(1,P,1,C, N)
PRINT STR$(C);":"; N
NEXT C
END
EXTERNAL SUB try(i,P(),S,F, N) !約数の積に分解する 例 12の場合、12=6*2=4*3=3*2*2
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR D=1 TO INT(F/2) !約数の候補
IF MOD(F,D)=0 THEN !大きい順に F/1,F/2,F/3,…,3,2
LET FD=F/D
LET W=S*P(i)^(FD-1) !6*2のとき、2^5*3^1とする
IF W<N THEN !W≧Nなら、これ以降は可能性はない
IF D=1 THEN !分解が完了なら
LET N=W !最小のもの
ELSE
CALL try(i+1,P,W,D, N) !次へ
END IF
END IF
END IF
NEXT D
END SUB
FOR N=2 TO 100 !2以上の自然数
LET C=0
CALL try(1,F,N, C)
PRINT STR$(N);":"; C;"個"
NEXT N
END
EXTERNAL SUB try(i,F(),N, C) !約数の積に分解する 例 12の場合、12=6*2=4*3=3*2*2
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR D=1 TO INT(N/2) !約数の候補
IF MOD(N,D)=0 THEN !大きい順に F/1,F/2,F/3,…,3,2
LET F(i)=N/D
IF i=1 OR (i>1 AND F(i-1)>=F(i)) THEN
IF D=1 THEN !分解が完了なら
LET C=C+1
PRINT F(1); !結果を表示する
FOR K=2 TO i
PRINT "*";F(K);
NEXT K
PRINT
ELSE
CALL try(i+1,F,D, C) !次へ
END IF
FOR N=1 TO 100 !自然数
LET C=0
CALL try(1,F,N, C)
PRINT STR$(N);":"; C;"個"
NEXT N
END
EXTERNAL SUB try(i,F(),N, C) !約数の積に分解する 例 12の場合、12=6*2=4*3=3*2*2
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR D=1 TO INTSQR(N) !約数の候補
IF MOD(N,D)=0 THEN
LET W=N/D
IF i=1 OR (i>1 AND F(i-1)>=W) THEN !並びは大きい順に ※1番目は無条件
LET F(i)=W
IF D=1 THEN !分解が完了なら
LET C=C+1
PRINT F(1); !結果を表示する
FOR K=2 TO i
PRINT "*";F(K);
NEXT K
PRINT
ELSE
CALL try(i+1,F,D, C) !次へ
END IF
END IF
IF D>1 AND D*D<>N THEN !平方数以外なら、もう一方も
IF i=1 OR (i>1 AND F(i-1)>=D) THEN
> 前回と同様に外部ルーチンで、NをN/DとDに分解します。
> 再帰呼び出しで、DをNとして分解を続けます。
>
>
> OPTION ARITHMETIC RATIONAL !多桁の整数
>
> DIM F(20) !約数の積
>
> PRINT " 1" !1のとき
> PRINT "1: 1 個"
>
> FOR N=2 TO 100 !2以上の自然数
> LET C=0
> CALL try(1,F,N, C)
> PRINT STR$(N);":"; C;"個"
> NEXT N
>
> END
>
> EXTERNAL SUB try(i,F(),N, C) !約数の積に分解する 例 12の場合、12=6*2=4*3=3*2*2
> OPTION ARITHMETIC RATIONAL !多桁の整数
> FOR D=1 TO INT(N/2) !約数の候補
> IF MOD(N,D)=0 THEN !大きい順に F/1,F/2,F/3,…,3,2
> LET F(i)=N/D
> IF i=1 OR (i>1 AND F(i-1)>=F(i)) THEN
>
> IF D=1 THEN !分解が完了なら
> LET C=C+1
>
> PRINT F(1); !結果を表示する
> FOR K=2 TO i
> PRINT "*";F(K);
> NEXT K
> PRINT
> ELSE
> CALL try(i+1,F,D, C) !次へ
> END IF
>
> END IF
> END IF
> NEXT D
> END SUB
>
OPTION ARITHMETIC COMPLEX !複素数モード
LET i=COMPLEX(0,1) !虚数単位
!x=1-2^(1/3)+4^(1/3)の場合、f(x)=x^3-3*x^2+9*x-9
DEF G(y)=1-y+y^2
LET y=2^(1/3)
LET w=EXP(2*PI*i/3) !y^3-1=0（y≠1）の解のひとつ、すなわち ω=(-1+(√3)i)/2
LET N=3 !解の個数（共役の個数）
DIM A(N) !α[1],α[2],…,α[n]
LET A(1)=G( y)
LET A(2)=G( w*y)
LET A(3)=G(w^2*y)
!(x-α[1])(x-α[2]) … (x-α[n])を展開する
DIM C(0 TO N) !係数
LET C(1)=1 !X-α[1] !n個の解について
LET C(0)=-A(1)
FOR K=2 TO N !ホーナー法による
LET C(K)=0
FOR J=K-1 TO 0 STEP -1 !展開する w=w*(X-α[k])
LET C(J+1)=C(J+1)+C(J)
LET C(J)=-C(J)*A(K)
NEXT J
NEXT K
例
!x=2^(1/3)+√(-2)の場合、f(x)=x^6+6x^4-4x^3+12x^2+24x+12
DEF G(x1,x2)=x1+x2
LET x1=2^(1/3)
LET x2=SQR(-2)
LET w=EXP(2*PI*i/3) !x^3-1=0（x≠1）の解のひとつ、すなわち (-1+(√3)i)/2
LET N=3*2 !共役の個数
DIM A(N)
LET A(1)=G( x1, x2)
LET A(2)=G( w*x1, x2)
LET A(3)=G(w^2*x1, x2)
LET A(4)=G( x1, -x2)
LET A(5)=G( w*x1, -x2)
LET A(6)=G(w^2*x1, -x2)
例
!x=3^(1/2)+2^(1/3)の場合、f(x)=x^6-9x^4-4x^3+27x^2-36x-23
DEF G(x1,x2)=x1+x2
LET x1=3^(1/2)
LET x2=2^(1/3)
LET v=EXP(2*PI*i/2) !x^2-1=0（x≠1）の解のひとつ、すなわち -1
LET w=EXP(2*PI*i/3) !x^3-1=0（x≠1）の解のひとつ、すなわち (-1+(√3)i)/2
LET N=2*3 !共役の個数
DIM A(N)
LET A(1)=G( x1, x2)
LET A(2)=G(v*x1, w*x2)
LET A(3)=G( x1, w^2*x2)
LET A(4)=G(v*x1, x2)
LET A(5)=G( x1, w*x2)
LET A(6)=G(v*x1, w^2*x2)
SUB MtxSet(L,K, aa(),A(,)) !行列式を組み立てる
FOR q=1 TO L+1 !列位置
READ w !次数
LET t=(K-1)*P+(q-1) !開始位置 k行1桁
FOR J=0 TO w
READ r !係数列
FOR i=1 TO P-L !1列ずつずらす
LET tt=(i-1)*(P+1)
IF J=0 THEN LET aa(t+tt)=w
LET A(t+tt,J)=r
NEXT i
NEXT J
NEXT q
END SUB
DIM S(0 TO MAX_DEGREE)
CALL PolynomialMatrixDET(P, aa,A, ss,S)
PRINT ss
MAT PRINT S;
EXTERNAL SUB PolynomialMatrixZER(n, aa(),A(,)) !零行列 MAT A=ZER
OPTION ARITHMETIC RATIONAL !有理数モード
MAT A=ZER !定数 0
MAT aa=ZER
END SUB
EXTERNAL SUB PolynomialMatrixIDN(n, aa(),A(,)) !単位行列 MAT A=IDN
OPTION ARITHMETIC RATIONAL !有理数モード
MAT A=ZER !定数 0
MAT aa=ZER
FOR i=1 TO n !対角線について
LET A((i-1)*n+(i-1),0)=1 !定数 1
NEXT i
END SUB
!演算関連
EXTERNAL SUB PolynomialMatrixMultiply(m,p,n, aa(),A(,),bb(),B(,), cc(),C(,)) !積 C=A*B
OPTION ARITHMETIC RATIONAL !有理数モード
DIM W(0 TO MAX_DEGREE),S(0 TO MAX_DEGREE)
MAT C=ZER
FOR y=1 TO m !y行
FOR x=1 TO n !x列
MAT W=ZER
LET ww=0
FOR i=1 TO p !積の和 w=Σa[y,i]b[i,x]
LET yy=(y-1)*p+(i-1)
LET xx=(i-1)*n+(x-1)
CALL PolyMtxMul(aa(yy),A,yy, bb(xx),B,xx, ss,S)
MAT W=W+S
LET ww=MAX(ww,ss)
NEXT i
CALL Poly_DegUpdt(ww,W) !※次数の補正
LET i=(y-1)*n+(x-1) !c[y,x]=w
FOR J=0 TO ww !copy it
LET C(i,J)=W(J)
NEXT J
LET cc(i)=ww
NEXT x
NEXT y
END SUB
EXTERNAL SUB PolyMtxMul(aa,A(,),y, bb,B(,),x, ss,S()) !乗算 S=A*B
OPTION ARITHMETIC RATIONAL !有理数モード
MAT S=ZER
FOR i=aa TO 0 STEP -1
LET k=A(y,i)
IF k=0 THEN !係数が0以外なら
ELSE
FOR j=bb TO 0 STEP -1
LET S(i+j)=S(i+j)+k*B(x,j) !すべての係数をかける
NEXT j
END IF
NEXT i
LET ss=aa+bb!次数
CALL Poly_DegUpdt(ss,S) !※その補正
END SUB
EXTERNAL SUB PolynomialMatrixTR(n, aa(),A(,), ss,S()) !行列Aのトレース
OPTION ARITHMETIC RATIONAL !有理数モード
MAT S=ZER
LET ss=0
FOR i=1 TO N !対角線の和
LET t=(i-1)*n+(i-1)
FOR J=0 TO aa(t)
LET S(J)=S(J)+A(t,J)
NEXT J
LET ss=MAX(ss,aa(t)) !次数
NEXT i
CALL Poly_DegUpdt(ss,S) !※その補正
END SUB
EXTERNAL SUB PolynomialMatrixDET(n, aa(),A(,), ss,S()) !行列式Aの値
OPTION ARITHMETIC RATIONAL !有理数モード
DIM xx(0 TO n^2-1),X(0 TO n^2-1,0 TO MAX_DEGREE) !adj(s*I-A)
CALL PolynomialMatrixIDN(n, xx,X) !MAT X=IDN
LET k=1
DO
DIM ww(0 TO n^2-1),W(0 TO n^2-1,0 TO MAX_DEGREE)
CALL PolynomialMatrixMultiply(n,n,n, aa,A,xx,X, ww,W) !MAT X=A*X
CALL PolynomialMatrixTR(n, ww,W, ss,S) !LET c(k)=-tr(X)/k !det(s*I-A)
MAT S=(-1/k)*S
IF k=N THEN EXIT DO
MAT X=W !MAT cE=(c(k))*IDN、 MAT X=X+cE
MAT xx=ww
FOR i=1 TO n !対角線について
LET t=(i-1)*n+(i-1)
FOR J=0 TO MAX(xx(t),ss)
LET X(t,J)=X(t,J)+S(J)
NEXT J
LET xx(t)=MAX(xx(t),ss) !次数
CALL Poly_MtxDegUpdt(xx(t),X,t) !※その補正
NEXT i
LET k=k+1
LOOP
IF MOD(n,2)=1 THEN MAT S=(-1)*S !(-1)^n*c(n)
END SUB
EXTERNAL SUB Poly_MtxDegUpdt(ss,S(,),t) !次数を補正する
OPTION ARITHMETIC RATIONAL !有理数モード
FOR J=ss TO 1 STEP -1
IF S(t,J)<>0 THEN EXIT FOR
NEXT J
LET ss=J
END SUB
!POLY.LIB より
EXTERNAL SUB Poly_DegUpdt(aa,A()) !次数を補正する
OPTION ARITHMETIC RATIONAL !有理数モード
FOR i=aa TO 1 STEP -1
IF A(i)<>0 THEN EXIT FOR
NEXT i
LET aa=i
END SUB
OPTION ARITHMETIC COMPLEX
DIM A(5,5)
!-------------------------------------------------------------------------------
! Generalized Impedance Converter 行列 3x3
!
! ┌──┐
! (0ohm)│ +├──────────┐
! ┌Zo┤Ｇ │ │
! 1A │ │ -├┐ │
! → │ └──┘│ │
! Zin ──┬──Z1─┴──Z2─┬┴─Z3──┬─Z4──┴─Z5──┐
! (Zin==V1)│ │┌──┐ │ │
! │ └┤- │ │ ▽
! │ │ Ｇ├Zo┘
! └──────────┤+ │(0Ω)
! └──┘
! ↑V1 ↑V2 ↑V3
!
! | 1/Z1 G/Z1 -G/Z1 ||V1| | 1|
! |-G/Z3 1/Z2+1/Z3+G/Z2+G/Z3 -G/Z2 ||V2|=| 0|
! |-G/Z4 G/Z4 1/Z4+1/Z5 ||V3| | 0|
!-----
SUB mat3x3(Z1,Z2,Z3,Z4,Z5)
LET A(1,1)= 1/Z1
LET A(1,2)= G/Z1
LET A(1,3)=-G/Z1
!
LET A(2,1)=-G/Z3
LET A(2,2)= 1/Z2+1/Z3+G/Z2+G/Z3
LET A(2,3)=-G/Z2
!
LET A(3,1)=-G/Z4
LET A(3,2)= G/Z4
LET A(3,3)= 1/Z4+1/Z5
END SUB
!-------------------------------------------------------------------------------
! Generalized Impedance Converter 行列 5x5
!
! ┌──┐
! │ +├──────────┐
! ┌Zo┤Ｇ │ │
! 1A │ │ -├┐ │
! → │ └──┘│ │
! Zin ──┬──Z1─┴──Z2─┬┴─Z3──┬─Z4──┴─Z5──┐
! (Zin==V1)│ │┌──┐ │ │
! │ └┤- │ │ ▽
! │ │ Ｇ├Zo┘
! └──────────┤+ │
! └──┘
! ↑V1 ↑V2 ↑V3 ↑V4 ↑V5
!
! | 1/Z1 -1/Z1 0 0 0 ||V1| | 1|
! |-1/Z1 1/Z1+1/Z2+1/Zo G/Zo-1/Z2 0 -G/Zo ||V2|=| 0|
! | 0 -1/Z2 1/Z2+1/Z3 -1/Z3 0 ||V3| | 0|
! |-G/Zo 0 G/Zo-1/Z3 1/Z3+1/Z4+1/Zo -1/Z4 ||V4| | 0|
! | 0 0 0 -1/Z4 1/Z4+1/Z5 ||V5| | 0|
!-----
SUB mat5x5(Z1,Z2,Z3,Z4,Z5,Zo)
LET A(1,1)= 1/Z1
LET A(1,2)=-1/Z1
LET A(1,3)= 0
LET A(1,4)= 0
LET A(1,5)= 0
!
LET A(2,1)=-1/Z1
LET A(2,2)= 1/Z1+1/Z2+1/Zo
LET A(2,3)= G/Zo-1/Z2
LET A(2,4)= 0
LET A(2,5)=-G/Zo
!
LET A(3,1)= 0
LET A(3,2)=-1/Z2
LET A(3,3)= 1/Z2+1/Z3
LET A(3,4)=-1/Z3
LET A(3,5)= 0
!
LET A(4,1)=-G/Zo
LET A(4,2)= 0
LET A(4,3)= G/Zo-1/Z3
LET A(4,4)= 1/Z3+1/Z4+1/Zo
LET A(4,5)=-1/Z4
!
LET A(5,1)= 0
LET A(5,2)= 0
LET A(5,3)= 0
LET A(5,4)=-1/Z4
LET A(5,5)= 1/Z4+1/Z5
END SUB
!-------------------------------------------------------------------------------
OPTION ANGLE DEGREES
SET TEXT background "opaque"
SET COLOR MIX(15) .4,.4,.4
SUB GIC_Zin( u1,u2,u3,u4,u5, Zo,m$)
CLEAR
CALL SCALE
LET w$="Zo="& STR$(Zo)& "Ω "& m$
PLOT TEXT ,AT logfL+1.1, logzL-.9*by :w$ !最下端
RESTORE
IF Zo=0 THEN MAT A=ZER(3,3) ELSE MAT A=ZER(5,5)
DO
READ G
IF G=0 THEN EXIT DO
PRINT w$
PRINT "G=";STR$(G)
PRINT " 周波数 V1/1 θ 設計式による値(Zo=0Ω)"
!----
LET f=fL
DO
LET ω=2*PI*f
IF u1< 1 THEN LET Z1=1/COMPLEX(0,ω*u1) ELSE LET Z1=u1
IF u2< 1 THEN LET Z2=1/COMPLEX(0,ω*u2) ELSE LET Z2=u2
IF u3< 1 THEN LET Z3=1/COMPLEX(0,ω*u3) ELSE LET Z3=u3
IF u4< 1 THEN LET Z4=1/COMPLEX(0,ω*u4) ELSE LET Z4=u4
IF u5< 1 THEN LET Z5=1/COMPLEX(0,ω*u5) ELSE LET Z5=u5
IF Zo=0 THEN CALL mat3x3(Z1,Z2,Z3,Z4,Z5) ELSE CALL mat5x5(Z1,Z2,Z3,Z4,Z5,Zo)
MAT A=INV(A)
LET Zv=ABS(A(1,1)) !A(1,1)= △11/△= V1/(1A) なので、A(1,1)==Zin
LET Za=arg(A(1,1))
!
!---------------- 比較の為、設計式による計算値 (電圧増幅器の出力抵抗 Zo=0)
!
!LET Zin=Z1*Z3*Z5/(Z2*Z4) ← 電圧増幅率 G= ∞ の場合
!
! G が小さい場合
! 1/Z2*1/Z4 + (1/Z2+1/Z3)*(1/Z4+1/Z5)*(1+G)/G^2
!Zin= Z1 * ───────────────────────
! 1/Z3*1/Z5 + (1/Z2+1/Z3)*(1/Z4+1/Z5)*(1+G)/G^2
!
LET w=(1/Z2+1/Z3)*(1/Z4+1/Z5)*(1+G)/G^2
LET Zin=Z1*(1/Z2*1/Z4 +w)/(1/Z3*1/Z5 +w)
!
LET Zv00=ABS(Zin)
LET Za00=arg(Zin)
!----------------
!
! リスト
PRINT USING "###,###,###.#Hz #,###,###,###Ω ####.#度 #,###,###,###Ω ####.#度": f, Zv, Za, Zv00, Za00
! グラフ
IF fL< f THEN
SET LINE COLOR "black"
PLOT LINES: LOG10(f_),LOG10(Zv_); LOG10(f),LOG10(Zv) !Ｚ[Ω]
SET LINE COLOR "red"
PLOT LINES: LOG10(f_),Za_/90+zct; LOG10(f),Za/90+zct !位相[度]
END IF
LET f_=f
LET Zv_=Zv
LET Za_=Za
LET f=f*stp
LOOP UNTIL fH< f
PRINT
LOOP
END SUB
SUB SCALE
LET logfL=LOG10(fL)
LET logfH=LOG10(fH)
LET logzL=LOG10(zL)
LET logzH=LOG10(zH)
LET zct=INT((logzH+logzL)/2)
!
ASK bitmap SIZE i,j
LET bx=(logfH-logfL)*40/(i-80) !左右 40pixel の border( 目盛りの余白)
LET by=(logzH-logzL)*24/(j-48) !上下 24pixel の border( 目盛りの余白)
SET WINDOW logfL-bx, logfH+bx, logzL-by, logzH+by
DRAW grid0
SET TEXT COLOR "red"
FOR i=-2 TO 2
PLOT TEXT ,AT logfH+.1*bx, zct+i-by/3, USING "+###°" :i*90 !ｙ軸 右
NEXT i
SET TEXT COLOR "black"
FOR i=logfL TO logfH
PLOT TEXT ,AT i-bx/2 , logzH+by/3 :sc$(i)& "Hz" !ｘ軸 上
NEXT i
FOR i=logzL TO logzH
PLOT TEXT ,AT logfL-bx, i-by/3 :sc$(i)& "Ω" !ｙ軸 左
NEXT i
END SUB
!Σ1/(k*n)!の計算
LET k=2
LET s=0
FOR n=30*k TO 1 STEP -1 !例 1/6!+1/4!+1/2!=((((0+1)/(6*5)+1)/(4*3)+1)/(2*1)
IF MOD(n,k)=0 THEN LET s=s+1
LET s=s/n
NEXT n
PRINT s+1 !1/0!を加味する
END
!盤の出力
SUB PrintBan(Ban(,))
local i,j
FOR i=0 TO N-1
FOR j=0 TO N-1
PRINT USING "###": Ban(i,j);
NEXT j
PRINT
NEXT i
PRINT
END SUB
!空いた枡を見つける
SUB findBlank(x,y,Ban(,), RET)
local i,j
FOR i=0 TO N-1
FOR j=0 TO N-1
IF Ban(i,j)=0 THEN
LET x=i
LET y=j
LET RET=-1
EXIT SUB
END IF
NEXT j
NEXT i
LET RET=0
END SUB
!kを枡(x,y)に置けるか ?
SUB isOkeru(x,y,k,Ban(,), RET)
local i,j
FOR i=0 TO N-1
IF Ban(i,y)=k THEN
LET RET=0 ! 横に同じ数はないか
EXIT SUB
END IF
NEXT i
FOR j=0 TO N-1
IF Ban(x,j)=k THEN
LET RET=0 !縦に同じ数はないか
EXIT SUB
END IF
NEXT j
FOR i=0 TO N3-1 !blockに同じ数はないか
FOR j=0 TO N3-1
IF Ban(N3*INT(x/N3)+i,N3*INT(y/N3)+j)=k THEN
LET RET=0
EXIT SUB
END IF
NEXT j
NEXT i
LET RET=-1
END SUB
!これが問題のバックトラック
SUB Try(Ban(,))
local x,y,k
CALL findBlank(x,y,Ban, RET) !盤に空いた枡(x,y)があるか
IF RET<>0 THEN
FOR k=1 TO N
CALL isOkeru(x,y,k,Ban, RET) !枡(x,y)にkを置けるか
IF RET<>0 THEN
LET Ban(x,y)=k !置けるなら置く
CALL Try(Ban) !次を確かめる
LET Ban(x,y)=0 !枡(x,y)にkを置けないとして別の置き方はないか
END IF
NEXT k
ELSE
PRINT "Solution" !解が見つかった
CALL PrintBan(Ban)
END IF
END SUB
DATA 0,0,0, 0,7,0, 9,4,0 !初期配置
DATA 0,7,0, 0,9,0, 0,0,5
DATA 3,0,0, 0,0,5, 0,7,0
DATA 0,8,7, 4,0,0, 1,0,0
DATA 4,6,3, 0,8,0, 0,0,0
DATA 0,0,0, 0,0,7, 0,8,0
DATA 8,0,0, 7,0,0, 0,0,0
DATA 7,0,0, 0,0,0, 0,2,8
DATA 0,5,0, 2,6,8, 0,0,0
RANDOMIZE
LET N=40
DIM X(N),Y(N),DX(N),DY(N)
CALL GINIT(XSIZE,YSIZE)
FOR I=1 TO N
LET X(I)=RND*XSIZE
LET Y(I)=RND*YSIZE
LET DX(I)=RND*5-2.5
LET DY(I)=RND*5-2.5
NEXT I
DO
FOR I=1 TO N
LET X(I)=X(I)+DX(I)
LET Y(I)=Y(I)+DY(I)
LET DY(I)=DY(I)+.1
IF X(I)<0 OR X(I)>XSIZE THEN LET DX(I)=-DX(I)
IF Y(I)<0 OR Y(I)>YSIZE THEN LET DY(I)=-DY(I)
NEXT I
CALL BOXFULL(0,0,XSIZE-1,YSIZE-1,0)
FOR I=1 TO N
IF Y(I)<0 AND DY(I)<0 THEN
LET Y(I)=RND*YSIZE
LET DY(I)=RND*5-2.5
END IF
CALL LINE(X(I),Y(I),X(I)-DX(I),Y(I)-DY(I),7)
NEXT I
WAIT DELAY 1/100
LOOP
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0 , XSIZE , YSIZE, 0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES: XS,YS;XE,YE
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA: X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
LET N1=20
LET N2=40
RANDOMIZE
DIM X(N1),Y(N1),DX(N1),DY(N1)
DIM X2(N2),Y2(N2),DX2(N2),DY2(N2)
CALL GINIT(XSIZE,YSIZE)
FOR I=1 TO N1
LET X(I)=RND*XSIZE
LET Y(I)=RND*YSIZE
LET THETA=ANGLE(X(I)-XSIZE/2,Y(I)-YSIZE/2)
LET DX(I)=COS(THETA)
LET DY(I)=SIN(THETA)
NEXT I
FOR I=1 TO N2
LET X2(I)=RND*XSIZE
LET Y2(I)=RND*YSIZE
LET THETA=ANGLE(X2(I)-XSIZE/2,Y2(I)-YSIZE/2)
LET DX2(I)=COS(THETA)
LET DY2(I)=SIN(THETA)
NEXT I
DO
CALL BOXFULL(0,0,XSIZE-1,YSIZE-1,0)
FOR I=1 TO N1
LET X(I)=X(I)+DX(I)
LET Y(I)=Y(I)+DY(I)
LET DX(I)=DX(I)+DX(I)/10
LET DY(I)=DY(I)+DY(I)/10
IF X(I)<0 OR X(I)>XSIZE OR Y(I)<0 OR Y(I)>YSIZE THEN
LET X(I)=XSIZE/2+RND*50-25
LET Y(I)=YSIZE/2+RND*50-25
LET THETA=ANGLE(X(I)-XSIZE/2,Y(I)-YSIZE/2)
LET DX(I)=COS(THETA)
LET DY(I)=SIN(THETA)
END IF
CALL LINE(X(I),Y(I),X(I)-DX(I),Y(I)-DY(I),7)
NEXT I
FOR I=1 TO N2
LET X2(I)=X2(I)+DX2(I)
LET Y2(I)=Y2(I)+DY2(I)
LET DX2(I)=DX2(I)+DX2(I)/50
LET DY2(I)=DY2(I)+DY2(I)/50
IF X2(I)<0 OR X2(I)>XSIZE OR Y2(I)<0 OR Y2(I)>YSIZE THEN
LET X2(I)=XSIZE/2+RND*50-25
LET Y2(I)=YSIZE/2+RND*50-25
LET THETA=ANGLE(X2(I)-XSIZE/2,Y2(I)-YSIZE/2)
LET DX2(I)=COS(THETA)
LET DY2(I)=SIN(THETA)
END IF
CALL PSET(X2(I),Y2(I),7)
NEXT I
WAIT DELAY 1/100
LOOP
END
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS: X , Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0 , XSIZE , YSIZE, 0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES: XS,YS;XE,YE
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA: X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
RANDOMIZE
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4),X1(0 TO 360),Y1(0 TO 360),Z1(0 TO 360),X2(0 TO 360),Y2(0 TO 360),Z2(0 TO 360)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET A=INT(RND*7)+1
DO
LET B=INT(RND*7)+1
LOOP UNTIL A<>B
LET R=INT(RND*10)+3
FOR I=0 TO 360
LET ALPHA=I*2
LET X1(I)=(A+R*SIN(ALPHA/2))*COS(ALPHA)
LET Z1(I)=(A+R*SIN(ALPHA/2))*SIN(ALPHA)
LET Y1(I)=A+R*COS(ALPHA/2)
LET X2(I)=(B+R*SIN(ALPHA/2))*COS(ALPHA)
LET Z2(I)=(B+R*SIN(ALPHA/2))*SIN(ALPHA)
LET Y2(I)=B+R*COS(ALPHA/2)
LET XMIN=MIN(XMIN,X1(I))
LET XMAX=MAX(XMAX,X1(I))
LET YMIN=MIN(YMIN,Y1(I))
LET YMAX=MAX(YMAX,Y1(I))
LET ZMIN=MIN(ZMIN,Z1(I))
LET ZMAX=MAX(ZMAX,Z1(I))
LET XMIN=MIN(XMIN,X2(I))
LET XMAX=MAX(XMAX,X2(I))
LET YMIN=MIN(YMIN,Y2(I))
LET YMAX=MAX(YMAX,Y2(I))
LET ZMIN=MIN(ZMIN,Z2(I))
LET ZMAX=MAX(ZMAX,Z2(I))
NEXT I
FOR I=0 TO 359 !'重心計算
LET MX=MX+X1(I)+X2(I)
LET MY=MY+Y1(I)+Y2(I)
LET MZ=MZ+Z1(I)+Z2(I)
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5 !'回転初期値
LET YDT=RND-.5
LET MX=MX/360/2
LET MY=MY/360/2
LET MZ=MZ/360/2
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 5,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE -RANGE TO RANGE,AT 0 : XMOVE
LOCATE VALUE NOWAIT(4),RANGE -RANGE TO RANGE,AT 0 : YMOVE
LOCATE VALUE NOWAIT(5),RANGE -RANGE TO RANGE,AT 0 : ZMOVE
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): XMOVE
LOCATE VALUE NOWAIT(4): YMOVE
LOCATE VALUE NOWAIT(5): ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=0 TO 359
CALL PLOT(X1(I),Y1(I),Z1(I))
CALL PLOT(X2(I),Y2(I),Z2(I))
CALL PLOT(X2(I+1),Y2(I+1),Z2(I+1))
CALL PLOT(X1(I+1),Y1(I+1),Z1(I+1))
CALL PLOT(X1(I),Y1(I),Z1(I))
PLOT LINES
NEXT I
IF FL=0 THEN
SET WINDOW LMIN*1.5,LMAX*1.5,LMIN*1.5,LMAX*1.5
LET WW=(LMAX-LMIN)*1.5
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5 !'移動量
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X-MX+XMOVE
LET POINT(2)=Y-MY+YMOVE
LET POINT(3)=Z-MZ+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1)) !'描画範囲
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
RANDOMIZE
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
PUBLIC NUMERIC K,XX(2730),YY(2730),ZZ(2730) !' 2+8*(4^(LEV-1)-1)/3
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET LL=2^9 !'TREEの大きさ
INPUT PROMPT "LEVEL(2<=LEV<=6)=":LEV
CALL TREE(LEV,0,0,0,0,LL,0,LL)
FOR I=1 TO K
LET MX=MX+XX(I)
LET MY=MY+YY(I)
LET MZ=MZ+ZZ(I)
LET XMIN=MIN(XMIN,XX(I))
LET XMAX=MAX(XMAX,XX(I))
LET YMIN=MIN(YMIN,YY(I))
LET YMAX=MAX(YMAX,YY(I))
LET ZMIN=MIN(ZMIN,ZZ(I))
LET ZMAX=MAX(ZMAX,ZZ(I))
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET MX=MX/K
LET MY=MY/K
LET MZ=MZ/K
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 5,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE -RANGE TO RANGE,AT 0 : XMOVE
LOCATE VALUE NOWAIT(4),RANGE -RANGE TO RANGE,AT 0 : YMOVE
LOCATE VALUE NOWAIT(5),RANGE -RANGE TO RANGE,AT 0 : ZMOVE
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): XMOVE
LOCATE VALUE NOWAIT(4): YMOVE
LOCATE VALUE NOWAIT(5): ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO K STEP 2
CALL PLOTLINE(XX(I),YY(I),ZZ(I),XX(I+1),YY(I+1),ZZ(I+1))
NEXT I
IF FL=0 THEN
SET WINDOW -LMAX*1.2,LMAX*1.2,-LMAX*1.2,LMAX*1.2
LET WW=(LMAX-LMIN)*1.2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
LET X0=X
LET Y0=Y
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-2,MIN(2,XDT))
LET YDT=MAX(-2,MIN(2,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X-MX+XMOVE
LET POINT(2)=Y-MY+YMOVE
LET POINT(3)=Z-MZ+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
END
EXTERNAL SUB TREE(N,XS,YS,ZS,XE,YE,ZE,L)
OPTION ARITHMETIC NATIVE
IF N>0 THEN
LET K=K+1
LET XX(K)=XS
LET YY(K)=YS
LET ZZ(K)=ZS
LET K=K+1
LET XX(K)=XE
LET YY(K)=YE
LET ZZ(K)=ZE
LET X=XE-XS
LET Y=YE-YS
LET Z=ZE-ZS
IF X<>0 THEN
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE+L/2,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE-L/2,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE+L/2,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE-L/2,ZE,L/2)
END IF
IF Y<>0 THEN
CALL TREE(N-1,XE,YE,ZE,XE+L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE-L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE+L/2,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE-L/2,L/2)
END IF
IF Z<>0 THEN
CALL TREE(N-1,XE,YE,ZE,XE+L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE-L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE+L/2,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE-L/2,ZE,L/2)
END IF
END IF
END SUB
OPTION ARITHMETIC NATIVE
PUBLIC NUMERIC K,LL,XO,YO,ZO,XX(4096),YY(4096),ZZ(4096) !'8^LEV
OPTION ANGLE DEGREES
INPUT PROMPT "LEVEL(1<=LEVEL=<4)=":LEV
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET LL=5 !'移動量
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM A(3),B(3),C(3),D(3),E(3),F(3),G(3),H(3)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
MAT READ A,B,C,D,E,F,G,H !'位置ベクトル
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
LET K=1
CALL RECURSIVE(LEV,A,E,F,B,C,G,H,D)
FOR I=1 TO K
LET MX=MX+XX(I)
LET MY=MY+YY(I)
LET MZ=MZ+ZZ(I)
LET XMIN=MIN(XMIN,XX(I))
LET XMAX=MAX(XMAX,XX(I))
LET YMIN=MIN(YMIN,YY(I))
LET YMAX=MAX(YMAX,YY(I))
LET ZMIN=MIN(ZMIN,ZZ(I))
LET ZMAX=MAX(ZMAX,ZZ(I))
NEXT I
LET MX=MX/K
LET MY=MY/K
LET MZ=MZ/K
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET LMIN=1E+10
LET LMAX=-1E+10
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 5,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE -RANGE TO RANGE,AT 0 : XMOVE
LOCATE VALUE NOWAIT(4),RANGE -RANGE TO RANGE,AT 0 : YMOVE
LOCATE VALUE NOWAIT(5),RANGE -RANGE TO RANGE,AT 0 : ZMOVE
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): XMOVE
LOCATE VALUE NOWAIT(4): YMOVE
LOCATE VALUE NOWAIT(5): ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO K
CALL PLOT(XX(I),YY(I),ZZ(I))
NEXT I
PLOT LINES
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
LET WW=(LMAX-LMIN)*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X-MX+XMOVE
LET POINT(2)=Y-MY+YMOVE
LET POINT(3)=Z-MZ+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
EXTERNAL SUB MOVE(A(),B())
OPTION ARITHMETIC NATIVE
LET XO=XO+LL*(B(1)-A(1))
LET YO=YO+LL*(B(2)-A(2))
LET ZO=ZO+LL*(B(3)-A(3))
LET K=K+1
LET XX(K)=XO
LET YY(K)=YO
LET ZZ(K)=ZO
END SUB
EXTERNAL SUB RECURSIVE(N,A(),E(),F(),B(),C(),G(),H(),D()) !'ヒルベルト曲線
OPTION ARITHMETIC NATIVE
IF N>0 THEN
CALL RECURSIVE(N-1,A,B,C,D,H,G,F,E)
CALL MOVE(A,E)
CALL RECURSIVE(N-1,A,D,H,E,F,G,C,B)
CALL MOVE(E,F)
CALL RECURSIVE(N-1,A,D,H,E,F,G,C,B)
CALL MOVE(F,B)
CALL RECURSIVE(N-1,F,B,A,E,H,D,C,G)
CALL MOVE(B,C)
CALL RECURSIVE(N-1,F,B,A,E,H,D,C,G)
CALL MOVE(C,G)
CALL RECURSIVE(N-1,C,B,F,G,H,E,A,D)
CALL MOVE(G,H)
CALL RECURSIVE(N-1,C,B,F,G,H,E,A,D)
CALL MOVE(H,D)
CALL RECURSIVE(N-1,H,G,F,E,A,B,C,D)
END IF
END SUB
RANDOMIZE
OPTION ARITHMETIC NATIVE
PUBLIC NUMERIC K,XX(4096),YY(4096),ZZ(4096) !'4^LEV
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
INPUT PROMPT "LEVEL(1<=LEV=<6)=":LEV
CALL RECURSIVE(LEV,0,0,0,128)
LET LL=128/2^LEV
FOR I=1 TO K
LET MX=MX+XX(I)+2*LL*COS(0)
LET MX=MX+XX(I)+2*LL*COS(120)
LET MX=MX+XX(I)+2*LL*COS(240)
LET MX=MX+XX(I)
LET MY=MY+YY(I)
LET MY=MY+YY(I)
LET MY=MY+YY(I)
LET MY=MY+YY(I)+2*LL
LET MZ=MZ+ZZ(I)+2*LL*SIN(0)
LET MZ=MZ+ZZ(I)+2*LL*SIN(120)
LET MZ=MZ+ZZ(I)+2*LL*SIN(240)
LET MZ=MZ+ZZ(I)
LET XMIN=MIN(XMIN,XX(I))
LET XMAX=MAX(XMAX,XX(I))
LET YMIN=MIN(YMIN,YY(I))
LET YMAX=MAX(YMAX,YY(I))
LET ZMIN=MIN(ZMIN,ZZ(I))
LET ZMAX=MAX(ZMAX,ZZ(I))
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET MX=MX/4/K
LET MY=MY/4/K
LET MZ=MZ/4/K
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 5,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE -RANGE TO RANGE,AT 0 : XMOVE
LOCATE VALUE NOWAIT(4),RANGE -RANGE TO RANGE,AT 0 : YMOVE
LOCATE VALUE NOWAIT(5),RANGE -RANGE TO RANGE,AT 0 : ZMOVE
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): XMOVE
LOCATE VALUE NOWAIT(4): YMOVE
LOCATE VALUE NOWAIT(5): ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO K
CALL TETRAHEDRON(XX(I),YY(I),ZZ(I),LL)
NEXT I
IF FL=0 THEN
SET WINDOW -LMAX,LMAX,-LMAX,LMAX
LET WW=LMAX*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-2,MIN(2,XDT))
LET YDT=MAX(-2,MIN(2,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X-MX+XMOVE
LET POINT(2)=Y-MY+YMOVE
LET POINT(3)=Z-MZ+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
SUB TETRAHEDRON(X,Y,Z,L) !'4面体
CALL PLOT(X+2*L*COS(0),Y,Z+2*L*SIN(0))
CALL PLOT(X+2*L*COS(120),Y,Z+2*L*SIN(120))
CALL PLOT(X+2*L*COS(240),Y,Z+2*L*SIN(240))
CALL PLOT(X+2*L*COS(0),Y,Z+2*L*SIN(0))
CALL PLOTLINE(X+2*L*COS(0),Y,Z+2*L*SIN(0),X,Y+2*L,Z)
CALL PLOTLINE(X+2*L*COS(120),Y,Z+2*L*SIN(120),X,Y+2*L,Z)
CALL PLOTLINE(X+2*L*COS(240),Y,Z+2*L*SIN(240),X,Y+2*L,Z)
END SUB
END
EXTERNAL SUB RECURSIVE(LEV,X,Y,Z,L) !'シェルピンスキー三角形
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
IF LEV=0 THEN
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
ELSE
CALL RECURSIVE(LEV-1,X,Y+L,Z,L/2)
CALL RECURSIVE(LEV-1,X+L*COS(0),Y,Z+L*SIN(0),L/2)
CALL RECURSIVE(LEV-1,X+L*COS(120),Y,Z+L*SIN(120),L/2)
CALL RECURSIVE(LEV-1,X+L*COS(240),Y,Z+L*SIN(240),L/2)
END IF
END SUB
RANDOMIZE
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET N=360 !'周期
LET LL=5 !'チューブ太さ
LET NN=8 !'チューブ分割数
LET RR=100 !'半径
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM XX(0 TO N+1),YY(0 TO N+1),ZZ(0 TO N+1)
DIM XN(0 TO NN),YN(0 TO NN),ZN(0 TO NN),XM(0 TO NN),YM(0 TO NN),ZM(0 TO NN)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
LET A=INT(RND*20)+1
LET B=INT(RND*20)+1
LET C=INT(RND*20)+1
LET D=INT(RND*360)
FOR I=0 TO N+1
LET XX(I)=RR*COS(A*I)
LET YY(I)=RR*SIN(B*I)
LET ZZ(I)=RR*COS(C*I+D)
LET XMIN=MIN(XMIN,XX(I))
LET XMAX=MAX(XMAX,XX(I))
LET YMIN=MIN(YMIN,YY(I))
LET YMAX=MAX(YMAX,YY(I))
LET ZMIN=MIN(ZMIN,ZZ(I))
LET ZMAX=MAX(ZMAX,ZZ(I))
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET LMIN=1E+10
LET LMAX=-1E+10
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 5,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE -RANGE TO RANGE,AT 0 : XMOVE
LOCATE VALUE NOWAIT(4),RANGE -RANGE TO RANGE,AT 0 : YMOVE
LOCATE VALUE NOWAIT(5),RANGE -RANGE TO RANGE,AT 0 : ZMOVE
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): XMOVE
LOCATE VALUE NOWAIT(4): YMOVE
LOCATE VALUE NOWAIT(5): ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=0 TO N
CALL PLOT(XX(I),YY(I),ZZ(I))
NEXT I
PLOT LINES
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
LET WW=(LMAX-LMIN)*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN EXIT DO
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
FILE GETSAVENAME F$,"STLファイル|*.stl"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".STL")=0 THEN LET F$=F$ & ".stl"
OPEN #1:NAME F$ !'STLファイル書き出し(バイナリー形式)
ERASE #1
PRINT #1:REPEAT$(CHR$(0),80);
PRINT #1:MKL$(2*NN*N);
FOR I=0 TO N
LET XA=XX(I+1)-XX(I)
LET YA=YY(I+1)-YY(I)
LET ZA=ZZ(I+1)-ZZ(I)
LET VX=YY(I+1)*ZZ(I)-ZZ(I+1)*YY(I)
LET VY=ZZ(I+1)*XX(I)-XX(I+1)*ZZ(I)
LET VZ=XX(I+1)*YY(I)-YY(I+1)*XX(I)
LET SS=SQR(VX^2+VY^2+VZ^2)
IF SS=0 THEN
LET VX=(YY(I+1)+1)*(ZZ(I)+1)-(ZZ(I+1)+1)*(YY(I)+1)
LET VY=(ZZ(I+1)+1)*(XX(I)+1)-(XX(I+1)+1)*(ZZ(I)+1)
LET VZ=(XX(I+1)+1)*(YY(I)+1)-(YY(I+1)+1)*(XX(I)+1)
LET SS=SQR(VX^2+VY^2+VZ^2)
END IF
LET VX=VX/SS
LET VY=VY/SS
LET VZ=VZ/SS
LET TX=XA+VX*LL
LET TY=YA+VY*LL
LET TZ=ZA+VZ*LL
FOR K=0 TO NN-1
CALL ROTATE(TX,TY,TZ,XA,YA,ZA,K*360/NN,XO,YO,ZO)
LET XN(K)=XO+XX(I)
LET YN(K)=YO+YY(I)
LET ZN(K)=ZO+ZZ(I)
NEXT K
IF I>0 THEN
FOR K=0 TO NN-1
LET X1=XM(K)
LET Y1=YM(K)
LET Z1=ZM(K)
IF K=NN-1 THEN
LET X2=XM(0)
LET Y2=YM(0)
LET Z2=ZM(0)
ELSE
LET X2=XM(K+1)
LET Y2=YM(K+1)
LET Z2=ZM(K+1)
END IF
IF K=NN-1 THEN
LET X3=XN(0)
LET Y3=YN(0)
LET Z3=ZN(0)
ELSE
LET X3=XN(K+1)
LET Y3=YN(K+1)
LET Z3=ZN(K+1)
END IF
LET X4=XN(K)
LET Y4=YN(K)
LET Z4=ZN(K)
CALL VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XS,YS,ZS)
PRINT #1:MKS$(XS);
PRINT #1:MKS$(YS);
PRINT #1:MKS$(ZS);
PRINT #1:MKS$(X1);
PRINT #1:MKS$(Y1);
PRINT #1:MKS$(Z1);
PRINT #1:MKS$(X2);
PRINT #1:MKS$(Y2);
PRINT #1:MKS$(Z2);
PRINT #1:MKS$(X3);
PRINT #1:MKS$(Y3);
PRINT #1:MKS$(Z3);
PRINT #1:CHR$(0);CHR$(0);
CALL VECTORNORMAL(X1,Y1,Z1,X3,Y3,Z3,X4,Y4,Z4,XS,YS,ZS)
PRINT #1:MKS$(XS);
PRINT #1:MKS$(YS);
PRINT #1:MKS$(ZS);
PRINT #1:MKS$(X1);
PRINT #1:MKS$(Y1);
PRINT #1:MKS$(Z1);
PRINT #1:MKS$(X3);
PRINT #1:MKS$(Y3);
PRINT #1:MKS$(Z3);
PRINT #1:MKS$(X4);
PRINT #1:MKS$(Y4);
PRINT #1:MKS$(Z4);
PRINT #1:CHR$(0);CHR$(0);
NEXT K
END IF
MAT XM=XN
MAT YM=YN
MAT ZM=ZN
NEXT I
CLOSE #1
SUB PLOT(X,Y,Z)
LET POINT(1)=X+XMOVE
LET POINT(2)=Y+YMOVE
LET POINT(3)=Z+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
EXTERNAL SUB ROTATE(XX,YY,ZZ,X0,Y0,Z0,TH,NX,NY,NZ)
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
!'(X0,Y0,Z0) 原点を通る回転軸
!'点 P(XX,YY,ZZ) TH度回転 P'(NX,NY,NZ)
DIM A(3,3)
LET S=SQR(X0*X0+Y0*Y0+Z0*Z0)
LET X=X0/S
LET Y=Y0/S
LET Z=Z0/S
LET A(1,1)=X*X*(1-COS(TH))+COS(TH)
LET A(1,2)=X*Y*(1-COS(TH))+Z*SIN(TH)
LET A(1,3)=X*Z*(1-COS(TH))-Y*SIN(TH)
LET A(2,1)=Y*X*(1-COS(TH))-Z*SIN(TH)
LET A(2,2)=Y*Y*(1-COS(TH))+COS(TH)
LET A(2,3)=Y*Z*(1-COS(TH))+X*SIN(TH)
LET A(3,1)=Z*X*(1-COS(TH))+Y*SIN(TH)
LET A(3,2)=Z*Y*(1-COS(TH))-X*SIN(TH)
LET A(3,3)=Z*Z*(1-COS(TH))+COS(TH)
LET NX=XX*A(1,1)+YY*A(1,2)+ZZ*A(1,3)
LET NY=XX*A(2,1)+YY*A(2,2)+ZZ*A(2,3)
LET NZ=XX*A(3,1)+YY*A(3,2)+ZZ*A(3,3)
END SUB
EXTERNAL SUB VECTORNORMAL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,XX,YY,ZZ) !'法線ベクトル
OPTION ARITHMETIC NATIVE
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 FUNCTION MKS$(X) !'IEEE754 32bit 浮動小数型
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
OPTION BASE 0
DIM B(32)
IF X<0 THEN LET B(0)=1
IF X<>0 THEN
IF ABS(X)<1 THEN
DO WHILE 2^(N+1)>ABS(X)
LET N=N-1
LOOP
LET N=N+1
ELSE
DO WHILE 2^(N+1)<ABS(X)
LET N=N+1
LOOP
END IF
LET NN=N
LET N=N+127
FOR I=1 TO 8
IF BITAND(N,2^(8-I))<>0 THEN LET B(I)=1
NEXT I
LET T=(ABS(X)-2^NN)/2^NN
FOR I=9 TO 31
LET T=T*2
IF T>=1 THEN
LET B(I)=1
LET T=T-INT(T)
END IF
NEXT I
END IF
LET AA$=CHR$(B(0)*128+B(1)*64+B(2)*32+B(3)*16+B(4)*8+B(5)*4+B(6)*2+B(7))
LET BB$=CHR$(B(8)*128+B(9)*64+B(10)*32+B(11)*16+B(12)*8+B(13)*4+B(14)*2+B(15))
LET CC$=CHR$(B(16)*128+B(17)*64+B(18)*32+B(19)*16+B(20)*8+B(21)*4+B(22)*2+B(23))
LET DD$=CHR$(B(24)*128+B(25)*64+B(26)*32+B(27)*16+B(28)*8+B(29)*4+B(30)*2+B(31))
LET MKS$=DD$&CC$&BB$&AA$
END FUNCTION
EXTERNAL FUNCTION MKL$(A) !'long整数型
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
DECLARE STRING A$,B$,C$,D$
IF A<0 THEN LET A=A+2^32
LET A$=CHR$(MOD(A,256))
LET B$=CHR$(MOD(INT(A/256),256))
LET C$=CHR$(MOD(INT(A/65536),256))
LET D$=CHR$(MOD(INT(A/16777216),256))
LET MKL$=A$&B$&C$&D$
END FUNCTION
サブルーチン perm の処理
先頭から(n-1)までを固定して、その並びから始まる最小のものを用意する（される）。
n
↓
1 i m
□□□□□□□□□
└┘ ← この範囲を右へ1つローテイトさせる
└─┘
└──┘
：
└─────┘
とする。
再帰呼出しされるごとに、辞書式順序で先頭から(n-1)までが確定されていく。
REM 1～nの順列を辞書式順序で生成する。
DECLARE EXTERNAL SUB perm
DIM a(100)
INPUT n
MAT a=ZER(n)
FOR i=1 TO n !並び 1,2,3,4,…,n
LET a(i)=i
NEXT i
CALL perm(a,1)
END
EXTERNAL SUB perm(a(),n)
LET m=UBOUND(a)
!----- debug -----
PRINT REPEAT$(" ",(m+1)*(n-1)); !階層
FOR i=1 TO m !並びを表示する
PRINT STR$(a(i));
NEXT i
PRINT
!----- debug -----
IF n=m THEN !すべて並んだなら
!!MAT PRINT a;
ELSE
FOR i=n TO m !ローテイトする範囲を設定する
LET t=a(i) !右へ1つローテイト
FOR j=i-1 TO n STEP -1
LET a(j+1)=a(j)
NEXT j
LET a(n)=t CALL perm(a,n+1) !次へ
LET t=a(n) !左へ1つローテイトで元に戻す
FOR j=n TO i-1
LET a(j)=a(j+1)
NEXT j
LET a(i)=t
NEXT i
END IF
END SUB
REM 1～nの順列を辞書式順序でなく生成する。
DECLARE EXTERNAL SUB perm
DIM a(100)
INPUT n
MAT a=ZER(n)
FOR i=1 TO n !並び 1,2,3,4,…,n
LET a(i)=i
NEXT i
CALL perm(a,1)
END
EXTERNAL SUB perm(a(),n)
LET m=UBOUND(a)
!----- debug -----
PRINT REPEAT$(" ",(m+1)*(n-1)); !階層
FOR i=1 TO m !並びを表示する
PRINT STR$(a(i));
NEXT i
PRINT
!----- debug -----
IF n=m THEN !すべて並んだなら
!!MAT PRINT a;
ELSE
FOR i=n TO m !箇所を設定する
LET t=a(n) !a[n]とa[i]を入れ替える
LET a(n)=a(i)
LET a(i)=t
CALL perm(a,n+1) !次へ
LET t=a(n) !元に戻す
LET a(n)=a(i)
LET a(i)=t
NEXT i
END IF
END SUB
! n 番目から、右終点 m 番までを１組に、順列の CALL を受ける。
! n+1 番目から、右終点 m 番までを、次の組として、その順列を、自身へ CALL する。
! これを、rotate left n~m で、先頭を、一順させる ・・・が、プログラムの、ほぼ全部。
!
! 以上の行き着く先は、n+1=m で、組の長さが１になって始めて終端する。
!
! そこでは、各階層での先頭が履歴として、配列 a() の中に、木構造の経路の様に並び、
! １つの順列パターンとなるので、それをプリントして RETURN する。
!
! CALL から戻ったら、
! n+1 番目から、右終点 m 番までの残りも、左ローテイトして先頭へ移し、同様に繰返す。
!
! n 番目から、右終点 m 番の、配列部分は、一順した後、必ず元へ戻るように終了させる。
! 元へ戻っていないと、各階層での CALL~RETURN で、配列が保存されず、一順管理も破綻する。
!------------------------------------------------------------------------------------
LET m=3
DIM a(m)
!
FOR i=1 TO m
LET a(i)=i
NEXT i
CALL perm(a,1) !( m 個の数列, n の初期値)
SUB perm(a(),n)
local i
IF n=m THEN
MAT PRINT USING REPEAT$("## ",m): a
ELSE
FOR i=n TO m
CALL perm(a,n+1)
!-------- !rotate Left 1
LET t=a(n) ! ┌── → ──┐
FOR j=n TO m-1 ! a(n)・・←・・a(m)
LET a(j)=a(j+1)
NEXT j
LET a(m)=t
!--------
NEXT i
END IF
END SUB
PUBLIC NUMERIC B(10),S
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R
PRINT PERM(N,R)
SELECT CASE R
CASE 2
CALL PERM2(N)
CASE 3
CALL PERM3(N)
CASE 4
CALL PERM4(N)
CASE 5
CALL PERM5(N)
CASE ELSE
DIM A(N)
CALL PERMN(1,N,R,A)
END SELECT
END
EXTERNAL SUB PERM2(N)
FOR I=1 TO N
FOR J=1 TO N
IF I<>J THEN
LET S=S+1
PRINT S;":";I;J
END IF
NEXT J
NEXT I
END SUB
EXTERNAL SUB PERM3(N)
FOR I=1 TO N
FOR J=1 TO N
FOR K=1 TO N
IF I<>J AND J<>K AND I<>K THEN
LET S=S+1
PRINT S;":";I;J;K
END IF
NEXT K
NEXT J
NEXT I
END SUB
EXTERNAL SUB PERM4(N)
FOR I=1 TO N
FOR J=1 TO N
FOR K=1 TO N
FOR L=1 TO N
IF I<>J AND I<>K AND I<>L AND J<>K AND J<>L AND K<>L THEN
LET S=S+1
PRINT S;":";I;J;K;L
END IF
NEXT L
NEXT K
NEXT J
NEXT I
END SUB
EXTERNAL SUB PERM5(N)
FOR I=1 TO N
FOR J=1 TO N
FOR K=1 TO N
FOR L=1 TO N
FOR M=1 TO N
IF I<>J AND I<>K AND I<>L AND I<>M AND J<>K AND J<>L AND J<>M AND K<>L AND K<>M AND L<>M THEN
LET S=S+1
PRINT S;":";I;J;K;L;M
END IF
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
END SUB
EXTERNAL SUB PERMN(NN,M,N,A())
IF N<NN THEN
MAT B=ZER
FOR J=1 TO N
IF B(A(J))<>0 THEN EXIT SUB
LET B(A(J))=1
NEXT J
LET S=S+1
PRINT S;":";
FOR J=1 TO N
PRINT A(J);
NEXT J
PRINT
ELSE
FOR I=1 TO M
LET A(NN)=I
CALL PERMN(NN+1,M,N,A)
NEXT I
END IF
END SUB
! m 個から r 個、取る場合は、以下の様に速めに終らせます。
!------------
LET m=4
LET r=2 !m 個から r 個
!
DIM a(m)
FOR i=1 TO m
LET a(i)=i
NEXT i
CALL perm( a,1) !CALL perm_fast( a,1) !速い
SUB perm(a(),n)
local i
IF n >r THEN !● r で、速めに終らせる。
MAT PRINT USING REPEAT$("## ",r)& " 配列の残り(無視)→"& REPEAT$("## ",m-r) :a
ELSE
FOR i=n TO m
CALL perm(a,n+1)
!-------- !rotate Left 1
LET t=a(n) ! ┌── → ──┐
FOR j=n TO m-1 ! a(n)・・←・・a(m)
LET a(j)=a(j+1)
NEXT j
LET a(m)=t
!--------
NEXT i
END IF
END SUB
!-------------------- swap を使った速い方も、同様に・・
SUB perm_fast( a(),n)
local i
IF n<=r THEN
FOR i=n TO m
swap a(n), a(i)
CALL perm_fast( a,n+1)
swap a(n), a(i)
NEXT i
ELSE
MAT PRINT USING REPEAT$("## ",r)& " 配列の残り(無視)→"& REPEAT$("## ",m-r) :a
END IF
END SUB
!クリックは、Graphic WINDOW 内の任意な場所で、
! 左押し→ 反転開始、動いている時に押し続けると 一時停止。
! 右押し→ プログラム終了。
!-------------------------
SET bitmap SIZE 501,501
! !401x401 501x501 641x641
SET TEXT font "",10 ! 8 10 11
LET pxw= 6 ! 5 6 7 !Pixels /問題座標ｘ単位
LET pyw= 9 ! 7 9 11 !Pixels / 〃 ｙ単位
!
ASK PIXEL SIZE(0,0;1,1) bmx,bmy
LET px=1/pxw !問題座標ｘ幅 /Pixel
LET py=1/pyw ! 〃 ｙ幅 /Pixel
LET ss=7 ! 〃 ｘ幅 /１人
DIM u( ss*3*pxw, 7*pyw+1)
DIM v( ss*8*pxw, 7*pyw+1), n$(0 TO 7)
MAT READ n$
DATA "head","neck","shoulder","abdomen","back","thigh","shin"," "
!
CALL act(0)
PLOT TEXT,AT ss*2, 17.0: "Right click to STOP"
PLOT TEXT,AT ss*2, 15.4: " Left click to TURN/PAUSE"
CALL act(1)
DO
mouse poll mx,my,ml,mr
IF ml=1 THEN
IF bak_t=1 THEN CALL act(2) ELSE CALL act(1)
END IF
WAIT DELAY 0
LOOP UNTIL mr=1
SUB act(t)
FOR st=1 TO 3 STEP 2
SET AREA COLOR 0
IF st=1 THEN LET k=16 ELSE LET k=44
SET WINDOW -(ss*st+2), bmx/pxw-px-(ss*st+2), -(bmy/pyw-py)+k,k
IF st=1 THEN LET i=i1 ELSE LET i=i3
IF st=1 THEN LET w$=w1$ ELSE LET w$=w3$
IF t=0 THEN CALL init08
IF t=1 THEN CALL left7
IF t=2 THEN CALL right8
IF st=1 THEN LET i1=i ELSE LET i3=i
IF st=1 THEN LET w1$=w$ ELSE LET w3$=w$
NEXT st
LET bak_t=t
END SUB
SUB init08
PLOT AREA: 0,7 ; 0,-7 ; ss*8-px,-7 ; ss*8-px,7 !clear image part
PLOT LINES: 0,0 ; 0, 7 ; ss*st-px, 7 ; ss*st-px,0 ; 0,0 !left upper around
PLOT LINES: ss*st,0 ; ss*st, 7 ; ss*8-px, 7 ; ss*8-px,0 ; ss*st,0 !right upper around
PLOT LINES: 0,-py; 0,-7-py; ss*8-px,-7-py; ss*8-px,-py !; 0,-py !all under around
LET w$=""
FOR i=0 TO 7
LET j=MOD(i*st,8) !← st=1／st=3 で doll の直線整列 散在を切換えている。
DRAW doll WITH SHIFT( i*ss+1, j-7)
LET w$=w$& n$(j)& " "
NEXT i
PLOT LINES: 0,-9; ss*8,-9; ss*8,-7.6; 0,-7.6; 0,-9 !text box
LET i=0
LET j=0
END SUB
SUB right8
MAT u=ZER( ss*st*pxw, 7*pyw+1)
ASK PIXEL ARRAY(i*ss,j+7) u ! right upper image
CALL move(u, 0, 1, 8) !↑ ( u(,), dx,dy, n)
CALL move(u,-1, 0, 8) !←
CALL move(u, 0,-1, 8) !↓
ASK PIXEL ARRAY(i*ss,j+7) v ! all upper image
CALL move(v, 1/7,0, st*7) !→ ( v(,), dx,dy, n)
PLOT AREA: px,py-9; ss*8-px,py-9; ss*8-px,-py-7.6; px,-py-7.6 !clear text box
END SUB
SUB left7
MAT u=ZER( ss*st*pxw, 7*pyw+1)
ASK PIXEL ARRAY(ss*i,j+7) v ! all upper image
CALL move(v, -1/7,0, st*7) !← ( v(,), dx,dy, n)
ASK PIXEL ARRAY(ss*i,j+7) u ! left upper image
CALL move(u, 0, 1, 8) !↑ ( u(,), dx,dy, n)
CALL move(u, 1, 0, 8) !→
CALL move(u, 0,-1, 8) !↓
PLOT TEXT,AT .8,-9: w$ !write text box
END SUB
SUB move( v(,), dx,dy, n)
LET w=SIZE(v,1)/(ss*pxw)
FOR k=1 TO n
MAT PLOT CELLS ,IN ss*(i+dx),7+j+dy; ss*(w+i+dx)-px,j+dy: v
IF 0< dy THEN PLOT AREA: ss*i,j ; ss*(i+w )-px,j ; ss*(i+w )-px,j+dy-py; ss*i,j+dy-py
IF dy< 0 THEN PLOT AREA: ss*i,j+7+dy+py; ss*(i+w )-px,j+7+dy+py; ss*(i+w )-px,j+7 ; ss*i,j+7
IF 0< dx THEN PLOT AREA: ss*i,j ; ss*(i+dx)-px,j ; ss*(i+dx)-px,j+7 ; ss*i,j+7
IF dx< 0 THEN PLOT AREA: ss*(i+w+dx),j ; ss*(i+w )-px,j ; ss*(i+w )-px,j+7 ; ss*(i+w+dx),j+7
CALL bwait(0)
LET i=i+dx
LET j=j+dy
NEXT k
END SUB
PICTURE doll
FOR h=0 TO 6
SET AREA COLOR 23+h
IF h< 2 THEN
PLOT AREA: 1,h; 2-px,h; 2-px,(h+1)-py; 1,(h+1)-py
PLOT AREA: 3,h; 4-px,h; 4-px,(h+1)-py; 3,(h+1)-py
ELSEIF h< 4 THEN
PLOT AREA: 1,h; 4-px,h; 4-px,(h+1)-py; 1,(h+1)-py
PLOT AREA: 0,h; 1-px*3,h; 1-px*3,(h+1)-py; 0,(h+1)-py
PLOT AREA: 5,h; 4+px*2,h; 4+px*2,(h+1)-py; 5,(h+1)-py
ELSEIF h=4 THEN
PLOT AREA: 0,h; 5-px,h; 5-px,(h+1)-py; 0,(h+1)-py
ELSEIF h=5 THEN
PLOT AREA: 2,5; 3-px,5; 3-px,6-py; 2,6-py
ELSEIF h=6 THEN
PLOT AREA: 1,h; 4-px,h; 4-px,(h+1)-py; 1,(h+1)-py
END IF
NEXT h
END PICTURE
SUB bwait(t) !default local value 't'
DO
mouse poll mx,my,ml,mr
IF 0< mr THEN STOP
IF 0< ml THEN LET t=.1
IF t<=0 THEN EXIT SUB
LET t=t-.1
WAIT DELAY .1
LOOP
END SUB
!'N個の異なる球をR個の異なる箱に分ける(空箱なし)
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R
PUBLIC STRING A$(10)
PUBLIC NUMERIC B(10),S
DIM AA(N)
PRINT FACT(R)*S2(N,R)
SELECT CASE N
CASE 2
FOR I=1 TO R
FOR J=1 TO R
LET B(I)=1
LET B(J)=1
LET FL=0
FOR II=1 TO R
IF B(II)=0 THEN LET FL=1
NEXT II
IF FL=0 THEN
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
END IF
MAT B=ZER
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
LET B(I)=1
LET B(J)=1
LET B(K)=1
LET FL=0
FOR II=1 TO R
IF B(II)=0 THEN LET FL=1
NEXT II
IF FL=0 THEN
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
END IF
MAT B=ZER
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
LET B(I)=1
LET B(J)=1
LET B(K)=1
LET B(L)=1
LET FL=0
FOR II=1 TO R
IF B(II)=0 THEN LET FL=1
NEXT II
IF FL=0 THEN
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET A$(L)=A$(L)&" 4"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
END IF
MAT B=ZER
NEXT L
NEXT K
NEXT J
NEXT I
CASE ELSE
CALL PN(1,N,R,AA)
END SELECT
END
EXTERNAL SUB PN(NN,M,R,AA())
IF M<NN THEN
FOR II=1 TO M
LET B(AA(II))=1
NEXT II
LET FL=0
FOR II=1 TO R
IF B(II)=0 THEN LET FL=1
NEXT II
IF FL=0 THEN
FOR II=1 TO M
LET A$(AA(II))=A$(AA(II))&" "&STR$(II)
NEXT II
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
END IF
MAT B=ZER
ELSE
FOR I=1 TO R
LET AA(NN)=I
CALL PN(NN+1,M,R,AA)
NEXT I
END IF
END SUB
EXTERNAL FUNCTION S2(N,K) !'第2スターリング数
IF K<1 OR K>N THEN
LET S2=0
EXIT FUNCTION
END IF
IF K=N OR K=1 THEN
LET S2=1
EXIT FUNCTION
END IF
LET S2=K*S2(N-1,K)+S2(N-1,K-1)
END FUNCTION
!'N個の異なる球をR個の異なる箱に分ける(空箱あり)
INPUT PROMPT "N,R=":N,R
PUBLIC STRING A$(10)
PUBLIC NUMERIC S
DIM AA(N)
PRINT R^N
SELECT CASE N
CASE 2
FOR I=1 TO R
FOR J=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET A$(L)=A$(L)&" 4"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
NEXT L
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET A$(L)=A$(L)&" 4"
LET A$(M)=A$(M)&" 5"
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
CASE ELSE
CALL PN(1,N,R,AA)
END SELECT
END
EXTERNAL SUB PN(NN,M,R,AA())
IF M<NN THEN
FOR II=1 TO M
LET A$(AA(II))=A$(AA(II))&" "&STR$(II)
NEXT II
LET S=S+1
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
LET A$(II)=""
NEXT II
PRINT
ELSE
FOR I=1 TO R
LET AA(NN)=I
CALL PN(NN+1,M,R,AA)
NEXT I
END IF
END SUB
!'N個の異なる球をR個の同じ箱に分ける(空箱なし)
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R
PRINT S2(N,R)
PUBLIC STRING A$(10),B$(10,1000)
PUBLIC NUMERIC C(10),S
DIM AA(N)
SELECT CASE N
CASE 2
FOR I=1 TO R
FOR J=1 TO R
LET C(I)=1
LET C(J)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
MAT A$=NUL$
END IF
LET C(I)=0
LET C(J)=0
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
LET C(I)=1
LET C(J)=1
LET C(K)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
MAT A$=NUL$
END IF
LET C(I)=0
LET C(J)=0
LET C(K)=0
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
LET C(I)=1
LET C(J)=1
LET C(K)=1
LET C(L)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET A$(L)=A$(L)&" 4"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
MAT A$=NUL$
END IF
LET C(I)=0
LET C(J)=0
LET C(K)=0
LET C(L)=0
NEXT L
NEXT K
NEXT J
NEXT I
CASE ELSE
CALL PN(1,N,R,AA)
END SELECT
END
EXTERNAL SUB PN(NN,M,R,AA())
IF M<NN THEN
FOR II=1 TO M
LET C(AA(II))=1
NEXT II
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
FOR II=1 TO M
LET A$(AA(II))=A$(AA(II))&" "&STR$(II)
NEXT II
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
MAT A$=NUL$
END IF
MAT C=ZER
ELSE
FOR I=1 TO R
LET AA(NN)=I
CALL PN(NN+1,M,R,AA)
NEXT I
END IF
END SUB
EXTERNAL FUNCTION S2(N,R) !'第2スターリング数
FOR J=0 TO R
LET V=V+COMB(R,J)*(-1)^J*(R-J)^N
NEXT J
LET S2=V/FACT(R)
END FUNCTION
EXTERNAL FUNCTION CHECK(R,A$(),B$(,),II)
SELECT CASE R
CASE 2
FOR I=1 TO R
FOR J=1 TO R
IF I<>J THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
IF I<>J AND J<>K AND I<>K THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
IF I<>J AND I<>K AND I<>L AND J<>K AND J<>L AND K<>L THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) AND LTRIM$(A$(L))=LTRIM$(B$(4,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT L
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
IF I<>J AND I<>K AND I<>L AND I<>M AND J<>K AND J<>L AND J<>M AND K<>L AND K<>M AND L<>M THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) AND LTRIM$(A$(L))=LTRIM$(B$(4,II)) AND LTRIM$(A$(M))=LTRIM$(B$(5,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
CASE 6
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
FOR O=1 TO R
IF I<>J AND I<>K AND I<>L AND I<>M AND I<>O AND J<>K AND J<>L AND J<>M AND J<>O THEN
IF K<>L AND K<>M AND K<>O AND L<>M AND L<>O AND M<>O THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) AND LTRIM$(A$(L))=LTRIM$(B$(4,II)) AND LTRIM$(A$(M))=LTRIM$(B$(5,II)) AND LTRIM$(A$(O))=LTRIM$(B$(6,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
END IF
NEXT O
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
END SELECT
END FUNCTION
!'N個の異なる球をR個の同じ箱に分ける(空箱あり)
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R AND N>=2
DIM AA(N)
PUBLIC STRING A$(10),B$(10,1000)
PUBLIC NUMERIC S,SS
FOR K=1 TO R
LET SS=SS+S2(N,K)
NEXT K
PRINT SS
SELECT CASE N
CASE 2
FOR I=1 TO R
FOR J=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
IF S=SS THEN STOP
MAT A$=NUL$
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
IF S=SS THEN STOP
MAT A$=NUL$
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
LET A$(I)=A$(I)&"1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
LET A$(L)=A$(L)&" 4"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
IF S=SS THEN STOP
MAT A$=NUL$
NEXT L
NEXT K
NEXT J
NEXT I
CASE ELSE
CALL PN(1,N,R,AA)
END SELECT
END
EXTERNAL SUB PN(NN,M,R,AA())
IF M<NN THEN
FOR II=1 TO M
LET A$(AA(II))=A$(AA(II))&" "&STR$(II)
NEXT II
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
IF S=SS THEN STOP
MAT A$=NUL$
ELSE
FOR I=1 TO R
LET AA(NN)=I
CALL PN(NN+1,M,R,AA)
NEXT I
END IF
END SUB
EXTERNAL FUNCTION S2(N,R) !'第2スターリング数
FOR J=0 TO R
LET V=V+COMB(R,J)*(-1)^J*(R-J)^N
NEXT J
LET S2=V/FACT(R)
END FUNCTION
EXTERNAL FUNCTION CHECK(R,A$(),B$(,),II)
SELECT CASE R
CASE 2
FOR I=1 TO R
FOR J=1 TO R
IF I<>J THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
IF I<>J AND J<>K AND I<>K THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
IF I<>J AND I<>K AND I<>L AND J<>K AND J<>L AND K<>L THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) AND LTRIM$(A$(L))=LTRIM$(B$(4,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT L
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
IF I<>J AND I<>K AND I<>L AND I<>M AND J<>K AND J<>L AND J<>M AND K<>L AND K<>M AND L<>M THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) AND LTRIM$(A$(L))=LTRIM$(B$(4,II)) AND LTRIM$(A$(M))=LTRIM$(B$(5,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
CASE 6
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
FOR O=1 TO R
IF I<>J AND I<>K AND I<>L AND I<>M AND I<>O AND J<>K AND J<>L AND J<>M AND J<>O THEN
IF K<>L AND K<>M AND K<>O AND L<>M AND L<>O AND M<>O THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) AND LTRIM$(A$(L))=LTRIM$(B$(4,II)) AND LTRIM$(A$(M))=LTRIM$(B$(5,II)) AND LTRIM$(A$(O))=LTRIM$(B$(6,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
END IF
NEXT O
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
END SELECT
END FUNCTION
!'N個の同じ球をR個の異なる箱に分ける(空箱なし)
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R AND R>1
DIM A(N)
PUBLIC NUMERIC S
PRINT COMB(N-1,R-1)
CALL COMBN(1,N-1,R-1,A)
END
EXTERNAL SUB COMBN(NN,N,R,A())
IF R<NN THEN
LET S=S+1
PRINT S;":[";
FOR J=1 TO N+1
PRINT "●";
FOR L=1 TO R
IF A(L)=J THEN PRINT "] [";
NEXT L
NEXT J
PRINT "]"
ELSE
FOR I=1 TO N-R+NN
LET A(NN)=I
IF NN=1 OR A(NN-1)<A(NN) THEN
CALL COMBN(NN+1,N,R,A)
END IF
NEXT I
END IF
END SUB
!'N個の同じ球をR個の異なる箱に分ける(空箱あり)
PUBLIC NUMERIC S
INPUT PROMPT "N,R=":N,R
PRINT COMB(N+R-3,R-1)
DIM A(N+R-1)
CALL RECURSIVE(1,N-1,R-1,A)
END
EXTERNAL SUB RECURSIVE(NN,M,N,A())
IF N<NN THEN
LET S=S+1
PRINT S;": [";
FOR J=1 TO M+1
PRINT "●";
FOR L=1 TO N
IF A(L)=J THEN PRINT "] [";
NEXT L
NEXT J
PRINT "]"
ELSE
FOR I=1 TO M
LET A(NN)=I
IF NN=1 OR A(NN-1)<=A(NN) THEN
CALL RECURSIVE(NN+1,M,N,A)
END IF
NEXT I
END IF
END SUB
!'N個の同じ球をR個の同じ箱に分ける(空箱なし)
PUBLIC NUMERIC S
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R AND N>=2
DIM A(N)
PRINT P(N,R)
SELECT CASE R
CASE 2
FOR I=1 TO N
LET J=N-I
IF I<=J THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT I
CASE 3
FOR I=1 TO N
FOR J=I TO N-I
LET K=N-I-J
IF I<=J AND J<=K THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I OR II=I+J THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT J
NEXT I
CASE 4
FOR I=1 TO N
FOR J=I TO N-I
FOR K=J TO N-I-J
LET L=N-I-J-K
IF I<=J AND J<=K AND K<=L THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I OR II=I+J OR II=I+J+K THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=1 TO N
FOR J=I TO N-I
FOR K=J TO N-I-J
FOR L=K TO N-I-J-K
LET M=N-I-J-K-L
IF I<=J AND J<=K AND K<=L AND L<=M THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I OR II=I+J OR II=I+J+K OR II=I+J+K+L THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT L
NEXT K
NEXT J
NEXT I
CASE ELSE
CALL RECURSIVE(1,R,N,A)
END SELECT
END
EXTERNAL SUB RECURSIVE(NN,N,M,A())
IF NN=N THEN
LET SS=M
FOR J=0 TO NN
LET SS=SS-A(J)
NEXT J
IF SS=0 THEN
IF A(NN-1)<=A(NN) THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
LET SS=SS+A(II)
IF II=SS THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
EXIT SUB
END IF
ELSE
FOR I=1 TO M
LET A(NN)=I
IF NN=1 OR A(NN-1)<=A(NN) THEN
CALL RECURSIVE(NN+1,N,M,A)
END IF
NEXT I
END IF
END SUB
EXTERNAL FUNCTION P(N,M) !'分割数
IF M=1 OR N=M THEN
LET P=1
ELSEIF N>=3 AND 2<=M AND M<=N-1 THEN
LET P=P(N-M,M)+P(N-1,M-1)
ELSE
LET P=0
END IF
END FUNCTION
!'N個の同じ球をR個の同じ箱に分ける(空箱あり)
PUBLIC NUMERIC S
INPUT PROMPT "N,R=":N,R
DIM A(N)
FOR K=1 TO R
LET SS=SS+P(N,K)
NEXT K
PRINT SS
SELECT CASE R
CASE 2
FOR I=0 TO N
LET J=N-I
IF I<=J THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT I
CASE 3
FOR I=0 TO N
FOR J=I TO N-I
LET K=N-I-J
IF I<=J AND J<=K THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I OR II=I+J THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT J
NEXT I
CASE 4
FOR I=0 TO N
FOR J=I TO N-I
FOR K=J TO N-I-J
LET L=N-I-J-K
IF I<=J AND J<=K AND K<=L THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I OR II=I+J OR II=I+J+K THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=0 TO N
FOR J=I TO N-I
FOR K=J TO N-I-J
FOR L=K TO N-I-J-K
LET M=N-I-J-K-L
IF I<=J AND J<=K AND K<=L AND L<=M THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
IF II=I OR II=I+J OR II=I+J+K OR II=I+J+K+L THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
NEXT L
NEXT K
NEXT J
NEXT I
CASE ELSE
CALL RECURSIVE(1,R,N,A)
END SELECT
END
EXTERNAL SUB RECURSIVE(NN,N,M,A())
IF NN=N THEN
LET SS=M
FOR J=0 TO NN
LET SS=SS-A(J)
NEXT J
IF SS=0 THEN
IF A(NN-1)<=A(NN) THEN
LET S=S+1
PRINT S;": [";
FOR II=1 TO N
PRINT "●";
LET SS=SS+A(II)
IF II=SS THEN PRINT "] [";
NEXT II
PRINT "]"
END IF
EXIT SUB
END IF
ELSE
FOR I=0 TO M
LET A(NN)=I
IF NN=1 OR A(NN-1)<=A(NN) THEN
CALL RECURSIVE(NN+1,N,M,A)
END IF
NEXT I
END IF
END SUB
EXTERNAL FUNCTION P(N,M) !'分割数
IF M=1 OR N=M THEN
LET P=1
ELSEIF N>=3 AND 2<=M AND M<=N-1 THEN
LET P=P(N-M,M)+P(N-1,M-1)
ELSE
LET P=0
END IF
END FUNCTION
!'N個の同じ球をR個の異なる箱に分ける(空箱あり)
INPUT PROMPT "N,R=":N,R
PRINT COMB(N+R-1,R-1)
SELECT CASE R
CASE 2
FOR I=0 TO N
LET J=N-I
LET S=S+1
PRINT S;":[";
FOR II=1 TO I
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO J
PRINT "●";
NEXT II
PRINT "]"
NEXT I
CASE 3
FOR I=0 TO N
FOR J=0 TO N-I
LET K=N-J-I
LET S=S+1
PRINT S;":[";
FOR II=1 TO I
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO J
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO K
PRINT "●";
NEXT II
PRINT "]"
NEXT J
NEXT I
CASE 4
FOR I=0 TO N
FOR J=0 TO N-I
FOR K=0 TO N-I-J
LET L=N-I-J-K
LET S=S+1
PRINT S;":[";
FOR II=1 TO I
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO J
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO K
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO L
PRINT "●";
NEXT II
PRINT "]"
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=0 TO N
FOR J=0 TO N-I
FOR K=0 TO N-I-J
FOR L=0 TO N-I-J-K
LET M=N-I-J-K-L
LET S=S+1
PRINT S;":[";
FOR II=1 TO I
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO J
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO K
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO L
PRINT "●";
NEXT II
PRINT "][";
FOR II=1 TO M
PRINT "●";
NEXT II
PRINT "]"
NEXT L
NEXT K
NEXT J
NEXT I
END SELECT
END
PRINT STR$(C); ": "; !結果を表示する
PRINT "["; !図示する
FOR X=1 TO N
PRINT "●";
FOR J=1 TO M-1
IF X=D(J) THEN PRINT "] ["; !1番目以降
NEXT J
NEXT X
PRINT "]"
ELSE
FOR i=S TO N-1 !p本目の仕切り線の位置 D(p)＜D(p+1)
LET D(P)=i
CALL try(P+1,i+1,D)
NEXT i
END IF
END SUB
PRINT STR$(C); ": "; !結果を表示する
PRINT "["; !図示する
FOR J=1 TO M-1
IF D(J)=0 THEN PRINT "] ["; !0番目の仕切り線
NEXT J
FOR X=1 TO N
PRINT "●";
FOR J=1 TO M-1
IF X=D(J) THEN PRINT "] ["; !1番目以降
NEXT J
NEXT X
PRINT "]"
ELSE
FOR i=S TO N !p本目の仕切り線の位置 D(p)≦D(p+1)
LET D(P)=i
CALL try(P+1,i,D)
NEXT i
END IF
END SUB
EXTERNAL SUB try(P,S,T,A(),B())
IF P>M THEN !最後の箱まで配って、
IF T=0 THEN !球を残らず配り終えたなら
CALL stub(N,M,A,B)
END IF
ELSE
FOR i=S TO T !p番目の箱 B(1)≦B(2)≦B(3)≦…≦B(p)
LET B(P)=i
CALL try(P+1,S,T-i,A,B) !(5),(6)
NEXT i
END IF
END SUB
EXTERNAL SUB stub(N,M,A(),B()) !同じ球● を 異なる球① へ
LET K=0 !最初のパターン
FOR J=1 TO M
FOR X=1 TO B(J)
LET A(K+X)=J
NEXT X
LET K=K+B(J)
NEXT J
MAT PRINT A; !debug
DO
LET C=C+1
PRINT STR$(C); ": "; !結果を表示する
FOR J=1 TO M !j番目の箱
PRINT "[";
FOR K=1 TO N
IF A(K)=J THEN PRINT K; !球の番号
NEXT K
PRINT "]";
NEXT J
PRINT
CALL NextPermFactorial(A,N, rc) !次へ
LOOP UNTIL rc<>0
END SUB
EXTERNAL SUB NextPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す ※「異なるn個のもの」と共通
LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)>=A(i+1) !０は番人
LET i=i-1
LOOP
IF i=0 THEN !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1
LET rc=1 !完了（最後の並びである）
EXIT SUB
END IF
LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)>=A(j)
LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t
LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
LET t=A(i) !swap it
LET A(i)=A(j)
LET A(j)=t
LET i=i+1
LET j=j-1
LOOP
LET rc=0 !未了
END SUB
EXTERNAL FUNCTION StirlingS2(n,m) !第2種スターリング数 ※公式による
LET s=0
FOR k=0 TO m-1 !包除原理より
LET s=s+(-1)^k*COMB(m,k)*(m-k)^n
NEXT k
LET StirlingS2=s/FACT(m)
END FUNCTION
LET S=0 !検算
FOR k=1 TO M
LET S=S+StirlingS2(n,k)
NEXT k
PRINT S;"通り"
END
EXTERNAL SUB try(P,S,T,A(),B())
IF P>M THEN !最後の箱まで配って、
IF T=0 THEN !球を残らず配り終えたなら
CALL stub(N,M,A,B)
END IF
ELSE
FOR i=S TO T !p番目の箱 B(1)≦B(2)≦B(3)≦…≦B(p)
LET B(P)=i
CALL try(P+1,i,T-i,A,B) !(7),(8)
NEXT i
END IF
END SUB
EXTERNAL SUB stub(N,M,A(),B()) !同じ球● を 異なる球① へ
LET K=0 !最初のパターン（m進法n桁）
FOR J=1 TO M
FOR X=1 TO B(J)
LET A(K+X)=J
NEXT X
LET K=K+B(J)
NEXT J
MAT PRINT A; !debug
DO
CALL Filter(N,M,A,B, rc) !箱の中の球の並びで篩う
IF rc<>0 THEN
LET C=C+1
PRINT STR$(C); ": "; !結果を表示する
FOR J=1 TO M !j番目の箱
PRINT "[";
FOR K=1 TO N
IF A(K)=J THEN PRINT K; !球の番号
NEXT K
PRINT "]";
NEXT J
PRINT
END IF
CALL NextPermFactorial(A,N, rc) !次へ
LOOP UNTIL rc<>0
END SUB
EXTERNAL SUB Filter(N,M,A(),B(), rc) !個数が同じ箱の並びが昇順になっているかどうあ確認する
DIM F(M) !m個の箱 値は、球の番号で最小のもの
LET rc=0 !NG
!中身（球の並び）について、
! [①][②][③4][⑤6] と [①][②][⑤6][③4] を同一とみなす必要がある。
FOR J=1 TO M !j番目の箱
FOR K=1 TO N !球の番号で最小のもの
IF A(K)=J THEN EXIT FOR
NEXT K
LET F(J)=K !空の場合は、N+1
NEXT J
!!!MAT PRINT F; !debug
FOR K=1 TO N !球の個数が同じものでは
LET W=-1
FOR J=1 TO M !j番目の箱
IF B(J)=K THEN
IF F(J)<W THEN EXIT FOR !球の番号が昇順のもの
LET W=F(J)
END IF
NEXT J
IF J<=M THEN EXIT FOR
NEXT K
IF K>N THEN LET rc=-1 !OK
END SUB
EXTERNAL SUB NextPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す ※「異なるn個のもの」と共通
LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)>=A(i+1) !０は番人
LET i=i-1
LOOP
IF i=0 THEN !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1
LET rc=1 !完了（最後の並びである）
EXIT SUB
END IF
LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)>=A(j)
LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t
LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
LET t=A(i) !swap it
LET A(i)=A(j)
LET A(j)=t
LET i=i+1
LET j=j-1
LOOP
LET rc=0 !未了
END SUB
EXTERNAL FUNCTION StirlingS2(n,m) !第2種スターリング数 ※公式による
LET s=0
FOR k=0 TO m-1 !包除原理より
LET s=s+(-1)^k*COMB(m,k)*(m-k)^n
NEXT k
LET StirlingS2=s/FACT(m)
END FUNCTION
!順列 Permutation nPr P(n,r)
!---------------------
! 入力数列 a() の準備
!---------------------
LET n=3
LET r=2
DIM a(n)
!
FOR i=1 TO n
LET a(i)=i
NEXT i
!----------------------------------------------------------
! 出力１行。速度を測るときは、MAT PRINT を削除( 先頭に"!")
!----------------------------------------------------------
SUB output1p
MAT PRINT USING REPEAT$("## ",r)& " 配列の残り(無視)→"& REPEAT$("## ",n-r) :a
END SUB
!----------------------------------------
!(No_print, n=9,r=9 の所要時間)@P3_500MHz
!-------perm00 27.08 sec.
!-------perm50 25.15 sec.
!-------perm10 19.88 sec.
!-------perm40 15.82 sec.
!-------perm20 12.03 sec.
!-------perm30 9.83 sec.
!(No_print, n=8,r=8 の所要時間)@P3_500MHz
!-------perm00 3.02 sec.
!-------perm50 2.75 sec.
!-------perm10 2.2 sec.
!-------perm40 1.76 sec.
!-------perm20 1.37 sec.
!-------perm30 1.1 sec.
!------------------------------------------------------------
!各文の引数から、a() が消え、k のみになっているが、
!元々 a() は、local(局所変数)でないので、問題を簡単にするため
!------------------------------------------------------------
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。
LET t0=TIME
CALL perm00(1) !( k の初期値=1)
PRINT "-------perm00 ";TIME-t0;"sec."
PRINT
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。先プログラムでの a() 保存 検査
LET t0=TIME
CALL perm50(1) !( k の初期値=1)
PRINT "-------perm50 ";TIME-t0;"sec."
PRINT
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。先プログラムでの a() 保存 検査
LET t0=TIME
CALL perm10(1) !( k の初期値=1)
PRINT "-------perm10 ";TIME-t0;"sec."
PRINT
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。先プログラムでの a() 保存 検査
LET t0=TIME
CALL perm40(1) !( k の初期値=1)
PRINT "-------perm40 ";TIME-t0;"sec."
PRINT
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。先プログラムでの a() 保存 検査
LET t0=TIME
CALL perm20(1) !( k の初期値=1)
PRINT "-------perm20 ";TIME-t0;"sec."
PRINT
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。先プログラムでの a() 保存 検査
LET t0=TIME
CALL perm30(1) !( k の初期値=1)
PRINT "-------perm30 ";TIME-t0;"sec."
PRINT
!
MAT PRINT USING REPEAT$("## ",n) :a !入力数列 a()表示。先プログラムでの a() 保存 検査
!----------------------------------------
!１回毎に、右左rotate 復元しながら、一巡。
!----------------------------------------
SUB perm00(k)
local i
IF r< k THEN
CALL output1p
ELSE
FOR i=k TO n
! !-------- !rotate Right 1
LET t=a(i) ! ┌── ← ──┐
FOR j=i-1 TO k STEP -1 ! a(k)・・→・・a(i)
LET a(j+1)=a(j)
NEXT j
LET a(k)=t
!--------
CALL perm00(k+1)
!-------- !rotate Left 1
LET t=a(k) ! ┌── → ──┐
FOR j=k TO i-1 ! a(k)・・←・・a(i)
LET a(j)=a(j+1)
NEXT j
LET a(i)=t
!--------
NEXT i
END IF
END SUB
!------------------------------------------------------------------
! 毎回、右左rotate で復元せず、RETURN までに１巡復元すればよいので、
! rotate １回( rotate の左右方向は、何れかに固定できればよい)
!------------------------------------------------------------------
SUB perm10(k)
local i
IF r< k THEN
CALL output1p
ELSE
FOR i=k TO n
CALL perm10(k+1)
!-------- !rotate Left 1
LET t=a(k) ! ┌── → ──┐
FOR j=k TO n-1 ! a(k)・・←・・a(n)
LET a(j)=a(j+1)
NEXT j
LET a(n)=t
!--------
NEXT i
END IF
END SUB
!------------------------------------------------------------------
! 一巡の要求は、先頭ｋ位置だけで、k+1 ～n は、その残りであればよく、
! 先頭位置・巡回位置の、交換(swap)・復元(swap)を、順番に行なう方法。
! rotate のように全桁の移送をしないため、高速になる。
!------------------------------------------------------------------
SUB perm20(k)
local i
IF r< k THEN
CALL output1p
ELSE
FOR i=k TO n
swap a(k),a(i)
CALL perm20(k+1)
swap a(k),a(i)
NEXT i
END IF
END SUB
!-----------------------------------------------------------------------
! perm20 の高速化。最初の 交換(k,k)・復元(k,k) が無駄で k+1 からに。最速
!-----------------------------------------------------------------------
SUB perm30(k)
local i
IF r< k THEN
CALL output1p
ELSE
CALL perm30(k+1)
FOR i=k+1 TO n
swap a(k),a(i)
CALL perm30(k+1)
swap a(k),a(i)
NEXT i
END IF
END SUB
!---------------------------------------------------------
! Perm30 の swap を１回で巡回させ、最後に rotate１回で補修
!---------------------------------------------------------
SUB perm40(k)
local i
IF r< k THEN
CALL output1p
ELSE
CALL perm40(k+1)
FOR i=k+1 TO n
swap a(k),a(i)
CALL perm40(k+1)
NEXT i
!-------- !rotate Left 1
LET t=a(k) ! ┌── → ──┐
FOR j=k TO n-1 ! a(k)・・←・・a(n)
LET a(j)=a(j+1)
NEXT j
LET a(n)=t
!--------
END IF
END SUB
!---------------------------------------------------------------------
! 保存無し 巡回だけなら、Perm40 の様に swap１回にして、別の b() で保存
!---------------------------------------------------------------------
SUB perm50(k)
local i,b(10) !b()の添字は、変数不可なので大きめ
IF r< k THEN
CALL output1p
ELSE
MAT b=a
CALL perm50(k+1)
FOR i=k+1 TO n
swap a(k),a(i)
CALL perm50(k+1)
NEXT i
MAT a=b
END IF
END SUB
LET t=N !C(n+m-1,n)=C(n+m-1,m-1)
LET N=N+M-1
LET M=t
DIM A(N)
CALL comb(A,1,M)
PRINT C;"通り"
END
!SAMPLEフォルダ内 COMBINAT.BAS より
EXTERNAL SUB comb(a(),k,r) !1～nの集合からr個を選ぶ組合せを生成する
IF r=0 THEN
LET C=C+1
FOR i=1 TO N
IF a(i)=1 THEN PRINT i;
NEXT i
PRINT " → ";
LET k=0 !n個の球 値は、箱の番号
FOR i=1 TO N
IF a(i)=1 THEN
PRINT i-k; !0,1,2,3,…,r-1が加味されているので
LET k=k+1
END IF
NEXT i
PRINT
ELSE
FOR i=k TO N-r+1!k以降の数からr個を選択する
LET a(i)=1 !2進法n桁とみなし、iビット目を1とする
CALL comb(a,i+1,r-1)
LET a(i)=0 !元に戻す
NEXT i
END IF
END SUB
DIM A(N+M-1) !n個の球と(m-1)個の仕切り線
FOR i=1 TO N !最初の並び（同じものを含む順列）
LET A(i)=1
NEXT i
FOR i=N+1 TO N+M-1
LET A(i)=2
NEXT i
MAT PRINT A;
LET C=0 !場合の数
DO
LET C=C+1
PRINT STR$(C); ": "; !結果を表示する
PRINT "[";
FOR K=1 TO N+M-1
IF A(K)=1 THEN PRINT "●";
IF A(K)=2 THEN PRINT "][";
NEXT K
PRINT "]";
PRINT
CALL NextPermFactorial(A,N+M-1, rc) !次へ
LOOP UNTIL rc<>0
PRINT C;"通り"
PRINT COMB(n+m-1,m-1);"通り"
END
EXTERNAL SUB NextPermFactorial(A(),N, rc) !辞書式順序で次の順列を返す ※「異なるn個のもの」と共通
LET i=N-1 !順列を右から左にみて、増加列から減少列に変わる位置iを探す
DO WHILE i>0 AND A(i)>=A(i+1) !０は番人
LET i=i-1
LOOP
IF i=0 THEN !A(1)>A(2)>A(3)> … >A(N)なら 例. N=4、4,3,2,1
LET rc=1 !完了（最後の並びである）
EXIT SUB
END IF
LET j=N !その位置iより右で、A(i)以上で最小の数A(j)を探す
DO WHILE A(i)>=A(j)
LET j=j-1
LOOP
LET t=A(i) !A(i)とA(j)を交換する
LET A(i)=A(j)
LET A(j)=t
LET i=i+1 !(i+1)からNまでの範囲を逆順にする
LET j=N
DO WHILE i<j
LET t=A(i) !swap it
LET A(i)=A(j)
LET A(j)=t
LET i=i+1
LET j=j-1
LOOP
LET rc=0 !未了
END SUB
EXTERNAL SUB try(P,T,B())
IF P>M THEN !最後の箱まで配って、
IF T=0 THEN !球を残らず配り終えたなら
LET C=C+1
PRINT STR$(C); ": "; !結果を表示する
FOR J=1 TO M !図示する
PRINT "[○";
FOR X=2 TO B(J)
PRINT "●";
NEXT X
PRINT "]";
NEXT J
PRINT
END IF
ELSE
FOR i=1 TO T !p番目の箱
LET B(P)=i
CALL try(P+1,T-i,B)
NEXT i
END IF
END SUB
!'N個の要素をR個の巡回列に分割する
DO
INPUT PROMPT "N,R=":N,R
LOOP UNTIL N>=R AND N>2
PRINT S1(N,R) !'第1種スターリング数
PUBLIC STRING A$(10),B$(10,1000)
PUBLIC NUMERIC C(10),S
SELECT CASE N
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
LET C(I)=1
LET C(J)=1
LET C(K)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET A$(I)=A$(I)&" 1"
LET A$(J)=A$(J)&" 2"
LET A$(K)=A$(K)&" 3"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
LET FL=ROTATECHK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
MAT A$=NUL$
LET A$(I)=A$(I)&" 1"
LET A$(J)=A$(J)&" 3"
LET A$(K)=A$(K)&" 2"
FOR II=1 TO S
LET FL=CHECK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
LET FL=ROTATECHK(R,A$,B$,II)
IF FL<>0 THEN EXIT FOR
NEXT II
IF FL=0 THEN
LET S=S+1
FOR II=1 TO R
LET B$(II,S)=A$(II)
NEXT II
PRINT S;":";
FOR II=1 TO R
PRINT "[";LTRIM$(A$(II));"]";
NEXT II
PRINT
END IF
MAT A$=NUL$
END IF
LET C(I)=0
LET C(J)=0
LET C(K)=0
NEXT K
NEXT J
NEXT I
CASE 4
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
LET C(I)=1
LET C(J)=1
LET C(K)=1
LET C(L)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET II=1
FOR JJ=2 TO N
FOR KK=2 TO N
FOR LL=2 TO N
IF II<>JJ AND II<>KK AND II<>LL AND JJ<>KK AND JJ<>LL AND KK<>LL THEN
LET A$(I)=A$(I)&" "&STR$(II)
LET A$(J)=A$(J)&" "&STR$(JJ)
LET A$(K)=A$(K)&" "&STR$(KK)
LET A$(L)=A$(L)&" "&STR$(LL)
FOR Q=1 TO S
LET FL=CHECK(R,A$,B$,Q)
IF FL<>0 THEN EXIT FOR
LET FL=ROTATECHK(R,A$,B$,Q)
IF FL<>0 THEN EXIT FOR
NEXT Q
IF FL=0 THEN
LET S=S+1
FOR Q=1 TO R
LET B$(Q,S)=A$(Q)
NEXT Q
PRINT S;":";
FOR Q=1 TO R
PRINT "[";LTRIM$(A$(Q));"]";
NEXT Q
PRINT
END IF
MAT A$=NUL$
END IF
NEXT LL
NEXT KK
NEXT JJ
END IF
LET C(I)=0
LET C(J)=0
LET C(K)=0
LET C(L)=0
NEXT L
NEXT K
NEXT J
NEXT I
CASE 5
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
LET C(I)=1
LET C(J)=1
LET C(K)=1
LET C(L)=1
LET C(M)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET II=1
FOR JJ=2 TO N
FOR KK=2 TO N
FOR LL=2 TO N
FOR MM=2 TO N
IF II<>JJ AND II<>KK AND II<>LL AND II<>MM AND JJ<>KK AND JJ<>LL AND JJ<>MM AND KK<>LL AND KK<>MM AND LL<>MM THEN
LET A$(I)=A$(I)&" "&STR$(II)
LET A$(J)=A$(J)&" "&STR$(JJ)
LET A$(K)=A$(K)&" "&STR$(KK)
LET A$(L)=A$(L)&" "&STR$(LL)
LET A$(M)=A$(M)&" "&STR$(MM)
FOR Q=1 TO S
LET FL=CHECK(R,A$,B$,Q)
IF FL<>0 THEN EXIT FOR
LET FL=ROTATECHK(R,A$,B$,Q)
IF FL<>0 THEN EXIT FOR
NEXT Q
IF FL=0 THEN
LET S=S+1
FOR Q=1 TO R
LET B$(Q,S)=A$(Q)
NEXT Q
PRINT S;":";
FOR Q=1 TO R
PRINT "[";LTRIM$(A$(Q));"]";
NEXT Q
PRINT
END IF
MAT A$=NUL$
END IF
NEXT MM
NEXT LL
NEXT KK
NEXT JJ
END IF
LET C(I)=0
LET C(J)=0
LET C(K)=0
LET C(L)=0
LET C(M)=0
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
CASE 6
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
FOR L=1 TO R
FOR M=1 TO R
FOR O=1 TO R
LET C(I)=1
LET C(J)=1
LET C(K)=1
LET C(L)=1
LET C(M)=1
LET C(O)=1
LET FG=0
FOR II=1 TO R
IF C(II)=0 THEN LET FG=1
NEXT II
IF FG=0 THEN
LET II=1
FOR JJ=2 TO N
FOR KK=2 TO N
FOR LL=2 TO N
FOR MM=2 TO N
FOR NN=2 TO N
IF II<>JJ AND II<>KK AND II<>LL AND II<>MM AND II<>NN AND JJ<>KK AND JJ<>LL AND JJ<>MM AND JJ<>NN AND KK<>LL AND KK<>MM AND KK<>NN AND LL<>MM AND LL<>NN AND MM<>NN THEN
LET A$(I)=A$(I)&" "&STR$(II)
LET A$(J)=A$(J)&" "&STR$(JJ)
LET A$(K)=A$(K)&" "&STR$(KK)
LET A$(L)=A$(L)&" "&STR$(LL)
LET A$(M)=A$(M)&" "&STR$(MM)
LET A$(O)=A$(O)&" "&STR$(NN)
FOR Q=1 TO S
LET FL=CHECK(R,A$,B$,Q)
IF FL<>0 THEN EXIT FOR
LET FL=ROTATECHK(R,A$,B$,Q)
IF FL<>0 THEN EXIT FOR
NEXT Q
IF FL=0 THEN
LET S=S+1
FOR Q=1 TO R
LET B$(Q,S)=A$(Q)
NEXT Q
PRINT S;":";
FOR Q=1 TO R
PRINT "[";LTRIM$(A$(Q));"]";
NEXT Q
PRINT
END IF
MAT A$=NUL$
END IF
NEXT NN
NEXT MM
NEXT LL
NEXT KK
NEXT JJ
END IF
LET C(I)=0
LET C(J)=0
LET C(K)=0
LET C(L)=0
LET C(M)=0
LET C(O)=0
NEXT O
NEXT M
NEXT L
NEXT K
NEXT J
NEXT I
END SELECT
END
EXTERNAL FUNCTION S1(N,K) !'第1種スターリング数
IF K<1 OR K>N THEN
LET S1=0
EXIT FUNCTION
END IF
IF K=N THEN
LET S1=1
EXIT FUNCTION
END IF
LET S1=(N-1)*S1(N-1,K)+S1(N-1,K-1)
END FUNCTION
EXTERNAL FUNCTION CHECK(R,A$(),B$(,),II)
SELECT CASE R
CASE 1
FOR I=1 TO R
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
NEXT I
CASE 2
FOR I=1 TO R
FOR J=1 TO R
IF I<>J THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT J
NEXT I
CASE 3
FOR I=1 TO R
FOR J=1 TO R
FOR K=1 TO R
IF I<>J AND J<>K AND I<>K THEN
IF LTRIM$(A$(I))=LTRIM$(B$(1,II)) AND LTRIM$(A$(J))=LTRIM$(B$(2,II)) AND LTRIM$(A$(K))=LTRIM$(B$(3,II)) THEN
LET CHECK=1
EXIT FUNCTION
END IF
END IF
NEXT K
NEXT J
NEXT I
CASE ELSE
DIM B(R)
FOR I=1 TO R
LET B(I)=I
NEXT I
CALL PERM(B,1)
END SELECT
SUB PERM(B(),N)
LOCAL I,J
LET M=UBOUND(B)
IF N=M THEN
LET FL=0
FOR K=1 TO M
IF LTRIM$(A$(B(K)))=LTRIM$(B$(K,II)) THEN LET FL=FL+1
NEXT K
IF FL=M THEN
LET CHECK=1
EXIT FUNCTION
END IF
ELSE
FOR I=N TO M
LET T=B(I)
FOR J=I-1 TO N STEP-1
LET B(J+1)=B(J)
NEXT J
LET B(N)=T
CALL PERM(B,N+1)
LET T=B(N)
FOR J=N TO I-1
LET B(J)=B(J+1)
NEXT J
LET B(I)=T
NEXT I
END IF
END SUB
END FUNCTION
EXTERNAL FUNCTION ROTATECHK(R,A$(),B$(,),II) !'巡回列かどうか
FOR I=1 TO R
FOR J=1 TO R
LET AA$=LTRIM$(A$(I))
LET BB$=LTRIM$(B$(J,II))
IF LEN(AA$)=LEN(BB$) THEN
FOR N=3 TO LEN(AA$) STEP 2
LET C$=""
LET K=N
FOR L=1 TO (LEN(AA$)+1)/2
LET C$=C$&AA$(K:K)&" "
IF K>=LEN(AA$) THEN LET K=1 ELSE LET K=K+2
NEXT L
IF BB$=RTRIM$(C$) THEN
LET ROTATECHK=1
EXIT FUNCTION
END IF
NEXT N
END IF
NEXT J
NEXT I
LET ROTATECHK=0
END FUNCTION
DIM a(n)
FOR i=1 TO n !最初の並び 1,2,3,…,n
LET a(i)=i
NEXT i
PUBLIC NUMERIC c !場合の数
LET c=0
PUBLIC NUMERIC s1(100) !n段目 s1(n,k)
MAT s1=ZER(n)
CALL perm(a,1)
MAT PRINT s1;
END
EXTERNAL SUB perm(a(),k) !辞書順序でn-順列（n!通り）を生成する
IF k=n THEN !すべて並んだなら
PRINT "["; !置換を表示する
FOR i=1 TO n
PRINT a(i);
NEXT i
PRINT "] = ";
LET p=0 !巡回置換の個数
DIM f(n) !篩い
MAT f=ZER
FOR i=1 TO n !n文字
IF f(i)=0 THEN !現れていないなら
LET p=p+1
PRINT "("; !巡回置換を表示する
LET t=i
DO
PRINT t;
LET f(t)=1
LET t=a(t) !次へ
LOOP UNTIL t=i !巡回するまで
PRINT ")";
END IF
NEXT i
IF p=m THEN !m個なら
LET c=c+1
PRINT " ←";c
ELSE
PRINT
END IF
LET s1(p)=s1(p)+1 !n!=Σs1(n,p)
ELSE
FOR i=k TO n
LET t=a(i)
FOR j=i-1 TO k STEP -1
LET a(j+1)=a(j)
NEXT j
LET a(k)=t
CALL perm(a,k+1)
LET t=a(k)
FOR j=k TO i-1
LET a(j)=a(j+1)
NEXT j
LET a(i)=t
NEXT i
END IF
END SUB
!'これは正多角形の場合です
DIM X(20),Y(20)
OPTION ANGLE DEGREES
FOR N=4 TO 20
LET RMIN=0
LET RMAX=100000
DO
LET R=(RMIN+RMAX)/2
FOR I=1 TO N
LET X(I)=R*COS((I-1)*360/N)
LET Y(I)=R*SIN((I-1)*360/N)
NEXT I
LET RR=SQR((X(2)-X(1))^2+(Y(2)-Y(1))^2)*N !'1辺の長さ*n
LET S=AREA(N,X,Y) !'面積
IF S<RR THEN LET RMIN=R ELSE LET RMAX=R
LOOP UNTIL ABS(RR-S)<1E-6
PRINT N;"角形"
PRINT "半径=";R
FOR I=1 TO N
PRINT "座標 X=";X(I);"Y=";Y(I)
NEXT I
PRINT "面積";S
NEXT N
END
EXTERNAL FUNCTION AREA(N,X(),Y())
LET A=X(N-1)*Y(1)-X(1)*Y(N-1)
FOR I=2 TO N-1
LET A=A+X(I-1)*Y(I)-X(I)*Y(I-1)
NEXT I
LET AREA=ABS(A)/2
END FUNCTION
> EXTERNAL FUNCTION AREA(N,X(),Y())
> LET A=X(N-1)*Y(1)-X(1)*Y(N-1)
> FOR I=2 TO N-1
> LET A=A+X(I-1)*Y(I)-X(I)*Y(I-1)
> NEXT I
> LET AREA=ABS(A)/2
> END FUNCTION
頂点番号は1～Nなので、N番目の頂点が加味されていないようです。
EXTERNAL FUNCTION AREA(N,X(),Y())
LET A=X(N)*Y(1)-X(1)*Y(N)
FOR I=2 TO N
LET A=A+X(I-1)*Y(I)-X(I)*Y(I-1)
NEXT I
LET AREA=ABS(A)/2
END FUNCTION
DIM a(n)
FOR i=1 TO n !最初の並び 1,2,3,…,n
LET a(i)=i
NEXT i
PUBLIC NUMERIC C !場合の数
LET C=0
CALL perm(a,2) !円順列、じゅず順列
PRINT C;"通り"
END
EXTERNAL SUB perm(a(),k) !辞書順序でn-順列（n!通り）を生成する
OPTION ARITHMETIC COMPLEX !複素平面
IF k=n THEN !すべて並んだなら
IF a(2)<a(n) THEN !じゅず順列
CALL stub(a)
END IF
ELSE
FOR i=k TO n
LET t=a(i) !k≦iとして、kからiまでの範囲を右ローテイト
FOR j=i-1 TO k STEP -1
LET a(j+1)=a(j)
NEXT j
LET a(k)=t
CALL perm(a,k+1) !次へ
LET t=a(k) !k≦iとして、kからiまでの範囲を左ローテイトで元に戻す
FOR j=k TO i-1
LET a(j)=a(j+1)
NEXT j
LET a(i)=t
NEXT i
END IF
END SUB
EXTERNAL SUB stub(a())
OPTION ARITHMETIC COMPLEX !複素平面
!z=EXP(2πi/n)として、A[1]+A[2]z+A[3]z^2+A[4]z^3+ … +A[n]z^(n-1)=0かどうか確認する
LET z=EXP(2*PI*COMPLEX(0,1)/n)
DIM P(0 TO n) !多角形の頂点位置を算出する
LET P(0)=0
FOR i=1 TO n
LET P(i)=P(i-1)+a(i)*z^(i-1)
NEXT i
IF ABS(P(n))<1E-12 THEN !題意を満たすなら
LET S=0
FOR C1=0 TO 1 !数字1を0,1個
FOR C2=0 TO 1
FOR C3=0 TO 1
FOR C4=0 TO 1
FOR C5=0 TO 1
FOR C6=0 TO 1
FOR C7=0 TO 1
FOR C8=0 TO 1
FOR C9=0 TO 1
IF MOD(C1*1+C2*2+C3*3+C4*4+C5*5+C6*6+C7*7+C8*8+C9*9,9)=0 THEN LET S=S+1
NEXT C9
NEXT C8
NEXT C7
NEXT C6
NEXT C5
NEXT C4
NEXT C3
NEXT C2
NEXT C1
PRINT S; "通り"
END
その２ 動的計画法
DATA 9 !種類
DATA 1,2,3,4,5,6,7,8,9 !硬貨
DATA 1,1,1,1,1,1,1,1,1 !枚数
READ N
DIM A(N),B(N)
MAT READ A
MAT READ B
LET T=0
FOR K=1 TO N
LET T=T+A(K)*B(K)
NEXT K
PRINT "総額="; T; "円"
DIM F(0 TO T)
MAT F=ZER
LET F(0)=1 !0円
FOR K=1 TO N
FOR i=T TO 0 STEP -1 !今までに支払える金額に対して
LET Fi=F(i)
IF Fi>0 THEN
LET W=i
FOR C=1 TO B(K) !新しい硬貨を追加する
LET W=W+A(K)
LET F(W)=F(W)+Fi
NEXT C
END IF
NEXT i
NEXT K
MAT PRINT F;
LET S=0
FOR i=0 TO T
IF MOD(i,9)=0 THEN LET S=S+F(i)
NEXT i
PRINT S; "通り"
END
●m進法n桁に対応させて数え上げる
個数がすべて同じなので、「m^n通り」に対応させられる。
LET S=0
FOR i=0 TO 2^9-1 !場合の数の候補
LET T=i
LET W=0
FOR X=1 TO 9 !2進法9桁
LET W=W+MOD(T,2)*X
LET T=INT(T/2)
NEXT X
IF MOD(W,9)=0 THEN LET S=S+1
NEXT i
PRINT S; "通り"
END
LET n=8 !1から8までの数字
DIM a(n)
MAT a=ZER
PUBLIC NUMERIC S
FOR r=0 TO n !r個を選ぶ
LET S=0
CALL comb(a,1,r)
PRINT S; "通り"
NEXT r
END
EXTERNAL SUB comb(a(),k,r) !1～nの集合からr個を選ぶ組合せを生成する
IF r=0 THEN
LET w=0
FOR i=1 TO UBOUND(a)
LET w=w+a(i)*i
NEXT i
IF MOD(w,9)=0 THEN LET S=S+1
ELSE
FOR i=k TO UBOUND(a)-r+1 !k以降の数からr個を選択する
LET a(i)=1
CALL comb(a,i+1,r-1)
LET a(i)=0
NEXT i
END IF
END SUB
CALL GINIT(600,600)
LET S=1
LET ST=40
FOR Y=0 TO 600 STEP ST
LET C=7
FOR X=XX TO 600 STEP ST
CALL BOXFULL(X,Y,X+ST,Y+ST,C)
LET C=7-C
NEXT X
LET XX=XX+20*S
IF XX=40 OR XX=0 THEN LET S=-S
NEXT Y
SET LINE WIDTH 3
FOR Y=0 TO 600 STEP ST
CALL LINE(0,Y,600,Y,1)
NEXT Y
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) .5,.5,.5
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB BOX(XS,YS,XE,YE,C)
CALL LINE(XS,YS,XE,YS,C)
CALL LINE(XE,YS,XE,YE,C)
CALL LINE(XE,YE,XS,YE,C)
CALL LINE(XS,YE,XS,YS,C)
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
CALL GINIT(550,550)
CALL TILE(0,0,550,550,7,0,50)
LET A=2
FOR Y=50 TO 500 STEP 50
IF Y=300 THEN LET A=3-A
FOR X=50 TO 500 STEP 50
CALL DIA(X,Y,14,14,A)
LET A=3-A
IF X=250 THEN LET A=3-A
NEXT X
NEXT Y
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"
SET COLOR MIX(0) 1,1,1
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 0,0,0
CLEAR
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB TILE(XS,YS,XE,YE,C1,C2,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE)
IF MOD(I+J,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB DIA(X,Y,M,N,P)
SET AREA COLOR 0
PLOT AREA:X-M,Y;X,Y-N;X+M,Y;X,Y+M
SET AREA COLOR 7
SELECT CASE P
CASE 1
PLOT AREA:X-M,Y;X-M/2,Y-N/2;X,Y;X-M/2,Y+N/2
PLOT AREA:X,Y;X+M/2,Y-N/2;X+M,Y;X+M/2,Y+N/2
CASE 2
PLOT AREA:X,Y;X-M/2,Y-N/2;X,Y-N;X+M/2,Y-N/2
PLOT AREA:X,Y;X+M/2,Y+N/2;X,Y+N;X-M/2,Y+N/2
END SELECT
END SUB
CALL GINIT(650,650)
CALL TILE(0,0,649,649,4,7,50)
FOR Y=50 TO 600 STEP 50
FOR X=50 TO 600 STEP 50
READ A
CALL DIA(X,Y,14,14,A)
NEXT X
NEXT Y
DATA 1,2,1,2,2,1,2,1,1,2,1,2
DATA 1,1,2,1,2,2,1,2,1,1,2,1
DATA 2,1,1,2,1,2,2,1,2,1,1,2
DATA 1,2,1,1,2,1,2,2,1,2,1,1
DATA 2,1,2,1,1,2,1,2,2,1,2,1
DATA 2,2,1,2,1,1,2,1,2,2,1,2
DATA 1,2,2,1,2,1,1,2,1,2,2,1
DATA 2,1,2,2,1,2,1,1,2,1,2,2
DATA 1,2,1,2,2,1,2,1,1,2,1,2
DATA 1,1,2,1,2,2,1,2,1,1,2,1
DATA 2,1,1,2,1,2,2,1,2,1,1,2
DATA 1,2,1,1,2,1,2,2,1,2,1,1
END
EXTERNAL SUB TILE(XS,YS,XE,YE,C1,C2,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE)
IF MOD(I+J,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 11/255,125/255,62/255
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB DIA(X,Y,M,N,P)
SET AREA COLOR 0
PLOT AREA:X-M,Y;X,Y-N;X+M,Y;X,Y+M
SET AREA COLOR 7
SELECT CASE P
CASE 1
PLOT AREA:X-M,Y;X-M/2,Y-N/2;X,Y;X-M/2,Y+N/2
PLOT AREA:X,Y;X+M/2,Y-N/2;X+M,Y;X+M/2,Y+N/2
CASE 2
PLOT AREA:X,Y;X-M/2,Y-N/2;X,Y-N;X+M/2,Y-N/2
PLOT AREA:X,Y;X+M/2,Y+N/2;X,Y+N;X-M/2,Y+N/2
END SELECT
END SUB
OPTION BASE 0
CALL GINIT(600,600)
DIM C(7)
FOR I=0 TO 7
READ C(I)
NEXT I
DATA 3,2,2,3,2,3,3,2
CALL TILE(0,0,599,599,6,7,600/17)
FOR Y=35 TO 565 STEP 600/17
FOR X=35 TO 565 STEP 600/17
CALL DIA(X,Y,5,C(MOD(A+B,8)))
LET B=B+1
NEXT X
LET A=A+1
NEXT Y
END
EXTERNAL SUB TILE(XS,YS,XE,YE,C1,C2,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE)
IF MOD(I+J,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 204/255,0,152/255
SET COLOR MIX(3) 1,1,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 160/255,215/255,51/255
SET COLOR MIX(7) 79/255,187/255,129/255
CLEAR
END SUB
EXTERNAL SUB DIA(X,Y,RR,C)
DIM XX(4),YY(4)
SET AREA COLOR C
FOR I=1 TO 4
LET XX(I)=X+RR*COS(I*PI/2)
LET YY(I)=Y+RR*SIN(I*PI/2)
NEXT I
MAT PLOT AREA:XX,YY
END SUB
CALL GINIT(600,600)
CALL TILE(0,0,599,599,1,2,3,2,20)
LET C=0
LET XX=40
FOR Y=20 TO 590 STEP 20
FOR X=XX TO 590 STEP 40
CALL DIA(X,Y,5,C)
LET C=7-C
NEXT X
LET XX=60-XX
NEXT Y
CALL TILE2(120,120,479,479,1,2,3,2,20)
LET C=7
LET XX=140
FOR Y=140 TO 480 STEP 20
FOR X=XX TO 480 STEP 40
CALL DIA(X,Y,5,C)
LET C=7-C
NEXT X
LET XX=260-XX
NEXT Y
END
EXTERNAL SUB TILE(XS,YS,XE,YE,C1,C2,C3,C4,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE)
IF MOD(I+J,4)=0 THEN LET C=C1
IF MOD(I+J,4)=1 THEN LET C=C2
IF MOD(I+J,4)=2 THEN LET C=C3
IF MOD(I+J,4)=3 THEN LET C=C4
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB TILE2(XS,YS,XE,YE,C1,C2,C3,C4,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE)
IF MOD(4+I-J,4)=0 THEN LET C=C1
IF MOD(4+I-J,4)=1 THEN LET C=C2
IF MOD(4+I-J,4)=2 THEN LET C=C3
IF MOD(4+I-J,4)=3 THEN LET C=C4
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,0,YSIZE-1
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,0,0
SET COLOR MIX(2) 1,.5,0
SET COLOR MIX(3) 1,204/255,0
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB DIA(X,Y,RR,C)
DIM XX(4),YY(4)
SET AREA COLOR C
FOR I=1 TO 4
LET XX(I)=X+RR*COS(I*PI/2)
LET YY(I)=Y+RR*SIN(I*PI/2)
NEXT I
MAT PLOT AREA:XX,YY
END SUB
LET XSIZE=600
LET YSIZE=600
CALL GINIT(XSIZE,YSIZE)
CALL TILE(0,0,XSIZE-1,YSIZE-1,0,7,10)
CALL CIRCLEFULL(XSIZE/2,YSIZE/2,150,0,7,10)
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB CIRCLEFULL(X0,Y0,R,C1,C2,SIZE)
FOR Y=-R+Y0 TO R+Y0
FOR X=-R+X0 TO R+X0
IF(X-X0)*(X-X0)+(Y0-Y)*(Y0-Y)<=R*R THEN
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE/4)
IF MOD(I+J,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
END IF
NEXT X
NEXT Y
END SUB
EXTERNAL SUB TILE(XS,YS,XE,YE,C1,C2,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE/4)
LET J=INT(Y/SIZE)
IF MOD(I+J,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
CALL GINIT(600,600)
CALL BOXFULL(0,0,599,599,4)
LET K=-50
FOR L=1 TO 4
READ R,K
DATA 62,-50
DATA 115,20
DATA 161,-30
DATA 231,10
LET TH=-90
LET C=0
DO
LET XX=300+R*COS(TH*PI/180)
LET YY=300+R*SIN(TH*PI/180)
DO
LET TH=TH+.5
LET X0=300+R*COS(TH*PI/180)
LET Y0=300+R*SIN(TH*PI/180)
LOOP UNTIL SQR((XX-X0)^2+(YY-Y0)^2)>24
PLOT LINES
SET COLOR C
FOR I=0 TO 4
LET X=XX+12*COS((I*90+TH+K)*PI/180)
LET Y=YY+12*SIN((I*90+TH+K)*PI/180)
PLOT LINES:X,Y;
NEXT I
LET C=7-C
LOOP WHILE TH<270
NEXT L
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) .5,.5,.5
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
!'回る円の中心を見つめていると黄色の点が消える
CALL GINIT(600,600)
DO
FOR TH=0 TO 360 STEP 30
SET DRAW MODE HIDDEN
CLEAR
CALL CIRCLE(300,300,200,1)
FOR I=0 TO 7
LET X=300+200*COS((I*45+TH)*PI/180)
LET Y=300+200*SIN((I*45+TH)*PI/180)
CALL LINE(300,300,X,Y,1)
NEXT I
FOR I=0 TO 2
LET XX=300+100*COS((-30+I*120)*PI/180)
LET YY=300+100*SIN((-30+I*120)*PI/180)
CALL CIRCLEFULL(XX,YY,2,6)
NEXT I
SET DRAW MODE EXPLICIT
WAIT DELAY 1/8
NEXT TH
LOOP
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL SUB CIRCLE(X,Y,R,C)
SET COLOR C
PLOT LINES
FOR I=0 TO 360 STEP 10
LET XX=X+R*COS(I*PI/180)
LET YY=Y+R*SIN(I*PI/180)
PLOT LINES:XX,YY;
NEXT I
PLOT LINES
END SUB
CALL GINIT(600,600)
LET S=5
FOR X=0 TO 600 STEP 6*S
CALL BOXFULL(X,0,X+S,600,4)
NEXT X
FOR Y=0 TO 600 STEP 6*S
CALL BOXFULL(0,Y,600,Y+S,4)
NEXT Y
FOR Y=0 TO 600 STEP 6*S
FOR X=0 TO 600 STEP 6*S
CALL CIRCLEFULL(X+S/2,Y+S/2,3,7)
NEXT X
NEXT Y
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) .5,.5,.5
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
CALL GINIT(600,600)
DIM X(4),Y(4)
DO
FOR TH=0 TO 360 STEP 5
FOR I=1 TO 4
LET X(I)=300+170*COS((I*90+TH)*PI/180)
LET Y(I)=300+170*SIN((I*90+TH)*PI/180)
NEXT I
SET DRAW MODE HIDDEN
CLEAR
SET COLOR 2
MAT PLOT AREA:X,Y
MOUSE POLL XX,YY,LEFT,RIGHT
IF RIGHT=1 THEN STOP
IF LEFT=0 THEN !'左クリック中、描画なし
CALL CIRCLEFULL(140,300,80,7)
CALL CIRCLEFULL(460,300,80,7)
CALL CIRCLEFULL(300,140,80,7)
CALL CIRCLEFULL(300,460,80,7)
END IF
SET DRAW MODE EXPLICIT
WAIT DELAY 1/16
NEXT TH
LOOP
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
CALL GINIT(600,600)
DIM XX(4),YY(4)
SET AREA COLOR 7
SET COLOR 7
LET S=3
DO
FOR TH=S TO S+360 STEP 10
LET X=300+200*COS(TH*PI/180)
LET Y=300+200*SIN(TH*PI/180)
PLOT LINES:300,300;X,Y
FOR I=1 TO 4
LET XX(I)=X+15*COS((I*90+TH+45)*PI/180)
LET YY(I)=Y+15*SIN((I*90+TH+45)*PI/180)
NEXT I
MAT PLOT AREA:XX,YY
NEXT TH
SET DRAW MODE EXPLICIT
WAIT DELAY .2
SET DRAW MODE HIDDEN
CLEAR
LET S=-S
LOOP
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
CALL GINIT(640,640)
SET LINE WIDTH 4
FOR Y=0 TO 640 STEP 40
CALL LINE(0,Y,640,Y,7)
NEXT Y
FOR X=0 TO 640 STEP 40
CALL LINE(X,0,X,640,7)
NEXT X
FOR Y=40 TO 600 STEP 80
FOR X=40 TO 600 STEP 80
CALL BOXFULL(X-10,Y-10,X+10,Y+10,0)
NEXT X
NEXT Y
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"
SET COLOR MIX(0) 1,1,1
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 0,0,0
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
CALL GINIT(600,600)
LOCATE VALUE NOWAIT,RANGE -100 TO 100 ,AT 50: Y
LET XX=5
LET X=50
DO
LET X=X+XX
SET DRAW MODE HIDDEN
CLEAR
LOCATE VALUE NOWAIT:Y
PLOT AREA:300,150;X,150-Y;X,450+Y;300,450
SET DRAW MODE EXPLICIT
WAIT DELAY 1/50
IF X<50 THEN LET XX=-XX
IF X>550 THEN LET XX=-XX
LOOP
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"
SET COLOR MIX(0) 1,1,1
SET COLOR MIX(1) 0,0,0
CLEAR
END SUB
CALL GINIT(600,600)
CALL DISPLAY(1)
PAUSE
CALL DISPLAY(0)
END
EXTERNAL SUB DISPLAY(SW)
CLEAR
SET LINE WIDTH 5
CALL LINE(270,220,70,450,7)
CALL LINE(270,220,470,450,7)
CALL LINE(70,450,470,450,7)
IF SW=1 THEN
CALL LINE(160,220,560,220,7)
CALL LINE(160,220,70,450,7)
CALL LINE(560,220,470,450,7)
CALL LINE(270,220,180,450,7)
END IF
CALL SYMBOL(270,190,"A",7)
CALL SYMBOL(50,450,"B",7)
CALL SYMBOL(490,450,"C",7)
END SUB
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
SET TEXT HEIGHT 30
SET TEXT JUSTIFY "CENTER","HALF"
END SUB
EXTERNAL SUB SYMBOL(X,Y,A$,C)
SET TEXT COLOR C
PLOT TEXT,AT X,Y:A$
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
CALL GINIT(600,600)
SET LINE WIDTH 5
RANDOMIZE
FOR X=25 TO 200 STEP 25
CALL LINE(X,0,300,300-X,7)
NEXT X
LET X=25+INT(RND*9)*25
CALL LINE(500,500-X,600,600-X,7)
CALL BOX(300,50,500,500,7)
PAUSE
CALL LINE(X,0,600,600-X,2)
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB BOX(XS,YS,XE,YE,C)
CALL LINE(XS,YS,XE,YS,C)
CALL LINE(XE,YS,XE,YE,C)
CALL LINE(XE,YE,XS,YE,C)
CALL LINE(XS,YE,XS,YS,C)
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
CALL GINIT(600,600)
LET C1=1
LET C2=6
CALL DISPLAY(C1,C2,5)
PAUSE
CALL DISPLAY(C1,C2,50)
END
EXTERNAL SUB DISPLAY(C1,C2,SIZE)
CALL TILE(0,0,599,599,C1,C2,SIZE)
CALL TILE(50,50,250,250,2,C2,SIZE)
CALL TILE(350,50,550,250,4,C2,SIZE)
CALL TILE(50,350,250,550,C1,2,SIZE)
CALL TILE(350,350,550,550,C1,4,SIZE)
END SUB
EXTERNAL SUB TILE(XS,YS,XE,YE,C1,C2,SIZE)
FOR Y=YS TO YE
FOR X=XS TO XE
LET I=INT(X/SIZE)
LET J=INT(Y/SIZE)
IF MOD(I+J,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
NEXT X
NEXT Y
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE,YSIZE,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
CALL GINIT(600,600)
LET C1=4
LET C2=6
CALL DISPLAY(C1,C2,5)
PAUSE
CALL DISPLAY(C1,C2,60)
END
EXTERNAL SUB DISPLAY(C1,C2,SIZE)
FOR X=0 TO 600 STEP SIZE
CALL BOXFULL(X,0,X+SIZE/2,600,C1)
CALL BOXFULL(X+SIZE/2,0,X+SIZE,600,C2)
NEXT X
CALL CIRCLEFULL(150,300,130,C1,7,SIZE/2)
CALL CIRCLEFULL(450,300,130,7,C2,SIZE/2)
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
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"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) .5,.5,.5
CLEAR
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
EXTERNAL SUB CIRCLEFULL(X0,Y0,R,C1,C2,SIZE)
FOR Y=-R+Y0 TO R+Y0
FOR X=-R+X0 TO R+X0
IF(X-X0)*(X-X0)+(Y0-Y)*(Y0-Y)<=R*R THEN
LET I=INT(X/SIZE)
IF MOD(I,2)=0 THEN LET C=C1 ELSE LET C=C2
CALL PSET(X,Y,C)
END IF
NEXT X
NEXT Y
END SUB
