DIM W(0 TO 7-1)
MAT W=ZER
LET Y0=1900
FOR Y=Y0 TO Y0+400-1
FOR M=1 TO 12
LET T=DayOfWeek(Y,M,13)
LET W(T)=W(T)+1
NEXT M
NEXT Y
MAT PRINT W;
PRINT DayOfWeek(1900,1,1)
END
EXTERNAL FUNCTION DayOfWeek(y,m,d) !西暦y年m月d日の曜日 ※0なら日曜日、1なら月曜日、2なら火曜日、……、6なら土曜日
IF m<3 THEN
LET y=y-1 !y年1,2月をy-1年13,14月へ
LET m=m+12
END IF
LET DayOfWeek=MOD(y+INT(y/4)-INT(y/100)+INT(y/400)+INT((13*m+8)/5)+d,7) !ツェラー（Zeller）の公式 1582年10月15日（金）以降
END FUNCTION
REM 部分荷重下の単純支持板の中央のたわみ
REM 「板とシェルの理論」130頁143式 参照
REM a:板のx方向の幅
REM b:板のy方向の長さ
REM u:荷重のx方向の幅
REM v:荷重のy方向の長さ
REM q:単位面積当たりの荷重(kN/cm^2)
REM t:板厚
REM mu:ポアソン比(0.3)
REM E:縦弾性係数 20500(kN/cm^2)
LET mu=0.3
LET E=20500
LET D=E*t^3/12/(1-mu^3)
LET GS=0
FOR M=1 TO 1000 '100回程度ならOK
IF MOD(M ,2) = 0 THEN GOTO 10
LET AM=M*PI*b/2/a
LET GM=M*PI*v/4/a
LET s=1/M^5*SIN(M*PI*u/2/a)*(1-1/COSH(AM)*(COSH(AM-2*GM)+GM*SINH(AM-2*GM)+AM*SINH(2*GM)/2/COSH(AM)))
LET GS=GS+S
10 NEXT M
LET W=GS*4*q*a^4/d/PI^5
PRINT "Sigma=";GS
PRINT "w(cm)=";W
FOR QQ=(10^(K-2)-1)/9 TO 10^(K-2)-1 !X+A
IF POS(STR$(QQ),"0")>0 THEN !0を除く
ELSE
LET Q=(5*10^(K-2)+QQ)*10+5
LET X=(P+Q+R)/3
IF X=INT(X) THEN !和が3の倍数
LET D=2*X-R !右辺 X-B
IF POS(STR$(D),"0")>0 THEN
ELSE
IF INT(D/10^(K-1))=2 AND MOD(D,10)=8 THEN
LET E=2*X-Q !右辺 X-A
IF POS(STR$(E),"0")>0 THEN
ELSE
IF INT(E/10^(K-1))=3 AND MOD(E,10)=7 THEN
LET F=2*X-P !右辺 X+(A+B)
IF POS(STR$(F),"0")>0 THEN
ELSE
IF INT(F/10^(K-1))=7 AND MOD(F,10)=3 THEN
!!!PRINT P;Q;R; D;E;F !debug
CALL chk(P,Q,R,D,E,F, rc)
IF rc<>0 THEN !条件を満たす
LET S=S+1
PRINT P;Q;R; D;E;F
END IF
END IF !f
END IF
END IF !e
END IF
END IF !d
END IF
END IF !3の倍数
END IF !q
NEXT QQ
PRINT S;"通り"
END
EXTERNAL SUB chk(P,Q,R,D,E,F, rc) !条件を満たすかどうか確認する
LET rc=0
FOR i=1 TO K !最上位の桁を消す
LET T=10^i
IF MOD(P,T)^2+MOD(Q,T)^2+MOD(R,T)^2<>MOD(D,T)^2+MOD(E,T)^2+MOD(F,T)^2 THEN EXIT FOR
NEXT i
IF i>K THEN
FOR i=1 TO K-1 !一の位の桁を消す
LET T=10^i
IF INT(P/T)^2+INT(Q/T)^2+INT(R/T)^2<>INT(D/T)^2+INT(E/T)^2+INT(F/T)^2 THEN EXIT FOR
NEXT i
IF i>K-1 THEN
LET W=INT((K-1)/2)
FOR i=1 TO W !最上位と一の位の桁を消す
LET T=10^i
LET TT=10^(K-i)
IF INT(MOD(P,TT)/T)^2+INT(MOD(Q,TT)/T)^2+INT(MOD(R,TT)/T)^2 <> &
& INT(MOD(D,TT)/T)^2+INT(MOD(E,TT)/T)^2+INT(MOD(F,TT)/T)^2 THEN EXIT FOR
NEXT i
IF i>W THEN
LET W=INT((K-1)/2)
FOR i=1 TO W !最上位と一の位の桁を残す
LET T=10^(INT(K/2)-i)
LET TT=10^(INT(K/2)+i)
IF (INT(P/TT)*T+MOD(P,T))^2+(INT(Q/TT)*T+MOD(Q,T))^2+(INT(R/TT)*T+MOD(R,T))^2 <> &
& (INT(D/TT)*T+MOD(D,T))^2+(INT(E/TT)*T+MOD(E,T))^2+(INT(F/TT)*T+MOD(F,T))^2 THEN EXIT FOR
NEXT i
IF i>W THEN
LET rc=1 !OK
END IF
LET n=123456789
FOR a=1 TO 9
IF a=3 OR a=6 THEN
ELSE
PRINT "m=9k+";STR$(a)
FOR k=0 TO a
LET m=9*k+a
PRINT USING "######### × ## = ###########": n,m,n*m
NEXT k
PRINT
END IF
NEXT a
END
LET N=7 !段数 ※N≧1
LET A0=1
LET A1=1
FOR i=2 TO N
LET A2=A1+A0
LET A0=A1 !次へ
LET A1=A2
NEXT i
PRINT A1;"通り"
END
その２ 並べる
DEF ReptCOMB(N,R)=COMB(N+R-1,R) !重複組合せ
LET N=7 !段数
LET C=0 !場合の数
LET C1=0
LET C2=0
FOR Y=0 TO INT(N/2) !不定方程式を解く
LET X=N-2*Y
LET C=C+ReptCOMB(X+1,Y)
LET C1=C1+FACT(X+Y)/(FACT(X)*FACT(Y)) !別解
LET C2=C2+COMB(X+Y,Y) !別解
NEXT Y
PRINT C;"通り"
PRINT C1;"通り"
PRINT C2;"通り"
END
LET N=15 !段数 ※N≧2
LET A0=1
LET A1=1
LET A2=2
FOR i=3 TO N
LET A3=A2+A0
LET A0=A1 !次へ
LET A1=A2
LET A2=A3
NEXT i
PRINT A2;"通り"
END
その２ 並べる
LET N=15 !段数
LET C=0 !場合の数
FOR Y=0 TO INT(N/2) !不定方程式を解く
LET X=N-2*Y
LET C=C+COMB(X+1,Y)
NEXT Y
PRINT C;"通り"
END
その３ 樹形図で考える
LET N=15 !段数
DIM A(0 TO N) !上り方
LET A(0)=0 !※番兵
PUBLIC NUMERIC C !場合の数
LET C=0
CALL try(1,0, N,A)
END
EXTERNAL SUB try(P,S, N,A()) !バックトラック法で検索する
FOR i=1 TO 2
IF i=2 AND i=A(P-1) THEN !1段とばしは連続しない
ELSE
LET A(P)=i !p歩目
LET T=S+i
IF T=N THEN !目的の段数へ到達したなら
LET C=C+1
PRINT "No."; C
FOR K=1 TO P !結果を表示する
PRINT A(K);
NEXT K
PRINT
ELSEIF T<N THEN !次へ
CALL try(P+1,T, N,A)
END IF
END IF
NEXT i
END SUB
SET bitmap SIZE 960,160 !表示領域
SET WINDOW -2,52,-1,2
DRAW grid(2,0.5)
LET T=50 !時間区間 [0,T]
DEF G(jw)=1.021*(1/(0.01875+jw)-1/(5.01+jw))
LET N=1024*8 !データ総数 ※大きいほど精度がよい
DIM d(0 TO N-1) !入出力用配列
LET Gamma=5 !※|γ|=3～7
!γを大きくすれば精度は上がりそうだが、
!あとでExp(γt)をかけるので、tが大きいところで発散する。
LET r=Gamma/T !γを決める
FOR k=0 TO N/2 !変換データの作成
LET Fs=G( COMPLEX(r, 2*PI*k/T) ) !sk=γ+i*2π*k/T、k=0～n-1
LET Hw=(COS(2*PI*k/N)+1)/2 !データは離散なため、ハニング関数をかけて平滑化する ※精度の向上
LET d(k)=N/T*Fs*Hw !n/T*Y(k) * Hw 0～N/2
IF NOT(k=0 OR k=N/2) THEN LET d(N-k)=COMPLEX(Re(d(k)),-Im(d(k))) !N-1～N/2+1は、共役複素数
NEXT k
CALL IFFT(d) !高速逆フーリエ変換
LET dt=T/N !時間刻み幅 ⊿t
FOR k=0 TO N-1 STEP 8 !結果の表示 [0,T]
LET tt=k*dt !経過時間
PLOT LINES: tt, Re(d(k))*EXP(r*tt); !Exp(γt)をかける ※Exp(γ*k*T/n)、k=0～n-1
NEXT k
PLOT LINES
!検算
DEF f(t)=1.021*(EXP(-0.01875*t)-EXP(-5.01*t))
SET LINE COLOR 4
FOR k=0 TO T STEP 1/2^8
PLOT LINES: k,f(k);
NEXT k
PLOT LINES
END
EXTERNAL SUB IFFT(x()) !高速逆フーリエ変換 x() : 入力/出力データ
OPTION ARITHMETIC COMPLEX !複素数モード
DECLARE EXTERNAL SUB FFTMAIN
LET nx=SIZE(x)
LET theta=2*PI/nx
CALL FFTMAIN(x, theta)
MAT x=(1/nx)*x
END SUB
EXTERNAL SUB FFTMAIN(x(), theta)
OPTION ARITHMETIC COMPLEX !複素数モード
LET nx=SIZE(x)
IF MOD(nx, 2)<>0 THEN !DFTの計算
DIM w(0 TO nx-1), xtmp(0 TO nx-1)
MAT xtmp=x
FOR k=0 TO nx-1
LET tmp=theta*k
FOR n=0 TO nx-1
LET w(n)=EXP( COMPLEX(0, -tmp*n) )
NEXT n
LET x(k)=DOT(w, xtmp)
NEXT k
ELSE !２分して再帰呼出し
LET hnx=nx/2
DIM x0(0 TO hnx-1), x1(0 TO hnx-1)
FOR k=0 TO hnx-1
LET x0(k)=x(k)+x(k+hnx)
LET wk=EXP( COMPLEX(0, theta*k) )
LET x1(k)=wk*(x(k)-x(k+hnx))
NEXT k
CALL FFTMAIN(x0, 2*theta)
CALL FFTMAIN(x1, 2*theta)
FOR k=0 TO hnx-1
LET x(2*k)=x0(k)
LET x(2*k+1)=x1(k)
NEXT k
END IF
END SUB
DEF G(jw)=1.021*(1/(0.01875+jw)-1/(5.01+jw))
：
FOR k=0 TO N/2 !変換データの作成
LET Fs=G( COMPLEX(r, 2*PI*k/T) ) !sk=γ+i*2π*k/T、k=0～n-1
を
DEF G(w)=1.021*(1/(0.01875+j*w)-1/(5.01+j*w))
LET j=COMPLEX(0,1) !虚数単位
：
FOR k=0 TO N/2 !変換データの作成
LET Fs=G( COMPLEX(r, 2*PI*k/T)/j ) !sk=γ+i*2π*k/T、k=0～n-1
とすれば対応ができると思います。
また、
IF NOT(k=0 OR k=N/2) THEN LET d(N-k)=COMPLEX(Re(d(k)),-Im(d(k))) !N-1～N/2+1は、共役複素数
は
IF NOT(k=0 OR k=N/2) THEN LET d(N-k)=Conj(d(k)) !N-1～N/2+1は、共役複素数
とした方がわかりやすいですね。
>
> DEF G(w)=1.021*(1/(0.01875+j*w)-1/(5.01+j*w))
> LET j=COMPLEX(0,1) !虚数単位
> ：
> FOR k=0 TO N/2 !変換データの作成
> LET Fs=G( COMPLEX(r, 2*PI*k/T)/j ) !sk=γ+i*2π*k/T、k=0～n-1
>
> とすれば対応ができると思います。
>
> また、
> IF NOT(k=0 OR k=N/2) THEN LET d(N-k)=COMPLEX(Re(d(k)),-Im(d(k))) !N-1～N/2+1は、共役複素数
> は
> IF NOT(k=0 OR k=N/2) THEN LET d(N-k)=Conj(d(k)) !N-1～N/2+1は、共役複素数
> とした方がわかりやすいですね。
>
>
OPTION ARITHMETIC COMPLEX !ガウス平面（複素平面）
LET i=COMPLEX(0,1) !虚数単位
SET WINDOW -1.5,1.5, -1.5,1.5 !表示領域
DRAW grid(0.5,0.5)
DRAW circle !単位円
!x^6-1=0の6つの解
LET x1=EXP(2*PI*i*1/6) !α LET th=2*PI/6、LET x1=COS(1*th)+i*SIN(1*th)
LET x2=EXP(2*PI*i*2/6)
LET x3=EXP(2*PI*i*3/6)
LET x4=EXP(2*PI*i*4/6)
LET x5=EXP(2*PI*i*5/6)
LET x6=EXP(2*PI*i*6/6)
DRAW circle WITH SCALE(0.05)*SHIFT(x6)
DRAW disk WITH SCALE(0.05)*SHIFT(x3)
SET AREA COLOR 4 !赤色
DRAW disk WITH SCALE(0.05)*SHIFT(x1)
DRAW disk WITH SCALE(0.05)*SHIFT(x5)
SET AREA COLOR 2 !青色
DRAW disk WITH SCALE(0.05)*SHIFT(x2)
DRAW disk WITH SCALE(0.05)*SHIFT(x4)
OPTION ARITHMETIC COMPLEX !ガウス平面（複素平面）
LET i=COMPLEX(0,1) !虚数単位
SET WINDOW -1.5,1.5, -1.5,1.5 !表示領域
DRAW grid(0.5,0.5)
DRAW circle !単位円
LET N=9 !150程度
!Fn(x)=0のm個の解
DIM X(N)
LET M=0
FOR K=1 TO N
IF gcd(K,N)=1 THEN !互いに素
LET M=M+1
LET X(M)=EXP(2*PI*K*i/N)
DRAW disk WITH SCALE(0.05)*SHIFT(X(M))
PRINT STR$(M);": "; X(M), K
END IF
NEXT K
PRINT
!Fn(x)=(x-X[1])(x-X[2])…(x-X[m])=A[m]x^m+A[m-1]x^(m-1)+ … +A[2]x^2+A[1]x+A[0]
DIM A(0 TO N)
CALL PolynomialExpandD1(M,X, aa,A)
FOR K=0 TO aa
LET T=INT(Re(A(K))+0.005) !精度 小数点以下3桁程度
IF T<>0 THEN PRINT T; "x^";STR$(K)
!!PRINT A(K),"x^";STR$(K)
NEXT K
END
EXTERNAL FUNCTION gcd(a,b) !最大公約数を求める
OPTION ARITHMETIC COMPLEX !ガウス平面（複素平面）
DO UNTIL b=0
LET r=MOD(a,b)
LET a=b
LET b=r
LOOP
LET gcd=a
END FUNCTION
!POLY.LIB 抜粋
EXTERNAL SUB PolynomialExpandD1(N,X(), aa,A()) !(x-x[1])(x-x[2]) … (x-x[n])を展開する
OPTION ARITHMETIC COMPLEX !ガウス平面（複素平面）
MAT A=ZER
LET A(1)=1 !X-x[1] !n個の解について
LET A(0)=-X(1)
FOR K=2 TO N !ホーナー法による
FOR i=K-1 TO 0 STEP -1 !展開する w=w*(X-x[k])
LET A(i+1)=A(i+1)+A(i)
LET A(i)=-A(i)*X(K)
NEXT i
NEXT K
LET aa=N !次数
END SUB
a b * c * d * (((ab)c)d)
a b * c d * * ((ab)(cd))
a b c * * d * ((a(bc))d)
a b c * d * * (a((bc)d))
a b c d * * * (a(b(cd)))
!トーナメント表をつくる
LET N=4 !チーム数
LET W$=REPEAT$(" ",N+(N-1))
LET W$(1:1)="A"
CALL try(2,N,0,0,W$)
LET M=N-1
PRINT COMB(2*M,M+1)/M; "通り"
END
EXTERNAL SUB try(P,N,X,Y,W$) !バックトラック法で検索する
IF X=N-1 AND Y=N-1 THEN !終点なら
!!!PRINT W$ !debug
CALL PrintOut(N,W$)
!CALL PrintOut2(N,W$)
ELSE
IF Y+1<=X THEN !縦方向
LET W$(P:P)="*"
CALL try(P+1,N,X,Y+1,W$)
END IF
IF X+1<N THEN !横方向
LET W$(P:P)=CHR$((X+1)+ORD("A")) !B,C,D,…
CALL try(P+1,N,X+1,Y,W$)
END IF
END IF
END SUB
EXTERNAL SUB PrintOut(N,S$) !トーナメント表の形状を表示する（逆ポーランド記法）
DIM STK$(N) !stack
LET Q=0
FOR i=1 TO LEN(S$) !スクリプト文を解釈実行する
LET T$=S$(i:i)
SELECT CASE T$
CASE "*" !pop
LET X$=STK$(Q-1) !(x,y)
LET Y$=STK$(Q)
LET Q=Q-1 !(-2)+(1)=(-1)より
LET STK$(Q)="("&X$&Y$&")"
CASE IS>="A",IS<="Z" !push
LET Q=Q+1
LET STK$(Q)=T$
CASE ELSE
PRINT "論理エラーです。"; T$; i
STOP
END SELECT
NEXT i
PRINT STK$(1)
END SUB
EXTERNAL SUB PrintOut2(N,S$) !トーナメント表の形状を表示する
OPTION CHARACTER BYTE !バイト単位
DEF SPC(X)=(X-1)*4+1 !表示位置
DIM STK(N) !stack
LET W$=REPEAT$(" ",SPC(N)+1) !1行分の文字列（バッファ）
FOR i=1 TO LEN(S$) !スクリプト文を解釈実行する
LET T$=S$(i:i)
SELECT CASE T$
CASE "*" !pop
LET X=STK(P-1) !z=(xy)
IF X<0 THEN
LET X=-X
LET K=SPC(X)+1
LET W$(K:K)=CHR$(X+ORD("A")-1) !1,2,3,…をA,B,C,…へ
END IF
LET Y=STK(P)
IF Y<0 THEN
LET Y=-Y
LET K=SPC(Y)+1
LET W$(K:K)=CHR$(Y+ORD("A")-1)
END IF
LET Z=(X+Y)/2
LET P=P-1 !(-2)+(+1)より
LET STK(P)=Z
PRINT W$
LET W$=REPEAT$(" ",SPC(N)+1)
LET W$(SPC(X):SPC(X)+1)="└" !対戦
LET W$(SPC(Z):SPC(Z)+1)="┬"
LET W$(SPC(Y):SPC(Y)+1)="┘"
FOR J=1 TO P-1 !ブロック
LET K=STK(J)
IF K>0 THEN LET W$(SPC(K):SPC(K)+1)="│"
NEXT J
CASE IS>="A",IS<="Z" !push
LET P=P+1
LET STK(P)=-(ORD(T$)-ORD("A")+1) !A,B,C,…を-1,-2,-3,…へ
CASE ELSE
PRINT "論理エラーです。"; T$; i
STOP
END SELECT
NEXT i
PRINT W$ !決勝戦
PRINT
END SUB
考察
Ｂ
│+,-,*,/
・─・
│ │+,-,*,/
・─・─・
│ │ │+,-,*,/
Ａ─・─・─・
a b c d
a b d c
a c b d
：
d c b a
として、逆ポーランド表記（後置表記）の式を生成する。
これは、中置表記での四則演算（加減乗除）と括弧による式を表すことができる。
式の形状は、
a b + c + d + (((a+b)+c)+d)
a b + c d + + ((a+b)+(c+d))
a b c + + d + ((a+(b+c))+d)
a b c + d + + (a+((b+c)+d))
a b c d + + + (a+(b+(c+d)))
となる。
よって、4!×5×4^3 通りを検証する。
（終り）
OPTION ARITHMETIC RATIONAL !分数の計算
PUBLIC NUMERIC D(4)
DATA 1,2,5,8
!DATA 1,2,4,10
MAT READ D
PUBLIC NUMERIC F(0 TO 7000) !0～n
MAT F=ZER
LET N=4 !チーム数
DIM A(N+(N-1))
LET A(1)=1 !A
CALL try(2,0,0, N,A)
END
EXTERNAL SUB try(P,X,Y, N,A()) !バックトラック法で検索する
OPTION ARITHMETIC RATIONAL !分数の計算
IF X=N-1 AND Y=N-1 THEN !終点なら
!!!MAT PRINT A; !debug
CALL check(N,A)
ELSE
IF Y+1<=X THEN !縦方向
LET A(P)=-(Y+1) !*
CALL try(P+1,X,Y+1, N,A)
END IF
IF X+1<N THEN !横方向
LET A(P)=(X+1)+1 !B,C,D,…
CALL try(P+1,X+1,Y, N,A)
END IF
END IF
END SUB
EXTERNAL SUB check(N,P()) !数、演算子の並びを考える
OPTION ARITHMETIC RATIONAL !分数の計算
DIM A(N),B(N-1)
FOR h=0 TO FACT(N)-1 !a,b,c,…,d の順列
CALL Num2PermFactorial(h, A,N)
FOR J=0 TO 4^(N-1)-1 !+,-,*,/ の重複順列
LET T=J !4進法
FOR i=1 TO N-1 !+,-,*,/ を -1,-2,-3,-4 へ
LET B(i)=-(MOD(T,4)+1)
LET T=INT(T/4)
NEXT i
CALL Calc(N,P,A,B) !計算する
NEXT J
NEXT h
END SUB
EXTERNAL SUB Calc(N,P(),A(),B()) !逆ポーランド記法の式を計算する
OPTION ARITHMETIC RATIONAL !分数の計算
DIM STK(N),EXP$(N) !stack
LET Q=0
FOR i=1 TO N+(N-1) !スクリプト文を解釈実行する
SELECT CASE P(i)
CASE IS<0 !* pop
LET X=STK(Q-1) !(xy)
LET Y=STK(Q)
LET X$=EXP$(Q-1) !x○y
LET Y$=EXP$(Q)
LET Q=Q-1 !(-2)+(1)=(-1)より
LET T=-P(i)
IF B(T)=-1 THEN !加算
LET STK(Q)=X+Y
LET EXP$(Q)="(" & X$ & "+" & Y$ & ")"
ELSEIF B(T)=-2 THEN !減算
LET STK(Q)=X-Y
LET EXP$(Q)="(" & X$ & "-" & Y$ & ")"
ELSEIF B(T)=-3 THEN !乗算
LET STK(Q)=X*Y
LET EXP$(Q)=X$ & "×" & Y$
ELSEIF B(T)=-4 THEN !除算
IF Y=0 THEN EXIT SUB !0で割る
LET STK(Q)=X/Y
LET EXP$(Q)=X$ & "÷" & Y$
ELSE
PRINT "論理エラーです。"; T$; i
STOP
END IF
CASE IS>0 !A,B,…,Z push
LET T=D(A(P(i)))
LET Q=Q+1
LET STK(Q)=T
IF T<0 THEN !負の値
LET EXP$(Q)="(" & STR$(T) & ")"
ELSE !非負の値
LET EXP$(Q)=STR$(T)
END IF
CASE ELSE
PRINT "論理エラーです。"; T$; i
STOP
END SELECT
NEXT i
!!!PRINT STK(1) !debug
LET T=STK(1) !結果を表示する
IF T>=0 AND T=INT(T) AND F(T)=0 THEN !非負整数、1番目
LET F(T)=1
PRINT T; "= "; EXP$(1)
END IF
END SUB
!COMB.LIB 抜粋
EXTERNAL SUB Num2PermFactorial(h, A(),N) !番号から順列パターンを生成する ※辞書式順序
OPTION ARITHMETIC RATIONAL !分数の計算
LET v=h !非負の10進数整数を階乗進数へ
FOR j=N TO 1 STEP -1 !下の桁から順に
LET w=N-j+1
LET t=INT(v/w)
LET A(j)=v-t*w +1 !階乗進数の各桁の値＋１ A[1..N]=(N-1)! … 3! 2! 1! 0!
LET v=t
NEXT j
FOR j=N-1 TO 1 STEP -1 !順列パターンへ
FOR k=j+1 TO N
IF A(k)>=A(j) THEN LET A(k)=A(k)+1
NEXT k
NEXT j
END SUB
EXTERNAL SUB try(P,N,M(,)) !バックトラック法で検索する
LET K=INT(N/2) !1の並びを左詰めにする（チームを区別しないので）
IF P<=K THEN !1～(半分) 番目のチームなら
FOR W=0 TO K !0勝,1勝,2勝,…
FOR J=1 TO W !1行目を埋める
LET M(P,P+J)=1 !右上半分
LET M(P+J,P)=0 !左下半分
NEXT J
FOR J=W+1 TO N-P !n敗,(n-1)敗,(n-2)敗,…
LET M(P,P+J)=0
LET M(P+J,P)=1
NEXT J
IF P=N-1 THEN !すべての行が埋まったなら
CALL check(N,M)
ELSE
CALL try(P+1,N,M) !次の行へ
END IF
NEXT W
ELSE
FOR W=0 TO 2^(N-P)-1 !p行目を埋める
LET T=W
FOR J=1 TO N-P
LET B=MOD(T,2)
LET M(P,P+J)=B !右上半分
LET M(P+J,P)=1-B !左下半分
LET T=INT(T/2)
NEXT J
IF P=N-1 THEN !すべての行が埋まったなら
CALL check(N,M)
ELSE
CALL try(P+1,N,M) !次の行へ
END IF
NEXT W
END IF
END SUB
EXTERNAL SUB check(N,M(,)) !既出のパターンと同じかどうか確認する
DIM F(0 TO N-1) !勝敗のパターン
MAT F=ZER
FOR i=1 TO N !i番目のチームの勝ち数
LET S=0
FOR J=1 TO N
LET S=S+M(i,J)
NEXT J
LET F(S)=F(S)+1
NEXT i
!!!MAT PRINT F; !0勝,1勝,2勝,…,(n-1)勝のチーム数
FOR i=1 TO C !既出のパターンと同じかどうか確認する
FOR J=0 TO N-1
IF D(i,J)<>F(J) THEN EXIT FOR
NEXT J
IF J>N-1 THEN EXIT FOR !同じパターンなら
NEXT i
IF i>C THEN !新規の場合、登録する
LET C=C+1
FOR J=0 TO N-1 !copy it
LET D(C,J)=F(J)
NEXT J
PRINT "No."; STR$(C) !結果を表示する
MAT PRINT F;
MAT PRINT M;
END IF
END SUB
例
x^8+x^7+1
=(x^3-1)(x5+x^2)+x^2 +(x^3-1)(x^4+x)+x +1
≡x^2+x+1 mod (x^3-1)
≡0 mod (x^2+x+1)
DATA 8 !1+x^7+x^8
DATA 1,0,0,0,0,0,0,1,1
READ aa
DIM A(0 TO aa)
MAT READ A
LET d=3 !x^3-1
DIM B(0 TO d-1)
MAT B=ZER
FOR i=0 TO aa
IF A(i)<>0 THEN
LET q=INT(i/d) !i=q*d+r
LET r=MOD(i,d)
PRINT A(i); "x^"; STR$(r)
LET B(r)=B(r)+A(i)
END IF
NEXT i
MAT PRINT B; !余り B(0)+B(1)x+B(2)x^2+ …
END
例
x^8+x^4+1
=(x^3+1)(x5-x^2)+x^2 +(x^3+1)x-x +1
≡x^2-x+1 mod (x^3+1)
≡0 mod (x^2-x+1)
DATA 8 !1+x^4+x^8
DATA 1,0,0,0,1,0,0,0,1
READ aa
DIM A(0 TO aa)
MAT READ A
LET d=3 !x^3+1
DIM B(0 TO d-1)
MAT B=ZER
FOR i=0 TO aa
IF A(i)<>0 THEN
LET q=INT(i/d) !i=q*d+r
LET r=MOD(i,d)
PRINT A(i)*(-1)^q; "x^"; STR$(r)
LET B(r)=B(r)+A(i)*(-1)^q
END IF
NEXT i
MAT PRINT B; !余り B(0)+B(1)x+B(2)x^2+ …
END
DIM B(0 TO d-1)
MAT B=ZER
FOR i=0 TO m*k
IF A(i)<>0 THEN
LET q=INT(i/d) !i=q*d+r
LET r=MOD(i,d)
PRINT A(i); "x^"; STR$(r)
LET B(r)=B(r)+A(i)
END IF
NEXT i
MAT PRINT B; !余り B(0)+B(1)x+B(2)x^2+ …
例
x^4-13x^2+36
={(x^2-9)(x^2+9) +81} -13{(x^2-9)+9} +36
≡81-117+36 mod (x^2-9)
≡0
DATA 4 !36-3x^2+x^4
DATA 36,0,-13,0,1
READ aa
DIM A(0 TO aa)
MAT READ A
LET d=2 !x^2-9
LET k=9
DIM B(0 TO d-1)
MAT B=ZER !余り B(0)+B(1)x+B(2)x^2+ …
FOR J=0 TO aa
IF A(J)<>0 THEN
LET q=INT(J/d) !i=q*d+r
LET r=MOD(J,d)
PRINT k^q*A(J); "x^"; STR$(r)
LET B(r)=B(r)+k^q*A(J)
END IF
NEXT J
MAT PRINT B; !結果を表示する
DIM G(M) !重複を除いた個数をG(k)とする
LET G(1)=B-1 !1段目
LET C=G(1)
FOR K=2 TO M !k段目
LET T=INT((K-1)*B/K) !kxが(k-1)Bより大きな数はすべて重複しない
FOR X=2 TO T !b列目
LET N=K*X
FOR P=1 TO K-1 !nをpqに分解する
LET Q=N/P
IF Q=INT(Q) AND (Q>=2 AND Q<=B) THEN EXIT FOR !重複する
NEXT P
IF P>K-1 THEN LET C=C+1 !重複しないなら
NEXT X
LET C=C+(B-T)
LET G(K)=C
NEXT K
MAT PRINT G; !debug
!組（A=2,3,5,6,7,10,11,12,13,…）に応じて計算していく。
LET C=0
LET AA=INT(SQR(A))
DIM F(AA) !2～[√A]までの数（篩いに用いる）
MAT F=ZER
LET S=0 !組にすることで除外された数の個数
FOR J=2 TO AA !素因数分解して、因数の組み合わせで組に分ける
IF F(J)=0 THEN !新しい組なら
PRINT "A="; J !debug
LET K=0
LET T=J !{j^1, j^2, j^3, …, j^k}の要素は、k個
DO WHILE T<=A
IF T<=AA THEN LET F(T)=1 !同じ組である
LET S=S+1
LET K=K+1
FOR K=1 TO 3 !1番目、2番目、3番目
LET A=T(N1)
LET B=P(N2)
LET C=H(N3)
DO UNTIL A=B AND B=C
LET M=MAX(MAX(A,B),C) !一番大きな数に揃える
DO WHILE A<M
LET N1=N1+1
LET A=T(N1)
LOOP
DO WHILE B<M
LET N2=N2+1
LET B=P(N2)
LOOP
DO WHILE C<M
LET N3=N3+1
LET C=H(N3)
LOOP
LOOP
PRINT STR$(K);":"; A; N1;N2;N3 !1533776805
LET N1=N1+1 !次へ
LET N2=N2+1
LET N3=N3+1
NEXT K
END
2次方程式を解く方法
!!OPTION ARITHMETIC RATIONAL !多桁の整数
LET N=1
FOR K=1 TO 3 !1番目、2番目、3番目
DO
LET X=N*(2*N-1) !六角数
LET D=SQR(1+24*X) !五角数X=N(3N-1)/2より
IF D=INT(D) THEN
LET M=(1+D)/6
IF M=INT(M) THEN
LET D=SQR(1+8*X) !三角数X=N(N+1)/2より
IF D=INT(D) THEN
LET M=(1+D)/2
IF M=INT(M) THEN EXIT DO
END IF
END IF
END IF
LET N=N+1
LOOP
PRINT STR$(K);":"; X ;N !1533776805
!7^2009 mod 1000 の計算
LET x=1
FOR n=1 TO 2009
LET x=MOD(x*7,1000)
PRINT n; x
NEXT n
END
その２
!7^2009=(7^20)^100*7^9≡1^100*7^9≡7^9 mod 1000
LET x=7
LET c=1
DO UNTIL x=1 OR c>2009 !7^c≡1 mod 1000を満たすcを見つける
LET x=MOD(x*7,1000)
LET c=c+1
LOOP
PRINT c
LET m=MOD(2009,c) !2009=c*Q+mより、(7^c)^Q*(7^m)と分解する
PRINT m
PRINT MOD(7^m,1000) !7^c≡1 mod 1000なので
END
OPTION ARITHMETIC RATIONAL !多桁整数
LET s=0
FOR r=2 TO 0 STEP -1 !r=3,2,1,0のとき
LET s=s + comb(1000,r)*50^r*(-1)^(1000-r)
NEXT r
PRINT MOD(s*7^9,10^3) !残り7^9を加味して
END
その２ 多項式(x-1)^rの展開とその値
OPTION ARITHMETIC RATIONAL !多桁整数
LET x=50 !7*7=49=50-1より、7^2008=(50-1)^1004
LET s=0 !二項定理で展開した式をホーナー法で計算する
FOR r=2 TO 0 STEP -1 !r=3以上では、50^rが10000で割り切れるから、下3桁はすべて0となる。
!!FOR r=1004 TO 0 STEP -1
LET s=MOD(s*x + comb(1004,r)*(-1)^(1004-r), 10^3)
NEXT r
PRINT MOD(s*7,10^4) !残り7を加味して
END
その２-２ 多項式(x-3)^rの展開とその値
OPTION ARITHMETIC RATIONAL !多桁整数
LET x=10 !7^2009=(10-3)^2009
LET s=0 !二項定理で展開した式をホーナー法で計算する
FOR r=2 TO 0 STEP -1 !10^3, 10^2, 10, 1
!!FOR r=2009 TO 0 STEP -1
LET s=MOD(s*x + comb(2009,r)*(-3)^(2009-r), 10^3)
NEXT r
PRINT s
END
IF q=0 THEN
LET t=p^2-4*r !判別式
IF t>0 THEN
CALL Solve2Equ(1,0,-(-p-SQR(t))/2 ,y1,y2,K1)
CALL Solve2Equ(1,0,-(-p+SQR(t))/2 ,y3,y4,K2)
ELSEIF t=0 THEN !(y^2 + p/2)^2=0の形
CALL Solve2Equ(1,0,p/2 ,y1,y2,K1)
LET K2=0
ELSE !2式とも虚数解
LET K1=0
LET K2=0
END IF
ELSE
CALL Solve3Equ(1,-p,-4*r,4*p*r-q^2, z1,z2,z3,KK)
LET t=SQR(z1-p)
LET K=0 !実数解の個数
IF K1>0 THEN
LET K=K+1
LET x(K)=y1-a3/(4*a4) !1番目 x=y-a3/(4*a4)
IF K1=2 THEN
LET K=K+1
LET x(K)=y2-a3/(4*a4) !2番目
END IF
END IF
IF K2>0 THEN
LET K=K+1
LET x(K)=y3-a3/(4*a4) !3番目
IF K2=2 THEN
LET K=K+1
LET x(K)=y4-a3/(4*a4) !4番目
END IF
END IF
END SUB
考察
オイラーの定理より、a＞0、n＞1のとき、(a,n)=1ならa^φ(n)≡1 mod n
(7,10^k)=1なので、7^φ(10^k)≡1 mod 10^k
k=1のとき、φ(10)=4より、7^4≡1 mod 10
k=2のとき、φ(100)=40より、7^40≡1 mod 100
k=3のとき、φ(1000)=400より、7^400≡1 mod 1000
k=4のとき、φ(10000)=4000より、7^4000≡1 mod 10000
：
よって、01、001、0001、00001、… のように下のけたに0が並ぶ。
この場合、7^4=2401のように、7^4≡1 mod 100、7^40≡1 mod 1000、… となる。
（終り）
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR N=1 TO 9 !mod 10^n
LET A=7
LET K=0
LET B=1 !a^k=b
DO
LET K=K+1
LET B=MOD(B*A,10^N)
LOOP UNTIL B=1 !a^k≡1
PRINT N; K
NEXT N
END
LET C=0 !回数
DO
LET C=C+1
LET T=prmdiv(N)
IF T=N THEN !素数
PRINT " ";STR$(N);
LET N=10*N+1
ELSE
PRINT " *";STR$(N);
LET N=N/T
END IF
LOOP UNTIL prmdiv(N)=N AND (N<=43 OR N<i)
PRINT N
!PRINT C
END IF
NEXT i
END
!UBASIC.LIB 抜粋
EXTERNAL FUNCTION prmdiv(n) !１より大きな最小の約数
OPTION ARITHMETIC RATIONAL !多桁の整数
IF n<>INT(n) THEN !整数以外なら
PRINT "prmdiv関数でパラメータが不適当です。"
STOP
ELSEIF n=0 THEN
LET prmdiv=0
ELSE
LET n=ABS(n) !絶対値をとる
IF MOD(n,2)=0 THEN !２の倍数
LET prmdiv=2
ELSEIF MOD(n,3)=0 THEN !３の倍数
LET prmdiv=3
ELSE
FOR i=5 TO INTSQR(n) STEP 6
IF MOD(n,i)=0 THEN !5,11,17,23,29,…
LET prmdiv=i
EXIT FUNCTION
ELSEIF MOD(n,i+2)=0 THEN !7,13,19,25,31,…
LET prmdiv=i+2
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
NEXT i
LET prmdiv=n !その数自身
END IF
END IF
END FUNCTION
LET S=LOG10(b)
LET T=LOG10(b+1)
LET W=LOG10(a)
LET m=0
DO
LET n1=CEIL( (m+S)/W )
LET n2=CEIL( (m+T)/W )
IF n1<n2 THEN EXIT DO
LET m=m+1
LOOP
!!!PRINT m; n1;n2 !debug
PRINT n1;"乗"
DATA 4
DATA 3,2 !3で割ると2余る
DATA 5,3 !5で割ると3余る
DATA 7,5 !7で割ると5余る
DATA 11,7 !11で割ると7余る
DATA 1000,10000 !1000以上10000未満の範囲
READ K
DIM A(K),B(K) !x≡a mod b
FOR i=1 TO K
READ B(i),A(i)
NEXT i
LET S=1 !中国剰余定理（Chinese remainder theorem）より
FOR i=1 TO K
LET S=S*B(i) !b1*b2* … *bn
NEXT i
!!!PRINT S !debug
LET R=0 !x=Σui*xi*ai (mod b1*b2* … *bn)
FOR i=1 TO K
LET T=S/B(i) !ui*xi≡1 (mod bi)
LET R=R+T*modinv(T,B(i))*A(i)
NEXT i
LET R=MOD(R,S) !解
!!!PRINT R !debug
READ P,Q ![p,q)の範囲で検索する
LET C=0
LET N=CEIL((P-R)/S)*S+R
DO WHILE N<Q
LET C=C+1
PRINT N
LET N=N+S
LOOP
PRINT C; "個"
EXTERNAL FUNCTION modinv(a,n) !nを法としたaの逆元 a*x≡1 (mod n)
OPTION ARITHMETIC RATIONAL !多桁の整数
LET d0=a !(a,1)
LET x0=1
LET d1=n !(n,0)
LET x1=0
DO WHILE d1<>0 !拡張ユークリッドの互除法によりa*x+b*y=cの解を求める
LET t=INT(d0/d1)
LET T1=d0 !(d0,x0)=(d1,x1)、(d1,x1)=(d0-t*d1,x0-t*x1)
LET T2=x0
LET d0=d1 !次へ
LET x0=x1
LET d1=T1-t*d1
LET x1=T2-t*x1
LOOP
IF d0=1 THEN !GCD(a,n)=1なら
IF x0<0 THEN LET x0=x0+n !mod(x0,n)
LET modinv=x0
ELSE
LET modinv=0
END IF
END FUNCTION
dim l(n) '各ｱｰﾑ長さ
dim rd(3) '手先目標位置座標 rd(1) x rd(2) y
dim px(n) '各関節のx座標
dim py(n) '各関節のy座標
dim dp(n) '手先目標位置と、手先位置との偏差 dp(1)=rd(1)-px(n) dp(2)=rd(2)-py(n)
dim q(n) 'q(1)=c1 q(2)=c2 q(3)=c3 q(4)=c4... q(n)=cn
dim dq(n) '各角度調整量
dim s(n) 's(i)=sin(q(1)+q(2)+....+q(i))
dim c(n) 'c(i)=cos(q(1)+q(2)+....+q(i))
dim ja(n,n) 'ﾔｺﾋﾞｱﾝ行列
dim invj(n,n) '逆ﾔｺﾋﾞｱﾝ行列
'初期設定
l0=110 '土台固定ｱｰﾑ長さ
for i=1 to n
l(i)=120*(rnd+0.5) 'ｱｰﾑ1～n長さ
next i
'各関節初期角度
for i=1 to n
q(i)=10*pai/180 '度からﾗｼﾞｱﾝに変換
next i
call sici 's(i),c(i)の計算
'逆行列化ｺﾏﾝﾄﾞ、mat invj=inv(ja)が
'使える様にする為にﾔｺﾋﾞｱﾝ行列を,正方行列とする為に、
'ja(3,1)～ja(3,n)、ja(n,1)～ja(n,n)にrndを設定
for i=3 to n
for j=1 to n
ja(i,j)=rnd
next j
next i
call position '関節1～5、手先の位置の計算
call draw '表示
call cal1 'ｼﾐｭﾚｰｼｮﾝ計算
'---------------------------------------------
sub cal1
do while zz=0 '無限ﾙｰﾌﾟ
mouse poll xm,ym,left,right
rd(1)=xm-xbase '手先目標位置x座標
rd(2)=ym-ybase-l0 '手先目標位置y座標
'誤差の評価
pe=dp(1)^2+dp(2)^2
if pe<2 then
call check '誤差範囲に収束したら表示
end if
call sici 's(i),c(i)の計算
'ﾔｺﾋﾞｱﾝ行列を設定
ja(1,n)=-l(n)*s(n)
ja(2,n)=l(n)*c(n)
for i=n-1 to 1 step -1
ja(1,i)=ja(1,i+1)-l(i)*s(i)
ja(2,n)=ja(2,i+1)+l(i)*c(i)
next i
mat invj=inv(ja) 'ﾔｺﾋﾞｱﾝ逆行列計算
kp=0.03 '修正ｹﾞｲﾝ
'各関節角度修正量計算
'dq=kp*invj*dp '行列dq=ｽｶﾗkp*行列invj*行列dp
mat invj=kp*invj
mat dq=invj*dp '各関節角度修正量
'各関節角度の修正更新
mat q=q+dq
for i=1 to n
q(i)=mod(q(i),(pai*2)) '360度以内に正規化
next i
loop
end sub
'---------------------------------------------
sub sici
's(i),c(i)の計算
'関節iの角度を、l(i-1)と成す角度と定義することにより、
'関節iのx軸と成す角度はΣq(i)と表現出来、
's(i)=sin(q(1)+q(2)+....+q(i))
'c(i)=cos(q(1)+q(2)+....+q(i))
'となる
for i=1 to n
cw=0
for j=1 to i
cw=cw+q(j)
next j
s(i)=sin(cw) 's(i)=sin(q(1)+q(2)+...+q(i))
c(i)=cos(cw) 'c(i)=cos(q(1)+q(2)+...+q(i))
next i
end sub
'---------------------------------------------
sub position
'関節1～nのx､y座標を計算、i=nのときは手先のxy座標となる
px(1)=l(1)*c(1)
py(1)=l(1)*s(1)
for i=2 to n
px(i)=px(i-1)+l(i)*c(i)
py(i)=py(i-1)+l(i)*s(i)
next i
end sub
'---------------------------------------------
sub check
'収束したら表示する
call draw
end sub
'---------------------------------------------
sub draw
set draw mode hidden
set line width 4
line(0,0)-(2000,960),1,bf '画面ｸﾘﾔ
line(100,ybase)-(1700,ybase),5 'ﾍﾞｰｽﾗｲﾝ
circle(0+xbase,l0+ybase),10,4,,,,f '固定ｱｰﾑの関節
'各関節表示
for i=1 to n
circle(px(i)+xbase,py(i)+ybase+l0),10,4,,,,f
next i
'各ｱｰﾑの表示
line(xbase,ybase)-(xbase,ybase+l0),5 '固定ｱｰﾑ
'ｱｰﾑ1～n表示
for i=1 to n
line-(px(i)+xbase,py(i)+ybase+l0),6
next i
circle(xm,ym),10,5,,,,f '手先目標位置
'各関節角度表示
xb=1400
yb=900
set text color 5
set text font "MS明朝",20
for i=1 to n
plot text, at xb,yb-50*(i-1):"c"
plot text, at xb+15,yb-50*(i-1),using "##":i
plot text, at xb+50,yb-50*(i-1):"="
cw=0
for j=1 to i
cw=cw+q(j)
next j
cw=mod(cw,(2*pai))*180/pai '360度以内に正規化し、度に変換
plot text, at xb+110,yb-50*(i-1),using"#####.#":cw
next i
set draw mode explicit
end sub
'---------------------------------------------
次のプログラムで実行してみたら
>
> !連立1次合同式を解く
>
> OPTION ARITHMETIC RATIONAL !多桁の整数
>
> DATA 4
> DATA 3,1 !3で割ると1余る
> DATA 4,2 !4で割ると2余る
> DATA 5,3 !5で割ると3余る
> DATA 8,4 !8で割ると4余る
> DATA 1000,10000 !1000以上10000未満の範囲
>
> READ K
> DIM A(K),B(K) !x≡a mod b
> FOR i=1 TO K
> READ B(i),A(i)
> NEXT i
>
>
> LET S=1 !中国剰余定理（Chinese remainder theorem）より
> FOR i=1 TO K
> LET S=S*B(i) !b1*b2* … *bn
> NEXT i
> !!!PRINT S !debug
>
> LET R=0 !x=Σui*xi*ai (mod b1*b2* … *bn)
> FOR i=1 TO K
> LET T=S/B(i) !ui*xi≡1 (mod bi)
> LET R=R+T*modinv(T,B(i))*A(i)
> NEXT i
> LET R=MOD(R,S) !解
> !!!PRINT R !debug
>
>
> READ P,Q ![p,q)の範囲で検索する
> LET C=0
> LET N=CEIL((P-R)/S)*S+R
> DO WHILE N<Q
> LET C=C+1
> PRINT N
> LET N=N+S
> LOOP
> PRINT C; "個"
>
>
> !初項r、公差sの等差数列 項数k個 r,r+s,r+2s,…,r+(k-1)s
> PRINT CEIL((Q-R)/S)-CEIL((P-R)/S); "個"
>
> END
>
>
> !UBASIC.LIB 抜粋
>
> EXTERNAL FUNCTION modinv(a,n) !nを法としたaの逆元 a*x≡1 (mod n)
> OPTION ARITHMETIC RATIONAL !多桁の整数
> LET d0=a !(a,1)
> LET x0=1
> LET d1=n !(n,0)
> LET x1=0
> DO WHILE d1<>0 !拡張ユークリッドの互除法によりa*x+b*y=cの解を求める
> LET t=INT(d0/d1)
> LET T1=d0 !(d0,x0)=(d1,x1)、(d1,x1)=(d0-t*d1,x0-t*x1)
> LET T2=x0
> LET d0=d1 !次へ
> LET x0=x1
> LET d1=T1-t*d1
> LET x1=T2-t*x1
> LOOP
> IF d0=1 THEN !GCD(a,n)=1なら
> IF x0<0 THEN LET x0=x0+n !mod(x0,n)
> LET modinv=x0
> ELSE
> LET modinv=0
> END IF
> END FUNCTION
>
>
DATA 4
DATA 3,1 !x≡1 mod 3
DATA 4,2 !x≡2 mod 4
DATA 5,3 !x≡3 mod 5
DATA 8,4 !x≡4 mod 8
READ K
DIM A(K),B(K) !x≡a mod b
FOR i=1 TO K
READ B(i),A(i)
NEXT i
LET L=B(1) !最小公倍数を求める
FOR i=2 TO K
LET L=LCM(L,B(i))
NEXT i
LET C=0
FOR X=A(K) TO L STEP B(K) !1つの合同式（ x≡a[k] mod b[k] ）を満たす数が
FOR i=1 TO K-1 !他の合同式を満たすかどうか確認する
IF MOD(X,B(i))<>A(i) THEN EXIT FOR
NEXT i
IF i>K-1 THEN !条件を満たす
LET C=C+1
PRINT X; "+"; L; "k" !解
END IF
NEXT X
IF C=0 THEN PRINT "解なし"
EXTERNAL SUB try(P,T, N,M,B())
IF P=M THEN !R番目なら
LET B(P)=B(P)+T !set it
FOR i=1 TO INT(M/2) !対称性（直線状）
IF B(i)<>B(M-i+1) THEN EXIT FOR
NEXT i
IF B(i)<B(M-i+1) OR i>INT(M/2) THEN
DIM F(N) !1～nの数字
MAT F=ZER
FOR i=1 TO M !i番目から
FOR K=0 TO M-i !続くk個の数字
LET S=0
FOR X=0 TO K !その和
LET S=S+B(i+X)
NEXT X
LET F(S)=1
NEXT K
NEXT i
FOR i=1 TO N !すべて表されるかどうか確認する
IF F(i)=0 THEN EXIT FOR
NEXT i
IF i>N THEN
LET C=C+1 !結果を表示する
MAT PRINT B;
END IF
END IF
LET B(P)=B(P)-T !restore it
ELSE
FOR i=0 TO T !p番目
LET B(P)=B(P)+i !set it
CALL try(P+1,T-i, N,M,B)
LET B(P)=B(P)-i !restore it
NEXT i
DIM Q(N) !各関節の角度 ※単位は度、ワールド座標系
DATA 30,30,30,30
MAT READ Q
CALL PrintOut(N,L,Q, PX,PY,QQ)
DO
mouse poll mx,my,left,right !目標の位置(x,y)
IF right=1 THEN STOP !右ボタンが押下されるまで
!逆運動学
DIM J(2,N) !ヤコビアン
LET J(1,N)=-L(N)*SIN(RAD(QQ))
LET J(2,N)= L(N)*COS(RAD(QQ))
FOR i=N-1 TO 1 STEP -1
LET QQ=QQ-Q(i+1)
LET J(1,i)=J(1,i+1)-L(i)*SIN(RAD(QQ))
LET J(2,i)=J(2,i+1)+L(i)*COS(RAD(QQ))
NEXT i
DIM JT(N,2),W(2,2),JJ(N,2)
MAT JT=TRN(J)
MAT W=J*JT
MAT W=INV(W)
MAT JJ=JT*W !擬似逆行列A^+=A^t*(A*A^t)^(-1)
DIM r(2) !位置誤差
LET r(1)=mx-PX
LET r(2)=my-PY
DIM dQ(N) !⊿θ=kJ^(-1)⊿x
MAT dQ=JJ*r
FOR i=1 TO N !θ←θ+⊿θ
LET Q(i)=MOD(Q(i)+5*dQ(i),360)
NEXT i
CALL PrintOut(N,L,Q, PX,PY,QQ) !手先位置
LOOP
END
EXTERNAL SUB PrintOut(N,L(),Q(), PX,PY,QQ) !順運動学で手先位置を算出する。表示する
SET DRAW mode hidden !ちらつき防止の開始
CLEAR
DRAW grid(2,2) !座標
LET PX=0 !原点(0,0)
LET PY=0
LET QQ=0 !Σθ
FOR i=1 TO N !n個の関節
LET QQ=QQ+Q(i)
LET X=PX+L(i)*COS(RAD(QQ)) !x=L[1]cos(Q[1])+L[2]cos(Q[1]+Q[2])+ …
LET Y=PY+L(i)*SIN(RAD(QQ)) !y=L[1]sin(Q[1])+L[2]sin(Q[1]+Q[2])+ …
PLOT LINES: PX,PY; X,Y
PLOT TEXT ,AT PX,PY: USING$("####.##",Q(i))&"°"
dim x(n) '関節のx座標
dim y(n) '関節のx座標
dim r(n) '各ｱｰﾑの長さ
dim q(n) '各関節の角度
'各ｱｰﾑの長さ
for i=0 to n-1
r(i)=100*(rnd+0.5)
next i
'各関節の角度
for i=1 to n-1
q(i)=rad(30)
next i
'各関節の初期位置計算
px=0 '原点(0,0)
py=0
qq=0 'Σθ
for i=0 to n-1 'n個の関節
qq=qq+q(i)
x(i)=px+r(i)*cos(qq) 'x=l1*cos(q1)+l2*cos(q1+q2)+l3*cos(q1+q2+q3)+....
y(i)=py+r(i)*sin(qq) 'y=l1*sin(q1)+l2*sin(q1+q2)+l3*sin(q1+q2+q3)+...
px=x(i) 'px更新
py=y(i) 'py更新
next i
'繰り返し計算
do
call cal 'リンクの動作シミュレーション計算
call draw '状態描画
loop
'端点の移動
mouse poll xm,ym,left,right
x(n-1)=xm-xbase
y(n-1)=ym-ybase
if right=1 then stop 'ﾏｳｽ右ｸﾘｯｸで停止
'連続ｱｰﾑの移動
for i=1 to n-1
l=sqr( (x(i)-x(i-1) )^2+(y(i)-y(i-1) )^2 ) '関節間ｱｰﾑの現在長さ
cosc=(x(i)-x(i-1) )/l '現在のｱｰﾑとx軸との余弦値
sinc=(y(i)-y(i-1) )/l '現在のｱｰﾑとy軸との正弦値
x(i-1)=x(i)-r(i-1)*cosc 'x(i-1)をx(i)と真のｱｰﾑ長さr(i-1)と余弦値を使って算出
y(i-1)=y(i)-r(i-1)*sinc 'y(i-1)をy(i)と真のｱｰﾑ長さr(i-1)と正弦値を使って算出
next i
end sub
'---------------------------------------------------------------------------
'動作描画
sub draw
set draw mode hidden
set line width 4
line(0,0)-(2000,960),1,bf '画面ｸﾘﾔ
'ｱｰﾑ、関節表示更新
for i=0 to n-2
line(x(i)+xbase,y(i)+ybase)-(x(i+1)+xbase,y(i+1)+ybase),4
circle (x(i)+xbase,y(i)+ybase),10,4,,,,f
next i
'移動端点の表示更新
circle (x(n-1)+xbase,y(n-1)+ybase),10,5,,,,f
set draw mode explicit
end sub
'---------------------------------------------------------------------------
LET k=CEIL(n/4)
PRINT k !debug
IF k>1 AND MOD(n,4)=3 THEN !4k-1の場合
FOR i=4*k-4 TO 2*k STEP -2
PRINT i;
NEXT i
PRINT 4*k-2;
FOR i=2*k-3 TO 1 STEP -2
PRINT i;
NEXT i
PRINT 4*k-1;
FOR i=1 TO 2*k-3 STEP 2
PRINT i;
NEXT i
FOR i=2*k TO 4*k-4 STEP 2
PRINT i;
NEXT i
PRINT 2*k-1;
FOR i=4*k-3 TO 2*k+1 STEP -2
PRINT i;
NEXT i
PRINT 4*k-2;
FOR i=2*k-2 TO 2 STEP -2
PRINT i;
NEXT i
PRINT 2*k-1;
PRINT 4*k-1;
FOR i=2 TO 2*k-2 STEP 2
PRINT i;
NEXT i
FOR i=2*k+1 TO 4*k-3 STEP 2
PRINT i;
NEXT i
PRINT
ELSEIF k>1 AND MOD(n,4)=0 THEN !4kの場合
FOR i=4*k-2 TO 2*k STEP -2
PRINT i;
NEXT i
PRINT 4*k-1;
FOR i=2*k-3 TO 1 STEP -2
PRINT i;
NEXT i
PRINT 4*k;
FOR i=1 TO 2*k-3 STEP 2
PRINT i;
NEXT i
FOR i=2*k TO 4*k-2 STEP 2
PRINT i;
NEXT i
PRINT 2*k-1;
FOR i=4*k-3 TO 2*k+1 STEP -2
PRINT i;
NEXT i
PRINT 4*k-1;
FOR i=2*k-2 TO 2 STEP -2
PRINT i;
NEXT i
PRINT 2*k-1;
PRINT 4*k;
FOR i=2 TO 2*k-2 STEP 2
PRINT i;
NEXT i
FOR i=2*k+1 TO 4*k-3 STEP 2
PRINT i;
NEXT i
LET t0=TIME
LET N=4
PUBLIC NUMERIC C !解の個数
LET C=0
DIM F(2*N) !数字1～2n
MAT F=ZER
CALL try(N, N,F) !差がn,…,3,2,1 ※N+1
IF C=0 THEN PRINT "解なし"
PRINT TIME-t0
END
EXTERNAL SUB try(P, N,F()) !バックトラック法で検索する
FOR i=1 TO 2*N-P !未使用の数字が候補である
IF F(i)=0 AND F(i+P)=0 THEN !組(i,i+p)は条件を満たす
LET F(i)=P !使用中 ※P-1
LET F(i+P)=P !※P-1
IF P=1 THEN !すべて並んだなら ※2
LET C=C+1
PRINT "No.";C
MAT PRINT F;
FOR s=1 TO N !差が1～nの順に
FOR x=1 TO 2*N
IF F(x)=s THEN
PRINT "(";x;",";x+s;") "; !ペア
EXIT FOR
END IF
NEXT x
NEXT s
PRINT
ELSE
CALL try(P-1, N,F) !次へ
END IF
LET F(i)=0 !元に戻す
LET F(i+P)=0
END IF
NEXT i
END SUB
LET N=1000
FOR K=0 TO N !n±k
FOR S=1 TO -1 STEP -2 !符号
LET M=N+S*K
IF MOD(M,7)=4 THEN !題意を満たすなら
IF MOD(M,5)=3 THEN
IF MOD(M,3)=2 THEN
PRINT M
STOP
END IF
END IF
END IF
NEXT S
NEXT K
END
(6)について、
┌┴┐
┌┴┐D Dは3勝
┌┴┐C Cは2勝
┌┴┐B Bは1勝
e A Aは0勝
の4試合
よって、11+4=15試合
!(3),(4)について
LET N=7 !n連勝
DIM P(N) !n人の看板
MAT P=ZER
LET C=0 !試合の回数
LET K=N !※右側yが「勝つ」として、Pの並びは0,1,2,3,…,(n-1)
DO
FOR X=1 TO K-1 !xとyとの試合
FOR Y=X+1 TO K
IF P(Y)=P(X) THEN
LET P(Y)=P(Y)+1 !試合の結果を反映させる
LET P(X)=0
LET C=C+1
PRINT C !結果を表示する
MAT PRINT P;
END IF
NEXT Y
NEXT X
IF P(K)=K-1 THEN
PRINT K-1;"連勝をつくりました。"
PRINT
LET K=K-1
IF K=1 THEN
LET S=0 !Σ
FOR i=1 TO N
LET S=S +2^(i-1)-1
NEXT i
PRINT S
変更点は，
POINT STYLE, LINE STYLE，AREA STYLE INDEX, LINE WIDTH に
0（不正な数値）を指定したときの挙動の誤りの修正です。
10 SET LINE STYLE 0
20 ASK LINE STYLE n
30 PRINT n
40 END
の実行結果が，
オプション―互換性―描画―図形関連SET文の不正な引数
が「続行不能例外として扱う」のとき，
EXTYPE 11062 のエラー，
「続行可能例外として扱う(JIS)」のとき，
1
であれば，Ver. 7.7.6 です。
DIM AX(3,4) !XYZ軸の形をした図形
DATA 1,0,0 !X
DATA 0,1,0 !Y
DATA 0,0,1 !Z
FOR i=1 TO 3
FOR J=1 TO 3
READ AX(i,J) !x,y,z
LET AX(i,4)=1 !w
NEXT J
NEXT i
DIM BX(8,4) !立方体の8頂点
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
FOR i=1 TO 8
FOR J=1 TO 3
READ BX(i,J) !x,y,z
LET BX(i,4)=1 !w
NEXT J
NEXT i
DIM T(8,4) !(x',y',z')
DIM M(4,4)
DATA "+X","-X","+Y","-Y","+Z","-Z" !ボタン
DIM BTN$(6)
MAT READ BTN$
DO
SET DRAW mode hidden !ちらつき防止(開始)
CLEAR
CALL button(-2.8,2.8, 0.6,0.3, 6, BTN$,S) !軸の回転メニュー
SELECT CASE S
CASE 0 !+x
CALL D3ROTATE(RAD(5),AX(1,1),AX(1,2),AX(1,3), M) !5度ずつ
CASE 1 !-x
CALL D3ROTATE(RAD(-5),AX(1,1),AX(1,2),AX(1,3), M)
CASE 2 !+y
CALL D3ROTATE(RAD(5),AX(2,1),AX(2,2),AX(2,3), M)
CASE 3 !-y
CALL D3ROTATE(RAD(-5),AX(2,1),AX(2,2),AX(2,3), M)
CASE 4 !+z
CALL D3ROTATE(RAD(5),AX(3,1),AX(3,2),AX(3,3), M)
CASE 5 !-z
CALL D3ROTATE(RAD(-5),AX(3,1),AX(3,2),AX(3,3), M)
CASE ELSE
MAT M=IDN
END SELECT
MAT T=AX*M
MAT AX=T
MAT T=BX*M
MAT BX=T
CALL button(-2.0,2.8, 0.6,0.3, 6, BTN$,S) !図形の回転メニュー
SELECT CASE S
CASE 0 !+x
CALL D3ROTATE(RAD(5),AX(1,1),AX(1,2),AX(1,3), M) !5度ずつ
CASE 1 !-x
CALL D3ROTATE(RAD(-5),AX(1,1),AX(1,2),AX(1,3), M)
CASE 2 !+y
CALL D3ROTATE(RAD(5),AX(2,1),AX(2,2),AX(2,3), M)
CASE 3 !-y
CALL D3ROTATE(RAD(-5),AX(2,1),AX(2,2),AX(2,3), M)
CASE 4 !+z
CALL D3ROTATE(RAD(5),AX(3,1),AX(3,2),AX(3,3), M)
CASE 5 !-z
CALL D3ROTATE(RAD(-5),AX(3,1),AX(3,2),AX(3,3), M)
CASE ELSE
MAT M=IDN
END SELECT
MAT T=BX*M
MAT BX=T
CALL button(-2.0,0.0, 0.6,0.3, 6, BTN$,S) !図形の平行移動メニュー
SELECT CASE S
CASE 0 !+x
CALL VEC3NORMALIZE(AX(1,1),AX(1,2),AX(1,3), xx,yy,zz) !方向ベクトル
CASE 1 !-x
CALL VEC3NORMALIZE(-AX(1,1),-AX(1,2),-AX(1,3), xx,yy,zz)
CASE 2 !+y
CALL VEC3NORMALIZE(AX(2,1),AX(2,2),AX(2,3), xx,yy,zz)
CASE 3 !-y
CALL VEC3NORMALIZE(-AX(2,1),-AX(2,2),-AX(2,3), xx,yy,zz)
CASE 4 !+z
CALL VEC3NORMALIZE(AX(3,1),AX(3,2),AX(3,3), xx,yy,zz)
CASE 5 !-z
CALL VEC3NORMALIZE(-AX(3,1),-AX(3,2),-AX(3,3), xx,yy,zz)
CASE ELSE
LET xx=0
LET yy=0
LET zz=0
END SELECT
CALL D3SHIFT(xx*0.05,yy*0.05,zz*0.05, M) !0.05ずつ
MAT T=BX*M
MAT BX=T
!XYZ軸を描く
! (x,y,z) → (x,y)
! Y
! ↑
! Z→X
! のXY平面へ投影する。
SET LINE COLOR 4 !X軸
PLOT LINES: AX(1,1),AX(1,2); 0,0
PLOT TEXT, AT AX(1,1),AX(1,2): "x"
SET LINE COLOR 3 !Y軸
PLOT LINES: AX(2,1),AX(2,2); 0,0
PLOT TEXT, AT AX(2,1),AX(2,2): "y"
SET LINE COLOR 2 !Z軸
PLOT LINES: AX(3,1),AX(3,2); 0,0
PLOT TEXT, AT AX(3,1),AX(3,2): "z"
!立方体を描く
SET LINE COLOR 1
FOR i=1 TO 3 !上面
PLOT LINES: BX(i,1),BX(i,2); BX(i+1,1),BX(i+1,2)
NEXT i
PLOT LINES: BX(4,1),BX(4,2); BX(1,1),BX(1,2)
FOR i=1 TO 4 !側面
PLOT LINES: BX(i,1),BX(i,2); BX(i+4,1),BX(i+4,2)
NEXT i
FOR i=5 TO 7 !下面
PLOT LINES: BX(i,1),BX(i,2); BX(i+1,1),BX(i+1,2)
NEXT i
PLOT LINES: BX(8,1),BX(8,2); BX(5,1),BX(5,2)
SET DRAW mode explicit !ちらつき防止(終了)
WAIT DELAY 0.1
LOOP
SUB button(x,y, dx,dy, n, btn$(),s) !左上位置(x,y)、大きさdx,dy、n個のボタン
LET xx=x
LET yy=y
FOR i=1 TO n
PLOT LINES: xx,yy; xx+dx,yy !枠を描く
PLOT LINES: xx+dx,yy; xx+dx,yy-dy
PLOT LINES: xx+dx,yy-dy; xx,yy-dy
PLOT LINES: xx,yy-dy; xx,yy
PLOT TEXT ,AT xx+dx/3,yy-4*dy/5: btn$(i) !名前 ※調整が必要
LET yy=yy-dy
NEXT i
mouse poll mx,my,left,right !マウスポインタの位置を得る
LET s=-1
FOR K=0 TO 6-1
IF ABS(mx-(x+dx/2))<dx/2 AND ABS(my-((y-dy*K)-dy/2))<dy/2 THEN LET s=K !k番目のボタン内なら
NEXT K
!!!PRINT s !debug
END SUB
END
EXTERNAL SUB VEC3NORMALIZE(Vx,Vy,Vz, x,y,z) !単位ベクトルへ
LET l=SQR(Vx*Vx+Vy*Vy+Vz*Vz)
IF l<>0 THEN
LET x=Vx/l
LET y=Vy/l
LET z=Vz/l
END IF
END SUB
EXTERNAL SUB D3ROTATE(a,Vx,Vy,Vz, M(,)) !任意軸（位置ベクトル(Vx,Vy,Vz) ）まわりの回転
CALL VEC3NORMALIZE(Vx,Vy,Vz, x,y,z)
LET c=COS(a)
LET s=SIN(a)
MAT M=ZER
LET M(1,1)=x*x*(1-c)+c
LET M(1,2)=x*y*(1-c)+z*s
LET M(1,3)=z*x*(1-c)-y*s
LET M(2,1)=x*y*(1-c)-z*s
LET M(2,2)=y*y*(1-c)+c
LET M(2,3)=y*z*(1-c)+x*s
LET M(3,1)=z*x*(1-c)+y*s
LET M(3,2)=y*z*(1-c)-x*s
LET M(3,3)=z*z*(1-c)+c
LET M(4,4)=1
END SUB
EXTERNAL SUB D3SCALE(a,b,c, M(,)) !拡大・縮小
MAT M=IDN
LET M(1,1)=a
LET M(2,2)=b
LET M(3,3)=c
END SUB
EXTERNAL SUB D3SHIFT(l,m,n, A(,)) !平行移動
MAT A=IDN
LET A(4,1)=l
LET A(4,2)=m
LET A(4,3)=n
END SUB
!(x,y,z)=(奇数,偶数,奇数)
FOR X=1 TO T STEP 2
FOR Y=X+1 TO 2*T STEP 2
LET P=6*X*Y
LET Q=X^3+Y^3
LET Z=Y+1
LET W=Z^2-P
DO WHILE W<0
IF Z*W=-Q THEN
IF GCD3(X,Y,Z)=1 THEN PRINT X;Y;Z
END IF
LET Z=Z+2
LET W=Z^2-P
LOOP
NEXT Y
NEXT X
END
または、
OPTION ARITHMETIC RATIONAL !多桁の整数
DEF GCD3(X,Y,Z)=GCD(GCD(X,Y),Z)
FOR Z=1 TO 6000 STEP 2 !上限
FOR X=1 TO Z STEP 2
FOR Y=X+1 TO Z STEP 2
IF X^3+Y^3+Z^3=6*X*Y*Z THEN
IF GCD3(X,Y,Z)=1 THEN PRINT X;Y;Z
END IF
NEXT Y
NEXT X
NEXT Z
!点(x1,y1)、(x2,y2)を通る直線と曲線X^3+Y^3+1-6XY=0との交点を求める
EXTERNAL SUB try(X1,Y1, X2,Y2, X3,Y3)
OPTION ARITHMETIC RATIONAL !有理数
IF X2-X1=0 THEN !y軸に平行
!x=x1=mと連立させて、M^3+Y^3-6MY+1=0 解と係数の関係より、Y1+Y2+Y3=0
LET X3=X1
LET Y3=-(Y1+Y2)
PRINT "("; STR$(X1); ","; STR$(Y1); ")と("; STR$(X2); ","; STR$(Y2); ")を通る直線"
PRINT X3;Y3
ELSE
LET M=(Y2-Y1)/(X2-X1) !2点を通る直線 y={(y2-y1)/(x2-x1)}(x-x1)+y1=mx+n
LET N=-M*X1+Y1
!!!PRINT M;N !debug
!y=mx+nと連立させて、残りの解を得る。
!X^3+(MX+N)^3+1-6X(MX+N)=0 ∴(M^3+1)X^3+(3M^2N-6M)X^2+(3MN^2-6N)X+(N^3+1)=0
!解と係数の関係より、X^2について、X1+X2+X3=-(3M^2N-6M)/(M^3+1)
IF M^3+1=0 THEN !2次式になる
PRINT "解なし"
STOP
ELSE
LET X3=-(3*M^2*N-6*M)/(M^3+1)-(X1+X2)
LET Y3=M*X3+N
PRINT "("; STR$(X1); ","; STR$(Y1); ")と("; STR$(X2); ","; STR$(Y2); ")を通る直線"
PRINT X3;Y3
END IF
END IF
END SUB
LET K=1 !順位
LET W=T(1,d+1) !その値
FOR I=1 TO c
PRINT I;" ";N$(I);
FOR J=1 TO 6
PRINT TAB (J*7+c+3);T(I,J);
NEXT J
IF T(I,d+1)<W THEN !小さい値なら
LET K=K+1 !順位を下げる
LET W=T(I,d+1)
END IF
PRINT TAB(62); K !表示する
NEXT I
!氏名と点数の入力--------------------------------
DATA エーさん ,23 ,20 ,28 ,15 ,5
! !10 rem 高田の５点円
! !20 rem --- 円に内接する任意の五角形の生成から始める
OPTION ARITHMETIC COMPLEX
SET WINDOW -400,400,-400,400
RANDOMIZE
SET TEXT background "opaque"
! !30 CLG
! !40 DEF2PT P: DEF2CR C : DEF2ED E: DEF2LN L
DIM ANG(5), PR(5) !50 DIM ANG[5],PR[5]
LET ANG(1)=2*RND !60 ANG[1]=RND(0) ←2* の脱落
FOR i=2 TO 5 !70 FOR I=2 TO 5: ANG[I]=1+2*RND(0)+ANG[I-1] : NEXT
LET ANG(i)=1+2*RND+ANG(i-1)
NEXT i
LET ANG0=2*PI/(ANG(5)+1) !80 ANG0=360/(ANG[5]+1)
!
FOR i=1 TO 5 !90 FOR I=1 TO 5: ANG[I]=ANG0*ANG[I] : NEXT
LET ANG(i)=ANG0*ANG(i)
NEXT i
!
LET R=200 !100 R=200: C=R*C
DRAW circle WITH SCALE(R)
FOR i=1 TO 5 !110 FOR I=1 TO 5
LET PR(i)=R*EXP(COMPLEX(0,ANG(i))) !120 LET P=R*COS(ANG[I]), R*SIN(ANG[I]): PR[I]=P
NEXT i !130 NEXT
!
! !140 E12=PR[1]@PR[2] : E13=PR[1]@PR[3]
! !150 E14=PR[1]@PR[4] : E15=PR[1]@PR[5]
! !160 E23=PR[2]@PR[3] : E24=PR[2]@PR[4]
! !170 E25=PR[2]@PR[5] : E34=PR[3]@PR[4]
! !180 E35=PR[3]@PR[5] : E45=PR[4]@PR[5]
PLOT LINES: PR(1);PR(2);PR(3);PR(4);PR(5);
PLOT LINES: PR(1);PR(3);PR(5);PR(2);PR(4);PR(1)
!
! !190 P12=E13&E25 : P23=E24&E13 : P34=E35&E24
! !200 P45=E14&E35 : P51=E14&E25
LET P12=xpt2L( PR(1),PR(3), PR(2),PR(5))
LET P23=xpt2L( PR(2),PR(4), PR(1),PR(3))
LET P34=xpt2L( PR(3),PR(5), PR(2),PR(4))
LET P45=xpt2L( PR(1),PR(4), PR(3),PR(5))
LET P51=xpt2L( PR(1),PR(4), PR(2),PR(5))
! PLOT POINTS: P12; P23; P34; P45; P51
FUNCTION xpt2L(a,b, c,d) !直線a~b 直線c~d の交点
LET L1=b-a
LET a_=a/L1
LET c_=c/L1
LET d_=d/L1
LET x=(im(a_)-im(c_))*re(d_-c_)/im(d_-c_)+re(c_)
LET xpt2L=COMPLEX(x,im(a_))*L1
END FUNCTION
SUB LBSEC(a,b, c,d) !直線a~b に垂直で a~b の中点を通る直線 → c~d
LET c=(a+b)/2
LET d=(b-a)*COMPLEX(0,1)+c
END SUB
CALL LBSEC( PR(1),PR(2), a,b) !210 GROFF: L1=LBSEC(PR[1],PR[2])
CALL LBSEC( PR(1),P12, c,d) !211 L2=LBSEC(PR[1],P12)
LET P1=xpt2L(a,b, c,d) !220 P0=L1&L2: R0=DIS(P0,PR[1]) : LET C1=P0,R0
LET R1=ABS(PR(1)-P1)
DRAW circle WITH SCALE(R1)*SHIFT(P1) !221 GRON: C1=C1
CALL LBSEC( PR(2),PR(3), a,b) !230 GROFF: L1=LBSEC(PR[2],PR[3])
CALL LBSEC( PR(2),P23 , c,d) !231 L2=LBSEC(PR[2],P23)
LET P2=xpt2L(a,b, c,d) !240 P0=L1&L2: R0=DIS(P0,PR[2]) : LET C2=P0,R0
LET R2=ABS( PR(2)-P2)
DRAW circle WITH SCALE(R2)*SHIFT(P2) !241 GRON: C2=C2
!
! !250 GROFF: L1=LBSEC(PR[3],PR[4])
! !251 L2=LBSEC(PR[3],P34)
! !260 P0=L1&L2: R0=DIS(P0,PR[3]) : LET C3=P0,R0
! !261 GRON: C3=C3
CALL LBSEC( PR(3),PR(4), a,b)
CALL LBSEC( PR(3),P34 , c,d)
LET P3=xpt2L(a,b, c,d)
LET R3=ABS( PR(3)-P3)
DRAW circle WITH SCALE(R3)*SHIFT(P3)
! !270 GROFF: L1=LBSEC(PR[4],PR[5])
! !271 L2=LBSEC(PR[4],P45)
! !280 P0=L1&L2: R0=DIS(P0,PR[4]) : LET C4=P0,R0
! !281 GRON: C4=C4
CALL LBSEC( PR(4),PR(5), a,b)
CALL LBSEC( PR(4),P45 , c,d)
LET P4=xpt2L(a,b, c,d)
LET R4=ABS( PR(4)-P4)
DRAW circle WITH SCALE(R4)*SHIFT(P4)
! !290 GROFF: L1=LBSEC(PR[5],PR[1])
! !291 L2=LBSEC(PR[5],P51)
! !300 P0=L1&L2: R0=DIS(P0,PR[5]) : LET C5=P0,R0
! !301 GRON: C5=C5
CALL LBSEC( PR(5),PR(1), a,b)
CALL LBSEC( PR(5),P51 , c,d)
LET P5=xpt2L(a,b, c,d)
LET R5=ABS( PR(5)-P5)
DRAW circle WITH SCALE(R5)*SHIFT(P5)
!
! !310 PU=C1&C2 : PV=C2&C3 : PW=C3&C4 : PX=C4&C5
! !311 PY=C5&C1
LET PU=xpt2C(P1,R1, P2,R2)
LET PV=xpt2C(P2,R2, P3,R3)
LET PW=xpt2C(P3,R3, P4,R4)
LET PX=xpt2C(P4,R4, P5,R5)
LET PY=xpt2C(P5,R5, P1,R1)
PLOT POINTS: PU; PV; PW; PX; PY
FUNCTION xpt2C(p0,r0, p1,r1) !円(中心p0,半径r0) と 円(中心p1,半径r1) の
LET p01=p1-p0 !交点２個から、原点に近い方。
LET ux=(r0^2+ABS(p01)^2-r1^2)/(2*ABS(p01))
LET uy=SQR(r0^2-ux^2)
LET u=COMPLEX(ux,uy)
LET p=p0+u*p01/ABS(p01)
LET p_=p0+conj(u)*p01/ABS(p01)
LET xpt2C=p
IF ABS(p_)< ABS(p) THEN LET xpt2C=p_
END FUNCTION
! !320 GROFF: L1=LBSEC(PU,PV) : L2=LBSEC(PU,PX)
! !330 P0=L1&L2: R0=DIS(P0,PU) : LET CT=P0,R0
! !331 GRON: CT=CT
CALL LBSEC( PU,PV, a,b)
CALL LBSEC( PU,PX, c,d)
LET P0=xpt2L(a,b, c,d)
LET R0=ABS( PU-P0)
DRAW circle WITH SCALE(R0)*SHIFT(P0)
!
! !340 LET X,Y=PR[1]: DPTEXT X,Y,"A"
! !350 LET X,Y=PR[2]: DPTEXT X,Y,"B"
! !360 LET X,Y=PR[3]: DPTEXT X,Y,"C"
! !370 LET X,Y=PR[4]: DPTEXT X,Y,"D"
! !380 LET X,Y=PR[5]: DPTEXT X,Y,"E"
! !390 LET X,Y=P12: DPTEXT X,Y,"F"
! !400 LET X,Y=P23: DPTEXT X,Y,"G"
! !410 LET X,Y=P34: DPTEXT X,Y,"H"
! !420 LET X,Y=P45: DPTEXT X,Y,"I"
! !430 LET X,Y=P51: DPTEXT X,Y,"J"
! !440 LET X,Y=PU: DPTEXT X,Y,"U"
! !450 LET X,Y=PV: DPTEXT X,Y,"V"
! !460 LET X,Y=PW: DPTEXT X,Y,"W"
! !470 LET X,Y=PX: DPTEXT X,Y,"X"
! !480 LET X,Y=PY: DPTEXT X,Y,"Y"
! !490 DPTEXT -300, 200, "高田の五点円"
PLOT TEXT,AT PR(1):"A"
PLOT TEXT,AT PR(2):"B"
PLOT TEXT,AT PR(3):"C"
PLOT TEXT,AT PR(4):"D"
PLOT TEXT,AT PR(5):"E"
PLOT TEXT,AT P12:"F"
PLOT TEXT,AT P23:"G"
PLOT TEXT,AT P34:"H"
PLOT TEXT,AT P45:"I"
PLOT TEXT,AT P51:"J"
PLOT TEXT,AT PU:"U"
PLOT TEXT,AT PV:"V"
PLOT TEXT,AT PW:"W"
PLOT TEXT,AT PX:"X"
PLOT TEXT,AT PY:"Y"
PLOT TEXT,AT -300, 200: "高田の五点円"
REM 高田の５点円
REM --- 円に内接する任意の五角形の生成から始める
!
OPTION ARITHMETIC COMPLEX
SET WINDOW -400,400,-400,400
RANDOMIZE
SET TEXT background "opaque"
DIM ANG(5), PR(5)
!
LET R=200
DRAW circle WITH SCALE(R) !５角形の外接円を描く
LET ANG(1)=2*RND
FOR i=2 TO 5
LET ANG(i)=1+2*RND+ANG(i-1) !ANG()= RND が不変なら等しい間隔の、加算値
NEXT i
LET ANG0=2*PI/(ANG(5)+1) !(ANG(5)+1)= 1周分の間隔の総和
FOR i=1 TO 5
LET PR(i)=R*EXP(COMPLEX(0,ANG0*ANG(i))) !PR()= 不規則な、5分割の、円周上の点
NEXT i
!
PLOT LINES: PR(1);PR(2);PR(3);PR(4);PR(5); !５角形と
PLOT LINES: PR(1);PR(3);PR(5);PR(2);PR(4);PR(1) !その対角線を描く
!
LET P12=xpt2L( PR(1),PR(3), PR(2),PR(5)) !P12= 直線PR(1)~PR(3) 直線PR(2)~PR(5) の交点
LET P23=xpt2L( PR(2),PR(4), PR(1),PR(3))
LET P34=xpt2L( PR(3),PR(5), PR(2),PR(4))
LET P45=xpt2L( PR(1),PR(4), PR(3),PR(5))
LET P51=xpt2L( PR(1),PR(4), PR(2),PR(5))
! PLOT POINTS: P12; P23; P34; P45; P51
!
CALL circ3p(PR(1),PR(2),P12, P1,R1) !3点 PR(1),PR(2),P12 を通る円を描き、中心:P1 半径:R1を返す。
CALL circ3p(PR(2),PR(3),P23, P2,R2)
CALL circ3p(PR(3),PR(4),P34, P3,R3)
CALL circ3p(PR(4),PR(5),P45, P4,R4)
CALL circ3p(PR(5),PR(1),P51, P5,R5)
!
LET PU=xpt2C(P1,R1, P2,R2) !PU= 円(中心P1,半径R1) と 円(中心P2,半径R2) の交点
LET PV=xpt2C(P2,R2, P3,R3) ! 交点は２個あるが、原点に近い方１つ返す。
LET PW=xpt2C(P3,R3, P4,R4)
LET PX=xpt2C(P4,R4, P5,R5)
LET PY=xpt2C(P5,R5, P1,R1)
PLOT POINTS: PU; PV; PW; PX; PY
!
CALL circ3p(PU,PV,PX, P0,R0) !3点 PU,PV,PX を通る円を描き、中心:P0 半径:R0を返す。
!
PLOT TEXT,AT PR(1):"A"
PLOT TEXT,AT PR(2):"B"
PLOT TEXT,AT PR(3):"C"
PLOT TEXT,AT PR(4):"D"
PLOT TEXT,AT PR(5):"E"
PLOT TEXT,AT P12:"F"
PLOT TEXT,AT P23:"G"
PLOT TEXT,AT P34:"H"
PLOT TEXT,AT P45:"I"
PLOT TEXT,AT P51:"J"
PLOT TEXT,AT PU:"U"
PLOT TEXT,AT PV:"V"
PLOT TEXT,AT PW:"W"
PLOT TEXT,AT PX:"X"
PLOT TEXT,AT PY:"Y"
PLOT TEXT,AT -300, 200: "高田の五点円"
FUNCTION xpt2L(a,b, c,d) !直線a~b 直線c~d の交点
LET L1=b-a
LET a_=a/L1
LET c_=c/L1
LET d_=d/L1
LET x=(im(a_)-im(c_))*re(d_-c_)/im(d_-c_)+re(c_)
LET xpt2L=COMPLEX(x,im(a_))*L1
END FUNCTION
SUB LBSEC(a,b, c,d) !直線a~b に垂直で a~b の中点を通る直線 → c~d
LET c=(a+b)/2
LET d=(b-a)*COMPLEX(0,1)+c
END SUB
SUB circ3p(u,v,w, C,R) !３点 u,v,w に接する円を描き、中心C 半径R を返す。
CALL LBSEC( u,v, a,b)
CALL LBSEC( u,w, c,d)
LET C=xpt2L(a,b, c,d)
LET R=ABS(u-C)
DRAW circle WITH SCALE(R)*SHIFT(C)
END SUB
FUNCTION xpt2C(p0,r0, p1,r1) !円(中心p0,半径r0) と 円(中心p1,半径r1) の交点
LET p01=p1-p0
LET ux=(r0^2+ABS(p01)^2-r1^2)/(2*ABS(p01))
LET uy=SQR(r0^2-ux^2)
LET u=COMPLEX(ux,uy)
LET p=p0+u*p01/ABS(p01)
LET p_=p0+conj(u)*p01/ABS(p01)
LET xpt2C=p
IF ABS(p_)< ABS(p) THEN LET xpt2C=p_ !交点２個 p p_ から原点に近い方が返り値。
END FUNCTION
DIM AX(3,4) !XYZ軸の形をした図形（3本の方向ベクトル、3本の矢）
DATA 1,0,0 !X
DATA 0,1,0 !Y
DATA 0,0,1 !Z
FOR i=1 TO 3
FOR J=1 TO 3
READ AX(i,J) !x,y,z
LET AX(i,4)=1 !w
NEXT J
NEXT i
DIM BX(8,4) !立方体の8頂点
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
FOR i=1 TO 8
FOR J=1 TO 3
READ BX(i,J) !x,y,z
LET BX(i,4)=1 !w
NEXT J
NEXT i
DIM T(50,4) !(x',y',z',w')=(x,y,z,w)M による座標変換
DIM MA(4,4),MB(4,4), M(4,4)
MAT MA=IDN !図形Aに対する累積された変換
MAT MB=IDN !図形Bに対する累積された変換
DATA "+RX","-RX","+RY","-RY","+RZ","-RZ" !ボタン
DATA "+TX","-TX","+TY","-TY","+TZ","-TZ" !ボタン
DIM BTN1$(6),BTN2$(6)
MAT READ BTN1$
MAT READ BTN2$
DO
SET DRAW mode hidden !ちらつき防止(開始)
CLEAR
MAT T=AX*MA !軸の傾き
CALL button(-2.8,2.8, 0.6,0.3, 6, BTN1$, S,S2) !回転メニュー
SELECT CASE S
CASE 1 !+x
CALL D3ROTATE(RAD(5),T(1,1),T(1,2),T(1,3), M) !5度ずつ
CASE 2 !-x
CALL D3ROTATE(RAD(-5),T(1,1),T(1,2),T(1,3), M)
CASE 3 !+y
CALL D3ROTATE(RAD(5),T(2,1),T(2,2),T(2,3), M)
CASE 4 !-y
CALL D3ROTATE(RAD(-5),T(2,1),T(2,2),T(2,3), M)
CASE 5 !+z
CALL D3ROTATE(RAD(5),T(3,1),T(3,2),T(3,3), M)
CASE 6 !-z
CALL D3ROTATE(RAD(-5),T(3,1),T(3,2),T(3,3), M)
CASE ELSE
MAT M=IDN
END SELECT
MAT MB=MB*M
IF S2=2 THEN !左ボタン押下で軸も回転させる
MAT MA=MA*M
END IF
CALL button(-2.0,0.0, 0.6,0.3, 6, BTN2$, S,S2) !図形の平行移動メニュー
SELECT CASE S
CASE 1 !+x
CALL VEC3NORMALIZE(T(1,1),T(1,2),T(1,3), xx,yy,zz) !方向ベクトル
CASE 2 !-x
CALL VEC3NORMALIZE(-T(1,1),-T(1,2),-T(1,3), xx,yy,zz)
CASE 3 !+y
CALL VEC3NORMALIZE(T(2,1),T(2,2),T(2,3), xx,yy,zz)
CASE 4 !-y
CALL VEC3NORMALIZE(-T(2,1),-T(2,2),-T(2,3), xx,yy,zz)
CASE 5 !+z
CALL VEC3NORMALIZE(T(3,1),T(3,2),T(3,3), xx,yy,zz)
CASE 6 !-z
CALL VEC3NORMALIZE(-T(3,1),-t(3,2),-T(3,3), xx,yy,zz)
CASE ELSE
LET xx=0
LET yy=0
LET zz=0
END SELECT
CALL D3SHIFT(xx*0.05,yy*0.05,zz*0.05, M) !0.05ずつ
MAT MB=MB*M
SET LINE COLOR 4 !X軸
PLOT LINES: 0,0; T(1,1),T(1,2)
PLOT TEXT, AT T(1,1),T(1,2): "x"
SET LINE COLOR 3 !Y軸
PLOT LINES: 0,0; T(2,1),T(2,2)
PLOT TEXT, AT T(2,1),T(2,2): "y"
SET LINE COLOR 2 !Z軸
PLOT LINES: 0,0; T(3,1),T(3,2)
PLOT TEXT, AT T(3,1),T(3,2): "z"
!立方体を描く
MAT T=BX*MB !図形を回転させる
SET LINE COLOR 1
FOR i=1 TO 3 !上面
PLOT LINES: T(i,1),T(i,2); T(i+1,1),T(i+1,2)
NEXT i
PLOT LINES: T(4,1),T(4,2); T(1,1),T(1,2)
FOR i=1 TO 4 !側面の稜線
PLOT LINES: T(i,1),T(i,2); T(i+4,1),T(i+4,2)
NEXT i
FOR i=5 TO 7 !下面
PLOT LINES: T(i,1),T(i,2); T(i+1,1),T(i+1,2)
NEXT i
PLOT LINES: T(8,1),T(8,2); T(5,1),T(5,2)
SET DRAW mode explicit !ちらつき防止(終了)
WAIT DELAY 0.1
LOOP
SUB button(x,y, dx,dy, n, btn$(), s,s2) !左上位置(x,y)、大きさdx,dy、n個のボタン
mouse poll mx,my,left,right !マウスポインタの状態を得る
LET s2=left*2+right !0:なし、1:右、2:左、3:左右
LET s=-1 !マウスポインタが、どのボタンと重なっているか
LET x1=x !左上
LET y1=y
FOR k=1 TO n !タイル貼り
LET x2=x1+dx !右下
LET y2=y1-dy
IF (mx>=MIN(x1,x2) AND mx<=MAX(x1,x2)) AND (my>=MIN(y1,y2) AND my<=MAX(y1,y2)) THEN
LET s=k !k番目のボタン内なら
END IF
EXTERNAL SUB VEC3NORMALIZE(Vx,Vy,Vz, x,y,z) !単位ベクトルへ正規化する
LET l=SQR(Vx*Vx+Vy*Vy+Vz*Vz)
IF l<>0 THEN
LET x=Vx/l
LET y=Vy/l
LET z=Vz/l
END IF
END SUB
EXTERNAL SUB D3ROTATE(a,Vx,Vy,Vz, M(,)) !任意軸（位置ベクトル(Vx,Vy,Vz) ）まわりの回転
CALL VEC3NORMALIZE(Vx,Vy,Vz, x,y,z)
LET c=COS(a)
LET s=SIN(a)
MAT M=ZER
LET M(1,1)=x*x*(1-c)+c
LET M(1,2)=x*y*(1-c)+z*s
LET M(1,3)=z*x*(1-c)-y*s
LET M(2,1)=x*y*(1-c)-z*s
LET M(2,2)=y*y*(1-c)+c
LET M(2,3)=y*z*(1-c)+x*s
LET M(3,1)=z*x*(1-c)+y*s
LET M(3,2)=y*z*(1-c)-x*s
LET M(3,3)=z*z*(1-c)+c
LET M(4,4)=1
END SUB
EXTERNAL SUB D3SCALE(a,b,c, M(,)) !拡大・縮小
MAT M=IDN
LET M(1,1)=a
LET M(2,2)=b
LET M(3,3)=c
END SUB
EXTERNAL SUB D3SHIFT(l,m,n, A(,)) !平行移動
MAT A=IDN
LET A(4,1)=l
LET A(4,2)=m
LET A(4,3)=n
END SUB
前回 ※サブルーチン部分は省略
SET WINDOW -3,3,-3,3 !表示領域
DIM AX(3,4) !XYZ軸の形をした図形（3本の方向ベクトル、3本の矢）
DATA 1,0,0 !X
DATA 0,1,0 !Y
DATA 0,0,1 !Z
FOR i=1 TO 3
FOR J=1 TO 3
READ AX(i,J) !x,y,z
LET AX(i,4)=1 !w
NEXT J
NEXT i
DIM BX(8,4) !立方体の8頂点
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
FOR i=1 TO 8
FOR J=1 TO 3
READ BX(i,J) !x,y,z
LET BX(i,4)=1 !w
NEXT J
NEXT i
DIM T(50,4) !(x',y',z',w')=(x,y,z,w)M による座標変換
DIM M(4,4)
DATA "+RX","-RX","+RY","-RY","+RZ","-RZ" !ボタン
DATA "+TX","-TX","+TY","-TY","+TZ","-TZ" !ボタン
DIM BTN1$(6),BTN2$(6)
MAT READ BTN1$
MAT READ BTN2$
DO
SET DRAW mode hidden !ちらつき防止(開始)
CLEAR
CALL button(-2.8,2.8, 0.6,0.3, 6, BTN1$, S,S2) !回転メニュー
SELECT CASE S
CASE 1 !+x
CALL D3ROTATE(RAD(5),AX(1,1),AX(1,2),AX(1,3), M) !5度ずつ
CASE 2 !-x
CALL D3ROTATE(RAD(-5),AX(1,1),AX(1,2),AX(1,3), M)
CASE 3 !+y
CALL D3ROTATE(RAD(5),AX(2,1),AX(2,2),AX(2,3), M)
CASE 4 !-y
CALL D3ROTATE(RAD(-5),AX(2,1),AX(2,2),AX(2,3), M)
CASE 5 !+z
CALL D3ROTATE(RAD(5),AX(3,1),AX(3,2),AX(3,3), M)
CASE 6 !-z
CALL D3ROTATE(RAD(-5),AX(3,1),AX(3,2),AX(3,3), M)
CASE ELSE
MAT M=IDN
END SELECT
MAT T=BX*M !図形を回転させる
MAT BX=T
IF S2=2 THEN !左ボタン押下で軸も回転させる
MAT T=AX*M
MAT AX=T
END IF
CALL button(-2.0,0.0, 0.6,0.3, 6, BTN2$, S,S2) !図形の平行移動メニュー
SELECT CASE S
CASE 1 !+x
CALL VEC3NORMALIZE(AX(1,1),AX(1,2),AX(1,3), xx,yy,zz) !方向ベクトル
CASE 2 !-x
CALL VEC3NORMALIZE(-AX(1,1),-AX(1,2),-AX(1,3), xx,yy,zz)
CASE 3 !+y
CALL VEC3NORMALIZE(AX(2,1),AX(2,2),AX(2,3), xx,yy,zz)
CASE 4 !-y
CALL VEC3NORMALIZE(-AX(2,1),-AX(2,2),-AX(2,3), xx,yy,zz)
CASE 5 !+z
CALL VEC3NORMALIZE(AX(3,1),AX(3,2),AX(3,3), xx,yy,zz)
CASE 6 !-z
CALL VEC3NORMALIZE(-AX(3,1),-AX(3,2),-AX(3,3), xx,yy,zz)
CASE ELSE
LET xx=0
LET yy=0
LET zz=0
END SELECT
CALL D3SHIFT(xx*0.05,yy*0.05,zz*0.05, M) !0.05ずつ
MAT T=BX*M
MAT BX=T
SET LINE COLOR 4 !X軸
PLOT LINES: 0,0; AX(1,1),AX(1,2)
PLOT TEXT, AT AX(1,1),AX(1,2): "x"
SET LINE COLOR 3 !Y軸
PLOT LINES: 0,0; AX(2,1),AX(2,2)
PLOT TEXT, AT AX(2,1),AX(2,2): "y"
SET LINE COLOR 2 !Z軸
PLOT LINES: 0,0; AX(3,1),AX(3,2)
PLOT TEXT, AT AX(3,1),AX(3,2): "z"
!立方体を描く
SET LINE COLOR 1
FOR i=1 TO 3 !上面
PLOT LINES: BX(i,1),BX(i,2); BX(i+1,1),BX(i+1,2)
NEXT i
PLOT LINES: BX(4,1),BX(4,2); BX(1,1),BX(1,2)
FOR i=1 TO 4 !側面の稜線
PLOT LINES: BX(i,1),BX(i,2); BX(i+4,1),BX(i+4,2)
NEXT i
FOR i=5 TO 7 !下面
PLOT LINES: BX(i,1),BX(i,2); BX(i+1,1),BX(i+1,2)
NEXT i
PLOT LINES: BX(8,1),BX(8,2); BX(5,1),BX(5,2)
!x^3+Ax^2+□x+□=0、x^4+Px^3+Qx^2+□x+□=0
LET A=5
LET P=11
LET Q=-4
LET N=(-A)^2-2*(Q-(-A)*(-P+A))
PRINT "N=";N
FOR x=0 TO SQR(N/3) !0≦x≦[√(n/3)]、x≦y≦[√(n/2)]
FOR y=x TO SQR(N/2)
!2次方程式Z^2+(x^2+y^2-n)=0を解の公式を使って解く
LET D=0^2-4*1*(x^2+y^2-N) !判別式
LET DD=SQR(D)
IF DD=INT(DD) THEN !整数解
LET Z=(-0+DD)/(2*1) !解の公式
IF y<=Z THEN PRINT x;y;Z
END IF
NEXT y
NEXT x
END
LET A=5 !x^3+Ax^2+□x+□=0、x^4+Px^3+Qx^2+□x+□=0
LET P=11
LET Q=-4
LET B=Q-(-A)*(-P+A) !f(x)=x^3+Ax^2+Bx+□
PRINT B
CALL Solve2EQU(3,2*A,B, x1,x2,K) !f'(x)
PRINT K; x1;x2 !debug
LET xx1=IP(x1) !βの範囲
LET xx2=IP(x2)
PRINT xx1;xx2
!f(x)=(x-β){x^2+(β+A)x+(β^2+Aβ+B)}と因数分解される。
!x^2+(β+A)x+(β^2+Aβ+B)=0の2つの解はα,γ
!判別式D=(β+A)^2-4(β^2+Aβ+B)=(-3)β^2+(-2A)β+(A^2-4B)=-3(β+A/3)^2+(A^2-4B)-A^2/3
DEF G(X)=(AA*X+BB)*X+CC !判別式Dは、上に凸
LET AA=-3
LET BB=-2*A
LET CC=A^2-4*B
LET x3=-A/3 !軸
PRINT x3 !debug
IF x3>=xx1 AND x3<=xx2 THEN LET MX=G(x3) ELSE LET MX=MAX(G(xx1),G(xx2)) !最大値
LET MN=MIN(G(xx1),G(xx2)) !最小値
PRINT MN;MX
DEF F(X)=((X+A)*X+B)*X
FOR T=CEIL(SQR(MN)) TO SQR(MX) !Dが平方数、すなわちD=t^2
PRINT T
CALL Solve2EQU(AA,BB,CC-T*T, x1,x2,K)
PRINT K; x1;x2 !βの候補
PRINT -F(x1); -F(x2) !C=-f(β)
PRINT (-(x1+A)-T)/2; (-(x1+A)+T)/2 !α
PRINT (-(x2+A)-T)/2; (-(x2+A)+T)/2 !γ
NEXT T
END
EXTERNAL SUB Solve2Equ(a,b,c, x1,x2,K) !2次方程式 Ax^2+Bx+Cx=0、A≠0 の解
IF a=0 THEN
PRINT "2次の係数が0なので、2次方程式ではありません。"; a;b;c
LET K=-1
ELSE
LET D=b^2-4*a*c !判別式
IF D>=0 THEN !実数解なら
LET x1=(-b-SQR(D))/(2*a) !1つの解
IF D=0 THEN !重解なら
!!!!!!!!!!LET x2=x1
LET K=1
ELSE
LET x2=(-b+SQR(D))/(2*a) !もう1つの解
LET K=2
END IF
ELSE !虚数解なら
LET x1=-b/(2*a) !実部
LET x2=SQR(-D)/(2*a) !虚部
LET K=0
END IF
END IF
END SUB
FOR AA=IP(x2) TO MIN(x1,-A/3) !αを固定する
CALL Solve2EQU(1,AA+A,AA^2+A*AA+B, BB,CC,K) !β,γは、x^2+(α+A)x+(α^2+Aα+B)=0の解
IF BB=INT(BB) AND CC=INT(CC) THEN !整数なら
IF BB>=AA AND BB<=CC THEN !α≦β≦γなら
PRINT AA;BB;CC
PRINT -AA*BB*CC !□
END IF
END IF
NEXT AA
END
EXTERNAL SUB Solve2Equ(a,b,c, x1,x2,K) !2次方程式 Ax^2+Bx+Cx=0、A≠0 の解
IF a=0 THEN
PRINT "2次の係数が0なので、2次方程式ではありません。"; a;b;c
LET K=-1
ELSE
LET D=b^2-4*a*c !判別式
IF D>=0 THEN !実数解なら
LET x1=(-b-SQR(D))/(2*a) !1つの解
IF D=0 THEN !重解なら
!!!!!!!!!!LET x2=x1
LET K=1
ELSE
LET x2=(-b+SQR(D))/(2*a) !もう1つの解
LET K=2
END IF
ELSE !虚数解なら
LET x1=-b/(2*a) !実部
LET x2=SQR(-D)/(2*a) !虚部
LET K=0
END IF
END IF
END SUB
DRAW disk WITH SCALE(0.1)*SHIFT(OA)
PLOT TEXT ,AT OA: "A"
DRAW disk WITH SCALE(0.1)*SHIFT(OB)
PLOT TEXT ,AT OB: "B"
DRAW disk WITH SCALE(0.1)*SHIFT(OC)
PLOT TEXT ,AT OC: "C"
PLOT LINES: OA; OB; OC; OA !三角形ABCを描く
LET OD=(OA+OB)/2 !辺ABの中点
LET OE=(OB+OC)/2 !辺BCの中点
LET OF=(OC+OA)/2 !辺CAの中点
DRAW disk WITH SCALE(0.1)*SHIFT(OD)
DRAW disk WITH SCALE(0.1)*SHIFT(OE)
DRAW disk WITH SCALE(0.1)*SHIFT(OF)
LET P=-(OA+OB+OC) !f(x)=x^3+Px^2+Qx+R
LET Q=OA*OB+OB*OC+OC*OA
PRINT P; Q; -OA*OB*OC
CALL Solve2EQU(3,2*P,Q, x1,x2) !f'(x)の解
PRINT x1; x2
DRAW disk WITH SCALE(0.1)*SHIFT(x1)
DRAW disk WITH SCALE(0.1)*SHIFT(x2)
IF x1-x2=0 THEN !円になる場合
LET m=0
ELSE
LET m=arg(x1-x2) !傾き(-π,π]
END IF
LET C=(x1+x2)/2 !中心 Re(x1)
LET F=ABS(x1-x2)/2 !焦点F(f,0)、F'(-f,0)とする
LET A=(ABS(x1-OD)+ABS(x2-OD))/2 !2焦点までの距離の和2aの楕円は
LET B=SQR(A^2-F^2) !標準形(x/a)^2+(y/b)^2=1である
DRAW Elipse(A,B) WITH ROTATE(m)*SHIFT(C) !それを中心Cでm傾ける
PRINT F; A;B
PRINT C; (OA+OB+OC)/3 !重心
END
EXTERNAL SUB Solve2EQU(A,B,C, x1,x2) !2次方程式Ax^2+Bx+C=0を解く
OPTION ARITHMETIC COMPLEX !複素平面
LET D=B^2-4*A*C
LET x1=(-B-SQR(D))/(2*A)
LET x2=(-B+SQR(D))/(2*A) !共役
END SUB
EXTERNAL PICTURE Elipse(A,B) !標準形楕円を描く x^2/a^2+y^2/b^2=1
OPTION ARITHMETIC COMPLEX !複素平面
FOR T=0 TO 360 !弧を描く
LET X=A*COS(RAD(T))
LET Y=B*SIN(RAD(T))
PLOT LINES: X,Y;
NEXT T
PLOT LINES
DRAW disk WITH SCALE(0.1)*SHIFT(0,0) !中心を描く
IF A>=B THEN !焦点を描く
LET C=SQR(A^2-B^2)
DRAW disk WITH SCALE(0.1)*SHIFT( C,0)
DRAW disk WITH SCALE(0.1)*SHIFT(-C,0)
ELSE
LET C=SQR(B^2-A^2)
DRAW disk WITH SCALE(0.1)*SHIFT(0, C)
DRAW disk WITH SCALE(0.1)*SHIFT(0,-C)
END IF
END PICTURE
!多桁整数÷整数
DATA 8,8,8,8,8, 8,8,8,8,8, 8,8,8,8,8, 8,8,8,8,8 !10進法表記 ※上の位から
LET R=0
FOR i=1 TO 20 !筆算
READ A !各位の数字
LET R=MOD(R*10+A,37)
NEXT i
PRINT R
END
2進モード（浮動小数点による数値計算）
LET S=0
FOR A=0.001 TO 0.009 STEP 0.001
LET S=S+A
NEXT A
PRINT S
END
や
LET S=0
LET A=0.001
DO WHILE A<=0.009
LET S=S+A
LET A=A+0.001
LOOP
PRINT S
END
は、最後の0.009が加味されないので、正しく計算できません。
-------------------------------------------
問題 鴎友学園女子中学 2008年
友子さんは算数のテストを5回受けました。得点はすべて整数でした。
このとき、次の問に答えなさい。
(1) 次の①～⑥のうち、5回の平均点として考えられないものをすべて答えなさい。
また、その理由を簡単に説明しなさい。
① 66.4 ② 68.7 ③ 75.3 ④ 78.5 ⑤ 87.4 ⑥ 88.2
(2) 最高点が95点、最低点が60点だったとき、(1)で残ったもののうち、
5回の平均点として考えられないものをすべて答えなさい。
また、その理由を簡単に説明しなさい。
答え
!(1)
DATA 66.4, 68.7, 75.3, 78.5, 87.4, 88.2
FOR i=1 TO 6
READ A
LET T=A*5
IF T<>INT(T) THEN PRINT i; A !合計点が整数にならないので
NEXT i
END
!(2)
DATA 66.4, 68.7, 75.3, 78.5, 87.4, 88.2
FOR i=1 TO 6
READ A
LET T=A*5
IF T=INT(T) THEN !合計点が整数になる
LET W=(T-(95+60))/3 !最高点の95点と最低点の60点を除いたときの平均点
IF W<60 OR W>95 THEN PRINT i; A !最低点より小さい、最高点より大きい
END IF
NEXT i
END
LET N=13 !枚数
DIM A(N) !並び
MAT A=ZER
LET P=0 !位置
FOR K=1 TO N !番号
LET i=0
DO WHILE i<2 !p番目の位置から2番目の位置を求める
LET P=P+1 !p=[1,N]
IF P>N THEN LET P=1
IF A(P)=0 THEN LET i=i+1 !埋まっている場合、スキップする
LOOP
LET A(P)=K
NEXT K
MAT PRINT A; !結果を表示する
END
LET N=13 !枚数
DIM A(N) !並び
MAT A=ZER
LET P=0 !位置
FOR K=1 TO N !番号
LET i=0
DO WHILE i<K !p番目の位置から2番目の位置を求める
LET P=P+1 !p=[1,N]
IF P>N THEN LET P=1
IF A(P)=0 THEN LET i=i+1 !埋まっている場合、スキップする
LOOP
LET A(P)=K
NEXT K
MAT PRINT A; !結果を表示する
END
PUBLIC NUMERIC C !場合の数
LET C=0
LET N=4 !枚数
DIM A(N) !並び n!通り
FOR i=1 TO N !最初の並び 1,2,3,…,n
LET A(i)=i
NEXT i
CALL perm(A,1)
END
EXTERNAL SUB perm(a(),n) !1からnまでの順列を辞書式順序で生成する
LET m=UBOUND(a)
IF n=m THEN
!!!MAT PRINT a; !debug
CALL stub(m,a)
ELSE
FOR i=n TO m
LET t=a(i)
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)
FOR j=n TO i-1
LET a(j)=a(j+1)
NEXT j
LET a(i)=t
NEXT i
END IF
END SUB
EXTERNAL SUB stub(N,A()) !シミュレーション
DIM B(N),Q(N)
MAT B=A !copy it
LET M=N
LET P=0
LET K=0
DO WHILE K<N !1からnまで
DO !束の一番上
LET P=P+1 !p=[1,N]
IF P>N THEN LET P=1
LOOP UNTIL B(P)>0
LET K=K+1
IF B(P)=K THEN !一致するカード
LET Q(N-M+1)=K !場の並び
LET B(P)=-1 !取り除く
LET M=M-1
IF M=0 THEN !カードがすべてなくなったなら
LET C=C+1
PRINT "No.";C
MAT PRINT A; !元の束（左側が上とする）
MAT PRINT Q; !場の並び
PRINT
EXIT DO
END IF
LET K=0
END IF
LOOP
END SUB
LET t0=TIME
DATA 1,2,3,4,5,6,7,8,9,10,11,12,13
!!DATA 2,1,3,4,5,6,7,8,9,10,11,12,13
!!DATA 3,1,2,4,5,6,7,8,9,10,11,12,13
!!DATA 4,1,2,3,5,6,7,8,9,10,11,12,13
!!DATA 5,1,2,3,4,6,7,8,9,10,11,12,13 !済み
!!DATA 6,1,2,3,4,5,7,8,9,10,11,12,13 !済み
!!DATA 7,1,2,3,4,5,6,8,9,10,11,12,13 !済み
!!DATA 8,1,2,3,4,5,6,7,9,10,11,12,13
!!DATA 9,1,2,3,4,5,6,7,8,10,11,12,13
!!DATA 10,1,2,3,4,5,6,7,8,9,11,12,13
!!DATA 11,1,2,3,4,5,6,7,8,9,10,12,13
!!DATA 12,1,2,3,4,5,6,7,8,9,10,11,13
!!DATA 13,1,2,3,4,5,6,7,8,9,10,11,12
DIM A(13)
MAT READ A
PUBLIC NUMERIC C !場合の数
LET C=0
CALL perm(A,2) !※先頭を固定する
PRINT C; "通り"
PRINT TIME-t0
END
EXTERNAL SUB perm(a(),n) !1からnまでの順列を生成する（辞書式でない）
LET m=UBOUND(a)
IF n=m THEN !すべて並んだなら
!!!MAT PRINT a; !debug
LET X=0
CALL stub2(1,m,a, X)
IF X-1=4 THEN !回数 ※ ←←←←←←←←←←
LET C=C+1
PRINT "No.";C
MAT PRINT A; !束の並び（左側が上とする）
END IF
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
EXTERNAL SUB stub2(L,N,A(), X) !シミュレーション
DIM B(N),Q(N)
MAT B=A !copy it
LET M=N
LET P=0
LET K=0
DO WHILE K<N !1からnまで数える
DO !束の一番上
LET P=P+1 !p=[1,N]
IF P>N THEN LET P=1
LOOP UNTIL B(P)>0
LET K=K+1
IF B(P)=K THEN !一致するカード
LET Q(N-M+1)=K !場の並び
LET B(P)=-1 !取り除く
LET M=M-1
IF M=0 THEN !カードがすべてなくなったなら
CALL stub2(L+1,N,Q, X) !連続で可能かどうか
EXIT SUB
END IF
LET K=0
END IF
LOOP
LET X=L !L回目がNG
END SUB
n=11までなら、n!通りを直接処理しても現実的なので、次のようになります。
LET N=11 !枚数 ※ ←←←←←←←←←←
DIM A(N) !並び 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,1)
PRINT C; "通り"
END
SET WINDOW -11,5,-8,8 !表示領域を設定する ※調整が必要である
DRAW grid !XY座標
!放物線y=Ax^2+Bx+C=A(x+B/(2A))^2-(B^2-4AC)/(4A)
LET A=1 !放物線 y=x^2
LET B=0
LET C=0
CALL gcDRAWFNC2(A,B,C,-11,5)
CALL gcFNC2POINT(A,B,C, X1,Y1) !点P1
SUB gcFNC2POINT(A,B,C, PX,PY) !放物線の頂点を得る
LET PX=-B/(2*A)
LET PY=-(B^2-4*A*C)/(4*A)
DRAW disk WITH SCALE(0.1)*SHIFT(PX,PY)
PRINT "頂点=";PX;PY
END SUB
LET P=-1 !放物線 y=-(x+8)^2-1
LET Q=-16
LET R=-65
CALL gcDRAWFNC2(P,Q,R,-11,5)
CALL gcFNC2POINT(P,Q,R, X2,Y2) !点P2
!●放物線の相似
CALL gcDIVIDE(X1,Y1,X2,Y2,P,-A, xx,yy) !外分する点
DRAW disk WITH SCALE(0.1)*SHIFT(xx,yy)
PRINT xx;yy
!●相似の中心点と放物線との距離を考える。
LET S=2*A^2 !λ^3の係数
LET T=A*(4 +4*A*yy +B^2 -4*A*C) !λ^2の係数
LET U=2*(1 +4*A*yy +B^2 -4*A*C) !λ^1の係数
LET V=4*(yy -A*xx^2 -B*xx -C) !λ^0の係数
PRINT S;T;U;V !debug
EXTERNAL SUB gcDRAWFNC2(A,B,C,d1,d2) !2次関数y=Ax^2+Bx+C、x=[d1,d2]を描く
OPTION ARITHMETIC COMPLEX !複素数平面
IF A=0 THEN
PRINT "A=0なので、2次関数ではありません。"; A;B;C
ELSE
ASK WINDOW x1,x2,y1,y2
LET x1=MAX(x1,d1)
LET x2=MIN(x2,d2)
FOR x=x1 TO x2 STEP (x2-x1)/2^8 !※折れ線による
PLOT LINES: x,(A*x+B)*x+C;
NEXT x
PLOT LINES
END IF
END SUB
!点A(x1,y1),B(x2,y2)を結ぶ線分ABをm:nに分ける点（内分・外分する点）
EXTERNAL SUB gcDIVIDE(x1,y1,x2,y2,m,n, xx,yy)
OPTION ARITHMETIC COMPLEX !複素数平面
LET xx=(n*x1+m*x2)/(m+n) !※外分m:nは、m:(-n)となる
LET yy=(n*y1+m*y2)/(m+n)
END SUB
!複素数版 EQU.LIB より抜粋
EXTERNAL SUB Solve3Equ(P,Q,R, x1,x2,x3)!代数方程式 x^3+Px^2+Qx+R=0 の解
OPTION ARITHMETIC COMPLEX !複素数を扱う
!カルダノ（Cardano）の方法より
LET a=-P^2/3+Q !x=y-P/3として、2次の項のない3次方程式y^3+a*y+b=0に変形する
LET b=2*P^3/27-P*Q/3+R
LET t=b^2/4+a^3/27 !(b/2)^2+(a/3)^3（判別式D=27*b^2+4*a^3と同値）
LET z1=-b/2+SQR(t) !3乗根を求める
LET z2=-b/2-SQR(t)
IF t>=0 THEN !1実根と2虚根
LET u=SGN(z1)*ABS(z1)^(1/3) !実数の範囲
LET v=SGN(z2)*ABS(z2)^(1/3)
ELSE !3実根（不還元の場合）
LET u=EXP(LOG(z1)/3) !複素数の範囲
LET v=EXP(LOG(z2)/3)
END IF
!!!PRINT u*v; -a/3 !debug
LET w=(-1+SQR(-3))/2 !ω=(-1+√(-3))/2は1の原始3乗根の1つ
LET y1=u+v !y^3+a*y+b=0の解
LET y2=w*u+w^2*v
LET y3=w^2*u+w*v
LET x1=y1-P/3 !x=y-P/3
LET x2=y2-P/3
LET x3=y3-P/3
END SUB
width=1260
height=640
SET BITMAP SIZE width, height
reft=0
right=width
bottom=0
top=height
'左端，右端，下端，上端
set window left,right,bottom,top
'描画エリアの背景色着色範囲設定
set area color 1 !'黒
plot area : left,bottom;left,top;right,top;right,bottom
'--------------------------------------------------------------
xbase=100 '画面表示x起点
ybase=100 '画面表示y起点
randomize
n=8 '球の数
dim x(n),y(n) '球のx、y座標
dim vx(n),vy(n) '球のx、y成分速度
wb=400 '枠の幅
hb=400 '枠の高さ
r=30 '球の半径
dt=0.2 'サンプリングタイム
'初期位置設定
for i=0 to n-1
xi=rnd*wb*10
yi=rnd*hb*10
if xi>0+r and xi<wb-r and yi>0+r and yi<hb-r then
x(i)=xi
y(i)=yi
else
i=i-1
end if
next i
'初期速度設定
for i=0 to n-1
vx(i)=(rnd-0.5)*20*2
vy(i)=(rnd-0.5)*20*2
next i
do
'位置の更新
for i=0 to n-1
x(i)=x(i)+vx(i)*dt
y(i)=y(i)+vy(i)*dt
'枠との衝突処理
if x(i)<0+r then '左の枠に衝突
vx(i)=-vx(i)
x(i)=r
end if
if x(i)>wb-r then
vx(i)=-vx(i) '右の枠に衝突
x(i)=wb-r
end if
if y(i)<0+r then '下の枠に衝突
vy(i)=-vy(i)
y(i)=r
end if
if y(i)>hb-r then '上の枠に衝突
vy(i)=-vy(i)
y(i)=hb-r
end if
'球同士の衝突
call cal1 'これが、上手くいきませんです
next i
'球の表示
set draw mode hidden
line(0,0)-(width,height),1,bf
for i=0 to n-1
col=mod(i,6)+2
circle(xbase+x(i),ybase+y(i)),r,col,,,,f
next i
'枠の表示
set line width 4
line(xbase,ybase)-(xbase+wb,ybase+hb),6,b
set draw mode explicit
loop
'-----------------------------------------------------
sub cal1
'球同士の衝突
if n>=2 then
for j=0 to n-1
if i<>j then
l=sqr( (x(i)-x(j))^2+(y(i)-y(j))^2 ) '球ij間距離
v=sqr( vx(i)^2+vy(i)^2 ) '球iの衝突前の速度
if l<=2*r and v>0 and l>0 then '衝突判定と、v=0、l=0の回避
cosa=(x(i)-x(j))/l '球ij衝突時の球ijの中心線とx軸の成す角度aのcos値
sina=(y(i)-y(j))/l '球ij衝突時の球ijの中心線とx軸の成す角度aのsin値
cosc=vx(i)/v '球iの衝突時の球i速度ベクトルがx軸の成す角度cのcos値
sinc=vy(i)/v '球iの衝突時の球i速度ベクトルがx軸の成す角度cのcos値
cosd=cosa*sinc+cosc*sina '衝突時の球ijの接触点法線と球iの速度ベクトルと成す角度dのcos値
cosac=cosa*cosc-sina*sinc '角度a+cのcos値
cosdc=cosc*cosd-sinc*sind '角度d+cのcos値
sindc=cosc*sind+cosd*sinc '角度d+cのsin値
!十進BASICの書式になっています。
!--------------------------------------------------------------
!lark12_long
!
! 反射.bas
!
! 各球の質量は１、接触摩擦はなし
!
! H26-07-10
!
!
LET width=641 !1260
LET HEIGHT=641 !640
SET BITMAP SIZE width, HEIGHT
!
LET left=0
LET right=width
LET bottom=0
LET top=HEIGHT
!
!左端，右端，下端，上端
SET WINDOW left,right, bottom,top
!
!描画エリアの背景色着色範囲設定
SET AREA COLOR 1 !黒
PLOT AREA : left,bottom; left,top; right,top; right,bottom
!--------------------------------------------------------------
LET xbase=100 !画面表示x起点
LET ybase=100 !画面表示y起点
!
RANDOMIZE
!
LET n=8 !球の数
OPTION BASE 0
DIM x(n),y(n), en(6,6),xb(n),yb(n) !球のx、y座標
DIM vx(n),vy(n) !球のx、y成分速度
!
LET wb=400 !枠の幅
LET hb=400 !枠の高さ
!
LET r=30 !球の半径
LET dt=0.2 !サンプリングタイム
!
!初期位置設定
LET i=0
DO
LET u=INT(6*RND)
LET v=INT(6*RND)
IF en(u,v)=0 THEN
LET x(i)=r*(1.15+2.2*u)
LET y(i)=r*(1.15+2.2*v)
LET en(u,v)=1
LET i=i+1
END IF
LOOP UNTIL n<=i
!
!初期速度設定
FOR i=0 TO n-1
LET vx(i)=(RND-0.5)*20*2
LET vy(i)=(RND-0.5)*20*2
NEXT i
!
!位置の更新
DO
FOR i=0 TO n-1
LET xb(i)=x(i)
LET yb(i)=y(i)
LET x(i)=x(i)+vx(i)*dt
LET y(i)=y(i)+vy(i)*dt
!
!枠との衝突処理
IF x(i)< 0+r THEN !左の枠に衝突
LET vx(i)=-vx(i)
LET x(i)=r
END IF
IF x(i)> wb-r THEN
LET vx(i)=-vx(i) !右の枠に衝突
LET x(i)=wb-r
END IF
IF y(i)< 0+r THEN !下の枠に衝突
LET vy(i)=-vy(i)
LET y(i)=r
END IF
IF y(i)> hb-r THEN !上の枠に衝突
LET vy(i)=-vy(i)
LET y(i)=hb-r
END IF
!
!球同士の衝突
CALL cal1
NEXT i
SET DRAW mode hidden
!
!画面消去
!line(0,0)-(width,height),1,bf
SET AREA COLOR 1
PLOT AREA :0,0; width,0; width,HEIGHT; 0,HEIGHT
!
!球の表示
FOR i=0 TO n-1
!col=mod(i,6)+2
!circle(xbase+x(i),ybase+y(i)),r,col,,,,f
SET AREA COLOR MOD(i,6)+2
DRAW disk WITH SCALE(r)*SHIFT(xbase+x(i),ybase+y(i))
NEXT i
!
!枠の表示
SET LINE width 4
!line(xbase,ybase)-(xbase+wb,ybase+hb),6,b
SET LINE COLOR 6
PLOT LINES: xbase,ybase; xbase+wb,ybase; xbase+wb,ybase+hb; xbase,ybase+hb; xbase,ybase
!
SET DRAW mode explicit
WAIT DELAY .01
mouse poll mox,moy,mlb,mrb
LOOP UNTIL 0< mrb
!----------------------------------
! 球同士の衝突( 球表面の摩擦係数０)
!----------------------------------
SUB cal1
IF n>=2 THEN
FOR j=0 TO n-1
IF i<>j THEN
LET lb=SQR( (xb(i)-xb(j))^2+(yb(i)-yb(j))^2) !過去の球(i)(j)間距離
LET l=SQR( ( x(i) -x(j))^2+( y(i) -y(j))^2) !現在の球(i)(j)間距離
IF l<=2*r AND l< lb THEN !距離と、その増減で、衝突判定
LET vi=SQR( vx(i)^2+vy(i)^2 ) !球(i)の速度の絶対値
LET vj=SQR( vx(j)^2+vy(j)^2 ) !球(j)の速度の絶対値
LET cosnx=(x(j)-x(i))/l !球(i)中心を始点とする接触点法線ベクトルの角度 nx のcos 値
LET sinnx=(y(j)-y(i))/l !球(i)中心を始点とする接触点法線ベクトルの角度 nx のsin 値
!--
LET cosix=vx(i)/vi !球(i)速度ベクトルの角度 ix の cos 値
LET sinix=vy(i)/vi !球(i)速度ベクトルの角度 ix の sin 値
LET cosjx=vx(j)/vj !球(j)速度ベクトルの角度 jx の cos 値
LET sinjx=vy(j)/vj !球(j)速度ベクトルの角度 jx の sin 値
LET cos_in=cosix*cosnx+sinix*sinnx !cos(ix-nx)
LET sin_in=sinix*cosnx-cosix*sinnx !sin(ix-nx)
LET cos_jn=cosjx*cosnx+sinjx*sinnx !cos(jx-nx)
LET sin_jn=sinjx*cosnx-cosjx*sinnx !sin(jx-nx)
!--
LET v_in=vi*cos_in !vi*cos(ix-nx) 接触点法線方向の、球(i)速度ベクトル
LET v_jn=vj*cos_jn !vj*cos(jx-nx) 接触点法線方向の、球(j)速度ベクトル
swap v_in, v_jn !接触点法線方向の、球(i)(j)速度ベクトル入替り
LET v_it=vi*sin_in !vi*sin(ix-nx) 接触点接線方向の、球(i)速度ベクトル
LET v_jt=vj*sin_jn !vj*sin(jx-nx) 接触点接線方向の、球(j)速度ベクトル
!--
LET vx(i)= v_in*cosnx -v_it*sinnx !球(i)速度ベクトルの x 成分速度
LET vy(i)= v_in*sinnx +v_it*cosnx !球(i)速度ベクトルの y 成分速度
LET vx(j)= v_jn*cosnx -v_jt*sinnx !球(j)速度ベクトルの x 成分速度
LET vy(j)= v_jn*sinnx +v_jt*cosnx !球(j)速度ベクトルの y 成分速度
END IF
END IF
NEXT j
END IF
END SUB
!----------------------------------
! 球同士の衝突( 球表面の摩擦係数０)
!----------------------------------
SUB cal1
IF n>=2 THEN
FOR j=0 TO n-1
IF i<>j THEN
LET lb=SQR( (xb(i)-xb(j))^2+(yb(i)-yb(j))^2) !過去の球(i)(j)間距離
LET l=SQR( ( x(i) -x(j))^2+( y(i) -y(j))^2) !現在の球(i)(j)間距離
IF l<=2*r AND l< lb THEN !距離と、その増減で、衝突判定
LET nx=(x(j)-x(i))/l !球(i)中心を始点とする接触点法線ベクトル x 成分
LET ny=(y(j)-y(i))/l ! 〃 〃 y 成分
!--
LET v_in=nx*vx(i)+ny*vy(i) !接触点法線方向の、球(i)速度ベクトル内積
LET v_jn=nx*vx(j)+ny*vy(j) ! 〃 球(j)速度ベクトル内積
swap v_in, v_jn ! 〃 球(i)(j)速度ベクトル入替り
LET v_it=-ny*vx(i)+nx*vy(i) ! 〃 接線方向の、球(i)速度ベクトル内積
LET v_jt=-ny*vx(j)+nx*vy(j) ! 〃 球(j)速度ベクトル内積
!--
LET vx(i)= nx*v_in -ny*v_it !球(i)速度ベクトルの x 成分
LET vy(i)= ny*v_in +nx*v_it ! 〃 y 成分
LET vx(j)= nx*v_jn -ny*v_jt !球(j)速度ベクトルの x 成分
LET vy(j)= ny*v_jn +nx*v_jt ! 〃 y 成分
END IF
END IF
NEXT j
END IF
END SUB
!---------------------------------------------------------------
! 球同士の衝突( 球表面の摩擦係数０、同質量)
!
! ※法線単位ベクトルの内外向き、
! 接線単位ベクトルの回転向きは、(i)(j)が共用 する限り何れも可。
!---------------------------------------------------------------
SUB cal1
IF n>=2 THEN
FOR j=0 TO n-1
IF i<>j THEN
LET lb=SQR( (xb(i)-xb(j))^2+(yb(i)-yb(j))^2) !過去の球(i)(j)間距離
LET l=SQR( ( x(i) -x(j))^2+( y(i) -y(j))^2) !現在の球(i)(j)間距離
IF l<=2*r AND l< lb THEN !距離と、その増減で、衝突判定
LET nx=(x(i)-x(j))/l !接触点 法線単位ベクトル x 成分
LET ny=(y(i)-y(j))/l ! 〃 y 成分
LET tx=-ny ! 接線単位ベクトル x 成分
LET ty= nx ! 〃 y 成分
!--
LET v_in=nx*vx(i)+ny*vy(i) !接触点 法線方向の 球(i)速度ベクトル内積
LET v_jn=nx*vx(j)+ny*vy(j) ! 〃 球(j)速度ベクトル内積
swap v_in, v_jn ! 〃 球(i)(j)速度 入替り
LET v_it=tx*vx(i)+ty*vy(i) ! 接線方向の 球(i)速度ベクトル内積
LET v_jt=tx*vx(j)+ty*vy(j) ! 〃 球(j)速度ベクトル内積
!--
LET vx(i)= nx*v_in +tx*v_it !球(i)速度ベクトルの x 成分
LET vy(i)= ny*v_in +ty*v_it ! 〃 y 成分
LET vx(j)= nx*v_jn +tx*v_jt !球(j)速度ベクトルの x 成分
LET vy(j)= ny*v_jn +ty*v_jt ! 〃 y 成分
END IF
END IF
NEXT j
END IF
END SUB
FUNCTION f(Ed,θ)
LET IS=SQR((Am/SQR(2)*Ed*SIN(φ))^2+(Vs-Am/SQR(2)*Ed*COS(φ))^2)/Xs
LET f=Ed^2/R -Vs*IS*COS(θ)
END FUNCTION
FUNCTION g(Ed,θ)
LET IS=SQR((Am/SQR(2)*Ed*SIN(φ))^2+(Vs-Am/SQR(2)*Ed*COS(φ))^2)/Xs
LET g=(Am/SQR(2)*Ed*SIN(θ+φ)-Xs*IS) -Vs*SIN(θ)
END FUNCTION
LET Am=0.5 !0＜Am≦1
LET φ=PI/18 !0＜φ＜π/2
LET R=100
LET Xs=PI
LET Vs=100
LET d=0.01 !∂
LET xi=0 !初期値
LET yi=0
FOR i=1 TO 50 !漸化式を収束させる
DIM x(2) !⊿x、⊿y
!連立１次方程式Jx=bを得る
DIM J(2,2)
LET fxy=f(xi,yi) !前進差分で近似して求める（平均変化率）
LET J(1,1)=(f(xi+d,yi)-fxy)/d !J=(∂f/∂x ∂f/∂y) ヤコビ(Jacobi)行列
LET J(1,2)=(f(xi,yi+d)-fxy)/d ! (∂g/∂x ∂g/∂y)
LET gxy=g(xi,yi)
LET J(2,1)=(g(xi+d,yi)-gxy)/d
LET J(2,2)=(g(xi,yi+d)-gxy)/d
DIM b(2)
LET b(1)=-fxy !b=(-f)
LET b(2)=-gxy ! (-g)
!---------- ※ガウスの消去法などで２元連立１次方程式を解く
DIM Ji(2,2) !逆行列を求める Full BASIC版
MAT Ji=INV(J) !正則なら
MAT x=Ji*b
!----------
LET xi=xi+x(1) !Xi+1=Xi+⊿x
LET yi=yi+x(2) !Yi+1=Yi+⊿y
DIM WU(2),WD(2),WL(2),WR(2) !壁の表面の向き（法線ベクトル）
DATA 0,-1, 0,1, 1,0, -1,0
MAT READ WU !上
MAT READ WD !下
MAT READ WL !左
MAT READ WR !右
LET UP=10 !壁の位置（原点からの符号つき距離） ※
LET DW=-10
LET LF=-6
LET RT=14
SET WINDOW LF,RT,DW,UP !表示領域
PUBLIC NUMERIC E !跳ね返り係数
LET E=1 !弾性衝突のとき
!---------------------------------------
LET N=5 !ボールの個数 ※
LET R=0.5 !ボールの半径 ※
DIM X(N),Y(N) !位置(x,y)
DATA -4,0, -3,0, -2,0, 3,0, 4,0 ! ※
FOR i=1 TO N
READ X(i),Y(i)
NEXT i
DIM VX(N),VY(N) !移動速度vのX,Y成分
DATA 2,0, 2,0, 2,0, 0,0, 0,0 ! ※
FOR i=1 TO N
READ VX(i),VY(i)
NEXT i
!---------------------------------------
LET dt=0.1 !⊿t
DO
SET DRAW mode hidden !ちらつき防止の開始
CLEAR
DRAW grid !座標
FOR i=1 TO N !ボールを描く
DRAW disk WITH SCALE(R)*SHIFT(X(i),Y(i))
NEXT i
SET DRAW mode explicit !ちらつき防止の終了
!ボールの移動
DO
LET HIT=0
FOR i=1 TO N !ボールiとボールjとの衝突を確認する
DIM OA(2),AV(2), OB(2),BV(2)
LET OA(1)=X(i) !copy it
LET OA(2)=Y(i)
LET AV(1)=VX(i)
LET AV(2)=VY(i)
IF DISTL(OA,WU,UP)<=R AND DOT(AV,WU)<0 THEN !表面から上壁に衝突するとき
CALL HIT_WALL(AV,WU)
LET HIT=-1
END IF
IF DISTL(OA,WD,-DW)<=R AND DOT(AV,WD)<0 THEN !下壁
CALL HIT_WALL(AV,WD)
LET HIT=-1
END IF
IF DISTL(OA,WL,-LF)<=R AND DOT(AV,WL)<0 THEN !左壁
CALL HIT_WALL(AV,WL)
LET HIT=-1
END IF
IF DISTL(OA,WR,RT)<=R AND DOT(AV,WR)<0 THEN !右壁
CALL HIT_WALL(AV,WR)
LET HIT=-1
END IF
FOR J=i+1 TO N !組み合わせによる
DIM AB(2),Vd(2)
LET OB(1)=X(J) !copy it
LET OB(2)=Y(J)
MAT AB=OB-OA !相対位置
IF DOT(AB,AB)<=(2*R)^2 THEN !衝突するとき
LET BV(1)=VX(J)
LET BV(2)=VY(J)
MAT Vd=AV-BV !ボールjを停止させた相対速度
IF DOT(AB,Vd)>0 THEN !近づくとき（離れていくときは除く）
CALL HIT_BALL(OA,AV, OB,BV, R)
LET VX(J)=BV(1) !衝突後
LET VY(J)=BV(2)
LET HIT=-2
END IF
END IF
NEXT J
LET VX(i)=AV(1) !衝突後
LET VY(i)=AV(2)
NEXT i
!!!PRINT HIT !debug
LOOP UNTIL HIT=0 !衝突がなくなるまで
FOR i=1 TO N
LET X(i)=X(i)+dt*VX(i) !移動させる
LET Y(i)=Y(i)+dt*VY(i)
NEXT i
WAIT DELAY 0.05 !アニメーションの速度 ※調整の必要性あり
LOOP
END
EXTERNAL SUB HIT_WALL(AV(), NW()) !ボールと壁との非弾性衝突による結果
DIM dV(2)
LET w=(1+E)*DOT(AV,NW) !壁の法線単位ベクトルnw
MAT dV=(w)*NW
MAT AV=AV-dV
END SUB
EXTERNAL SUB HIT_BALL(OA(),AV(), OB(),BV(), R) !同じ質量の2つのボールの非弾性衝突による結果
DIM OP(2),OC(2),V(2),dV(2)
MAT OP=OB-OA !衝突箇所の位置 ↑c
MAT OC=(1/2)*OP
MAT V=BV-AV !相対速度 v2-v1
LET w=(1+E)*DOT(OC,V)/(2*R*R) !w=(1+E)(↑c・(↑v2-↑v1))/(2r^2)
MAT dV=(w)*OC !ボールAの速度変化量
MAT AV=AV+dV !速度を変化させる
MAT BV=BV-dV
END SUB
EXTERNAL SUB VecNormalize(V()) !正規化する（長さが1の単位ベクトル）
LET L=SQR(DOT(V,V))
IF L<>0 THEN MAT V=(1/L)*V
END SUB
EXTERNAL FUNCTION DISTL(P(),N(),D) !点pと直線↑n・↑P+d=0との距離
LET DISTL=ABS(DOT(N,P)+D)/SQR(DOT(N,N))
END FUNCTION
●その２ 2次元（平面）の衝突
1000桁モード、2進モードでは、うまく動作します。
変更箇所
!---------------------------------------
LET N=2 !ボールの個数 ※
LET R=1 !ボールの半径 ※
DIM X(N),Y(N) !位置(x,y)
LET X(1)=-4
LET Y(1)=0
LET X(2)=SQR(3)
LET Y(2)=-1
DIM VX(N),VY(N) !移動速度vのX,Y成分
DATA 2,0, 0,0 ! ※
FOR i=1 TO N
READ VX(i),VY(i)
NEXT i
DEF F(X)=-1/SQR(3)*X !軌跡
DEF G(X)=SQR(3)*X
!---------------------------------------
LET dt=0.1 !⊿t
DO
SET DRAW mode hidden !ちらつき防止の開始
CLEAR
DRAW grid !座標
PLOT LINES: LF,F(LF); RT,F(RT)
PLOT LINES: LF,G(LF); RT,G(RT)
FOR i=1 TO N !ボールを描く
DRAW disk WITH SCALE(R)*SHIFT(X(i),Y(i))
NEXT i
!
!------------------------------------------------------
OPTION ARITHMETIC COMPLEX !複素数モード
LET wb=400 !枠の幅
LET hb=400 !枠の高さ
SET bitmap SIZE wb+101, hb+101
SET WINDOW -50,wb+50, -50,hb+50 !左端,右端, 下端,上端
!------------------------------------------------------
RANDOMIZE
!
LET n=8 !球の数
OPTION BASE 0
DIM p(n), pb(n) !球の座標の 現在と、１つ手前
DIM vp(n) !球の速度
DIM en(10,10) !初期位置設定の重複検査
!
SET COLOR MIX(0) 0,0,0 !CLEAR 文で黒にする。
LET dt=0.2 !サンプリングタイム
LET r=30 !球の半径
!
!-----
LET i=0
LET wb1=INT((wb-4)/(2*r+2))
LET hb1=INT((hb-4)/(2*r+2))
DO
LET u=INT(wb1*RND)
LET v=INT(hb1*RND)
IF en(u,v)=0 THEN
LET p(i)=COMPLEX(r+3+(2*r+2)*u, r+3+(2*r+2)*v) !初期位置設定
LET en(u,v)=1
LET i=i+1
END IF
LOOP UNTIL n<=i
!-----
FOR i=0 TO n-1
LET vp(i)=COMPLEX((RND-0.5)*40, (RND-0.5)*40) !初期速度設定
NEXT i
!-----
DO
FOR i=0 TO n-1
LET pb(i)=p(i)
LET p(i)=p(i)+vp(i)*dt
!---
IF re(p(i))< r AND re(vp(i))< 0 THEN !左の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(r,im(p(i)))
ELSEIF wb-r< re(p(i)) AND 0< re(vp(i)) THEN !右の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(wb-r,im(p(i)))
ELSEIF im(p(i))< r AND im(vp(i))< 0 THEN !下の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),r)
ELSEIF hb-r< im(p(i)) AND 0< im(vp(i)) THEN !上の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),hb-r)
END IF
!---
CALL cal1 !球同士の衝突
NEXT i
!
SET DRAW mode hidden !表示画、更新の一時停止。
CLEAR !全画面、黒で、塗りつぶす
FOR i=0 TO n-1
SET AREA COLOR MOD(i,6)+2
DRAW disk WITH SCALE(r)*SHIFT(p(i)) !球の表示
NEXT i
SET LINE width 4
SET LINE COLOR 6
PLOT LINES: 0; wb; COMPLEX(wb,hb); COMPLEX(0,hb); 0 !枠の表示
SET DRAW mode explicit !表示画、常時更新の再開。
!
WAIT DELAY .01 !節電。削除 → かなり速くなる
mouse poll mox,moy,mlb,mrb
LOOP UNTIL 0< mrb
!-----------------------------------------------------------
! 球同士の衝突( 球表面の摩擦係数０、同質量)
!
! ※法線単位ベクトルの内外向き、
! 接線単位ベクトルの回転向きは、(i)(j)が共用 する限り任意。
!-----------------------------------------------------------
SUB cal1
IF 2<=n THEN
FOR j=0 TO n-1
IF i<>j THEN
LET lb=ABS( pb(i)-pb(j)) !過去の球(i)(j)間距離
LET l=ABS( p(i) -p(j) ) !現在の球(i)(j)間距離
IF l<=2*r AND l< lb THEN !距離と、その増減で、衝突判定
LET np=(p(j)-p(i))/l !接触点 法線単位ベクトル
LET tp=np*COMPLEX(0,1) ! 〃 接線単位ベクトル
!--
LET v_in=re(conj(np)*vp(i)) !接触点 法線方向の 球(i)速さ(+-)
LET v_jn=re(conj(np)*vp(j)) ! 〃 球(j)速さ(+-)
swap v_in, v_jn ! 〃 球(i)(j)速さ 入替り
LET v_it=re(conj(tp)*vp(i)) ! 接線方向の 球(i)速さ(+-)
LET v_jt=re(conj(tp)*vp(j)) ! 〃 球(j)速さ(+-)
!--
LET vp(i)= v_in*np +v_it*tp !球(i)速度ベクトル
LET vp(j)= v_jn*np +v_jt*tp !球(j)速度ベクトル
END IF
END IF
NEXT j
END IF
END SUB
!----------------------------------
! 球同士の衝突( 球表面の摩擦係数０)
!----------------------------------
SUB cal1
IF n>=2 THEN
FOR j=0 TO n-1
IF i<>j THEN
LET lb=SQR( (xb(i)-xb(j))^2+(yb(i)-yb(j))^2) !過去の球(i)(j)間距離
LET l=SQR( ( x(i) -x(j))^2+( y(i) -y(j))^2) !現在の球(i)(j)間距離
IF l<=2*r AND l< lb THEN !距離と、その増減で、衝突判定
LET vi=SQR( vx(i)^2+vy(i)^2 ) !球(i)の速度の絶対値
LET vj=SQR( vx(j)^2+vy(j)^2 ) !球(j)の速度の絶対値
LET cosnx=(x(j)-x(i))/l !球(i)中心を始点とする接触点法線ベクトルの角度 nx のcos 値
LET sinnx=(y(j)-y(i))/l !球(i)中心を始点とする接触点法線ベクトルの角度 nx のsin 値
!--
LET cosix=vx(i)/vi !球(i)速度ベクトルの角度 ix の cos 値
LET sinix=vy(i)/vi !球(i)速度ベクトルの角度 ix の sin 値
LET cosjx=vx(j)/vj !球(j)速度ベクトルの角度 jx の cos 値
LET sinjx=vy(j)/vj !球(j)速度ベクトルの角度 jx の sin 値
LET cos_in=cosix*cosnx+sinix*sinnx !cos(ix-nx)
LET sin_in=sinix*cosnx-cosix*sinnx !sin(ix-nx)
LET cos_jn=cosjx*cosnx+sinjx*sinnx !cos(jx-nx)
LET sin_jn=sinjx*cosnx-cosjx*sinnx !sin(jx-nx)
!--
LET v_in=vi*cos_in !vi*cos(ix-nx) 接触点法線方向の、球(i)速度ベクトル
LET v_jn=vj*cos_jn !vj*cos(jx-nx) 接触点法線方向の、球(j)速度ベクトル
swap v_in, v_jn !接触点法線方向の、球(i)(j)速度ベクトル入替り
LET v_it=vi*sin_in !vi*sin(ix-nx) 接触点接線方向の、球(i)速度ベクトル
LET v_jt=vj*sin_jn !vj*sin(jx-nx) 接触点接線方向の、球(j)速度ベクトル
!--
LET vx(i)= v_in*cosnx -v_it*sinnx !球(i)速度ベクトルの x 成分速度
LET vy(i)= v_in*sinnx +v_it*cosnx !球(i)速度ベクトルの y 成分速度
LET vx(j)= v_jn*cosnx -v_jt*sinnx !球(j)速度ベクトルの x 成分速度
LET vy(j)= v_jn*sinnx +v_jt*cosnx !球(j)速度ベクトルの y 成分速度
END IF
END IF
NEXT j
END IF
END SUB
OPTION ARITHMETIC NATIVE
LET MAXLINE=1000
LET MAXSIZE=100
DIM VARIABLE_STRING$(MAXSIZE),VARIABLE_PUBLIC$(MAXSIZE)
DIM C$(MAXSIZE),C2$(4),A$(MAXLINE),VARIABLE_ARGUMENT$(MAXSIZE),VARIABLE_ARRAY$(MAXSIZE)
DIM EXPRESSION$(MAXSIZE,3),VA_DIM(MAXSIZE),VA_INIT$(MAXSIZE),VARIABLE_DIM$(MAXSIZE)
DIM VARIABLE_FOR$(MAXSIZE)
PUBLIC STRING FUNCNAME$(100),FUNCNAMENOARG$(100),VARIABLE$(100),TYPE$
PUBLIC NUMERIC FC,VA_COUNT
FILE GETOPENNAME F$,"BASファイル|*.BAS"
IF F$="" THEN STOP
OPEN #1:NAME F$
CALL CPRINT("// Converted file "&F$)
CALL CPRINT("")
CALL CPRINT("#include <iostream>")
CALL CPRINT("using namespace std;")
LET SETPREC$=" setprecision(15) << " !'マニピュレータ 15桁表示
LET TYPE$="double " !'10進、2進モード(double型)
FOR I=1 TO MAXLINE !'インクルードファイル設定
LINE INPUT #1, IF MISSING THEN EXIT FOR:A$(I)
CALL SETUP(A$(I)) !'コマンド等を大文字化
IF A$(I)(1:1)="&" THEN !'行継続
LET A$(I)(1:1)=""
FOR J=LEN(A$(I-1)) TO 1 STEP -1
IF A$(I-1)(J:J)="&" THEN
LET A$(I-1)(J:J)=TRIM$(A$(I))
LET A$(I)=""
EXIT FOR
END IF
NEXT J
END IF
IF POS(A$(I),"OPTION ARITHMETIC COMPLEX")>0 AND OPT=0 THEN
CALL CPRINT("#include <complex>")
LET TYPE$="complex <double> " !'複素数型
LET OPT=1
END IF
IF POS(A$(I),"OPTION ARITHMETIC DECIMAL_HIGH")>0 AND OPT=0 THEN
CALL CPRINT("#include <boost/multiprecision/cpp_dec_float.hpp>")
!'CALL CPRINT("#include <boost/math/constants/constants.hpp>") !'PI値
CALL CPRINT("using namespace boost::multiprecision;")
CALL CPRINT("typedef number<cpp_dec_float<1000> > big_float;") !'浮動小数1000桁型
LET SETPREC$=" setprecision(1001) << " !'マニピュレータ 1001桁表示
LET TYPE$="big_float "
LET OPT=1
END IF
IF POS(A$(I),"OPTION ARITHMETIC RATIONAL")>0 AND OPT=0 THEN
CALL CPRINT("#include <boost/multiprecision/cpp_int.hpp>")
CALL CPRINT("using namespace boost::multiprecision;")
!'LET TYPE$="cpp_int " !'任意精度整数型
LET TYPE$="cpp_rational " !'任意精度有理数型
!' CALL CPRINT("#include <boost/rational.hpp>")
!' LET TYPE$="rational <int> " !'有理数型
LET OPT=1
END IF
IF POS(A$(I),"OPEN")>0 AND LITERAL(A$(I),"OPEN")=0 AND INCLUDEOPEN=0 THEN
LET INCLUDEOPEN=1
CALL CPRINT("#include <fstream>")
END IF
RESTORE
DO
READ IF MISSING THEN EXIT DO:X$
LET S$=X$(1:LEN(X$)-1)&" ("
IF (POS(A$(I),X$)>0 AND LITERAL(A$(I),X$)=0 OR POS(A$(I),S$)>0 AND LITERAL(A$(I),S$)=0) AND INCLUDEMATH=0 THEN
LET INCLUDEMATH=1
CALL CPRINT("#include <cmath>")
EXIT DO
END IF
LOOP
DATA "ABS(","ACOS(","ASIN(","ATN(","ANGLE(","CSC(","COS(","COSH(","COT(","CEIL(","EXP(","FP(","IP(","INT("
DATA "LOG(","LOG2(","LOG10(","MOD(","REMAINDER(","SIN(","SINH(","SEC(","SQR("
DATA "TAN(","TANH(","TRUNCATE(","^"
DATA "ACSC(","ASEC(","ACOT(","ATANH(","ASINH(","ACOSH(","ASECH(","ACSCH(","ACOTH(","CSCH(","COTH(","CBRT(","ERF(","ERFC("
DATA "LGAMMA(","GAMMA(","HYPOT(","J0(","J1(","JN(","SECH(","Y0(","Y1(","YN("
IF POS(A$(I),"$")>0 AND INCLUDESTR=0 THEN
LET INCLUDESTR=1
CALL CPRINT("#include <string>")
CALL CPRINT("#include <sstream>")
IF INCLUDERND=0 THEN CALL CPRINT("#include <cstdlib>")
END IF
IF ((POS(A$(I),"RANDOMIZE")>0 AND LITERAL(A$(I),"RANDOMIZE")=0) OR (POS(A$(I),"TIME$")=0 AND POS(A$(I),"TIME")>0 AND LITERAL(A$(I),"TIME")=0)) AND INCLUDERND=0 THEN
LET INCLUDERND=1
IF INCLUDESTR=0 THEN CALL CPRINT("#include <cstdlib>")
CALL CPRINT("#include <ctime>")
END IF
NEXT I
LET MAXLINE=I
CLOSE #1
IF TYPE$="double " OR TYPE$="complex <double> " THEN CALL CPRINT("#include <iomanip>")
IF OPT=1 OR INCLUDEOPEN=1 OR INCLUDEMATH=1 OR INCLUDESTR=1 OR INCLUDERND=1 THEN CALL CPRINT("")
LET PROTOTYPE=1
FOR I=1 TO MAXLINE !'プロトタイプ宣言
LET X$=A$(I)
IF POS(X$,"DECLARE")=0 AND POS(X$,"END")=0 AND POS(X$,"EXIT")=0 AND POS(X$,"(,)")=0 AND POS(X$,"(,,)")=0 AND POS(X$,"EXTERNAL")=1 THEN
IF POS(X$,"FUNCTION ")>0 AND LITERAL(X$,"FUNCTION ")=0 THEN
CALL COMMAND_FUNCTION(X$)
LET FL=1
END IF
IF POS(X$,"SUB ")>0 AND LITERAL(X$,"SUB ")=0 THEN
CALL COMMAND_SUB(X$)
LET FL=1
END IF
END IF
NEXT I
IF FL=1 THEN CALL CPRINT("")
LET PROTOTYPE=0
FOR I=1 TO MAXLINE !'以下、関数定義(インライン関数)
IF POS(A$(I),"ROUND(")>0 AND FL_ROUND=0 THEN
CALL CPRINT("inline double round(double x,double n) {") !'関数オーバーロード
CALL CPRINT("return floor(x*pow(10,n)+.5)/pow(10,n);")
CALL CPRINT("}")
CALL CPRINT("inline double round(double x) {") !'関数オーバーロード
CALL CPRINT("return floor(x+.5);")
CALL CPRINT("}")
LET FL_ROUND=1
END IF
IF (POS(A$(I),"SGN(")>0 OR POS(A$(I),"IP(")>0 OR POS(A$(I),"FP(")>0 OR POS(A$(I),"TRUNCATE(")>0) AND FL_SGN=0 THEN
CALL CPRINT("inline double sgn(double x) {")
CALL CPRINT("if (x>0) return 1.0;")
CALL CPRINT("if (x<0) return -1.0;")
CALL CPRINT("return 0;")
CALL CPRINT("}")
CALL CPRINT("inline double ip(double x) {")
CALL CPRINT("return sgn(x)*floor(abs(x));")
CALL CPRINT("}")
CALL CPRINT("inline double fp(double x) {")
CALL CPRINT("return x-ip(x);")
CALL CPRINT("}")
CALL CPRINT("inline double truncate(double x,double n) {")
CALL CPRINT("return ip(x*pow(10.0,(int)n))/pow(10.0,(int)n);")
CALL CPRINT("}")
!'CALL CPRINT("inline double remainder(double x,double y) {")
!'CALL CPRINT("return x-y*ip(x/y);")
!'CALL CPRINT("}")
LET FL_SGN=1
END IF
IF POS(A$(I),"ANGLE(")>0 AND FL_ANGLE=0 THEN
CALL CPRINT("inline double angle(double x,double y) {")
CALL CPRINT("return atan2(y,x);")
CALL CPRINT("}")
LET FL_ANGLE=1
END IF
IF POS(A$(I),"ASECH(")>0 AND FL_ASECH=0 THEN
CALL CPRINT("inline double asech(double x) {")
CALL CPRINT("return log((sqrt(1.0-x*x)+1.0)/x);")
CALL CPRINT("}")
LET FL_ASECH=1
END IF
IF POS(A$(I),"ACSCH(")>0 AND FL_ACSCH=0 THEN
CALL CPRINT("inline double acsch(double x) {")
CALL CPRINT("return log((sgn(x)*sqrt(x*x+1.0)+1.0)/x);")
CALL CPRINT("}")
LET FL_ACSCH=1
END IF
IF POS(A$(I),"ACOTH(")>0 AND FL_ACOTH=0 THEN
CALL CPRINT("inline double acoth(double x) {")
CALL CPRINT("return log((x+1.0)/(x-1.0))/2.0;")
CALL CPRINT("}")
LET FL_ACOTH=1
END IF
IF POS(A$(I),"FACT(")>0 AND FL_FACT=0 THEN
CALL CPRINT("inline double fact(double x) {")
CALL CPRINT("if (x<=1.0) return 1.0;")
CALL CPRINT("return fact(x-1)*x;")
CALL CPRINT("}")
LET FL_FACT=1
END IF
IF POS(A$(I),"PERM(")>0 AND FL_PERM=0 THEN
CALL CPRINT("inline double perm(double n,double r) {")
!'CALL CPRINT("return fact(n)/fact(n-r);")
CALL CPRINT("double p=1.0;")
CALL CPRINT("for (int i=1;i<=r;i++)")
CALL CPRINT("p*=n-i+1.0;")
CALL CPRINT("return p;")
CALL CPRINT("}")
LET FL_PERM=1
END IF
IF POS(A$(I),"COMB(")>0 AND FL_COMB=0 THEN
CALL CPRINT("inline double comb(double n,double r) {")
!' CALL CPRINT("return perm(n,r)/fact(r);")
CALL CPRINT("double p=1.0;")
CALL CPRINT("for(int i=1;i<=r;i++)")
CALL CPRINT("p*=(n-i+1.0)/(double)i;")
CALL CPRINT("return p;")
CALL CPRINT("}")
LET FL_COMB=1
END IF
IF (POS(A$(I),"GCD(")>0 OR POS(A$(I),"LCM(")>0) AND FL_GCD=0 THEN
CALL CPRINT("inline double gcd(double m,double n) {")
CALL CPRINT("if (n==0) return m;")
CALL CPRINT("return gcd(n,fmod(m,n));")
CALL CPRINT("}")
CALL CPRINT("inline double lcm(double m,double n) {")
CALL CPRINT("return m*n/gcd(m,n);")
CALL CPRINT("}")
LET FL_GCD=1
END IF
!'IF POS(A$(I),"MAX(")>0 AND FL_MAX=0 THEN
!' CALL CPRINT("template <typename T>")
!' CALL CPRINT("inline T tmax(T x , T y) {")
!' CALL CPRINT("if(x>y) return x;")
!' CALL CPRINT("return y;")
!' CALL CPRINT("}")
!' LET FL_MAX=1
!'END IF
!'IF POS(A$(I),"MIN(")>0 AND FL_MIN=0 THEN
!' CALL CPRINT("template <typename T>")
!' CALL CPRINT("inline T tmin(T x , T y) {")
!' CALL CPRINT("if(x<y) return x;")
!' CALL CPRINT("return y;")
!' CALL CPRINT("}")
!' LET FL_MIN=1
!'END IF
IF POS(A$(I),"BITOR(")>0 AND FL_BITOR=0 THEN
CALL CPRINT("inline int bit_or(double x,double y) {")
CALL CPRINT("return (int)x|(int)y;")
CALL CPRINT("}")
LET FL_BITOR=1
END IF
IF POS(A$(I),"BITAND(")>0 AND FL_BITAND=0 THEN
CALL CPRINT("inline int bit_and(double x,double y) {")
CALL CPRINT("return (int)x&(int)y;")
CALL CPRINT("}")
LET FL_BITAND=1
END IF
IF POS(A$(I),"BITXOR(")>0 AND FL_BITXOR=0 THEN
CALL CPRINT("inline int bit_xor(double x,double y) {")
CALL CPRINT("return (int)x^(int)y;")
CALL CPRINT("}")
LET FL_BITXOR=1
END IF
IF POS(A$(I),"BITNOT(")>0 AND FL_BITNOT=0 THEN
CALL CPRINT("inline int bit_not(double x) {")
CALL CPRINT("return ~(int)x;")
CALL CPRINT("}")
LET FL_BITNOT=1
END IF
IF POS(A$(I),"BITIMP(")>0 AND FL_BITIMP=0 THEN
CALL CPRINT("inline int bit_imp(double x,double y) {")
CALL CPRINT("return ~(int)x|(int)y;")
CALL CPRINT("}")
LET FL_BITIMP=1
END IF
IF POS(A$(I),"BVAL(")>0 AND FL_BVAL=0 THEN
!' CALL CPRINT("inline int bval(string x,int n) {")
!' CALL CPRINT("if (n==16) x="&CHR$(34)&"0x"&CHR$(34)&"+x;")
!' CALL CPRINT("if (n==8) x="&CHR$(34)&"0"&CHR$(34)&"+x;")
!' CALL CPRINT("return atoi(x.c_str());")
!' CALL CPRINT("}")
CALL CPRINT("inline int bval(string x,int n) {")
CALL CPRINT("int y=0,a;")
CALL CPRINT("string s="&CHR$(34)&"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"&CHR$(34)&";")
CALL CPRINT("for (int i=0;i<x.size();i++) {")
CALL CPRINT("x[i]=toupper(x[i]);")
CALL CPRINT("a=s.find(x[i],0);")
CALL CPRINT("y=y*n+a;")
CALL CPRINT("}")
CALL CPRINT("return y;")
CALL CPRINT("}")
LET FL_BVAL=1
END IF
IF POS(A$(I),"VAL(")>0 AND POS(A$(I),"BVAL(")=0 AND FL_VAL=0 THEN
CALL CPRINT("inline double val(string x) {")
CALL CPRINT("return atof(x.c_str());")
CALL CPRINT("}")
LET FL_VAL=1
END IF
IF POS(A$(I),"UBOUND(")>0 AND FL_UBOUND=0 THEN
CALL CPRINT("template <typename TYPE, size_t N>")
CALL CPRINT("inline size_t ubound(const TYPE (&)[N]) {")
CALL CPRINT("return N;")
CALL CPRINT("}")
LET FL_UBOUND=1
END IF
IF POS(A$(I),"SUBSTR$(")>0 AND FL_SUBSTR=0 THEN
CALL CPRINT("inline string substr(string x,double m,double n) {")
CALL CPRINT("return x.substr((int)m-1,(int)n);")
CALL CPRINT("}")
LET FL_SUBSTR=1
END IF
IF POS(A$(I),"BSTR$(")>0 AND POS(A$(I),"SUBSTR$(")=0 AND FL_BSTR=0 THEN
!' CALL CPRINT("inline string bstr(double x,int n) {")
!' CALL CPRINT("ostringstream stream;")
!' CALL CPRINT("if (n==16) stream << hex << (int)x;")
!' CALL CPRINT("else if (n==8) stream << oct << (int)x;")
!' CALL CPRINT("else stream << dec << (int)x;")
!' CALL CPRINT("cout << dec;") !'マニピュレータ設定を10進法に戻す
!' CALL CPRINT("return stream.str();")
!' CALL CPRINT("}")
CALL CPRINT("inline string bstr(double x,int n) {")
CALL CPRINT("string a="&CHR$(34)&"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"&CHR$(34)&",b;")
CALL CPRINT("int i;")
CALL CPRINT("while (x!=0) {")
CALL CPRINT("i=fmod((int)x,n);")
CALL CPRINT("b=a[i]+b;")
CALL CPRINT("x=floor(x/n);")
CALL CPRINT("}")
CALL CPRINT("return b;")
CALL CPRINT("}")
LET FL_BSTR=1
END IF
IF POS(A$(I),"STR$(")>0 AND POS(A$(I),"SUBSTR$(")=0 AND POS(A$(I),"BSTR$(")=0 AND FL_STR=0 THEN
CALL CPRINT("inline string str(double x) {")
CALL CPRINT("ostringstream stream;")
CALL CPRINT("stream << x;")
CALL CPRINT("return stream.str();")
CALL CPRINT("}")
LET FL_STR=1
END IF
IF POS(A$(I),"POS(")>0 AND FL_POS=0 THEN
CALL CPRINT("inline int pos(string x,string y) {") !'関数オーバーロード
CALL CPRINT("return x.find(y,0)+1;")
CALL CPRINT("}")
CALL CPRINT("inline int pos(string x,string y,double n) {") !'関数オーバーロード
CALL CPRINT("return x.find(y,(int)n)+1;")
CALL CPRINT("}")
LET FL_POS=1
END IF
IF POS(A$(I),"REPEAT$(")>0 AND FL_REPEAT=0 THEN
CALL CPRINT("inline string repeat(string a,double n) {")
CALL CPRINT("string x;")
CALL CPRINT("for(int i=0;i<n;i++)")
CALL CPRINT("x+=a;")
CALL CPRINT("return x;")
CALL CPRINT("}")
LET FL_REPEAT=1
END IF
IF POS(A$(I),"SPC(")>0 AND FL_SPC=0 THEN
CALL CPRINT("inline string spc(int n) {")
CALL CPRINT("string x;")
CALL CPRINT("for (int i=0;i<n;i++)")
CALL CPRINT("x+="&CHR$(34)&" "&CHR$(34)&";")
CALL CPRINT("return x;")
CALL CPRINT("}")
LET FL_SPC=1
END IF
!'IF POS(A$(I),"TAB(")>0 AND FL_TAB=0 THEN
!' CALL CPRINT("inline string tab(int n) {")
!' CALL CPRINT("string x;")
!' CALL CPRINT("for (int i=0;i<n;i++)")
!' CALL CPRINT("x+="&CHR$(34)&" "&CHR$(34)&";")
!' CALL CPRINT("return x;")
!' CALL CPRINT("}")
!' LET FL_TAB=1
!'END IF
IF POS(A$(I),"LTRIM$(")>0 AND FL_LTRIM=0 THEN
CALL CPRINT("inline string ltrim(string x) {")
CALL CPRINT("int i;")
CALL CPRINT("for (i=0;i<x.size();i++)")
CALL CPRINT("if(x.substr(i,1)!="&CHR$(34)&" "&CHR$(34)&") break;")
CALL CPRINT("return x.substr(i);")
CALL CPRINT("}")
LET FL_LTRIM=1
END IF
IF POS(A$(I),"RTRIM$(")>0 AND FL_RTRIM=0 THEN
CALL CPRINT("inline string rtrim(string x) {")
CALL CPRINT("int i;")
CALL CPRINT("for (i=x.size();i>0;i--)")
CALL CPRINT("if(x.substr(i,1)!="&CHR$(34)&" "&CHR$(34)&") break;")
CALL CPRINT("return x.substr(0,i);")
CALL CPRINT("}")
LET FL_RTRIM=1
END IF
IF POS(A$(I),"ORD(")>0 AND FL_ORD=0 THEN
CALL CPRINT("inline int ord(string x) {")
CALL CPRINT("return (int)x[0];")
CALL CPRINT("}")
LET FL_ORD=1
END IF
IF POS(A$(I),"CHR$(")>0 AND FL_CHR=0 THEN
CALL CPRINT("inline string chr(char x) {")
CALL CPRINT("return string(1,x);")
CALL CPRINT("}")
LET FL_CHR=1
END IF
IF POS(A$(I),"UCASE$(")>0 AND FL_UCASE=0 THEN
CALL CPRINT("inlne string ucase(string x) {")
CALL CPRINT("string s;")
CALL CPRINT("for(int i=0;i<x.size();i++)")
CALL CPRINT("s+=toupper(x[i]);")
CALL CPRINT("return s;")
CALL CPRINT("}")
LET FL_UCASE=1
END IF
IF POS(A$(I),"LCASE$(")>0 AND FL_LCASE=0 THEN
CALL CPRINT("inline string lcase(string x) {")
CALL CPRINT("string s;")
CALL CPRINT("for(int i=0;i<x.size();i++)")
CALL CPRINT("s+=tolower(x[i]);")
CALL CPRINT("return s;")
CALL CPRINT("}")
LET FL_LCASE=1
END IF
IF POS(A$(I),"LEFT$(")>0 AND FL_LEFT=0 THEN
CALL CPRINT("inline string left(string x,double n) {")
CALL CPRINT("return x.substr(x.size()-(int)n,(int)n);")
CALL CPRINT("}")
LET FL_LEFT=1
END IF
IF POS(A$(I),"RIGHT$(")>0 AND FL_RIGHT=0 THEN
CALL CPRINT("inline string right(string x,double n) {")
CALL CPRINT("return x.substr(0,(int)n);")
CALL CPRINT("}")
LET FL_RIGHT=1
END IF
IF POS(A$(I),"MID$(")>0 AND FL_MID=0 THEN
CALL CPRINT("inline string mid(string x,double m,double n) {")
CALL CPRINT("return x.substr((int)m-1,(int)m+(int)n-1);")
CALL CPRINT("}")
LET FL_MID=1
END IF
!'IF POS(A$(I),"SWAP ")>0 AND FL_SWAP=0 THEN
!' CALL CPRINT("template <typename T>")
!' CALL CPRINT("inline void cswap(T &x,T &y) {")
!' CALL CPRINT("T z;")
!' CALL CPRINT("z=x;x=y;y=z;")
!' CALL CPRINT("}")
!' LET FL_SWAP=1
!'END IF
IF POS(A$(I),"EPS(")>0 AND FL_EPS=0 THEN
CALL CPRINT("inline double eps(x) {")
CALL CPRINT("if (x==0) return 1e-99;")
CALL CPRINT("if (x>0 && x<10) return 1e-14;")
CALL CPRINT("return fmax(pow(10,floor(log10(abs(x))-14)),1e-99);")
CALL CPRINT("}")
LET FL_EPS=1
END IF
IF POS(A$(I),"DEF ")>0 AND LITERAL(A$(I),"DEF ")=0 THEN
LET X$=A$(I)
IF POS(X$,"!")>0 AND LITERAL(X$,"!")=0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"!"))
IF POS(X$,"REM ")>0 AND LITERAL(X$,"REM ")=0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"REM "))
IF X$<>"" THEN
IF POS(X$,"(")=0 THEN
LET FNAME$=TRIM$(BETWEENSTRING$(X$,"DEF ","="))
ELSE
LET FNAME$=TRIM$(BETWEENSTRING$(X$,"DEF ","("))
END IF
LET FNAME$=LCASE$(TRANSRESERVED$(FNAME$))
IF POS(FNAME$,"$")>0 THEN LET FNAME$=TRANSFORM$(FNAME$,"$","")
LET FC=FC+1
LET FUNCNAME$(FC)=FNAME$
IF POS(X$,"(")>0 THEN
LET BETWEEN$=BETWEENSTRING$(X$,"(",")")
LET BETWEEN$=TRIM$(LCASE$(TRANSRESERVED$(BETWEEN$)))
ELSE
LET BETWEEN$=""
LET FUNCNAMENOARG$(FC)=FNAME$&"()"
END IF
LET BEHIND$=BEHINDSTRING$(X$,"=")
LET BEHIND$=TRANSRESERVED$(BEHIND$)
LET BEHIND$=TRIM$(LCASE$(TRANSFUNC$(BEHIND$)))
IF POS(BETWEEN$,",")=0 THEN
IF BETWEEN$="" THEN
CALL CPRINT("inline "&TYPE$&FNAME$&"(void) {")
ELSE
CALL CPRINT("inline "&TYPE$&FNAME$&"("&TYPE$&BETWEEN$&") {")
END IF
ELSE
LET AA$=""
CALL TOKUN(BETWEEN$,C$,N)
FOR J=1 TO N
LET AA$=AA$&TYPE$&C$(J)&","
NEXT J
CALL CPRINT("inline "&TYPE$&FNAME$&"("&AA$(1:LEN(AA$)-1)&") {")
END IF
CALL CPRINT("return "&BEHIND$&";")
CALL CPRINT("}")
END IF
END IF
NEXT I
LET CTAB=0
FOR I=1 TO MAXLINE
!' IF POS(A$(I),"EPS")>0 AND FL_EPS=0 THEN
!' IF TYPE$="bigfloat " THEN
!' CALL CPRINT("bigfloat eps;")
!' CALL CPRINT("eps.assign("&CHR$(34)&"1e-1000"&CHR$(34)&");")
!' ELSE
!' CALL CPRINT("const double eps=1e-14;")
!' END IF
!' LET FL_EPS=1
!' END IF
IF POS(A$(I),"PI")>0 AND LITERAL(A$(I),"PI")=0 AND FL_PI=0 THEN
!'IF TYPE$="big_float " THEN CALL CPRINT("const big_float pi=boost::math::constants::pi<big_float>();")
IF TYPE$="double " OR TYPE$="complex <double> " THEN
!'CALL CPRINT("const double pi=M_PI;")
CALL CPRINT("const double pi=3.1415926535897932384626;")
END IF
LET FL_PI=1
END IF
IF (POS(A$(I),"PUBLIC NUMERIC")>0 OR POS(A$(I),"PUBLIC STRING")>0) AND LITERAL(A$(I),"PUBLIC")=0 THEN !'グローバル変数宣言
LET X$=A$(I)
CALL COMMAND_PUBLIC(X$)
LET FL_PUBLIC=1
END IF
NEXT I
IF FL_EPS=1 OR FL_PI=1 OR FL_PUBLIC=1 THEN CALL CPRINT("")
CALL CPRINT("int main(int argc, char* argv[]) {")
MAT VARIABLE_ARGUMENT$=NUL$
LET VA_ARGUMENT_COUNT=0
CALL SCAN$(A$,1) !'ローカル変数宣言
!'CALL CPRINT("cout <<"&SETPREC$(1:POS(SETPREC$,"<<")-1)&";") !'マニピュレータ設定
!'CALL CPRINT("cout << uppercase << dec << right << fixed;")
FOR II=1 TO MAXLINE !'メイン処理
CALL MAIN(A$(II))
NEXT II
STOP
SUB MAIN(X$) !'分岐処理ルーチン
LET X$=TRIM$(X$)
IF X$="" THEN EXIT SUB
IF POS(X$,"!")>0 OR POS(X$,"REM ")>0 THEN !'「REM・AINDER」
IF LITERAL(X$,"!")=0 AND LITERAL(X$,"REM")=0 THEN
CALL COMMAND_REM(X$) !'「IF A$="!" THEN 」
EXIT SUB
END IF
END IF
CALL CPRINT("// "&X$)
IF POS(X$,"IF ")=1 OR POS(X$,"IF(")=1 OR POS(X$,"ELSEIF")=1 THEN
IF (POS(X$,"END")=0 OR LITERAL(X$,"END")<>0) AND (POS(X$,"READ")=0 OR LITERAL(X$,"READ")<>0) AND (POS(X$,"INPUT")=0 OR LITERAL(X$,"INPUT")<>0) THEN
CALL COMMAND_IF(X$)
EXIT SUB !'「READ IF MISSING THEN」「INPUT #1,IF MISSING THEN」「END IF」
END IF
END IF
IF POS(X$,"LET ")=1 THEN
CALL COMMAND_LET(X$)
EXIT SUB
END IF
IF POS(X$,"PRINT")=1 AND (POS(X$,"USING")=0 OR LITERAL(X$,"USING")<>0) THEN
CALL COMMAND_PRINT(X$) !'「PRINT "USING"」
EXIT SUB
END IF
IF POS(X$,"CASE ")>0 AND LITERAL(X$,"CASE")=0 THEN
CALL COMMAND_CASE(X$) !'「SELECT CASE」「CASE ELSE」
EXIT SUB
END IF
IF POS(X$,"CALL ")=1 THEN
CALL COMMAND_CALL(X$)
EXIT SUB
END IF
IF POS(X$,"ELSE")=1 AND POS(X$,"CASE")=0 AND POS(X$,"ELSEIF")=0 AND LITERAL(X$,"ELSE")=0 AND LITERAL(X$,"CASE")=0 THEN
CALL COMMAND_ELSE(X$)
EXIT SUB
END IF
IF POS(X$,"DIM ")=1 THEN
CALL COMMAND_DIM(X$)
EXIT SUB
END IF
IF POS(X$,"FUNCTION ")>0 AND POS(X$,"DECLARE")=0 AND POS(X$,"(,)")=0 AND POS(X$,"(,,)")=0 AND LITERAL(X$,"FUNCTION ")=0 AND POS(X$,"EXTERNAL")=1 THEN
CALL COMMAND_FUNCTION(X$)
EXIT SUB
END IF
IF POS(X$,"SUB ")>0 AND POS(X$,"DECLARE")=0 AND POS(X$,"(,)")=0 AND POS(X$,"(,,)")=0 AND LITERAL(X$,"SUB ")=0 AND POS(X$,"EXTERNAL")=1 THEN
CALL COMMAND_SUB(X$)
EXIT SUB
END IF
IF POS(X$,"FOR ")=1 THEN
CALL COMMAND_FOR(X$)
EXIT SUB
END IF
IF POS(X$,"NEXT ")=1 THEN
CALL COMMAND_NEXT(X$)
EXIT SUB
END IF
IF POS(X$,"DO")=1 THEN
CALL COMMAND_DO(X$)
EXIT SUB
END IF
IF POS(X$,"LOOP")=1 THEN
CALL COMMAND_LOOP(X$)
EXIT SUB
END IF
IF POS(X$,"INPUT ")=1 AND POS(X$,"IF")=0 AND POS(X$,"CHARACTER")=0 AND POS(X$,"ELAPSED")=0 AND POS(X$,"TIMEOUT")=0 OR POS(X$,"LINE INPUT")=1 THEN
CALL COMMAND_INPUT(X$) !'「CHARACTER INPUT」「INPUT ELAPSED」「INPUT TIMEOUT」「INPUT #1,IF MISSING THEN 」
EXIT SUB
END IF
IF POS(X$,"END")=1 AND POS(X$,"PICTURE")=0 THEN
CALL COMMAND_END(X$) !'「END」「END IF」「END SUB」「END FUNCTION」「END SELECT」
EXIT SUB
END IF
IF POS(X$,"EXIT")=1 AND POS(X$,"PICTURE")=0 THEN
CALL COMMAND_EXIT(X$)
EXIT SUB
END IF
IF POS(X$,"RANDOMIZE")=1 THEN
CALL COMMAND_RANDOMIZE(X$)
EXIT SUB
END IF
IF POS(X$,"STOP")=1 THEN
CALL COMMAND_STOP(X$)
EXIT SUB
END IF
IF POS(X$,"OPEN ")=1 THEN
CALL COMMAND_OPEN(X$)
EXIT SUB
END IF
IF POS(X$,"CLOSE")=1 THEN
CALL COMMAND_CLOSE(X$)
EXIT SUB
END IF
IF POS(X$,"SWAP ")=1 THEN
CALL COMMAND_SWAP(X$)
EXIT SUB
END IF
IF POS(X$,"OPTION ARITHMETIC")>0 THEN EXIT SUB
IF POS(X$,"OPTION ANGLE RADIANS")>0 THEN EXIT SUB
IF POS(X$,"OPTION BASE")>0 THEN EXIT SUB
IF POS(X$,"OPTION CHARACTER BYTE")>0 THEN EXIT SUB
IF POS(X$,"PUBLIC")>0 THEN EXIT SUB
IF POS(X$,"DEF ")>0 THEN EXIT SUB
IF POS(X$,"DECLARE EXTERNAL")>0 THEN EXIT SUB
IF POS(X$,"SET ECHO")>0 THEN EXIT SUB
CALL CPRINT(X$&" // ******* 未対応です *******")
END SUB
SUB COMMAND_PUBLIC(XX$) !'以下、各コマンド処理ルーチン
LOCAL I,K,J,N,L
LET X$=XX$
IF POS(X$,"!")>0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"!"))
IF POS(X$,"REM ")>0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"REM "))
LET X$=TRANSRESERVED$(X$) !'変数名がC/C++予約語なら変換
LET X$=TRANSFORM$(X$,"(","[") !'配列変数なら変換
LET X$=TRANSFORM$(X$,")","+1]")
LET I=1
DO
IF X$(I:I)="[" THEN
LET J=I+1
DO
IF X$(J:J)="," THEN !'多次元配列時の処理
LET X$(J:J)="+1]["
LET J=J+4
END IF
LET J=J+1
LOOP UNTIL X$(J:J)="]"
END IF
LET I=I+1
LOOP UNTIL LEN(X$)<=I
IF POS(X$,"NUMERIC")>0 THEN
LET BEHIND$=BEHINDSTRING$(X$,"NUMERIC ")
ELSEIF POS(X$,"STRING")>0 THEN
LET BEHIND$=BEHINDSTRING$(X$,"STRING ")
END IF
CALL TOKUN(BEHIND$,C$,K)
FOR I=1 TO K
IF POS(C$(I),"TO")>0 THEN !'下限指定 TO句の処理
IF POS(C$(I),"][")=0 THEN !'1次元配列
LET AA$=TRIM$(BETWEENSTRING$(C$(I),"[","TO"))
LET BB$=TRIM$(BETWEENSTRING$(C$(I),"TO","+1]"))
IF POS("0123456789",AA$(1:1))=0 OR POS("0123456789",BB$(1:1))=0 THEN !'定数でないなら
CALL CPRINT(XX$&" // ******* 未対応です *******")
EXIT SUB
ELSE
LET C$(I)=C$(I)(1:POS(C$(I),"["))&BB$&"+1]"
END IF
ELSE !'多次元配列時の処理
LET CC$=""
LET J=0
LET L=0
LET N=0
DO
LET J=POS(C$(I),"[",J+1)
LET L=POS(C$(I),"+1]",L+1)
LET N=N+1
LET C2$(N)=C$(I)(J+1:L-1)
LOOP UNTIL L+2>=LEN(C$(I))
FOR J=1 TO N
LET AA$=TRIM$(FRONTSTRING$(C2$(J),"TO"))
LET BB$=TRIM$(BEHINDSTRING$(C2$(J),"TO"))
IF POS("0123456789",AA$(1:1))=0 OR POS("0123456789",BB$(1:1))=0 THEN
CALL CPRINT(XX$&" // ******* 未対応です *******")
EXIT SUB
ELSE
LET CC$=CC$&BB$&"+1]["
END IF
NEXT J
LET C$(I)=C$(I)(1:POS(C$(I),"["))&CC$(1:LEN(CC$)-1)
END IF
END IF
IF POS(C$(I),"[")=0 THEN
LET VA_PUBLIC_COUNT=VA_PUBLIC_COUNT+1
LET VARIABLE_PUBLIC$(VA_PUBLIC_COUNT)=LCASE$(TRIM$(C$(I))) !'配列変数名登録
END IF
NEXT I
IF POS(X$,"NUMERIC")>0 THEN
IF POS(BEHIND$,"]")>0 THEN
LET BEHIND$=""
FOR I=1 TO K
LET BEHIND$=BEHIND$&C$(I)
IF POS(C$(I),"]")>0 THEN LET BEHIND$=BEHIND$&"={}," ELSE LET BEHIND$=BEHIND$&"," !'配列初期化設定
NEXT I
LET BEHIND$=BEHIND$(1:LEN(BEHIND$)-1)
ELSE
LET I=1
DO
IF BEHIND$(I:I)="," AND BEHIND$(I-3:I)<>"={}," THEN !'配列でないなら初期値0
LET BEHIND$(I:I)="=0,"
LET I=I+2
END IF
LET I=I+1
LOOP UNTIL LEN(X$)<=I
IF BEHIND$(LEN(BEHIND$)-2:LEN(BEHIND$))<>"={}" THEN
LET BEHIND$=BEHIND$&"=0"
END IF
END IF
CALL CPRINT(TYPE$&LCASE$(BEHIND$)&";")
ELSE
LET BEHIND$=TRANSFORM$(BEHIND$,"$","_string")
IF POS(BEHIND$,"]")>0 THEN
LET BEHIND$=TRANSFORM$(BEHIND$,"]",")={"&CHR$(34)&CHR$(34)&"}") !'string配列 NULL初期化
LET BEHIND$=TRANSFORM$(BEHIND$,")","]")
END IF
CALL CPRINT("string "&LCASE$(BEHIND$)&";")
END IF
END SUB
SUB COMMAND_DIM(XX$)
LOCAL I,N,J,K
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"DIM "))
LET INI$=""
CALL SPLIT2(BEHIND$,C$,N)
LET CC$=""
LET SS$=""
MAT EXPRESSION$=NUL$
MAT VA_DIM=ZER
MAT VA_INIT$=NUL$
MAT VARIABLE_DIM$=NUL$
FOR I=1 TO N
LET FL=0
LET C$(I)=TRIM$(C$(I))
IF POS(C$(I),"TO")>0 THEN !'下限指定時の処理
IF POS(C$(I),",")=0 THEN !'1次元配列時
LET AA$=TRIM$(BETWEENSTRING$(C$(I),"(","TO"))
LET BB$=TRIM$(BETWEENSTRING$(C$(I),"TO",")"))
IF POS("0123456789",AA$(1:1))=0 OR POS("0123456789",BB$(1:1))=0 THEN
CALL CPRINT(XX$&" // ******* 未対応です *******")
EXIT SUB
ELSE
LET C$(I)=C$(I)(1:POS(C$(I),"("))&BB$&")"
END IF
ELSE !'多次元配列時の処理
LET J=POS(C$(I),"(")
LET K=POS(C$(I),")")
LET AA$=C$(I)(J+1:K-1)
CALL TOKUN(AA$,C2$,K)
FOR J=1 TO K
LET AA$=TRIM$(FRONTSTRING$(C2$(J),"TO"))
LET BB$=TRIM$(BEHINDSTRING$(C2$(J),"TO"))
IF POS("0123456789",AA$(1:1))=0 OR POS("0123456789",BB$(1:1))=0 THEN
CALL CPRINT(XX$&" // ******* 未対応です *******")
EXIT SUB
ELSE
LET CC$=CC$&BB$&","
END IF
NEXT J
LET C$(I)=C$(I)(1:POS(C$(I),"("))&CC$(1:LEN(CC$)-1)&")"
LET CC$=""
END IF
END IF
LET AA$=""
LET BB$=""
IF POS(C$(I),"$")>0 THEN LET C$(I)=TRANSFORM$(C$(I),"$","_string")
LET B$=TRANSARRAYNAME$(C$(I))
IF TYPE$="complex <double> " THEN !'強制キャストとりあえず解除
LET INI$="static_cast<int>(abs("
LET B$=TRANSFORM$(B$,INI$,"")
LET B$=TRANSFORM$(B$,"))","")
LET AA$="abs("
LET BB$=")"
ELSE
LET INI$="static_cast<int>("
LET B$=TRANSFORM$(B$,INI$,"")
LET B$=TRANSFORM$(B$,")","")
END IF
LET C$(I)=TRANSFUNC$(B$)
IF B$=C$(I) THEN
LET K=POS(B$,"[")
FOR J=K+1 TO LEN(B$)
IF POS("abcdefghijklmnopqrstuvwxyz",LCASE$(B$(J:J)))>0 THEN LET FL=1 !'変数指定なら
NEXT J
ELSE
LET FL=1
END IF
IF FL=1 THEN
FOR J=1 TO LEN(C$(I))
IF C$(I)(J:J)="[" THEN EXIT FOR
NEXT J
LET VARIABLE_DIM$(I)=TRIM$(LCASE$(C$(I)(1:J-1)))
END IF
LET K=POS(C$(I),"[")
LET J=K
LET SP=0
DO
LET J=J+1
IF C$(I)(J:J)="(" THEN LET SP=SP+1
IF C$(I)(J:J)=")" THEN LET SP=SP-1
IF SP=0 AND C$(I)(J:J+1)="][" THEN
LET VA_DIM(I)=VA_DIM(I)+1
LET EXPRESSION$(I,VA_DIM(I))=LCASE$(C$(I)(K+1:J-1))
LET C$(I)(J:J+1)="+1]["
LET J=J+3
LET K=J
END IF
LOOP UNTIL C$(I)(J:J)="]" OR LEN(C$(I))=J
LET VA_DIM(I)=VA_DIM(I)+1
LET EXPRESSION$(I,VA_DIM(I))=LCASE$(C$(I)(K+1:J-1))
LET C$(I)(J:J)="+1]"
IF FL=1 THEN
LET C$(I)=TRANSFORM$(C$(I),"[","\"&INI$)
LET C$(I)=TRANSFORM$(C$(I),"\","[")
IF TYPE$="complex <double> " THEN
LET C$(I)=TRANSFORM$(C$(I),"]","))\")
LET C$(I)=TRANSFORM$(C$(I),"\","]")
ELSE
LET C$(I)=TRANSFORM$(C$(I),"]",")\")
LET C$(I)=TRANSFORM$(C$(I),"\","]")
END IF
END IF
IF POS(C$(I),"_string")>0 THEN
IF FL=0 THEN
LET CC$=CC$&C$(I)&"={"&CHR$(34)&CHR$(34)&"},"
ELSE
LET CC$=CC$&C$(I)&","
LET VA_INIT$(I)=CHR$(34)&CHR$(34)&";" !'初期値"" NULL
END IF
ELSE
IF FL=0 THEN
LET SS$=SS$&C$(I)&"={},"
ELSE
LET SS$=SS$&C$(I)&","
LET VA_INIT$(I)="0;" !'初期値0
END IF
END IF
NEXT I
IF CC$<>"" THEN
CALL CPRINT("string "&LCASE$(LEFT$(CC$,LEN(CC$)-1))&";")
END IF
IF SS$<>"" THEN
CALL CPRINT(TYPE$&LCASE$(LEFT$(SS$,LEN(SS$)-1))&";")
END IF
FOR I=1 TO N !'可変長配列の初期化
IF VARIABLE_DIM$(I)<>"" THEN
SELECT CASE VA_DIM(I)
CASE 1
CALL CPRINT("for (int i=0;i<="&AA$&EXPRESSION$(I,1)&BB$&";i++)")
CALL CPRINT(VARIABLE_DIM$(I)&"[i]="&VA_INIT$(I))
CASE 2
CALL CPRINT("for (int i=0;i<="&AA$&EXPRESSION$(I,1)&BB$&";i++)")
CALL CPRINT("for (int j=0;j<="&AA$&EXPRESSION$(I,2)&BB$&";j++)")
CALL CPRINT(VARIABLE_DIM$(I)&"[i][j]="&VA_INIT$(I))
CASE 3
CALL CPRINT("for (int i=0;i<="&AA$&EXPRESSION$(I,1)&BB$&";i++)")
CALL CPRINT("for (int j=0;j<="&AA$&EXPRESSION$(I,2)&BB$&";j++)")
CALL CPRINT("for (int k=0;k<="&AA$&EXPRESSION$(I,3)&BB$&";k++)")
CALL CPRINT(VARIABLE_DIM$(I)&"[i][j][k]="&VA_INIT$(I))
CASE ELSE
END SELECT
END IF
NEXT I
END SUB
SUB COMMAND_FOR(X$)
LOCAL I
LET X$=TRANSRESERVED$(X$)
LET P$=TRIM$(LCASE$(BETWEENSTRING$(X$,"FOR","="))) !'制御変数名
LET NUM$=TRIM$(BETWEENSTRING$(X$,"=","TO")) !'初期値
IF POS(X$,"STEP")>0 THEN
LET ST$=BEHINDSTRING$(X$,"STEP") !'増分
LET ST$=TRANSARRAYNAME$(ST$)
LET ST$=TRANSFUNC$(ST$)
LET I=POS(ST$,"-")
IF I>0 THEN
LET SI$=">="
LET SIGN$="-"
LET ST$(I:I)=""
ELSE
LET SI$="<="
LET SIGN$="+"
END IF
LET T$=TRIM$(BETWEENSTRING$(X$,"TO","STEP")) !'終了値
ELSE
LET T$=TRIM$(BEHINDSTRING$(X$,"TO"))
LET ST$="1"
LET SI$="<="
LET SIGN$="+"
END IF
LET T$=TRANSARRAYNAME$(T$) !'配列変数名変換
LET T$=TRANSFUNC$(T$) !'関数名変換
LET NUM$=TRANSARRAYNAME$(NUM$)
LET NUM$=TRANSFUNC$(NUM$)
!!!CALL CPRINT("#pragma omp parallel for") !!! openMP マルチスレッド (#include<omp.h>)
CALL CPRINT("for("&P$&"="&LCASE$(NUM$)&";"&P$&SI$&LCASE$(T$)&";"&P$&SIGN$&"="&LCASE$(TRIM$(ST$))&") {")
END SUB
SUB COMMAND_NEXT(X$)
CALL CPRINT("}")
END SUB
SUB COMMAND_FUNCTION(XX$)
LOCAL N,K
LET X$=XX$
IF POS(X$,"!")>0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"!"))
IF POS(X$,"REM ")>0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"REM "))
LET X$=TRANSRESERVED$(X$)
IF POS(X$,"(")=0 THEN !'仮引数なしの場合
LET FNAME$=LCASE$(TRIM$(BEHINDSTRING$(X$,"FUNCTION"))) !'関数名
IF POS(FNAME$,"$")>0 THEN LET FNAME$=TRANSFORM$(FNAME$,"$","")
IF PROTOTYPE<>0 THEN !'プロトタイプ宣言
CALL CPRINT(TYPE$&FNAME$&"(void);")
LET FC=FC+1
LET FUNCNAME$(FC)=FNAME$ !'関数名登録
EXIT SUB
ELSE
CALL CPRINT(TYPE$&FNAME$&"(void)")
CALL CPRINT("{")
EXIT SUB
END IF
END IF
IF POS(X$,"()")>0 THEN LET X$=TRANSFORM$(X$,"()","[]") !'1次元配列 A() → A[]
LET BEHIND$=BEHINDSTRING$(X$,"(")
LET BEHIND$=BEHIND$(1:LEN(BEHIND$)-1) !'仮引数列
LET FNAME$=LCASE$(TRIM$(BETWEENSTRING$(X$,"FUNCTION","(")))
IF PROTOTYPE<>0 THEN
LET FC=FC+1
LET FUNCNAME$(FC)=FNAME$
END IF
CALL TOKUN(BEHIND$,C$,K)
LET AA$=""
MAT VARIABLE_ARGUMENT$=NUL$
LET VA_ARGUMENT_COUNT=0
FOR N=1 TO K
LET C$(N)=LCASE$(TRIM$(C$(N)))
LET B$=C$(N)
LET B$=TRANSFORM$(B$,"[]","")
LET VA_ARGUMENT_COUNT=VA_ARGUMENT_COUNT+1
LET VARIABLE_ARGUMENT$(VA_ARGUMENT_COUNT)=B$ !'仮引数変数名登録
IF POS(C$(N),"$")>0 THEN
LET C$(N)="string "&TRANSFORM$(C$(N),"$","_string")
ELSE
LET C$(N)=TYPE$&C$(N)
END IF
LET AA$=AA$&C$(N)&","
NEXT N
LET AA$=AA$(1:LEN(AA$)-1)
IF PROTOTYPE<>0 THEN LET AA$=AA$&");" ELSE LET AA$=AA$&")"
CALL CPRINT(TYPE$&LCASE$(FNAME$&"("&AA$))
IF PROTOTYPE=0 THEN !'プロトタイプ宣言でないなら使用変数名のスキャン、変数宣言
CALL CPRINT("{")
CALL SCAN$(A$,II)
END IF
END SUB
SUB COMMAND_SUB(XX$)
LOCAL N,K
LET X$=XX$
LET VA_CALL_COUNT=0
IF POS(X$,"!")>0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"!"))
IF POS(X$,"REM ")>0 THEN LET X$=TRIM$(FRONTSTRING$(X$,"REM "))
LET X$=TRANSRESERVED$(X$)
IF POS(X$,"(")=0 THEN !'仮引数なしの場合
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"SUB "))
IF PROTOTYPE<>0 THEN
CALL CPRINT("void "&LCASE$(BEHIND$)&"(void);")
EXIT SUB
ELSE
CALL CPRINT("void "&LCASE$(BEHIND$)&"(void)")
CALL CPRINT("{")
EXIT SUB
END IF
END IF
IF POS(X$,"()")>0 THEN LET X$=TRANSFORM$(X$,"()","[]")
LET BEHIND$=BEHINDSTRING$(X$,"(")
LET BEHIND$=BEHIND$(1:LEN(BEHIND$)-1)
LET SNAME$=TRIM$(LCASE$(BETWEENSTRING$(X$,"SUB","("))) !'サブルーチン名
CALL TOKUN(BEHIND$,C$,K)
LET AA$=""
MAT VARIABLE_ARGUMENT$=NUL$
LET VA_ARGUMENT_COUNT=0
FOR N=1 TO K
LET C$(N)=LCASE$(TRIM$(C$(N)))
LET B$=C$(N)
LET B$=TRANSFORM$(B$,"[]","")
LET VA_ARGUMENT_COUNT=VA_ARGUMENT_COUNT+1
LET VARIABLE_ARGUMENT$(VA_ARGUMENT_COUNT)=B$
IF POS(C$(N),"[")=0 THEN
LET B$="&"
ELSE
LET B$=""
END IF
IF POS(C$(N),"$")>0 THEN
LET C$(N)="string "&B$&TRANSFORM$(C$(N),"$","_string")
ELSE
LET C$(N)=TYPE$&B$&C$(N)
END IF
LET AA$=AA$&C$(N)&","
NEXT N
LET AA$=AA$(1:LEN(AA$)-1)
IF PROTOTYPE<>0 THEN LET AA$=AA$&");" ELSE LET AA$=AA$&")"
CALL CPRINT("void "&SNAME$&"("&AA$)
IF PROTOTYPE=0 THEN
CALL CPRINT("{")
CALL SCAN$(A$,II)
END IF
END SUB
SUB COMMAND_CASE(X$)
LOCAL I,N
LET X$=TRANSRESERVED$(X$)
IF POS(X$,"SELECT CASE")>0 THEN
LET SWITCH$=BEHINDSTRING$(X$,"SELECT CASE") !'SELECT CASE区の変数名
LET SWITCH$=TRANSARRAYNAME$(SWITCH$)
LET SWITCH$=LCASE$(TRANSFUNC$(SWITCH$))
IF POS(SWITCH$,"$")>0 AND LITERAL(SWITCH$,"$")=0 THEN LET SWITCH$=TRANSFORM$(SWITCH$,"$","_string")
LET NUMCASE=0
EXIT SUB
END IF
IF POS(X$,"CASE ELSE")>0 THEN
CALL CPRINT("}")
CALL CPRINT("else")
CALL CPRINT("{")
ELSEIF POS(X$,"CASE")>0 THEN !'CASE区の処理
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"CASE"))
LET AA$=""
CALL TOKUN(BEHIND$,C$,N)
FOR I=1 TO N
IF POS(C$(I),"TO")>0 THEN !'範囲指定時「CASE 1 TO 5」
LET FRONT$=FRONTSTRING$(C$(I),"TO")
LET BEHIND$=BEHINDSTRING$(C$(I),"TO")
LET AA$=AA$&TRIM$(FRONT$)&"<="&SWITCH$&" && "&SWITCH$&" <= "&TRIM$(BEHIND$)&" || "
ELSEIF POS(C$(I),"IS")>0 THEN !' IS区指定時「CASE IS>5,IS<0」
LET AA$=AA$&SWITCH$&TRIM$(BEHINDSTRING$(C$(I),"IS"))&" || "
ELSE
LET AA$=AA$&SWITCH$&"=="&C$(I)&" || " !'「CASE 1,3,5」
END IF
NEXT I
LET AA$=AA$(1:LEN(AA$)-4)
LET NUMCASE=NUMCASE+1
IF NUMCASE=1 THEN !'最初のCASE区
CALL CPRINT("if("&AA$&") { ")
ELSE !'2番目以降のCASE区
CALL CPRINT("}")
CALL CPRINT("else if("&AA$&") { ")
END IF
END IF
END SUB
SUB COMMAND_DO(XX$)
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
LET X$=TRANSCO$(X$)
LET X$=TRANSARRAYNAME$(X$)
LET X$=TRANSFUNC$(X$)
IF POS(X$,"DO WHILE")>0 THEN !'DO WHILE処理
LET BEHIND$=BEHINDSTRING$(X$,"WHILE")
CALL CPRINT("while ("&LLCASE$(TRIM$(BEHIND$))&") {")
EXIT SUB
END IF
IF POS(X$,"DO UNTIL")>0 THEN
LET BEHIND$=BEHINDSTRING$(X$,"UNTIL")
CALL CPRINT("do {") !'DO UNTIL処理
CALL CPRINT( "if ("&LLCASE$(TRIM$(BEHIND$))&") break;")
EXIT SUB
END IF
CALL CPRINT("do {")
END SUB
SUB COMMAND_LOOP(XX$)
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
LET X$=TRANSCO$(X$)
LET X$=TRANSARRAYNAME$(X$)
LET X$=TRANSFUNC$(X$)
IF POS(X$,"LOOP UNTIL")>0 THEN !'LOOP UNTIL処理
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"UNTIL"))
CALL CPRINT("if ("&LLCASE$(BEHIND$)&") break;")
END IF
IF POS(X$,"LOOP WHILE")>0 THEN !'LOOP WHILE処理
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"WHILE"))
CALL CPRINT("} while ("&LLCASE$(BEHIND$)&");")
EXIT SUB
END IF
CALL CPRINT("}")
END SUB
SUB COMMAND_LET(XX$)
LOCAL I,N,K
LET N=0
LET K=0
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
FOR I=1 TO LEN(X$)
IF X$(I:I)="=" THEN LET K=K+1
NEXT I
IF K=1 THEN LET BETWEEN$=LCASE$(TRIM$(BETWEENSTRING$(X$,"LET","=")))
LET AA$=""
IF K=1 AND BETWEEN$=FNAME$ THEN !'FUNCTION内で関数名と同じ場合
LET AA$="return "
LET X$=BEHINDSTRING$(X$,"=")
END IF
LET X$=TRANSFORM$(X$,"LET ","")
IF K=1 AND POS(BETWEEN$,",")=0 THEN
LET X$=TRANSARRAYNAME$(X$)
LET X$=LLCASE$(TRANSFUNC$(X$))
CALL CPRINT(AA$&X$&";")
EXIT SUB
END IF
IF K=1 THEN !'複数、多次元配列指定「LET A,B,C(1,1)=5」
LET X$=BEHINDSTRING$(X$,"=")
CALL SPLIT2(BETWEEN$,C$,N)
FOR I=1 TO N
IF POS(C$(I),"(")>0 THEN LET C$(I)=TRANSARRAYNAME$(C$(I))
LET X$=TRANSARRAYNAME$(X$)
LET X$=LLCASE$(TRANSFUNC$(X$))
CALL CPRINT(C$(I)&"="&X$&";")
NEXT I
ELSE !'「LET A=1,B=2,C=3」
CALL SPLIT2(X$,C$,N)
FOR I=1 TO N
LET BEHIND$=BEHINDSTRING$(C$(I),"=")
LET BEHIND$=TRANSARRAYNAME$(BEHIND$)
LET BEHIND$=LLCASE$(TRANSFUNC$(BEHIND$))
LET FRONT$=FRONTSTRING$(C$(I),"=")
IF POS(FRONT$,"(")>0 THEN LET FRONT$=TRANSARRAYNAME$(FRONT$)
LET FRONT$=TRANSFORM$(FRONT$,"$","_string")
CALL CPRINT(LCASE$(FRONT$)&"="&BEHIND$&";")
NEXT I
END IF
END SUB
SUB COMMAND_INPUT(XX$)
LOCAL I,J,K
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
LET NUM$=""
LET X$=TRANSFORM$(X$,"$","_string")
IF POS(X$,"#")>0 THEN !'ファイル読込指定時
LET NUM$=TRIM$(BETWEENSTRING$(X$,"#",":")) !'経路番号
LET X$=TRANSFORM$(X$,"#"&NUM$&":","")
END IF
LET K=POS(X$,"PROMPT")
IF K>0 THEN !'INPUT PROMPT文「INPUT PROMPT "男:1 女:2":N」
IF POS(X$,CHR$(34))>0 THEN !'文字定数取出
FOR I=K+6 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN
FOR J=I+1 TO LEN(X$)
IF X$(J:J)=CHR$(34) THEN
LET S$=TRIM$(X$(I:J))
LET I=J+1
EXIT FOR
END IF
NEXT J
END IF
NEXT I
FOR I=J+1 TO LEN(X$)
IF X$(I:I)=":" THEN EXIT FOR
NEXT I
LET ST$=TRIM$(X$(I+1:LEN(X$)))
ELSE
LET S$=TRIM$(BETWEENSTRING$(X$,"PROMPT",":")) !'出力文(文字定数取出)
LET ST$=TRIM$(BEHINDSTRING$(X$,":")) !'変数列取出
END IF
LET ST$=TRANSFORM$(ST$,","," >> ")
LET ST$=LCASE$(TRANSARRAYNAME$(ST$))
CALL CPRINT("cout << "&S$&";")
!' CALL CPRINT("cerr << "&S$&";")
IF POS(X$,"LINE INPUT")>0 THEN
CALL CPRINT("getline(cin,"&ST$&");") !'「LINE INPUT PROMPT "A=":A$」
ELSE
CALL CPRINT("cin >> "&ST$&";") !'「INPUT PROMPT "A,B,C=":A$,B$,C$」
END IF
ELSE
IF POS(X$,"LINE INPUT")>0 THEN
IF NUM$<>"" THEN
LET X$=TRANSARRAYNAME$(X$)
LET X$=TRANSFORM$(X$,"LINE INPUT","getline(fs"&NUM$&",") !'「LINE INPUT #1:A$」
CALL CPRINT(LCASE$(X$)&");")
ELSE
LET X$=TRANSFORM$(X$,"LINE INPUT","getline(cin,") !'「LINE INPUT A$」
CALL CPRINT(LCASE$(X$)&");")
END IF
ELSE
IF NUM$<>"" THEN
LET X$=TRANSFORM$(X$,"INPUT","fs"&NUM$&" >> ") !'「INPUT #1:A,B,C」
ELSE
LET X$=TRANSFORM$(X$,"INPUT","cin >> ") !'「INPUT A,B,C」
LET X$=TRANSFORM$(X$,","," >> ")
CALL CPRINT(LCASE$(X$)&";")
END IF
END IF
END IF
END SUB
SUB COMMAND_PRINT(XX$)
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
LOCAL I,J,N
LET NUM$=""
IF TRIM$(BEHINDSTRING$(X$,"PRINT"))="" THEN !'改行指定
CALL CPRINT("cout << endl;")
!'CALL CPRINT("cout << '\n';")
EXIT SUB
END IF
LET ST$=""
IF RIGHT$(X$,1)<>";" AND RIGHT$(X$,1)<>"," THEN !'文末に";"又は","がないなら改行指定
LET ST$=" << endl"
!'LET ST$=" << '\n'"
ELSE
IF RIGHT$(X$,1)=";" THEN LET X$(LEN(X$):LEN(X$))=" <<"&CHR$(39)&" "&CHR$(39) !'スペース文字に置き換え
IF RIGHT$(X$,1)="," THEN LET X$(LEN(X$):LEN(X$))=" <<"&CHR$(39)&REPEAT$(CHR$(32),20)&CHR$(39)
END IF
LET SP=0
LET I=0
DO
LET I=I+1
IF X$(I:I)=CHR$(34) THEN !'文字定数内の「,」「;」を除く「"A,B=";A,B」
FOR J=I+1 TO LEN(X$)
IF X$(J:J)=CHR$(34) THEN EXIT FOR
NEXT J
LET I=J
END IF
IF X$(I:I)="(" OR X$(I:I)="[" THEN !'多次元配列変数内の「,」を除く「A,B;C(1,1),D」
LET SP=SP+1
FOR J=I+1 TO LEN(X$)
IF X$(J:J)="(" OR X$(J:J)="[" THEN LET SP=SP+1
IF X$(J:J)=")" OR X$(J:J)="]" THEN LET SP=SP-1
IF SP=0 THEN EXIT FOR
NEXT J
LET I=J
END IF
IF X$(I:I)="," THEN LET X$(I:I)=" <<"&CHR$(39)&REPEAT$(CHR$(32),20)&CHR$(39)&"<< " !'「,」「;」を" "スペースに置換
IF X$(I:I)=";" THEN LET X$(I:I)=" <<"&CHR$(39)&" "&CHR$(39)&"<< "
LOOP UNTIL LEN(X$)<=I
IF POS(X$,"#")>0 THEN
LET NUM$=TRIM$(BETWEENSTRING$(X$,"#",":")) !'経路番号
LET X$=TRANSFORM$(X$,"#"&NUM$&":","")
IF TRIM$(X$)="PRINT" THEN
CALL CPRINT("fs"&NUM$&" << endl;")
EXIT SUB
END IF
END IF
IF POS(X$,CHR$(34))>0 THEN !'文字定数があるなら
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"PRINT"))
CALL SPLIT(BEHIND$,C$,N) !'PRINT文以降を分割
FOR I=1 TO N STEP 2
IF C$(I)<>"" THEN
LET C$(I)=TRANSARRAYNAME$(C$(I))
LET C$(I)=LCASE$(TRANSFUNC$(C$(I)))
END IF
NEXT I
IF NUM$<>"" THEN LET B$="fs"&NUM$&" << "&SETPREC$ ELSE LET B$="cout << "&SETPREC$
FOR I=1 TO N
LET B$=B$&TRIM$(C$(I))
NEXT I
LET B$=TRANSFORM$(B$,CHR$(39),CHR$(34))
CALL CPRINT(B$&ST$&";")
ELSE
LET X$=TRANSARRAYNAME$(X$)
LET X$=TRANSFUNC$(X$)
IF NUM$<>"" THEN
LET X$=TRANSFORM$(X$,"PRINT","fs"&NUM$&" <<"&SETPREC$)
ELSE
LET X$=TRANSFORM$(X$,"PRINT","cout <<"&SETPREC$)
END IF
LET X$=TRANSFORM$(X$,CHR$(39),CHR$(34))
CALL CPRINT(LCASE$(TRIM$(X$))&ST$&";")
END IF
END SUB
SUB COMMAND_IF(XX$)
LOCAL FRONT$,BEHIND$,I
LET SW=0
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
IF POS(X$,CHR$(34))>0 THEN !'「IF A$="THEN" THEN」
FOR I=1 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN LET SW=1-SW
IF SW=0 AND X$(I:I+3)="THEN" THEN
LET FRONT$=TRIM$(X$(1:I-1))
LET BEHIND$=TRIM$(X$(I+4:LEN(X$)))
EXIT FOR
END IF
NEXT I
ELSE
LET FRONT$=TRIM$(FRONTSTRING$(X$,"THEN"))
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"THEN"))
END IF
LET FRONT$=TRANSCO$(FRONT$)
LET FRONT$=TRANSARRAYNAME$(FRONT$)
LET FRONT$=TRANSFUNC$(FRONT$)
IF POS(FRONT$,"ELSEIF")>0 THEN
CALL CPRINT("}")
LET FRONT$=TRANSFORM$(FRONT$,"ELSEIF ","else if (")
LET FRONT$=TRANSFORM$(FRONT$,"ELSEIF(","else if ((")
ELSE
LET FRONT$=TRANSFORM$(FRONT$,"IF ","if (")
LET FRONT$=TRANSFORM$(FRONT$,"IF(","if ((")
END IF
CALL CPRINT(LLCASE$(FRONT$)&")")
CALL CPRINT("{")
IF BEHIND$<>"" THEN !'THEN区以降
IF POS(BEHIND$,"ELSE")>0 THEN !'ELSE区があるなら
LET FRONT$=BETWEENSTRING$(X$,"THEN","ELSE") !'THEN区とELSE区の間
LET BEHIND$=BEHINDSTRING$(X$,"ELSE") !'ELSE区以降
CALL MAIN(FRONT$) !'再帰処理
CALL CPRINT("}")
CALL CPRINT("else")
CALL CPRINT("{")
CALL MAIN(BEHIND$)
CALL CPRINT("}")
ELSE
CALL MAIN(BEHIND$)
CALL CPRINT("}")
END IF
END IF
END SUB
SUB COMMAND_ELSE(X$)
IF POS(X$,"ELSE")>0 THEN
CALL CPRINT("}")
CALL CPRINT("else")
CALL CPRINT("{")
END IF
END SUB
SUB COMMAND_OPEN(X$)
LET X$=TRANSRESERVED$(X$)
LET NAME$=TRIM$(BEHINDSTRING$(X$,"NAME"))
IF POS(X$,",ACCESS")>0 THEN
LET NAME$=TRIM$(BETWEENSTRING$(X$,"NAME",",ACCESS"))
IF POS(X$,"INPUT")>0 THEN
LET IO$="if" !'読み込みストリーム
!' OPENMODE$=",ios::in"
END IF
IF POS(X$,"OUTPUT")>0 THEN
LET IO$="of" !'書き込みストリーム
!' OPENMODE$=",ios::out"
END IF
IF POS(X$,"OUTIN")>0 THEN
LET IO$="f" !'読み書きストリーム
LET OPENMODE$=",ios::in | ios::out" !'●その他
END IF
ELSE
LET IO$="f"
LET OPENMODE$=",ios::in | ios::out" !'●その他
END IF
LET NUM$=TRIM$(BETWEENSTRING$(X$,"#",":")) !'経路番号
IF POS(NAME$,"$")>0 THEN LET NAME$=TRANSFORM$(NAME$,"$","_string.c_str()")
CALL CPRINT(IO$&"stream fs"&NUM$&"("&LLCASE$(NAME$)&OPENMODE$&");")
!' CALL CPRINT(IO$&"stream fs"&NUM$&";")
!' CALL CPRINT("fs&NUM$&".open("&LLCASE$(NAME$)&OPENMODE$&");")
CALL CPRINT("if (fs"&NUM$&".fail()){") !'エラー処理
CALL CPRINT("cout << "&CHR$(34)&"ファイルをオープンできません"&CHR$(34)&" << endl;")
CALL CPRINT("exit(1);")
CALL CPRINT("}")
END SUB
SUB COMMAND_CLOSE(X$)
CALL CPRINT("fs"&NUM$&".close();")
LET NUM$=""
END SUB
SUB COMMAND_EXIT(X$)
IF POS(X$,"EXIT SUB")>0 THEN
CALL CPRINT("return;")
EXIT SUB
END IF
IF POS(X$,"EXIT FUNCTION")>0 THEN
!' CALL CPRINT("return;")
EXIT SUB
END IF
IF POS(X$,"EXIT DO")>0 OR POS(X$,"EXIT FOR")>0 THEN
CALL CPRINT("break;")
EXIT SUB
END IF
END SUB
SUB COMMAND_END(X$)
!' IF X$="END" THEN
!' CALL CPRINT("cout << "&CHR$(34)&"Hit Enter Key"&CHR$(34)&" << endl;")
!' CALL CPRINT("cin.get();") !'エンターキー入力待ち(ウィンドゥが閉じてしまうのを防ぐ)
!' END IF
CALL CPRINT("}")
END SUB
SUB COMMAND_RANDOMIZE(X$)
CALL CPRINT("srand((unsigned)time(NULL));")
END SUB
SUB COMMAND_CALL(XX$)
LET X$=XX$
LET X$=TRANSRESERVED$(X$)
LOCAL I,N,J,K
LET AA$=""
LET X$=TRIM$(TRANSFORM$(X$,"CALL",""))
IF LITERAL(X$,"$")=0 THEN LET X$=TRANSFORM$(X$,"$","_string")
IF POS(X$,"(")=0 THEN !'引数なし
CALL CPRINT(LCASE$(X$)&"();")
EXIT SUB
END IF
LET FRONT$=TRIM$(FRONTSTRING$(X$,"("))
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"("))
CALL SPLIT2(BEHIND$(1:LEN(BEHIND$)-1),C$,N)
FOR I=1 TO N
IF C$(I)<>"" THEN
LET FL=0
FOR J=1 TO LEN(C$(I))
IF POS("+-*/^",C$(I)(J:J))>0 OR POS("0123456789",C$(I)(1:1))>0 THEN LET FL=1 !'引数が数式、定数なら
NEXT J
LET C$(I)=TRANSARRAYNAME$(C$(I))
IF POS(C$(I),CHR$(34))=0 AND POS(C$(I),"&")=0 THEN
LET BB$=C$(I)
LET C$(I)=TRANSFUNC$(C$(I)) !'関数名変換で変換されたか
IF BB$<>C$(I) OR FL=1 THEN !'引数が関数なら
LET VA_CALL_COUNT=VA_CALL_COUNT+1
LET BB$=LCASE$(C$(I))
LET C$(I)="dummy"&STR$(VA_CALL_COUNT) !'ダミー変数宣言
CALL CPRINT(TYPE$&C$(I)&"="&BB$&";")
END IF
ELSE !'文字定数指定なら
LET BB$=C$(I)
LET VA_CALL_COUNT=VA_CALL_COUNT+1
LET C$(I)="dummy"&STR$(VA_CALL_COUNT) !'ダミー変数宣言
CALL CPRINT("string "&C$(I)&"="&LLCASE$(BB$)&";")
END IF
END IF
LET AA$=AA$&C$(I)&","
NEXT I
CALL CPRINT(LLCASE$(FRONT$&"("&AA$(1:LEN(AA$)-1)&");"))
END SUB
SUB COMMAND_REM(XX$)
LOCAL I,FRONT$,BEHIND$
LET X$=XX$
LET I=POS(X$,"!")
LET X$=TRANSFORM$(X$,"!","//")
IF I=0 THEN
LET I=POS(X$,"REM ")
LET X$=TRANSFORM$(X$,"REM ","//")
END IF
IF I>1 THEN
LET FRONT$=TRIM$(X$(1:I-1)) !'注釈文字以前
!' LET BEHIND$=TRIM$(X$(I:LEN(X$))) !'注釈文字以降
CALL MAIN(FRONT$) !'再帰処理
!' CALL CPRINT(BEHIND$)
END IF
END SUB
SUB COMMAND_STOP(X$)
CALL CPRINT("exit(0);")
!'CALL CPRINT("exit(1);")
END SUB
SUB COMMAND_SWAP(X$)
LET X$=TRANSRESERVED$(X$)
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"SWAP "))
LET BEHIND$=TRANSARRAYNAME$(BEHIND$)
LET BEHIND$=TRANSFORM$(BEHIND$,"$","_string")
CALL CPRINT("swap("&LCASE$(BEHIND$)&");")
!'CALL CPRINT("cswap("&LCASE$(BEHIND$)&");")
END SUB
SUB SCAN$(A$(),NN) !'使用変数名の探索、宣言
LOCAL I,J,K,N
LET J=NN
LET AA$=""
LET BB$=""
LET B$=""
MAT VARIABLE$=NUL$
MAT VARIABLE_FOR$=NUL$
MAT VARIABLE_STRING$=NUL$
MAT VARIABLE_ARRAY$=NUL$
LET VA_COUNT=0
LET VA_FOR_COUNT=0
LET VA_STRING_COUNT=0
LET VA_ARRAY_COUNT=0
DO
LET X$=A$(J)
IF POS(X$,"!")>0 AND LITERAL(X$,"!")=0 THEN LET X$=FRONTSTRING$(X$,"!")
IF POS(X$,"REM ")>0 AND LITERAL(X$,"REM ")=0 THEN LET X$=FRONTSTRING$(X$,"REM ")
IF POS(X$,"DIM ")>0 AND LITERAL(X$,"DIM ")=0 THEN !'DIM文より探索
LET X$=TRANSRESERVED$(X$)
LET BEHIND$=TRIM$(BEHINDSTRING$(X$,"DIM "))
CALL SPLIT2(BEHIND$,C$,N)
FOR K=1 TO N
LET AA$=TRIM$(LCASE$(FRONTSTRING$(C$(K),"(")))
LET SAME=0
FOR I=1 TO VA_ARRAY_COUNT
IF AA$=VARIABLE_ARRAY$(I) THEN LET SAME=1
NEXT I
IF SAME=0 THEN
LET VA_ARRAY_COUNT=VA_ARRAY_COUNT+1
LET VARIABLE_ARRAY$(VA_ARRAY_COUNT)=AA$
END IF
NEXT K
END IF
LET X$=A$(J)
LET SAME=0
IF POS(X$,"!")>0 AND LITERAL(X$,"!")=0 THEN LET X$=FRONTSTRING$(X$,"!")
IF POS(X$,"REM ")>0 AND LITERAL(X$,"REM ")=0 THEN LET X$=FRONTSTRING$(X$,"REM ")
IF POS(X$,"LET ")>0 AND LITERAL(X$,"LET ")=0 THEN !'LET文より探索
LET K=0
FOR I=1 TO LEN(X$)
IF X$(I:I)="=" THEN LET K=K+1
NEXT I
IF K=1 THEN
LET X$=TRIM$(BETWEENSTRING$(X$,"LET ","="))
ELSE
LET X$=TRANSFORM$(X$,"LET ","")
END IF
IF POS(X$,",")=0 THEN !'単指定「LET A=5」
LET X$=LCASE$(TRANSRESERVED$(X$))
IF POS(X$,"(")=0 THEN
FOR I=1 TO MAXSIZE
IF VARIABLE_STRING$(I)=X$ OR VARIABLE$(I)=X$ OR VARIABLE_FOR$(I)=X$ OR FUNCNAME$(I)=X$ OR VARIABLE_PUBLIC$(I)=X$ OR VARIABLE_ARGUMENT$(I)=X$ OR VARIABLE_ARRAY$(I)=X$ THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
IF POS(X$,"$")>0 THEN
LET VA_STRING_COUNT=VA_STRING_COUNT+1
LET VARIABLE_STRING$(VA_STRING_COUNT)=X$
ELSE
LET VA_COUNT=VA_COUNT+1
LET VARIABLE$(VA_COUNT)=X$
END IF
END IF
ELSE
LET X$=FRONTSTRING$(X$,"(")
FOR I=1 TO VA_ARRAY_COUNT
IF VARIABLE_ARRAY$(I)=X$ THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
LET VA_ARRAY_COUNT=VA_ARRAY_COUNT+1
LET VARIABLE_ARRAY$(VA_ARRAY_COUNT)=X$ !'配列変数名登録
END IF
END IF
ELSE !'複数指定「LET A(1,1),B,C=5」
CALL SPLIT2(X$,C$,N)
FOR K=1 TO N
IF POS(C$(K),"=")>0 THEN LET C$(K)=TRIM$(FRONTSTRING$(C$(K),"="))!'複数指定「LET A=1,B=2,C=3」
IF POS(C$(K),"(")=0 THEN
FOR I=1 TO MAXSIZE
IF VARIABLE_STRING$(I)=C$(K) OR VARIABLE$(I)=C$(K) OR VARIABLE_FOR$(I)=C$(K) OR FUNCNAME$(I)=C$(K) OR VARIABLE_PUBLIC$(I)=C$(K) OR VARIABLE_ARGUMENT$(I)=C$(K) OR VARIABLE_ARRAY$(I)=X$ THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
IF POS(C$(K),"$")>0 THEN
LET VA_STRING_COUNT=VA_STRING_COUNT+1
LET VARIABLE_STRING$(VA_STRING_COUNT)=C$(K)
ELSE
LET VA_COUNT=VA_COUNT+1
LET VARIABLE$(VA_COUNT)=C$(K)
END IF
END IF
ELSE
LET C$(K)=FRONTSTRING$(C$(K),"(")
FOR I=1 TO VA_ARRAY_COUNT
IF VARIABLE_ARRAY$(I)=C$(K) THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
LET VA_ARRAY_COUNT=VA_ARRAY_COUNT+1
LET VARIABLE_ARRAY$(VA_ARRAY_COUNT)=C$(K) !'配列変数名登録
END IF
END IF
NEXT K
END IF
END IF
LET SAME=0
LET X$=A$(J)
IF POS(X$,"!")>0 AND LITERAL(X$,"!")=0 THEN LET X$=FRONTSTRING$(X$,"!")
IF POS(X$,"REM ")>0 AND LITERAL(X$,"REM ")=0 THEN LET X$=FRONTSTRING$(X$,"REM ")
IF POS(X$,"FOR ")>0 AND LITERAL(X$,"FOR ")=0 THEN !'FOR文より探索
LET X$=TRIM$(BETWEENSTRING$(X$,"FOR ","="))
LET X$=LCASE$(TRANSRESERVED$(X$))
FOR I=1 TO MAXSIZE
IF VARIABLE_FOR$(I)=X$ OR VARIABLE_STRING$(I)=X$ OR VARIABLE$(I)=X$ OR VARIABLE_PUBLIC$(I)=X$ OR VARIABLE_ARGUMENT$(I)=X$ THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
LET VA_FOR_COUNT=VA_FOR_COUNT+1
LET VARIABLE_FOR$(VA_FOR_COUNT)=X$
END IF
END IF
LET X$=A$(J)
IF POS(X$,"!")>0 AND LITERAL(X$,"!")=0 THEN LET X$=FRONTSTRING$(X$,"!")
IF POS(X$,"REM ")>0 AND LITERAL(X$,"REM ")=0 THEN LET X$=FRONTSTRING$(X$,"REM ")
IF POS(X$,"INPUT ")>0 AND LITERAL(X$,"INPUT ")=0 THEN !'INPUT文より探索
IF POS(X$,":")>0 THEN
LET SW=0
FOR I=1 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN LET SW=1-SW
IF SW=0 AND X$(I:I)=":" THEN EXIT FOR
NEXT I
LET X$=X$(I+1:LEN(X$))
ELSE
LET X$=TRIM$(BEHINDSTRING$(X$,"INPUT"))
END IF
LET X$=LCASE$(TRANSRESERVED$(X$))
LET SP=0
FOR I=1 TO LEN(X$)
IF X$(I:I)="(" THEN
LET SP=SP+1
FOR K=I+1 TO LEN(X$)
IF X$(K:K)="(" THEN LET SP=SP+1
IF SP>0 AND X$(K:K)="," THEN LET X$(K:K)="\" !'多次元配列内の「,」置換
IF X$(K:K)=")" THEN LET SP=SP-1
IF SP=0 THEN EXIT FOR
NEXT K
END IF
NEXT I
CALL TOKUN(X$,C$,N) !'区切り「,」で分割
FOR K=1 TO N
IF C$(K)<>"" THEN
LET SAME=0
IF POS(C$(K),"(")=0 THEN
FOR I=1 TO MAXSIZE
IF VARIABLE_FOR$(I)=C$(K) OR VARIABLE_STRING$(I)=C$(K) OR VARIABLE$(I)=C$(K) OR VARIABLE_PUBLIC$(I)=C$(K) OR VARIABLE_ARGUMENT$(I)=C$(K) OR VARIABLE_ARRAY$(I)=C$(K) THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
IF POS(C$(K),"$")>0 THEN
LET VA_STRING_COUNT=VA_STRING_COUNT+1
LET VARIABLE_STRING$(VA_STRING_COUNT)=C$(K)
ELSE
LET VA_COUNT=VA_COUNT+1
LET VARIABLE$(VA_COUNT)=C$(K)
END IF
END IF
END IF
END IF
NEXT K
END IF
LET X$=A$(J)
IF POS(X$,"!")>0 AND LITERAL(X$,"!")=0 THEN LET X$=FRONTSTRING$(X$,"!")
IF POS(X$,"REM ")>0 AND LITERAL(X$,"REM ")=0 THEN LET X$=FRONTSTRING$(X$,"REM ")
IF POS(X$,"CALL ")>0 AND POS(X$,"(")>0 AND LITERAL(X$,"CALL ")=0 THEN !'CALL文より探索
LET SP=0
FOR I=1 TO LEN(X$)
IF X$(I:I)="(" THEN
LET K=I
FOR N=K+1 TO LEN(X$)
IF X$(N:N)="(" THEN LET SP=SP+1
IF X$(N:N)=")" THEN LET SP=SP-1
IF SP>0 AND X$(N:N)="," THEN LET X$(N:N)="\"
IF SP=0 THEN EXIT FOR
NEXT N
LET BETWEEN$=X$(K+1:N-1)
EXIT FOR
END IF
NEXT I
CALL TOKUN(BETWEEN$,C$,N)
FOR K=1 TO N
IF C$(K)<>"" THEN
IF POS(C$(K),"(")>0 THEN LET C$(K)=TRIM$(FRONTSTRING$(C$(K),"("))
LET SAME=0
LET FL=0
IF C$(K)<>"" AND POS("0123456789",C$(K)(1:1))=0 THEN
FOR I=1 TO LEN(C$(K))
IF POS("+-*/^&"&CHR$(34),C$(K)(I:I))>0 THEN LET FL=1
NEXT I
IF FL=0 THEN
LET B$=TRANSFUNC$(C$(K))
IF B$<>C$(K) THEN LET FL=1
END IF
IF FL=0 THEN
LET C$(K)=LCASE$(TRANSRESERVED$(C$(K)))
FOR I=1 TO MAXSIZE
IF VARIABLE_FOR$(I)=C$(K) OR VARIABLE_STRING$(I)=C$(K) OR VARIABLE$(I)=C$(K) OR VARIABLE_PUBLIC$(I)=C$(K) OR VARIABLE_ARRAY$(I)=C$(K) OR VARIABLE_ARGUMENT$(I)=C$(K) THEN
LET SAME=1
EXIT FOR
END IF
NEXT I
IF SAME=0 THEN
IF POS(C$(K),"$")>0 THEN
LET VA_STRING_COUNT=VA_STRING_COUNT+1
LET VARIABLE_STRING$(VA_STRING_COUNT)=C$(K)
ELSE
LET VA_COUNT=VA_COUNT+1
LET VARIABLE$(VA_COUNT)=C$(K)
END IF
END IF
END IF
END IF
END IF
NEXT K
END IF
LET J=J+1
LOOP UNTIL POS(X$,"END")>0 AND POS(X$,"END IF")=0 AND POS(X$,"END SELECT")=0 AND POS(X$,"END WHEN")=0 AND LITERAL(X$,"END")=0
LET B$=""
LET AA$=""
LET BB$=""
IF VA_COUNT>0 THEN !'変数名宣言、初期化
LET B$=TYPE$
FOR I=1 TO VA_COUNT-1
IF VARIABLE$(I)<>"" THEN LET B$=B$&LCASE$(VARIABLE$(I))&"=0,"
NEXT I
IF VARIABLE$(VA_COUNT)<>"" THEN LET B$=B$&LCASE$(VARIABLE$(VA_COUNT))&"=0;" ELSE LET B$=B$(1:LEN(B$)-1)&";"
END IF
IF VA_FOR_COUNT>0 THEN !'FOR文での使用変数名宣言、初期化
LET BB$="double " !'仕様変更
!' LET BB$="int "
FOR I=1 TO VA_FOR_COUNT-1
IF VARIABLE_FOR$(I)<>"" THEN LET BB$=BB$&LCASE$(VARIABLE_FOR$(I))&"=0,"
NEXT I
IF VARIABLE_FOR$(VA_FOR_COUNT)<>"" THEN LET BB$=BB$&LCASE$(VARIABLE_FOR$(VA_FOR_COUNT))&"=0;" ELSE LET BB$=BB$(1:LEN(BB$)-1)&";"
END IF
IF VA_STRING_COUNT>0 THEN !'文字列変数名宣言、初期化
LET AA$="string "
FOR I=1 TO VA_STRING_COUNT-1
LET AA$=AA$&LCASE$(VARIABLE_STRING$(I))&"="&CHR$(34)&CHR$(34)&","
NEXT I
LET AA$=AA$&LCASE$(VARIABLE_STRING$(VA_STRING_COUNT))&"="&CHR$(34)&CHR$(34)&";"
END IF
IF B$<>"" THEN CALL CPRINT(B$)
IF BB$<>"" THEN CALL CPRINT(BB$)
IF AA$<>"" THEN
LET AA$=TRANSFORM$(AA$,"$","_string")
CALL CPRINT(AA$)
END IF
IF B$<>"" OR BB$<>"" OR AA$<>"" THEN CALL CPRINT("")
END SUB
SUB CPRINT(X$) !'簡易整形&表示
IF POS(X$,"{")>0 AND POS(X$,"{}")=0 AND POS(X$,"{"&CHR$(34)&CHR$(34)&"}")=0 AND LITERAL(X$,"{")=0 THEN
PRINT REPEAT$(" ",CTAB*4);
LET CTAB=CTAB+1
ELSEIF POS(X$,"}")>0 AND POS(X$,"{}")=0 AND POS(X$,"{"&CHR$(34)&CHR$(34)&"}")=0 AND LITERAL(X$,"}")=0 THEN
LET CTAB=CTAB-1
IF CTAB<0 THEN LET CTAB=0
PRINT REPEAT$(" ",CTAB*4);
ELSE
PRINT REPEAT$(" ",CTAB*4);
END IF
IF POS(X$,"null")>0 AND LITERAL(X$,"null")=0 THEN LET X$=TRANSFORM$(X$,"null","NULL")
PRINT TRIM$(X$)
END SUB
END
EXTERNAL SUB SPLIT(X$,C$(),N) !'PRINT文抽出ルーチン(偶数番目が文字定数)
OPTION ARITHMETIC NATIVE !'A;"ABC";B;"DEF" → C$(1)=A; C$(2)="ABC" C$(3)=;B; C$(4)="DEF"
MAT C$=NUL$ !'"ABC";B;C;"DEF" → C$(1)="" C$(2)="ABC" C$(3)=;B;C; C$(4)="DEF"
LET N=1
FOR I=1 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN
IF MOD(N,2)=0 THEN
LET C$(N)=C$(N)&X$(I:I)
LET N=N+1
ELSE
LET N=N+1
LET C$(N)=C$(N)&X$(I:I)
END IF
ELSE
LET C$(N)=C$(N)&X$(I:I)
END IF
NEXT I
END SUB
EXTERNAL SUB SPLIT2(X$,C$(),N) !'抽出ルーチン「,」区切り
OPTION ARITHMETIC NATIVE !'A,B(1,1),"A,B" → A
LET SP=0 !' B(1,1)
MAT C$=NUL$ !' "A,B"
LET N=0
LET SW=0
FOR I=1 TO LEN(X$)
IF I=1 OR X$(I:I)="," THEN
IF I=1 THEN LET K=1 ELSE LET K=I+1
FOR J=I+1 TO LEN(X$)
IF X$(J:J)="(" THEN LET SP=SP+1
IF X$(J:J)=")" THEN LET SP=SP-1
IF X$(J:J)=CHR$(34) THEN LET SW=1-SW
IF SW=0 AND SP=0 AND X$(J:J)="," OR J=LEN(X$) THEN EXIT FOR
NEXT J
LET N=N+1
IF J=LEN(X$) THEN LET J=J+1
LET C$(N)=TRIM$(X$(K:J-1))
LET I=J-1
END IF
NEXT I
END SUB
EXTERNAL FUNCTION TRANSFORM$(A$,B$,C$) !'置換ルーチン TRANSFORM$("AAABAB","A","a")="aaaBaB"
OPTION ARITHMETIC NATIVE
DO !'複数個に対応するためループ
LET N=POS(A$,B$)
IF N>0 THEN
LET L$=LEFT$(A$,N-1)
LET R$=RIGHT$(A$,LEN(A$)-LEN(B$)-N+1)
LET A$=L$&C$&R$
END IF
LOOP UNTIL N=0
LET TRANSFORM$=A$
END FUNCTION
EXTERNAL FUNCTION TRANSFORM2$(A$,B$,C$) !'置換ルーチン
OPTION ARITHMETIC NATIVE
LET I=0
DO
LET I=I+1
IF A$(I:I)=CHR$(34) THEN LET SW=1-SW
IF SW=0 AND A$(I:I+LEN(B$)-1)=B$ THEN
LET A$(I:I+LEN(B$)-1)=""
LET A$(I:I-1)=C$
END IF
LOOP UNTIL LEN(A$)<=I
LET TRANSFORM2$=A$
END FUNCTION
EXTERNAL FUNCTION FRONTSTRING$(A$,B$) !'前方取り出し FRONTSTRING$("ABCDEFG","DE")="ABC"
OPTION ARITHMETIC NATIVE
LET N=POS(A$,B$)
IF N=0 THEN
LET FRONTSTRING$=A$
ELSE
LET FRONTSTRING$=A$(1:N-1)
END IF
END FUNCTION
EXTERNAL FUNCTION BEHINDSTRING$(A$,B$) !'後方取り出し BEHINDSTRING$("ABCDEFG","DE")="FG"
OPTION ARITHMETIC NATIVE
LET N=POS(A$,B$)
IF N=0 THEN
LET BEHINDSTRING$=A$
ELSE
LET BEHINDSTRING$=A$(N+LEN(B$):LEN(A$))
END IF
END FUNCTION
EXTERNAL FUNCTION BETWEENSTRING$(X$,B$,A$) !'指定間取り出し BETWEENSTRING$("ABCDEFG","B","F")="CDE"
OPTION ARITHMETIC NATIVE
LET K$=BEHINDSTRING$(X$,B$)
LET BETWEENSTRING$=FRONTSTRING$(K$,A$)
END FUNCTION
EXTERNAL SUB TOKUN(A$,X$(),K) !'抽出ルーチン「,」区切り
OPTION ARITHMETIC NATIVE
LET B$=A$
MAT X$=NUL$
LET K=0
DO
LET N=POS(B$,",")
IF N>0 THEN
LET K=K+1
LET X$(K)=TRIM$(FRONTSTRING$(B$,","))
LET B$=BEHINDSTRING$(B$,",")
END IF
LOOP UNTIL N=0
LET K=K+1
IF RIGHT$(B$,1)="," THEN
LET X$(K)=TRIM$(LEFT$(B$,LEN(B$)-1))
ELSE
LET X$(K)=TRIM$(B$)
END IF
END SUB
EXTERNAL FUNCTION TRANSFUNC$(X$) !'関数名変換ルーチン SQR(X) → sqrt(x)
OPTION ARITHMETIC NATIVE
RESTORE
DO
READ IF MISSING THEN EXIT DO:S$,T$
LET FL=0
FOR I=1 TO FC
IF POS(LCASE$(X$),FUNCNAME$(I))>0 THEN !'FUNCTION定義で同一関数名ではない
LET FL=1
IF FUNCNAMENOARG$(I)<>"" THEN !'DEF文定義の引数なしの場合「()」をつける DEF F=X^2 , LET Y=Y+F → =y=y+f();
LET X$=TRANSFORM$(X$,UCASE$(FUNCNAMENOARG$(I)(1:LEN(FUNCNAMENOARG$(I))-2)),"#")
LET X$=TRANSFORM$(X$,"#",FUNCNAMENOARG$(I))
END IF
END IF
NEXT I
IF FL=0 THEN
DO WHILE POS(X$,S$)>0 AND LITERAL(X$,S$)=0
LET X$=TRANSFORM$(X$,S$,T$)
LOOP
LET SS$=S$(1:LEN(S$)-1)&" ("
DO WHILE POS(X$,SS$)>0 AND LITERAL(X$,SS$)=0
LET X$=TRANSFORM$(X$,SS$,T$)
LOOP
END IF
LOOP
DO
LET FL=0
!'IF POS(X$,"POS(")>0 THEN
!' LET I=POS(X$,"POS(")
!' LET X$=TRANSFORM$(X$,"POS(","")
!' LET X$=TRANSFORM$(X$,",",".find(")
!' LET I=POS(X$,")",I)
!' LET X$(I:I)=",0)"
!' LET FL=1
!'END IF
!' IF POS(X$,"VAL(")>0 AND POS(X$,"BVAL(")=0 THEN
!' LET X$=TRANSFORM$(X$,"VAL(","atod(")
!' LET X$=TRANSFORM$(X$,")",".c_str(}}")
!' LET X$=TRANSFORM$(X$,"}",")")
!' LET FL=1
!' END IF
IF POS(X$,"^")>0 AND LITERAL(X$,"^")=0 THEN
DO WHILE POS(X$,"^")>0
LET N=POS(X$,"^")
LET SP=0
FOR I=N-1 TO 1 STEP -1
IF X$(I:I)=")" OR X$(I:I)="]" THEN LET SP=SP+1
IF SP>0 AND (X$(I:I)="(" OR X$(I:I)="[") THEN LET SP=SP-1
IF POS("=,+-*/(<>[ ",X$(I:I))>0 AND SP=0 AND (I<>N-1 OR X$(I:I)<>" ") THEN
IF POS("(",X$(I:I))>0 AND POS("+-*/=,",X$(I-1:I-1))>0 OR POS("<>=,+-*/ ",X$(I:I))>0 OR POS("abcdefghijklmnopqrstuvwxyz",LCASE$(X$(I-1:I-1)))=0 OR POS("([",X$(I:I))>0 AND POS("abcdefghijklmnopqrstuvwxyz",LCASE$(X$(I-1:I-1)))>0 AND (X$(N-1:N)<>")^" AND X$(N-1:N)<>"]^") THEN
IF X$(N-1:N)=")^" OR X$(N-1:N)="]^" THEN
IF (POS("+-*/ ",X$(I-1:I-1))>0 OR X$(I-1:I)="((") AND POS("abcdefghijklmnopqrstuvwxyz",LCASE$(X$(I-1:I-1)))=0 THEN
LET X$(I:I-1)="pow("
ELSE
LET X$(I+1:I)="pow("
END IF
ELSE
LET X$(I+1:I)="pow("
END IF
EXIT FOR
END IF
ELSEIF SP=0 AND I=1 AND POS(",(=+-*/[ ",X$(I:I))=0 THEN
LET X$="pow("&X$
EXIT FOR
END IF
NEXT I
LET N=POS(X$,"^")
LET SP=0
FOR I=N+1 TO LEN(X$)
IF X$(I:I)="(" OR X$(I:I)="[" THEN LET SP=SP+1
IF SP>0 AND (X$(I:I)=")" OR X$(I:I)="]") THEN LET SP=SP-1
IF POS(",)+-*/]<> ",X$(I:I))>0 AND SP=0 AND (I<>N+1 OR X$(I:I)<>" ") THEN
LET X$(I:I-1)=")"
EXIT FOR
ELSEIF SP=0 AND I=LEN(X$) AND POS(",)+-*/] ",X$(I:I))=0 THEN
LET X$=X$&")"
END IF
NEXT I
LET X$(N:N)=","
LOOP
LET FL=1
END IF
IF POS(X$,"LEN(")>0 THEN
LET I=POS(X$,"LEN(")
LET X$=TRANSFORM$(X$,"BLEN(","")
LET X$=TRANSFORM$(X$,"LEN(","")
LET I=POS(X$,")",I)
LET X$(I:I)=""
LET X$(I:I)=".size()"
LET FL=1
END IF
!' IF POS(X$,"ANGLE(")>0 THEN
!' LET I=POS(X$,"ANGLE(")
!' LET J=POS(X$,",",I)
!' LET AA$=X$(I+6:J-1)
!' LET K=POS(X$,")",J)
!' LET BB$=X$(J+1:K-1)
!' LET X$=TRANSFORM$(X$,"ANGLE(","atan2(")
!' LET X$=TRANSFORM$(X$,AA$,REPEAT$("#",LEN(AA$)))
!' LET X$=TRANSFORM$(X$,BB$,REPEAT$("&",LEN(BB$)))
!' LET X$=TRANSFORM$(X$,REPEAT$("#",LEN(AA$)),BB$)
!' LET X$=TRANSFORM$(X$,REPEAT$("&",LEN(BB$)),AA$)
!' LET FL=1
!' END IF
!' IF POS(X$,"LEFT$(")>0 THEN
!' LET I=POS(X$,"LEFT$(")
!' LET X$=TRANSFORM$(X$,"LEFT$(","")
!' LET I=POS(X$,",",I)
!' LET X$(I:I)=".substr(0,"
!' LET FL=1
!' END IF
!' IF POS(X$,"RIGHT$(")>0 THEN
!' LET I=POS(X$,"RIGHT$(")
!' LET BETWEEN$=BETWEENSTRING$(X$,"RIGHT$(",",")
!' LET NUM$=BETWEENSTRING$(X$,",",")")
!' LET X$=TRANSFORM$(X$,"RIGHT$(","")
!' LET I=POS(X$,",",I)
!' LET X$(I:I)=".substr("&BETWEEN$&".size()-"&NUM$&","
!' LET FL=1
!' END IF
!' IF POS(X$,"MID$(")>0 THEN
!' DIM C$(3)
!' LET J=POS(X$,"MID$(")
!' LET SP=0
!' FOR I=J+5 TO LEN(X$)
!' IF X$(I:I)="," THEN LET SP=SP+1
!' IF SP=2 AND X$(I:I)=")" THEN EXIT FOR
!' NEXT I
!' CALL TOKUN(X$(J:I),C$)
!' LET X$=TRANSFORM$(X$,"MID$("&C$(1),C$(1)&".subst("&C$(2)&"-1,"&C$(3)&")")
!' LET FL=1
!' END IF
!' IF POS(X$,"BITAND(")>0 THEN
!' LET I=POS(X$,"BITAND(")
!' LET I=POS(X$,",",I)
!' LET X$(I:I)="&"
!' LET X$=TRANSFORM$(X$,"BITAND","")
!' LET FL=1
!' END IF
!' IF POS(X$,"BITOR(")>0 THEN
!' LET I=POS(X$,"BITOR(")
!' LET I=POS(X$,",",I)
!' LET X$(I:I)="|"
!' LET X$=TRANSFORM$(X$,"BITOR","")
!' LET FL=1
!' END IF
!' IF POS(X$,"BITXOR(")>0 THEN
!' LET I=POS(X$,"BITXOR(")
!' LET I=POS(X$,",",I)
!' LET X$(I:I)="^"
!' LET X$=TRANSFORM$(X$,"BITXOR","")
!' LET FL=1
!' END IF
!' IF POS(X$,"BITNOT(")>0 THEN
!' LET X$=TRANSFORM$(X$,"BITNOT","~")
!' LET FL=1
!' END IF
IF POS(X$,"&&")=0 AND POS(X$,"&")>0 AND LITERAL(X$,"&")=0 THEN
LET X$=TRANSFORM$(X$,"&","+")
LET FL=1
END IF
LET I=POS(X$,"/")
IF I>0 THEN
LET SW=0
LET I=0
DO
LET I=I+1
IF X$(I:I)=CHR$(34) THEN LET SW=1-SW
IF SW=0 AND X$(I:I)="/" AND X$(I:I+8)<>"/(double)" THEN
LET K=0
LET L=0
FOR J=I-1 TO 1 STEP -1 !'被除数
IF POS("0123456789",X$(J:J))>0 THEN !'定数か
LET K=1
END IF
IF POS("abcdefghijklmnopqrstuvwxyz",LCASE$(X$(J:J)))>0 THEN !'変数、関数なら
LET K=0 !'変数名 A123など
EXIT FOR
END IF
IF POS("= ;,+-*/<>()[]",X$(J:J))>0 AND (J<>I-1 OR X$(J:J)<>" ") THEN EXIT FOR
NEXT J
FOR J=I+1 TO LEN(X$) !'除数
IF POS("0123456789",X$(J:J))>0 THEN
LET L=1
END IF
IF POS("abcdefghijklmnopqrstuvwxyz",LCASE$(X$(J:J)))>0 THEN !'変数、関数なら
LET L=0
EXIT FOR
END IF
IF POS(" ;,+-*/<>()[]",X$(J:J))>0 AND (J<>I+1 OR X$(J:J)<>" ") THEN EXIT FOR
NEXT J
IF K=1 AND L=1 THEN !'共に定数なら
LET X$(I:I)="/(double)" !'double型へキャスト
LET I=I+8
LET FL=1
END IF
END IF
LOOP UNTIL I>=LEN(X$)
END IF
IF POS(X$,"TIME")>0 AND LITERAL(X$,"TIME")=0 AND POS(X$,"TIME$")=0 THEN
LET X$=TRANSFORM$(X$,"TIME","(unsigned)time(NULL)")
LET FL=1
END IF
IF POS(X$,CHR$(34)&CHR$(34)&CHR$(34)&CHR$(34))>0 THEN !'「PRINT """";A$;""""」
LET X$=TRANSFORM$(X$,CHR$(34)&CHR$(34)&CHR$(34)&CHR$(34),CHR$(39)&CHR$(34)&CHR$(39))
LET FL=1
END IF
LOOP UNTIL FL=0
IF LITERAL(X$,"$")=0 THEN LET X$=TRANSFORM$(X$,"$","_string")
LET TRANSFUNC$=X$
DATA "ABS(","abs(" !'関数名置換リスト BASIC → C/C++
DATA "ARG(","arg("
DATA "ANGLE(","angle("
DATA "ASIN(","asin("
DATA "ATN(","atan("
DATA "ACOS(","acos("
DATA "ACSC(","asin(1.0/" !'「"A・CSC("」
DATA "ASEC(","acos(1.0/"
DATA "ACOT(","atan(1.0/"
DATA "ATANH(","atanh("
DATA "ASINH(","asinh("
DATA "ACOSH(","acosh("
DATA "ASECH(","asech("
DATA "ACSCH(","acsch("
DATA "ACOTH(","acoth("
DATA "SUBSTR$(","substr(" !'「"SUB・STR$("」「"SU・BSTR$("」
DATA "BSTR$(","bstr("
DATA "BVAL(","bval("
DATA "BITAND(","bit_and("
DATA "BITOR(","bit_or("
DATA "BITXOR(","bit_xor("
DATA "BITNOT(","bit_not(" !'「"BIT・NOT("」
DATA "BITIMP(","bit_imp("
DATA "CEIL(","ceil("
DATA "CHR$(","chr("
DATA "COMB(","comb("
DATA "CONJ(","conj("
DATA "COMPLEX(","complex<double>("
DATA "COS(","cos("
DATA "COT(","1.0/tan("
DATA "CSC(","1.0/sin("
DATA "CSCH(","1.0/sinh("
DATA "COSH(","cosh("
DATA "COTH(","1.0/tanh("
DATA "CBRT(","cbrt(" !'立方根 X^(1/3)
DATA "DEG(","(180.0/pi*"
DATA "DENOM(","denominator("
DATA "EXP(","exp("
DATA "ERF(","erf(" !'誤差関数
DATA "ERFC(","erfc(" !'1-erf(x)
DATA "EPS(","eps("
DATA "FACT(","fact("
DATA "FP(","fp("
DATA "LGAMMA(","lgamma(" !'対数ガンマ関数「"L・GAMMA("」
DATA "GAMMA(","tgamma(" !'ガンマ関数
DATA "GCD(","gcd("
DATA "HYPOT(","hypot(" !'HYPOT(X,Y)=SQR(X*X+Y*Y)
DATA "IP(","ip("
DATA "INT(","floor("
DATA "IM(","imag("
DATA "J0(","j0(" !'ベッセル関数 J0(X)
DATA "J1(","j1(" !'ベッセル関数 J1(X)
DATA "JN(","jn(" !'ベッセル関数 JN(N,X)
DATA "LCM(","lcm("
DATA "LOG(","log("
DATA "LOG2(","log2("
DATA "LOG10(","log10("
DATA "LTRIM$(","ltrim("
DATA "LCASE$(","lcase("
DATA "LEFT$(","left("
DATA "MOD(","fmod("
DATA "MID$(","mid("
DATA "MAX(","fmax("
DATA "MIN(","fmin("
!'DATA "MAX(","tmax("
!'DATA "MIN(","tmin("
DATA "NOT(","(! "
DATA "NUMER(","numerator("
DATA "ORD(","ord("
DATA "PERM(","perm("
DATA "POS(","pos("
DATA "RND","rand()/32768.0"
DATA "ROUND(","round("
DATA "REMAINDER(","fmod("
DATA "RAD(","(pi/180.0*"
DATA "RE(","real("
DATA "RTRIM$(","rtrim("
DATA "RIGHT$(","right("
DATA "REPEAT$(","repeat("
DATA "SPC(","spc("
DATA "SGN(","sgn("
DATA "SQR(","sqrt("
DATA "SIN(","sin("
DATA "SEC(","1.0/cos("
DATA "SINH(","sinh("
DATA "SECH(","1.0/cosh("
!'DATA "STR$(","toString<double>("
DATA "STR$(","str("
DATA "UBOUND(","ubound("
DATA "TRUNCATE(","truncate("
DATA "TAN(","tan("
DATA "TANH(","tanh("
DATA "TAB(","tab("
DATA "UCASE$(","ucase("
DATA "VAL(","val("
DATA "Y0(","y0(" !'ベッセル関数 Y0(X)
DATA "Y1(","y1(" !'ベッセル関数 Y1(X)
DATA "YN(","yn(" !'ベッセル関数 YN(N,X)
END FUNCTION
EXTERNAL FUNCTION TRANSCO$(A$) !'条件式変換
OPTION ARITHMETIC NATIVE
LET S$="_0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
LET I=POS(A$,"AND")
IF I>0 AND POS(S$,A$(I-1:I-1))=0 AND POS(S$,A$(I+3:I+3))=0 THEN LET A$=TRANSFORM2$(A$,"AND"," && ")
LET I=POS(A$,"OR")
IF I>0 AND POS(S$,A$(I-1:I-1))=0 AND POS(S$,A$(I+2:I+2))=0 THEN LET A$=TRANSFORM2$(A$,"OR"," || ")
IF POS(A$,"<=")>0 THEN LET A$=TRANSFORM2$(A$,"=<","<=")
IF POS(A$,"=>")>0 THEN LET A$=TRANSFORM2$(A$,"=>",">=")
IF POS(A$,"<=")=0 AND POS(A$,">=")=0 AND POS(A$,"=")>0 THEN
LET A$=TRANSFORM2$(A$,"=","\") !'無限ループ抑制
LET A$=TRANSFORM2$(A$,"\","==")
END IF
IF POS(A$,"<>")>0 THEN LET A$=TRANSFORM2$(A$,"<>","!=")
IF POS(A$,"><")>0 THEN LET A$=TRANSFORM2$(A$,"><","!=")
LET TRANSCO$=A$
END FUNCTION
EXTERNAL FUNCTION TRANSRESERVED$(X$) !'C/C++予約語名変換("_"アンダーバー付加)
OPTION ARITHMETIC NATIVE
RESTORE
DO
READ IF MISSING THEN EXIT DO:A$
LET I=POS(X$,A$)
IF LITERAL(X$,A$)=0 AND (I>0 AND POS(" (),+-*/=<>",X$(I-1:I-1))>0) OR I=1 THEN
LET X$=TRANSFORM2$(X$,A$,"_"&LCASE$(A$))
END IF
LOOP
LET TRANSRESERVED$=X$
DATA ALIGNOF,ALIGNAS,ASM,AUTO,BOOL,BREAK,CATCH,CHAR,CLASS,CONST,CONSTEXPR,CONTINUE,DECLTYPE,DEFAULT,DELETE,DOUBLE
DATA ENUM,EXPLICIT,EXPORT,FALSE,FINAL,FLOAT,FRIEND,INLINE,LONG,MUTABLE,NAMESPACE,NEW,OPERATOR,OVERRIDE
DATA PRIVATE,PROTECTED,REGISTER,SHORT,SIGNED,SIZEOF,STATIC,STRUCT,SWITCH
DATA TEMPLATE,THIS,THROW,TRUE,TRY,TYPEDEF,TYPEID,TYPENAME,NOEXCEPT,NULLPTR,USING,UNION,UNSIGNED,VIRTUAL,VOID,VOLATILE
DATA XOR,RESTRICT
!'DATA COMPL,EXTERN
END FUNCTION
EXTERNAL FUNCTION TRANSARRAYNAME$(X$) !'配列変数名変換 SQR(A(10)) → SQR(a[10])
OPTION ARITHMETIC NATIVE
LET X$=TRIM$(X$)
LET I=0
DO
LET I=POS(X$,"(",I+1)
IF I=0 THEN EXIT DO
RESTORE
LET FL=0
DO
READ IF MISSING THEN EXIT DO:FUNC$
IF LEN(FUNC$)<=I AND X$(I-LEN(FUNC$)+1:I)=FUNC$ THEN
LET FL=1
IF FUNC$=" (" AND POS("abcdefghijklmnopqrstuvwxyz",LCASE$(X$(I-2:I-2)))>0 THEN !' A (N) → a[n]
LET X$(I-1:I-1)=""
LET FL=0
ELSE
EXIT DO
END IF
END IF
IF FUNC$(LEN(FUNC$):LEN(FUNC$))="(" THEN
LET S$=FUNC$(1:LEN(FUNC$)-1)&" ("
IF LEN(S$)<=I AND X$(I-LEN(S$)+1:I)=S$ THEN
LET FL=1
EXIT DO
END IF
END IF
LOOP
IF FL=0 THEN
FOR J=1 TO FC
IF LEN(FUNCNAME$(J))<=I AND LCASE$(X$(I-LEN(FUNCNAME$(J)):I))=FUNCNAME$(J)&"(" THEN
LET FL=1
EXIT FOR
END IF
NEXT J
END IF
IF I>1 AND (X$(I-1:I)="=(" OR X$(I-1:I)="^(") OR X$(1:1)="(" THEN LET FL=1
LET SP=0
IF FL=0 THEN
IF X$(I:I)="(" THEN LET SP=SP+1
LET X$(I:I)="["
LET J=I
DO
LET J=J+1
IF X$(J:J)="(" THEN LET SP=SP+1
IF X$(J:J)=")" THEN LET SP=SP-1
IF SP=0 THEN
LET X$(J:J)="]"
EXIT DO
END IF
IF SP=1 AND X$(J:J)="," THEN LET X$(J:J)="]["
LOOP UNTIL LEN(X$)<=J
END IF
LOOP
IF TYPE$="complex <double> " THEN
LET X$=TRANSFORM$(X$,"[","\static_cast<int>(abs(") !'int型へ強制キャスト(複素数型)
LET X$=TRANSFORM$(X$,"\","[")
LET X$=TRANSFORM$(X$,"]","))\")
LET X$=TRANSFORM$(X$,"\","]")
ELSE
LET X$=TRANSFORM$(X$,"[","\static_cast<int>(") !'int型へ強制キャスト
LET X$=TRANSFORM$(X$,"\","[")
LET X$=TRANSFORM$(X$,"]",")\")
LET X$=TRANSFORM$(X$,"\","]")
END IF
LET TRANSARRAYNAME$=X$
DATA "ABS(","ACOS(","ANGLE(","ARG(","ASIN(","ATN(","ACSC(","ASEC(","ACOT(","ASECH(","ACSCH(","ACOTH("
DATA "BITAND(","BITNOT(","BITOR(","BITXOR(","BLEN(","SUBSTR$(","BSTR$(","BVAL("
DATA "CEIL(","CHR$(","CONJ(","COS(","COSH(","COT(","COTH(","CON(","CSC(","CSCH(","COMPLEX(","COMB("
DATA "DEG(","DENOM(","DET(","DWORD$(","DOT("
DATA "EXP(","EPS(","FACT(","FP(","GCD("
DATA "IM(","INT(","IP(","LBOUND(","LCASE$(","LEFT$(","LEN(","LOG(","LOG10(","LOG2(","LTRIM$("
DATA "MAX(","MID$(","MIN(","MOD(","NOT(","NUMER(","ORD("
DATA "PACKDBL$(","PERM(","POS(","PIXLX(","PIXELY(","RAD(","RE(","REMAINDER(","REPEAT$(","RIGHT$(","RTRIM$(","ROUND("
DATA "SEC(","SECH(","SGN(","SIN(","SINH(","SQR(","STR$(","SIZE(","SPC("
DATA "TAB(","TAN(","TANH(","TRUNCATE("
DATA "UBOUND(","UCASE$(","USING$(","UNPACKDBL(","VAL(","WORD$(","WORLDX(","WORLDY("
DATA "LGAMMA(","GAMMA(","ERF(","ERFC(","HYPOT(","CBRT(","J0(","J1(","JN(","Y0(","Y1(","YN("
DATA "+(","-(","*(","/("," (","((","IF(","OR(","AND(","||(","&&(","pow("
END FUNCTION
EXTERNAL FUNCTION TRIM$(X$) !'空白削除
OPTION ARITHMETIC NATIVE
LET TRIM$=RTRIM$(LTRIM$(X$))
END FUNCTION
EXTERNAL FUNCTION LITERAL(X$,Y$) !'文字定数か
OPTION ARITHMETIC NATIVE
LET K=POS(X$,Y$)
LET S=0
IF K>0 THEN
FOR I=K+1 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN
LET S=S+1
EXIT FOR
END IF
NEXT I
FOR I=K-1 TO 1 STEP -1
IF X$(I:I)=CHR$(34) THEN
LET S=S+1
EXIT FOR
END IF
NEXT I
END IF
IF S=2 THEN LET LITERAL=1 ELSE LET LITERAL=0
END FUNCTION
EXTERNAL FUNCTION LLCASE$(X$) !'文字定数でないなら小文字化
OPTION ARITHMETIC NATIVE
LET S$=""
LET SW=0
FOR I=1 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN LET SW=1-SW
IF SW=0 THEN
LET S$=S$&LCASE$(X$(I:I))
ELSE
LET S$=S$&X$(I:I)
END IF
NEXT I
LET LLCASE$=S$
END FUNCTION
EXTERNAL FUNCTION UUCASE$(X$)
OPTION ARITHMETIC NATIVE
LET S$=""
LET SW=0
FOR I=1 TO LEN(X$)
IF X$(I:I)=CHR$(34) THEN LET SW=1-SW
IF SW=0 THEN
LET S$=S$&UCASE$(X$(I:I))
ELSE
LET S$=S$&X$(I:I)
END IF
NEXT I
LET UUCASE$=S$
END FUNCTION
EXTERNAL SUB SETUP(X$) !'手始めに大文字にする 大文字→小文字化(無限ループを抑える)
OPTION ARITHMETIC NATIVE
LET X$=TRIM$(X$)
LET I=POS(X$,"!")
IF I=0 THEN LET I=POS(X$,"REM ")
IF I>0 AND LITERAL(X$,"!")=0 AND LITERAL(X$,"REM ")=0 THEN
LET BEHIND$=X$(I:LEN(X$))
LET X$=X$(1:I-1)
END IF
LET X$=UUCASE$(X$)&BEHIND$
END SUB
LET RR=2 !赤の枚数 ※自然数n≧2
LET BB=1 !青の枚数 ※約数d=n-1
LET R=RR !赤の裏向きの枚数 step.1
LET B=BB !青の裏向きの枚数
DO
LET M=MIN(R,B) !表にする枚数 step.2
LET R=R-M !※dをひく
LET B=B-M
IF R=0 AND B=0 THEN !step.3C ※dで割り切れる
PRINT RR;BB !step.4
!!IF BB=1 THEN PRINT RR;BB !step.4
LET RR=RR+1 !次へ
LET BB=RR-1
LET R=RR
LET B=BB
ELSEIF B=0 THEN !step.3A
LET B=BB
ELSEIF R=0 THEN !step.3B
LET BB=BB-1 !※d=n-1,n-2,…,3,2,1
LET R=RR
LET B=BB
END IF
LOOP
END
LET A=6
LET B=10
LET C=15
LET N=23
CALL Solve(A,B,C,N)
PRINT
CALL Solve2(A,B,C,N)
CALL Solve2(B,C,A,N)
CALL Solve2(C,A,B,N)
PRINT
CALL Solve3(A,B,C,N)
CALL Solve3(B,C,A,N)
CALL Solve3(C,A,B,N)
END
!A,B,C,Nは非負整数とする。不定方程式Ax+By+Cz=Nの非負整数解は、
!By+Cz=N-Ax≧0なので、A=0,1,2,3,…,[N/A]として、By+Cz=Mに帰着させる。
EXTERNAL SUB Solve(A,B,C,N) !Ax+By+Cz=N
FOR X=0 TO N/A
CALL SolveEQU(B,C,N-A*X, Y,Z,K)
IF K=-1 THEN EXIT FOR
NEXT X
PRINT STR$(A);"x+";STR$(B);"y+";STR$(C);"z=";STR$(N)
IF K=-1 THEN PRINT X;Y;Z ELSE PRINT "解なし"
END SUB
!A,B,C,Nは非負整数とする。不定方程式Ax+By-Cz=Nの非負整数解は、
!Ax+By=N+Cz≧0なので、Z=0,1,2,3,…として、Ax+By=Mに帰着させる。
EXTERNAL SUB Solve2(A,B,C,N) !Ax+By-Cz=N
LET Z=0
DO
CALL SolveEQU(A,B,N+C*Z, X,Y,K)
IF K=-1 THEN EXIT DO
LET Z=Z+1
LOOP
PRINT STR$(A);"x+";STR$(B);"y-";STR$(C);"z=";STR$(N)
IF K=-1 THEN PRINT X;Y;Z ELSE PRINT "解なし"
END SUB
!A,B,C,Nは非負整数とする。不定方程式Ax-By-Cz=Nの非負整数解は、
!Ax-N=By+Cz≧0なので、X=0,1,2,3,…として、By+Cz=Mに帰着させる。
EXTERNAL SUB Solve3(A,B,C,N) !Ax-By-Cz=N
LET X=CEIL(N/A) !Ax-N≧0より
DO
CALL SolveEQU(B,C,A*X-N, Y,Z,K)
IF K=-1 THEN EXIT DO
LET X=X+1
LOOP
PRINT STR$(A);"x-";STR$(B);"y-";STR$(C);"z=";STR$(N)
IF K=-1 THEN PRINT X;Y;Z ELSE PRINT "解なし"
END SUB
EXTERNAL SUB SolveEQU(A,B,N, X,Y,K) !Ax+By=Nの非負整数解
LET K=-1
FOR X=0 TO N/A !Ax+By=N
LET Y=(N-A*X)/B
IF Y=INT(Y) THEN EXIT SUB !解
NEXT X
LET K=0 !解なし
END SUB
!
!------------------------------------------------------
OPTION ARITHMETIC COMPLEX !複素数モード
LET wb=400 !枠の幅
LET hb=400 !枠の高さ
SET bitmap SIZE wb+101, hb+101
SET WINDOW -50,wb+50, -50,hb+50 !左端,右端, 下端,上端
!------------------------------------------------------
RANDOMIZE 5 !引数を取ると、再現しない。
!
LET n=8 !球の数
DIM p(n) !球の座標
DIM vp(n) !球の速度
DIM m(n), r(n) !球の重量、半径
DATA 1,2,3,4,5,6,7,8,9,10 !球の重量データー
MAT READ m
FOR i=1 TO n
LET r(i)=20*m(i)^(1/3) !半径 r ∝ 重量の３乗根。4 で 半径≒31.7
NEXT i
!
SET COLOR MIX(0) 0,0,0 !CLEAR 文で黒にする。
SET COLOR MIX(1) 1,1,1 !text,line, 初期カラーを白にする。
LET dt=0.2 !サンプリングタイム
!
!----- 重ならない初期位置のランダム設定
LET j=1
DO
LET p(j)=COMPLEX( r(j)+2+(wb-2*r(j)-4)*RND, r(j)+2+(hb-2*r(j)-4)*RND)
FOR i=1 TO j-1
IF ABS(p(i)-p(j))< r(i)+r(j)+3 THEN EXIT FOR !オーバーラップ: 再試行
NEXT i
IF j<=i THEN LET j=j+1 !Ok: j+1
LOOP UNTIL n< j
!-----
DO
LET j=0
FOR i=1 TO n
LET vp(i)=COMPLEX((RND-0.5)*40, (RND-0.5)*40) !初期速度設定
LET j=j+ABS(vp(i))
NEXT i
LOOP UNTIL SQR(n)*20< j
!-----
DO
FOR i=1 TO n
LET p(i)=p(i)+vp(i)*dt
!---
IF re(p(i))< r(i) AND re(vp(i))< 0 THEN !左の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(r(i),im(p(i)))
ELSEIF wb-r(i)< re(p(i)) AND 0< re(vp(i)) THEN !右の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(wb-r(i),im(p(i)))
ELSEIF im(p(i))< r(i) AND im(vp(i))< 0 THEN !下の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),r(i))
ELSEIF hb-r(i)< im(p(i)) AND 0< im(vp(i)) THEN !上の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),hb-r(i))
END IF
!---
CALL collide !球同士の衝突
NEXT i
!
SET DRAW mode hidden !表示画、更新の一時停止。
CLEAR !全画面、黒で、塗りつぶす
PLOT TEXT,AT wb*.8,hb+20:"右クリック終了"
SET LINE COLOR 0
FOR i=1 TO n
SET AREA COLOR i
DRAW disk WITH SCALE(r(i))*SHIFT(p(i)) !球の表示
NEXT i
SET LINE width 4
SET LINE COLOR 6
PLOT LINES: 0; wb; COMPLEX(wb,hb); COMPLEX(0,hb); 0 !枠の表示
SET DRAW mode explicit !表示画、常時更新の再開。
!
WAIT DELAY .01 !節電。削除 → かなり速くなる
mouse poll mox,moy,mlb,mrb
LOOP UNTIL 0< mrb
!-----------------------------------------------------------
! 球同士の衝突( 表面摩擦０、異なる質量)
!
! ※反射速度は、法線ベクトルの内外向き、接線ベクトルの回転向き、
! などの影響を受けないが、法線上の 相対的速さ は、極性に反映。
!-----------------------------------------------------------
SUB collide
FOR j=1 TO n
IF i<>j THEN
LET l=ABS( p(i) -p(j) ) !球(i)(j)間距離
IF l<=r(i)+r(j) THEN !距離が範囲内、衝突の前 後？
LET np=(p(j)-p(i))/l !接触点 法線単位ベクトル
LET vni=re(conj(np)*vp(i)) !接触点 法線方向の 球(i)速さ(+-)
LET vnj=re(conj(np)*vp(j)) ! 〃 球(j)速さ(+-)
IF vnj-vni< 0 THEN !法線上、相対的速さ(+-)、衝突の前、確定。
LET w=((m(i)-m(j))*vni+2*m(j)*vnj)/(m(i)+m(j)) !球(i)
LET vnj=((m(j)-m(i))*vnj+2*m(i)*vni)/(m(i)+m(j)) !球(j) 反射後の速さ
LET vni=w
LET tp=np*COMPLEX(0,1) ! 〃 接線単位ベクトル
LET vti=re(conj(tp)*vp(i)) ! 接線方向の 球(i)速さ(+-)
LET vtj=re(conj(tp)*vp(j)) ! 〃 球(j)速さ(+-)
!--
LET vp(i)= vni*np +vti*tp !球(i)速度ベクトル
LET vp(j)= vnj*np +vtj*tp !球(j)速度ベクトル
END IF
END IF
END IF
NEXT j
END SUB
OPTION ARITHMETIC RATIONAL !多桁の整数
LET N=7 !席の数 ※2以上
DIM A(N) !これ以上隣り合わないように座れるパターン
MAT A=ZER
PUBLIC NUMERIC C !パターンの場合の数
LET C=0
PUBLIC NUMERIC X !場合の数
LET X=0
LET A(1)=1 !1番目の席に座る
CALL try(2,N,A)
PRINT
LET A(1)=0 !1番目の席を空ける
CALL try(2,N,A)
PRINT C; "通り"
PRINT X; "通り"
LET S=0
FOR K=INT((N+2)/3) TO INT((N+1)/2)
LET S=S+COMB(K+1,N-2*K+1)
PRINT K; COMB(K+1,N-2*K+1) !debug
NEXT K
PRINT S; "通り"
END
EXTERNAL SUB try(P,N,A()) !バックトラック法で埋めていく
OPTION ARITHMETIC RATIONAL !多桁の整数
IF P=N THEN !右端（最後の席）の場合
IF A(P-1)=0 THEN LET A(P)=1 !補正する
LET T=0 !座る順序を考える
FOR i=1 TO N
IF A(i)=0 THEN LET T=T+1
NEXT i
LET X=X+FACT(N-T)*FACT(T)
LET C=C+1
MAT PRINT A; !パターン
LET A(P)=0 !元に戻す
ELSE
IF A(P-1)=1 THEN !1つ前に座っている
LET A(P)=0 !空き席にする
CALL try(P+1,N,A) !左端から埋めていく
LET A(P)=0 !元に戻す
IF P+1<N THEN !空き席は連続2つまで可能である
LET A(P)=0
LET A(P+1)=0
CALL try(P+2,N,A)
LET A(P)=0
LET A(P+1)=0
END IF
ELSE !1つ前が空き席なら
LET A(P)=1 !座らせる
CALL try(P+1,N,A)
LET A(P)=0
END IF
END IF
END SUB
OPTION ARITHMETIC RATIONAL !多桁の整数
PRINT G100(10000)
END
EXTERNAL FUNCTION G10(N) !不定方程式10a=Nの解の個数
OPTION ARITHMETIC RATIONAL !多桁の整数
IF MOD(N,10)<>0 THEN
PRINT "10円未満の金額があります。"
STOP
END IF
LET G10=1 !すべて10円の1通り
END FUNCTION
EXTERNAL FUNCTION G50(N) !10a+50b=N ∴a=N-50bに帰着させる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/50) !50円の枚数
LET S=S+G10(N-50*K) !残りは、10円でつくる
NEXT K
LET G50=S
END FUNCTION
EXTERNAL FUNCTION G100(N) !10a+50b+100c=N ∴10a+50b=N-100cに帰着させる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/100) !100円の枚数
LET S=S+G50(N-100*K) !残りは、50円,10円でつくる
NEXT K
LET G100=S
END FUNCTION
多重FOR文による
OPTION ARITHMETIC RATIONAL !多桁の整数
LET N=10000
LET S=0
FOR C100=0 TO N/100 !100円玉の枚数
FOR C50=0 TO (N-100*C100)/50 !50円玉の枚数
LET S=S+1 !10円玉は1通り
NEXT C50
NEXT C100
PRINT S; "通り"
END
EXTERNAL FUNCTION F1(N) !1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET F1=1 !すべて1円の1通り
END FUNCTION
EXTERNAL FUNCTION F5(N) !5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/5) !5円の枚数
LET S=S+F1(N-5*K) !残りは、1円でつくる
NEXT K
LET F5=S
END FUNCTION
EXTERNAL FUNCTION F10(N) !10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/10) !10円の枚数
LET S=S+F5(N-10*K) !残りは、5円,1円でつくる
NEXT K
LET F10=S
END FUNCTION
EXTERNAL FUNCTION F50(N) !50円,10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/50) !50円の枚数
LET S=S+F10(N-50*K) !残りは、10円,5円,1円でつくる
NEXT K
LET F50=S
END FUNCTION
EXTERNAL FUNCTION F100(N) !100円,50円,10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/100)
LET S=S+F50(N-100*K)
NEXT K
LET F100=S
END FUNCTION
EXTERNAL FUNCTION F500(N) !500円,100円,50円,10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/500)
LET S=S+F100(N-500*K)
NEXT K
LET F500=S
END FUNCTION
EXTERNAL FUNCTION F1000(N) !1000円,500円,100円,50円,10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/1000)
LET S=S+F500(N-1000*K)
NEXT K
LET F1000=S
END FUNCTION
EXTERNAL FUNCTION F5000(N) !5000円,1000円,500円,100円,50円,10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/5000)
LET S=S+F1000(N-5000*K)
NEXT K
LET F5000=S
END FUNCTION
EXTERNAL FUNCTION F10000(N) !10000円,5000円,1000円,500円,100円,50円,10円,5円,1円の硬貨で、n円をつくる
OPTION ARITHMETIC RATIONAL !多桁の整数
LET S=0
FOR K=0 TO INT(N/10000)
LET S=S+F5000(N-10000*K)
NEXT K
LET F10000=S
END FUNCTION
多重FOR文による
OPTION ARITHMETIC RATIONAL !多桁の整数
LET N=500
LET S=0
FOR C100=0 TO N/100 !100円玉の枚数
LET R50=N-100*C100 !残り
FOR C50=0 TO R50/50 !50円玉
LET R10=R50-50*C50
FOR C10=0 TO R10/10 !10円玉
LET R5=R10-10*C10
!!FOR C5=0 TO R5/5 !5円玉
!! LET S=S+1 !1円玉は1通り
!!NEXT C5
LET S=S+(R5/5+1) !5円玉
NEXT C10
NEXT C50
NEXT C100
PRINT S; "通り"
END
OPTION ARITHMETIC RATIONAL !多桁の整数
LET M=10000 !金額
LET S=0
FOR C5000=0 TO M STEP 5000 !0,5000,10000,15000,…
LET T5000=M-C5000 !残りの金額に対して
FOR C1000=0 TO T5000 STEP 1000
LET T1000=T5000-C1000
FOR C500=0 TO T1000 STEP 500
LET T500=T1000-C500
FOR C100=0 TO T500 STEP 100
LET T100=T500-C100
FOR C50=0 TO T100 STEP 50
LET T50=T100-C50
FOR C10=0 TO T50 STEP 10
LET T10=T50-C10
LET S=S+INT(T10/5)+1 ! !0,5,10,15,… ※5n円を5,1円で両替する n+1通り
NEXT C10
NEXT C50
NEXT C100
NEXT C500
NEXT C1000
NEXT C5000
PRINT S;"通り" !18155171408 通り
END
FOR A=0 TO N-1
FOR B=0 TO N-1
FOR E=0 TO N-1
IF A+B+E=0 THEN !この箇所で同色になる場合
LET S=S+N^3*N^2 !残りF,G,Hは、何色でもよい。また、C,Dも何色でもよい。
ELSE
FOR C=0 TO N-1
FOR F=0 TO N-1
IF B+C+F=0 THEN
LET S=S+N^2*N^1 !残りG,Hは、何色でもよい。また、Dも何色でもよい。
ELSE
FOR D=0 TO N-1
FOR G=0 TO N-1
IF C+D+G=0 THEN
LET S=S+N^1 !残りHは、何色でもよい。
ELSE
IF D+A=0 THEN LET S=S+1 !D+A+H=0の1通り
!!FOR H=0 TO N-1
!! IF D+A+H=0 THEN
!! LET S=S+N^0
!! ELSE
!! END IF
!!NEXT H
END IF
NEXT G
NEXT D
END IF
NEXT F
NEXT C
END IF
NEXT E
NEXT B
NEXT A
PRINT S; N*S; "通り"
!その２
!中央でも角でもない4マスについて、
!中央マスとの色の関係であり得るパターンは、次の6通りである。
!これより、中央の色を固定して、2×2の同色がないものは、
LET T=0
!(1) 4マスすべてが中央マスと異なる色
LET T=T+(N-1)^4*N^4 ! 1*( (N-1)^4 * N^4 )
!(2) 4マスのうち1マスだけ中央マスと同じ色
LET T=T+4*(N-1)^3*N^4 ! 4*( 1*(N-1)^3 * N^4 )
!(3) 4マスのうち向い合う2マスだけ中央マスと同じ色
LET T=T+2*(N-1)^2*N^4 ! 2*( 1^2*(N-1)^2 * N^4 )
!(4) 4マスのうち隣接する2マスだけ中央マスと同じ色
LET T=T+4*(N-1)^3*N^3 ! 4*( 1^2*(N-1)^2 * (N-1)*N^3 )
!(5) 4マスのうち3マスが中央マスと同じ色
LET T=T+4*(N-1)^3*N^2 ! 4*( 1^3*(N-1) * (N-1)^2*N^2 )
!(6) 4マス全部が中央マスと同じ色
LET T=T+(N-1)^4 ! 1*( 1^4 * (N-1)^4 )
!他の色でも同数となる。
!よって、求める場合の数は、余事象なので、
LET S=N^9-N*T
LET K=8 !10^k ※kは自然数
PRINT 45*F(K)+1 !(0+1+2+3+… +9)*F(k) + 1
END
EXTERNAL FUNCTION F(K) !0から10^k-1まで数に現れる数字0,1,2,3,…,9のそれぞれの個数
IF K=1 THEN
LET F=1 !0から9までは、1個ずつ
ELSE
LET F=10^(K-1)+F(K-1)*10 !10^(k-1)の位がnのもの + 10^(k-1)の位未満がnのもの
END IF
END FUNCTION
! カエルの軌跡
!------------------------
OPTION ARITHMETIC COMPLEX
SET POINT STYLE 1
SET WINDOW -1.05, 1.05, -1, 1.1
DRAW grid(.2,.2)
RANDOMIZE
!
LET N=3 !角数
!---
DIM p(N)
LET w=2*PI/N !頂点ステップ角
LET s=-(PI+w)/2 !スタート角オフセット
FOR i=1 TO N
LET p(i)=EXP( COMPLEX(0, s+w*i) ) !底辺を揃えた Ｎ角形頂点の座標
NEXT i
!---
FOR i=1 TO N
PLOT LINES: p(i); !Ｎ角形 輪郭
NEXT i
PLOT LINES: p(1)
!---
LET w=p(1)
FOR i=1 TO 50000
LET s=IP(RND*N)+1 !LET s=MOD(i,N)+1 ←× (ｓの同配分だけでは、図が出来ない)
LET w=( w +p(s))/2
PLOT POINTS: w
NEXT i
>
> ! カエルの軌跡
> !------------------------
> OPTION ARITHMETIC COMPLEX
> SET POINT STYLE 1
> SET WINDOW -1.05, 1.05, -1, 1.1
> DRAW grid(.2,.2)
> RANDOMIZE
> !
> LET N=3 !角数
> !---
> DIM p(N)
> LET w=2*PI/N !頂点ステップ角
> LET s=-(PI+w)/2 !スタート角オフセット
> FOR i=1 TO N
> LET p(i)=EXP( COMPLEX(0, s+w*i) ) !底辺を揃えた Ｎ角形頂点の座標
> NEXT i
> !---
> FOR i=1 TO N
> PLOT LINES: p(i); !Ｎ角形 輪郭
> NEXT i
> PLOT LINES: p(1)
> !---
> LET w=p(1)
> FOR i=1 TO 50000
> LET s=IP(RND*N)+1 !LET s=MOD(i,N)+1 ←× (ｓの同配分だけでは、図が出来ない)
> LET w=( w +p(s))/2
> PLOT POINTS: w
> NEXT i
>
> END
たったこれだけのアルゴリズムでこんなに面白い図形が浮かび上がることに驚きました。
これをいじってたら
LET N=5
LET w=(2*w+3*p(s))/5
の場合に感動しました。
DATA 94,72,50,44,28,22
DIM S(6)
MAT READ S
FOR i=1 TO 4 !a[1]+a[2]
FOR J=i+1 TO 5 !a[1]+a[3]
FOR K=J+1 TO 6 !a[2]+a[3]
LET T=S(i)+S(J)+S(K) !総和
PRINT T
LET A=T/2-S(K)
LET B=T/2-S(J)
LET C=T/2-S(i)
IF C>=10 THEN PRINT A;B;C
NEXT K
NEXT J
NEXT i
END
DATA 94,72,50,44,28,22
DIM S(6)
MAT READ S
LET T=0 !総和
FOR i=1 TO 6
LET T=T+S(i)
NEXT i
PRINT T
FOR i=1 TO 5 !a[1]+a[2]=s[i]
LET A=(T-2*S(i))/2
LET B=S(i)-A
IF B>=10 THEN
PRINT S(i); A;B !debug
FOR J=i+1 TO 6 !a[1]+a[3]=s[j]
LET C=S(J)-A
IF C>=10 THEN PRINT A;B;C
NEXT J
DATA 94,72,50,44,28,22
DIM S(6)
MAT READ S
LET T=0 !総和
FOR i=1 TO 6
LET T=T+S(i)
NEXT i
PRINT T
LET A1=(T-2*S(1))/2
LET A2=S(1)-A1
LET A3=S(2)-A1
PRINT A1;A2;A3
END
DATA 30,37,38,41,42,49 !和 ※小さい順
DIM S(6)
MAT READ S
DIM A(4,4),x(4),b(4) !連立方程式 Ax=b
DATA 1,1,0,0 !1番目に小さい和a+b
DATA 1,0,1,0 !2番目に小さい和a+c
DATA 1,0,0,1 !1番小さい数と1番大きい数との和a+d
DATA 0,0,1,1 !1番目に大きい和c+d
MAT READ A
LET b(1)=S(1)
LET b(2)=S(2)
LET b(3)=S(3)
LET b(4)=S(6)
DIM iA(4,4) !解く
MAT iA=INV(A)
MAT x=iA*b
MAT PRINT x; !4つの数
DATA 93,83,81,49,47,46,44,37,34,12,10,2
DIM S(12)
MAT READ S
LET T=0 !総和
FOR i=1 TO 12
LET T=T+S(i)
NEXT i
PRINT T
FOR i=1 TO 10 !a[1]+a[2]
FOR J=i+1 TO 11 !a[1]+a[3]
IF 4*S(i)+2*S(J)=T THEN
PRINT S(i);S(J) !debug
FOR K=J+1 TO 12 !a[2]+a[3]
LET W=S(i)-S(J)
IF MOD(S(K)+W,2)=0 THEN !a[2]とa[3]の偶奇は一致する
LET B=(S(K)+W)/2
LET C=(S(K)-W)/2
LET A=S(i)-B
IF C>=10 THEN
FOR X=1 TO 12 !a[1]-a[2]を確認する
IF NOT(X=i OR X=J) THEN
IF A-B=S(X) THEN EXIT FOR
END IF
NEXT X
IF X<=12 THEN
FOR Y=1 TO 12 !a[1]-a[3]を確認する
IF NOT(Y=i OR Y=J OR Y=X) THEN
IF A-C=S(Y) THEN EXIT FOR
END IF
NEXT Y
IF Y<=12 THEN
PRINT S(K) !debug
FOR P=J+1 TO 12 !a[1]+a[4]
IF NOT(P=K OR P=X OR P=Y) THEN
LET D=S(P)-A
IF D>=10 THEN PRINT A;B;C;D
END IF
NEXT P
DATA 7,10,11,11,12,14,15,15,18,19
DIM S(10)
MAT READ S
LET T=0 !総和
FOR i=1 TO 10
LET T=T+S(i)
NEXT i
PRINT T
DATA 1,1,0,0,0
DATA 1,0,1,0,0
DATA 0,0,1,0,1
DATA 0,0,0,1,1
DATA 1,1,1,1,1
DIM A(5,5),x(5),b(5) !Ax=b
MAT READ A
LET b(1)=S(1) !1番目に小さい
LET b(2)=S(2) !2番目に小さい
LET b(3)=S(9) !2番目に大きい
LET b(4)=S(10) !1番目に大きい
LET b(5)=T/4 !和
DIM iA(5,5)
MAT iA=INV(A)
MAT x=iA*b
MAT PRINT x;
END
そのうちの3つを選んで和をつくる。
DATA 35,46,47,48,49,49,51,60,62,63
DIM S(10)
MAT READ S
LET T=0 !総和
FOR i=1 TO 10
LET T=T+S(i)
NEXT i
PRINT T
DATA 1,1,1,0,0
DATA 1,1,0,1,0
DATA 0,1,0,1,1
DATA 0,0,1,1,1
DATA 1,1,1,1,1
DIM A(5,5),x(5),b(5) !Ax=b
MAT READ A
LET b(1)=S(1) !1番目に小さい
LET b(2)=S(2) !2番目に小さい
LET b(3)=S(9) !2番目に大きい
LET b(4)=S(10) !1番目に大きい
LET b(5)=T/6 !和
DIM iA(5,5) !連立方程式を解く
MAT iA=INV(A)
MAT x=iA*b
MAT PRINT x; !解
END
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR N=3 TO 10
LET P=FACT(N)-N !n!-n
FOR B=N+1 TO P !b+n
IF MOD(P,B)=0 THEN !約数なら
LET K=1+P/B
PRINT STR$(B+P); "-"; STR$(K*(B-N)); "÷"; STR$(K); "="; STR$(N); "!"
END IF
NEXT B
NEXT N
END
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR K=2 TO 10
LET P=FACT(K-1)-1
FOR B=1 TO P
IF MOD(P,B)=0 THEN
LET A=P/B+1
PRINT STR$(A*K*B); "-"; STR$(A*K*(B-1)); "÷"; STR$(A); "="; STR$(K); "!"
END IF
NEXT B
NEXT K
END
LET S=0
FOR A=1 TO 5 !百の位
FOR B=0 TO 5 !十の位
IF NOT(B=A) THEN
FOR C=0 TO 5 !一の位
IF NOT(C=A OR C=B) THEN
PRINT A;B;C
LET S=S+(100*A+10*B+C)
END IF
NEXT C
END IF
NEXT B
NEXT A
PRINT S
END
DATA 4,3,2 !数字2,3,4の個数
DIM X(3)
MAT READ X
LET K=4 !桁数
LET S=0
FOR A=0 TO MIN(K,X(1)) !数字2をa個選ぶ
FOR B=0 TO MIN(K-A,X(2)) !数字3をb個選ぶ
LET C=K-(A+B) !数字4をc個選ぶ
IF C>=0 AND C<=X(3) THEN
PRINT A;B;C
LET S=S+FACT(A+B+C)/(FACT(A)*FACT(B)*FACT(C)) !同じものを含むときの順列
END IF
NEXT B
NEXT A
PRINT S; "通り"
END
補足 1:1の中間分数（隣り合う分数）
並び
a c
b d
が、ad+1=bcを満たすとする。
このとき、
a a+c c
b b+d d
を考える。
ad+1=bcの両辺にabをたして、ab+ad+1=ab+bc ∴a(b+d)+1=b(a+c)
ad+1=bcの両辺にcdをたして、ad+1+cd=bc+cd ∴(a+c)d+1=(b+d)c
これより、題意を満たして列を増やすことができる。
（終り）
RANDOMIZE
DIM A(10),B(10),M(1024)
FOR L=1 TO 1000 !'試行回数
MAT A=ZER !'カード全てを裏の状態とする
MAT B=ZER
LET S=0
DO
DO
LET I=INT(RND*10)+1 !'任意の位置のカード
LOOP UNTIL A(I)=0 !'裏向きのカードなら
IF RND<.5 THEN LET I=I+3 ELSE LET I=I-3 !'右回り、左回りに相当
IF I>10 THEN LET I=I-10
IF I<1 THEN LET I=I+10
LET A(I)=1 !'表向きにする
LET FL=0
FOR J=1 TO 10
IF A(J)<>B(J) THEN
LET FL=1 !'前回と違うなら
LET S=0
END IF
NEXT J
IF FL=0 THEN LET S=S+1 !'前回と同じ状態ならカウント
IF S>10 THEN !'同じ状態が10回続くなら
LET Z=0
FOR J=1 TO 10
LET Z=Z*2+A(J) !'各状態を2進法とみなす
NEXT J
LET M(Z)=M(Z)+1 !'カウントする
EXIT DO
END IF
MAT B=A !'状態をコピー
LOOP
NEXT L
MAT B=ZER
FOR I=1 TO 1024 !'各状態の表示
IF M(I)>0 THEN
PRINT RIGHT$("000000000"&BSTR$(I,2),10);" ";M(I)
LET N=BITCOUNT32(I) !'bitの数
LET B(N)=B(N)+M(I)
END IF
NEXT I
PRINT
FOR I=1 TO 10
PRINT I;B(I)
NEXT I
END
EXTERNAL FUNCTION BITCOUNT32(X) !'32bitの中の"1"の数
LET X=BITAND(X,BVAL("55555555",16))+BITAND(INT(X/2),BVAL("55555555",16))
LET X=BITAND(X,BVAL("33333333",16))+BITAND(INT(X/4),BVAL("33333333",16))
LET X=BITAND(X,BVAL("0F0F0F0F",16))+BITAND(INT(X/16),BVAL("0F0F0F0F",16))
LET X=BITAND(X,BVAL("00FF00FF",16))+BITAND(INT(X/256),BVAL("00FF00FF",16))
LET X=BITAND(X,BVAL("0000FFFF",16))+BITAND(INT(X/65536),BVAL("0000FFFF",16))
LET BITCOUNT32=X
END FUNCTION
FOR I=1 TO 1024 !'各状態の表示
IF M(I)>0 THEN
PRINT RIGHT$("000000000"&BSTR$(I,2),10);" ";M(I)
LET N=BITCOUNT32(I) !'bitの数
IF N=4 THEN INPUT D$ !'←このように一旦止めて見て下さい。
LET B(N)=B(N)+M(I)
END IF
NEXT I
IF FL=0 THEN LET S=S+1 !'前回と同じ状態ならカウント
IF S>100 THEN !'← 同じ状態が100回続くなら
LET Z=0
FOR J=1 TO 10
LET Z=Z*2+A(J) !'各状態を2進法とみなす
NEXT J
LET M(Z)=M(Z)+1 !'カウントする
EXIT DO
END IF
!⑤④③②
!⑥ ①
!⑦⑧⑨０
DIM A(0 TO N-1) !並び
MAT A=ZER !すべて裏にする
DIM B(0 TO 2^N-1) !（ビット）パターンごとの場合の数
MAT B=ZER
CALL try(A,N,B)
!!MAT PRINT B; !debug
DIM C(0 TO N) !裏の個数ごとの場合の数
MAT C=ZER
LET T=0 !総数
FOR i=0 TO 2^N-1
LET X$=right$("000000000"&BSTR$(i,2),N) !パターン
LET S=0 !裏の個数
FOR J=1 TO N
IF X$(J:J)="0" THEN LET S=S+1
NEXT J
PRINT X$; S; B(i)
LET C(S)=C(S)+B(i)
LET T=T+B(i)
NEXT i
PRINT T
FOR i=0 TO 10
PRINT i; C(i)/T
NEXT i
END
EXTERNAL SUB try(A(),N,B()) !バックトラック法で検証する
LET FLG=0
FOR i=0 TO N-1 !基準のカードが裏なら
IF A(i)=0 THEN
LET X=MOD(i-3,N) !右回りの4枚目の位置
IF A(X)=0 THEN !4枚目を表にする
LET A(X)=1
CALL try(A,N,B) !次へ
LET A(X)=0
LET FLG=-1 !ひっくり返した
END IF
LET Y=MOD(i+3,N) !左回り
IF A(Y)=0 THEN !4枚目を表にする
LET A(Y)=1
CALL try(A,N,B)
LET A(Y)=0
LET FLG=-1
END IF
END IF
NEXT i
IF FLG=0 THEN !これ以上ひっくり返せない
!!MAT PRINT A; !debug
LET S=0 !ビットパターンで並びを記録する
FOR i=0 TO N-1
LET S=S*2+A(i)
NEXT i
LET B(S)=B(S)+1
END IF
END SUB
FOR N=1 TO 10
PRINT N; f6(N); f6(N)/6^N; (1-(1/2)^N)*(1-(2/3)^N)
NEXT N
END
EXTERNAL FUNCTION f2(n) !2の倍数
IF N=1 THEN
LET f2=3 !2,4,6
ELSE
!n番目について、
!1,3,5のとき、(n-1)番までが2の倍数なら、2の倍数になる。
!2,4,6のとき、(n-1)番までは何でも良い。
LET f2=3*f2(n-1)+3*6^(n-1)
END IF
END FUNCTION
EXTERNAL FUNCTION f3(n) !3の倍数
IF N=1 THEN
LET f3=2 !3,6
ELSE
!1,2,4,5のとき、(n-1)番までが3の倍数
!3,6のとき、(n-1)番までは何でも良い
LET f3=4*f3(n-1)+2*6^(n-1)
END IF
END FUNCTION
EXTERNAL FUNCTION f6(n) !6の倍数
IF N=1 THEN
LET f6=1 !6
ELSE
!1,5のとき、(n-1)番までが6の倍数
!2,4のとき、(n-1)番までが3の倍数
!3のとき、(n-1)番までが2の倍数
!6のとき、(n-1)番までは何でも良い
LET f6=2*f6(n-1)+2*f3(n-1)+1*f2(n-1)+1*6^(n-1)
END IF
END FUNCTION
LET N=3 !n個の変数
DIM X(0 TO N) !※0番目は番兵
LET X(0)=1
PUBLIC NUMERIC C,S
LET C=0
LET S=0
LET K=1
DO WHILE 6*K<=6^N
CALL try(1, N,X,6*K)
LET K=K+1
LOOP
PRINT C;"通り"
PRINT S;"通り" !場合の数
END
EXTERNAL SUB try(P, N,X(),M) !x[1]x[2]x[3]…x[n]=m の解
IF P=N THEN !最後の変数のとき
IF X(P-1)<=M AND M<=6 THEN
LET X(P)=M
LET C=C+1
MAT PRINT X;
DIM B(6) !n!/(p!q!…r!)通りに並べる
MAT B=ZER
FOR i=1 TO N
LET B(X(i))=B(X(i))+1
NEXT i
LET S=S+PermFactorialM(B,6)
END IF
ELSE
FOR K=X(P-1) TO 6 !昇順
IF MOD(M,K)=0 THEN !約数なら
LET X(P)=K
CALL try(P+1, N,X,M/K) !次へ
END IF
NEXT K
END IF
END SUB
!COMB.LIB 抜粋
EXTERNAL FUNCTION PermFactorialM(B(),M) !同じものを含む順列の「場合の数」
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
-----------------------------------------
発展問題
n個のさいころを投げて、出たn個の目の積が立方数となる場合の数を求めよ。
答え
不定方程式版のプログラムを
：
LET S=0
LET K=1
DO WHILE K^3<=6^N
CALL try(1, N,X,K^3)
LET K=K+1
LOOP
PRINT C;"通り"
：
OPTION ARITHMETIC COMPLEX !複素数を扱う
LET N=2 !さいころの個数
LET K=3 !k乗
LET w=EXP(2*PI*COMPLEX(0,1)/K) !w^k-1=0
LET S=0
FOR A=0 TO K-1
FOR B=0 TO K-1
FOR C=0 TO K-1
LET S=S+(1+w^A+w^B+w^(2*A)+w^C+w^(A+B))^N
NEXT C
NEXT B
NEXT A
S=S/K^3 !場合の数
PRINT S
END
end sub
'----------------------------------------------------
sub cal2
'連立方程式
'解は a=0.1:b=0.2:c=0.3:d=0.4
'5*a+3*b-4*c+2*d=0.7
'4*a-3*b+4*c-2*d=0.2
'5*a+4*b+5*c-5*d=0.8
'2*a+10*b+10*c+9*d=8.8
end sub
'----------------------------------------------------
sub draw
'出力信号グラフ、信号名の表示
local xd1,yd1,xd2,yd2
'表示記述
set draw mode hidden
set line width 2
!---------------------------------------------------------------------
! 左クリックで、中間結果の重ね書き 一時停止。 再 左クリックで継続。
! 右クリックで、強制終了。(100 都市では、500M.P3 でも 75 秒程度)
!
!２次元座標を、xy で扱うと煩雑なため、１変数の複素数で操作している。
!
! x(i)= 都市(i)の座標 | c(j)= node(j)の座標
!cind(i)= 都市(i)の対応node番号 |xind(j)= node(j)の対応都市番号
! | nac(j)= node(j)の対応都市無しの回数
!---------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
LET hw=460
LET vw=460
SET BITMAP SIZE hw+41, vw+41
SET WINDOW -20, hw+20, -20, vw+20 !左,右, 下,上
!---
SET COLOR MIX(0) 0,0,0 !CLEAR 文で黒にする。
SET COLOR MIX(1) 1,1,1 !text,line, 初期カラーを白にする。
SET POINT STYLE 7
SET TEXT font "",12
SET TEXT COLOR 1
LET tx0=COMPLEX(0,vw-8) !文字列 左下端
RANDOMIZE 1
!
!------------調整項目( 定数)
LET M_=100 !都市数
LET C_=100 !初期 node 数 1～M_
LET G_=50 !node 移動パラメーター
LET a_= 0.95 !α= G_ の更新係数。G_(t+1)=α*G_(t)
LET r_=-0.2 !γ= α の更新係数。α(t+1)=α(t)+γ/M_*(C_(t)-C_(t-1))
!
!--------------
OPTION BASE 0
LET w=M_*5 !node 数の上限
DIM x(M_-1) !都市 座標
DIM cind(M_-1) !都市 番号 に対する node番号
DIM xind(w) !node 番号 に対する 都市番号
DIM c(w) !node 座標
DIM nac(w) !no access counter
CALL set_grid_ini !都市配置が、格子状の場合の準備(hn,vn,ss1)
!
!------------調整項目( 都市 の並べ方)
CALL set_grid(x) !格子状 配置( 都市 )
!CALL set_circle(x) !サークル 配置( 都市 )
CALL shuffle(x) !番号シャッフル( 都市 )
!CALL set_random(x) !ランダム 配置( 都市 )
!
!------------調整項目( 初期 node の並べ方)
!CALL set_grid(c) !格子状 配置( node )
CALL set_circle(c) !サークル 配置( node )
!CALL shuffle(c) !番号シャッフル( node )
!CALL set_random(c) !ランダム 配置( node )
!
!----------------------------------------
! メイン
!----------------------------------------
CLEAR
CALL pl_node_run !都市 node 位置と、その連結線
IF 1< C_ THEN pause 1
!
MAT cind=(-1)*CON !都市番号 に対応する node番号 クリア
MAT xind=(-1)*CON !node番号 に対応する 都市番号 クリア
MAT nac=ZER !no access counter
LET Mcyc=0 !都市一巡の回数
DO
LET Cb=C_
FOR i=0 TO C_-1
LET nac(i)=nac(i)+1 !各 node 毎の、no access counter
NEXT i
FOR ss_=0 TO M_-1
CALL Get_node !都市番号ss_に 最近傍node 取得
!--
SET DRAW mode hidden
CLEAR
CALL pl_node_run !都市位置表示と、全node の連結線
SET DRAW mode explicit
!--
mouse poll mox,moy,mlb,mrb !マウス状態取得
IF mlbk< mlb OR 0< mrb THEN
CALL pl_node_z !都市位置表示と、node の対応都市＋孤立node の連結線
DO
LET mlbk=mlb
mouse poll mox,moy,mlb,mrb
WAIT DELAY .03
IF 0< mrb THEN STOP !右クリック停止
LOOP UNTIL mlbk< mlb !左クリック続行
END IF
LET mlbk=mlb
!--
CALL move !都市番号ss_対応の 全node 移動
NEXT ss_
CALL Remove !連続３巡回、選ばれなかった node の除去
LET G_=G_*a_ !node 移動パラメーター G_ の更新
LET a_=a_+r_/M_*(C_-Cb) !更新係数 a_
LET Mcyc=Mcyc+1 !都市一巡の回数
!--
IF M_=C_ THEN LET cm_eq=cm_eq+1 ELSE LET cm_eq=0
LOOP UNTIL 1< cm_eq
CLEAR
CALL pl_node_z !都市位置表示と、node の対応都市＋孤立node の連結線
!----------------------------------------
! 連続３巡回、選ばれなかった node の除去
!----------------------------------------
SUB Remove
LET j=0
FOR i=0 TO C_-1
IF nac(i)< 3 THEN !no access ３回未満の node を前に詰める
LET c(j)=c(i) !node 座標
LET xind(j)=xind(i) !対応 都市番号
IF 0<=xind(j) THEN LET cind( xind(j))=j !対応 都市の 対応 node番号
LET nac(j)=nac(i) !no access node counter
LET j=j+1
END IF
NEXT i
LET C_=j
END SUB
!----------------------------------------
! 都市 ss_ の最近傍 node 取得
!----------------------------------------
SUB Get_node
IF 0<=cind(ss_) THEN LET xind( cind(ss_))=-1
LET lmin=1e9
FOR j=0 TO C_-1
LET l=ABS( x(ss_)-c(j) ) !都市ss_ と、各 node 間距離
IF l< lmin THEN
LET jc=j !最近傍の node 番号
LET loc=c(j) ! 〃 node 座標
LET lmin=l ! 〃 その距離
END IF
NEXT j
IF 0<=xind(jc) THEN CALL add !使用中 node の生成(複製)
LET xind(jc)=ss_ !node jc → 対応都市 xi
LET nac(jc)=0 !node jc：リセット no access node counter
LET cind(ss_)=jc !都市 xi → 対応node jc
END SUB
!----------------------------------------
! node の生成
!----------------------------------------
SUB add
LET jc=jc+1 !複製node番号jc を後続。
FOR i=C_-1 TO jc STEP -1 !既存node jc ～C_ を後へシフト
LET j=i+1 !転送元i → 転送先j
!--
LET c(j)=c(i) !node i の座標
LET xind(j)=xind(i) !node i 対応都市番号
LET nac(j)=nac(i) !node i：no access node counter
IF 0<=xind(i) THEN LET cind( xind(i))=j !node i の対応都市xind(i) → 対応node j
NEXT i
LET C_=C_+1
LET c(jc)=loc !複製node 座標
END SUB
!----------------------------------------
! 最近傍 node と周辺の移動 更新
!
! 座標移動node(j)= node(j)+ EXP[-{node番号間数(I~j)/G_}^2] * 座標差{都市(I)-node(j)}/√2
!----------------------------------------
SUB move !都市番号ss_の対応node jc と 周辺node 移動
LET jc=cind(ss_)
FOR j=0 TO C_-1
LET n=MIN( MOD(jc-j,C_), MOD(j-jc,C_))
LET fgn=EXP(-(n/G_)^2)/SQR(2) !更新率
LET c(j)=c(j)+fgn*( x(ss_)-c(j))
NEXT j
END SUB
!----------------------------------------
! 描画パーツ
!----------------------------------------
! 都市位置
SUB pl_city
FOR i=0 TO M_-1
IF 0<=cind(i) THEN SET POINT COLOR 6 ELSE SET POINT COLOR 5
PLOT POINTS: x(i) !黄: 都市 with node シアン: 都市 off node
NEXT i
END SUB
!----都市位置表示と、node の対応都市＋孤立node の連結線
SUB pl_node_z
CALL pl_city !都市位置
SET POINT COLOR 5
FOR i=0 TO C_-1
IF xind(i)< 0 THEN PLOT POINTS: c(i) !対応都市の無い node のみ 位置を加える
NEXT i
SET LINE COLOR 5
LET TL=0
IF 0<=xind(0) THEN LET wb=x( xind(0)) ELSE LET wb=c(0)
FOR i=C_-1 TO 0 STEP -1
IF 0<=xind(i) THEN LET w=x( xind(i)) ELSE LET w=c(i)
LET TL=TL+ABS(w-wb)
PLOT LINES: wb;w !連結線
LET wb=w
NEXT i
!----都市数 node数 一巡回数 距離
PLOT label,AT tx0 ,USING "都市数=#### node数=#### 都市一巡の回数=### 距離=###.##": M_,C_,Mcyc,TL/ss1
END SUB
!----都市位置表示と、全node の連結線
SUB pl_node_run
CALL pl_city !都市位置
FOR i=0 TO C_-1
IF 0<=xind(i) THEN SET POINT COLOR 4 ELSE SET POINT COLOR 5
PLOT POINTS: c(i) !赤: node with 都市 シアン: node off 都市
NEXT i
SET LINE COLOR 4
FOR i=0 TO C_-1
PLOT LINES: c(i); !赤: 連結線 of node
NEXT i
PLOT LINES: c(0)
!----都市数 node数 一巡回数
PLOT label,AT tx0 ,USING "都市数=#### node数=#### 都市一巡の回数=###": M_,C_,Mcyc
END SUB
!---------------------------------------------------
! 都市、node の初期 配置
!---------------------------------------------------
SUB set_grid_ini !都市配置が、格子状の場合の準備。
LET vn=INT( SQR(M_)) !他の配置になっても、距離の単位長 ss1 を共用。
LET hn=vn
IF vn*hn< M_ THEN LET hn=vn+1 !hn: 横列数 (端数列込み)
IF vn*hn< M_ THEN LET vn=vn+1 !vn: 縦行数
LET ss1=vw/vn !距離の単位長 (格子の一辺の長さ)
END SUB
SUB set_grid(a()) !格子状配置
IF M_< UBOUND(a) THEN LET w=C_ ELSE LET w=M_ !都市・node の識別
LET mi=0
FOR i=0 TO hn-1
FOR j=0 TO vn-1
LET a(mi)=ss1*COMPLEX(i,j)
LET mi=mi+1
IF w<=mi THEN EXIT SUB
NEXT j
NEXT i
END SUB
SUB set_circle(a()) !サークル配置
IF M_< UBOUND(a) THEN LET w=C_ ELSE LET w=M_ !都市・node の識別
LET x1=x(1)
IF x1=0 THEN !都市座標が 未設定の場合は、
LET x2=ss1*COMPLEX(hn-1,vn-1) !広がりを、M_ の格子状とし、
ELSE !都市座標が 設定済みの場合は、
LET x2=x1 !広がりの、最大最小をさがす
FOR i=0 TO M_-1
LET x1=COMPLEX( MIN(re(x1),re(x(i))), MIN(im(x1),im(x(i))) )
LET x2=COMPLEX( MAX(re(x2),re(x(i))), MAX(im(x2),im(x(i))) )
NEXT i
END IF
LET xc=(x1+x2)/2 !サークル中心点
LET ds=2*PI/w
FOR i=0 TO w-1
LET a(i)=xc+COMPLEX( re(x2-xc)*COS(i*ds), im(x2-xc)*SIN(i*ds) )
NEXT i
END SUB
SUB shuffle(a()) !番号シャッフル
IF M_< UBOUND(a) THEN LET w=C_ ELSE LET w=M_ !都市・node の識別
FOR i=0 TO w-1
LET j=INT(RND*w)
swap a(i),a(j)
NEXT i
END SUB
SUB set_random(a()) !ランダム配置
IF M_< UBOUND(a) THEN LET w=C_ ELSE LET w=M_ !都市・node の識別
LET j=0
DO
LET a(j)=COMPLEX( hw*(.8*RND+.1), vw*(.8*RND+.1))
FOR i=0 TO j-1
IF ABS(a(i)-a(j))< 7 THEN EXIT FOR !隣接間隔不足、再試行
NEXT i
IF j<=i THEN LET j=j+1
LOOP UNTIL w<=j
END SUB
! この実験をするには、先の投稿プログラムを以下のようにします。
!
!１）----------調整項目( 定数 )
! LET C_=M_
! LET G_=1～1.4
!２）----------調整項目( 都市 の並べ方)
! CALL set_grid(x) ← 投稿時の格子状のまま
! CALL shuffle(x) ←シャッフルの有無は、どちらでもよい
!３）----------調整項目( 初期 node の並べ方)
! CALL set_grid_order(c) ←このcall追加、他のcall停止。
!
!４）末尾に、今回の、SUB set_grid_order(x()) ～ END SUB を追加。
!---------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
LET hw=460
LET vw=460
SET BITMAP SIZE hw+41, vw+41
SET WINDOW -20, hw+20, -20, vw+20 !左,右, 下,上
!---
SET COLOR MIX(0) 0,0,0 !CLEAR 文で黒にする。
SET COLOR MIX(1) 1,1,1 !text,line, 初期カラーを白にする。
SET POINT STYLE 7
SET TEXT font "",14
SET TEXT COLOR 1
LET tx0=COMPLEX(0,vw-8) !文字列 左下端
!
OPTION BASE 0
DIM x(600) !都市 座標
!
!----------------------------------------
! メイン
!----------------------------------------
FOR M_=100 TO 1 STEP -1 !M_= 都市数
LET vn=INT( SQR(M_) )
LET hn=vn
IF vn*hn< M_ THEN LET hn=vn+1 !hn: 横列数 (端数列込み)
IF vn*hn< M_ THEN LET vn=vn+1 !vn: 縦行数
! LET ss1=vw/vn !距離の単位長 (格子の一辺の長さ) ※M_ が昇順の時。
IF ss1=0 THEN LET ss1=vw/vn !距離の単位長 (格子の一辺の長さ) ※最初の幅を固定
!--
CALL set_grid_order(x) !格子状配置 最短距離コース
!--
SET DRAW mode hidden
CLEAR
CALL pl_city_sts !表示
SET DRAW mode explicit
LET i=0
DO
mouse poll mox,moy,mlb,mrb
IF mrb=1 THEN EXIT FOR
LET i=i+1-mlb
WAIT DELAY .05
LOOP UNTIL 18<=i
NEXT M_
!----------------------------------------
! 描画
!----------------------------------------
SUB pl_city_sts !都市と、その連結線
SET POINT COLOR 6
SET LINE COLOR 5
LET TL=0
LET wb=x(0)
FOR i=M_-1 TO 0 STEP -1
LET w=x(i)
PLOT POINTS: w
PLOT LINES: wb;w
LET TL=TL+ABS(w-wb)
LET wb=w
NEXT i
!----都市数 距離
PLOT label,AT tx0 ,USING "都市数=#### 距離=###.##": M_,TL/ss1
END SUB
SUB set_grid_order(x())
LET rn=MOD(M_,vn) !rn: 右端列 の端数
IF rn=0 THEN LET rn=vn ! (端数０不可)
!--
LET mi=0
LET i=0
FOR j=0 TO vn-1 !・
LET x(mi)=ss1*COMPLEX(i,j) !↑
LET mi=mi+1 !・
NEXT j
LET i=i+1
!--
IF MOD(hn,2)=0 THEN
!--------------------------------------------横：even
DO WHILE i< hn-2
LET j=vn-1 !→・
IF i=hn-3 THEN
!--
IF MOD(vn,2)=0 THEN
!-----------------------------------横：even 縦：even
LET w=CEIL(rn/2)*2 !2,2,4,4,6,6
ELSE
!-----------------------------------横：even 縦：odd
LET w=INT(rn/2)*2+1 !1,3,3,5,5,7,7
!--
IF rn=1 THEN
LET x(mi)=ss1*COMPLEX(i,j) !・
LET mi=mi+1
LET x(mi)=ss1*COMPLEX(i+1,j) !→
LET mi=mi+1
LET j=j-1
END IF
END IF
!--
LET d=1
FOR j=j TO w STEP -1
LET x(mi)=ss1*COMPLEX(i,j) !・
LET mi=mi+1
LET i=i+d
LET x(mi)=ss1*COMPLEX(i,j) !←→
LET mi=mi+1
LET d=-d
NEXT j
END IF
!--
LET w=j
FOR j=j TO 1 STEP -1 !→・
LET x(mi)=ss1*COMPLEX(i,j) ! ↓
LET mi=mi+1 ! ・
NEXT j
LET i=i+1
!--
IF i< hn-2 AND 0< w THEN LET w=vn-1 ! ・
FOR j=1 TO w ! ↑
LET x(mi)=ss1*COMPLEX(i,j) !→・
LET mi=mi+1
NEXT j
LET i=i+1
LOOP
!--
FOR j=rn-1 TO 1 STEP -1 !→・
LET x(mi)=ss1*COMPLEX(i,j) ! ↓
LET mi=mi+1 ! ・
NEXT j
ELSE
!--------------------------------------------横：odd
DO WHILE i< hn-3
FOR j=vn-1 TO 1 STEP -1 !→・
LET x(mi)=ss1*COMPLEX(i,j) ! ↓
LET mi=mi+1 !
NEXT j
LET i=i+1
FOR j=1 TO vn-1 ! ・
LET x(mi)=ss1*COMPLEX(i,j) !→↑
LET mi=mi+1 !
NEXT j
LET i=i+1
LOOP
!--
FOR j=vn-1 TO rn STEP -1 !→・
LET x(mi)=ss1*COMPLEX(i,j) ! ↓
LET mi=mi+1 !
NEXT j
!--
LET d=1
FOR j=j TO 1 STEP -1
LET x(mi)=ss1*COMPLEX(i,j) !・
LET mi=mi+1
LET i=i+d
LET x(mi)=ss1*COMPLEX(i,j) !←→
LET mi=mi+1
LET d=-d
NEXT j
END IF
FOR i=hn-1 TO 1 STEP -1 !
LET x(mi)=ss1*COMPLEX(i,j) !
LET mi=mi+1 !←・
NEXT i
END SUB
PUBLIC STRING SEKKI24$(0 TO 23, 0 TO 1),QROKUYOU$,QJUKKAN$,Z$
PUBLIC NUMERIC QYEAR,QURUU,QMONTH,QDAY,QMAGE,QMAGENOON,QILLUMI,QMPHASE,RM_SUN0
LET A4=297/210
!'LET B5=257/182
!'LET B4=364/257
LET XSIZE=800
LET YSIZE=INT(XSIZE*A4)
LET XS=XSIZE*75/800
LET YS=YSIZE*250/800
CALL GINIT(XSIZE,YSIZE)
LET HEIGHT=XSIZE*50/800
SET TEXT HEIGHT HEIGHT
DIM DD(12),MON$(12)
MAT READ DD
DATA 31,28,31,30,31,30,31,31,30,31,30,31
MAT READ MON$
DATA 睦月,如月,弥生,卯月,皐月,水無月,文月,葉月,長月,神無月,霜月,師走
LET YEAR = INT(VAL(DATE$)/10000)
LET MONTH = MOD(INT(VAL(DATE$)/100),100)
INPUT PROMPT "西暦 年=":YEAR$
IF YEAR$<>"" THEN LET YEAR=VAL(YEAR$)
INPUT PROMPT "月=":MONTH$
IF MONTH$<>"" THEN LET MONTH=VAL(MONTH$)
LET TM = YMDT2JD(YEAR, MONTH, 1, 0, 0, 0)
LET R=MOD(TM+2,7)
SET LINE COLOR "BLACK"
LET XX=R*XSIZE/8
IF YEAR>=1989 THEN LET M$=" 平成"&STR$(YEAR-1988)&"年"
IF YEAR<1989 AND YEAR>=1926 THEN LET M$=" 昭和"&STR$(YEAR-1925)&"年"
IF YEAR<1926 AND YEAR>=1912 THEN LET M$=" 大正"&STR$(YEAR-1911)&"年"
IF YEAR<1912 AND YEAR>=1868 THEN LET M$=" 明治"&STR$(YEAR-1867)&"年"
CALL SYMBOL(XSIZE/2-HEIGHT*3,YSIZE/8,"BLACK",STR$(YEAR)&"年"&" "&STR$(MONTH)&"月")
SET TEXT HEIGHT HEIGHT/2
CALL SYMBOL(XSIZE/2+HEIGHT*4,YSIZE/9,"BLACK",M$)
CALL SYMBOL(XSIZE/2+HEIGHT*5,YSIZE/7,"BLACK",MON$(MONTH))
SET TEXT HEIGHT HEIGHT
FOR I=0 TO 6
READ A$,COL$
DATA 日,RED,月,BLACK,火,BLACK,水,BLACK,木,BLACK,金,BLACK,土,BLUE
CALL SYMBOL(XS+I*XSIZE/8,YSIZE/4,COL$,A$)
NEXT I
CALL CALC_SEKKI24(YEAR)
FOR I=1 TO DD(MONTH)
LET FL=0
SET TEXT HEIGHT HEIGHT
LET COL$=DAYCOLOR$(YEAR,MONTH,I,R)
CALL SYMBOL(XS+XX,YS+YY,COL$,USING$("##",I))
CALL CALC_KYUREKI(YEAR,MONTH,I)
IF QURUU<>0 THEN LET N$="閏" ELSE LET N$=""
LET TM = YMDT2JD(YEAR, MONTH, I, 0, 0, 0)
LET A$=CALC_JUKKAN$(TM)
LET B$=QSEI$(TM)
SET TEXT HEIGHT HEIGHT*.25
CALL MOON(XS+XX+HEIGHT*.6,YS+YY+HEIGHT*.5,HEIGHT*.5,QMAGENOON-.5,QILLUMI/100)
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*.3,COL$,QROKUYOU$&" "&N$&STR$(QMONTH)&"/"&STR$(QDAY))
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*.6,COL$,A$)
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*.9,COL$,B$)
IF Z$<>"" THEN CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.2,"GREEN",Z$)
FOR K=0 TO 23
IF VAL(SEKKI24$(K, 0)(6:7))=MONTH AND VAL(SEKKI24$(K, 0)(9:10))=I THEN
IF Z$<>"" THEN
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.5,"MAGENTA",SEKKI24$(K, 1))
LET FL=1
ELSE
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.2,"MAGENTA",SEKKI24$(K, 1))
LET FL=2
END IF
EXIT FOR
END IF
NEXT K
IF QMPHASE=14 THEN
LET S$="満月"
ELSEIF QMPHASE=0 THEN
LET S$="新月"
ELSE
!'LET S$=USING$("##.#",QILLUMI)&"%"
LET S$=""
END IF
IF S$<>"" THEN
IF Z$="" AND FL<>2 THEN
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.2,"BLUE",S$)
ELSEIF FL<>1 THEN
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.5,"BLUE",S$)
ELSE
CALL SYMBOL(XS+XX,YS+YY+HEIGHT*1.8,"BLUE",S$)
END IF
END IF
LET XX=XX+XSIZE/8
IF MOD(R+I,7)=0 THEN
LET XX=0
LET YY=YY+YSIZE/8
END IF
NEXT I
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
CLEAR
END SUB
EXTERNAL SUB SYMBOL(X,Y,COL$,A$)
SET TEXT COLOR COL$
PLOT TEXT,AT X,Y:A$
END SUB
EXTERNAL FUNCTION DAYCOLOR$(Y,M,N,R)
LET DAYCOLOR$="BLACK"
LET Z$=""
IF MOD(N+R,7)=1 THEN LET DAYCOLOR$="RED"
IF MOD(N+R,7)=0 THEN LET DAYCOLOR$="BLUE"
IF M=1 AND N=1 THEN
LET DAYCOLOR$="RED"
LET Z$="元日"
END IF
IF Y>=1973 AND M=1 AND N=2 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y>=2000 THEN
IF M=1 AND ((R<=1 AND R+N=9) OR (R>1 AND R+N=16)) THEN
LET DAYCOLOR$="RED"
LET Z$="成人の日"
END IF
ELSE
IF M=1 AND N=15 THEN
LET DAYCOLOR$="RED"
LET Z$="成人の日"
END IF
IF Y>=1973 AND M=1 AND N=16 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF M=2 AND N=11 THEN
LET DAYCOLOR$="RED"
LET Z$="建国記念の日"
END IF
IF Y>=1973 AND M=2 AND N=12 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y>=1900 AND Y<1980 THEN
IF M=3 AND N=INT(20.8357+0.242194*(Y-1980)-INT((Y-1983)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="春分の日"
END IF
IF Y>=1973 AND M=3 AND N=INT(20.8357+0.242194*(Y-1980)-INT((Y-1983)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=9 AND N=INT(23.2588+0.242194*(Y-1980)-INT((Y-1983)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="秋分の日"
END IF
IF Y>=1973 AND M=9 AND N=INT(23.2588+0.242194*(Y-1980)-INT((Y-1983)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
ELSEIF Y>=1980 AND Y<2100 THEN
IF M=3 AND N=INT(20.8431 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4) THEN
LET DAYCOLOR$="RED"
LET Z$="春分の日"
END IF
IF M=3 AND N=INT(20.8431 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4)+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=9 AND N=INT(23.2488 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4) THEN
LET DAYCOLOR$="RED"
LET Z$="秋分の日"
END IF
IF M=9 AND N=INT(23.2488 + 0.242194 * (Y - 1980)) - INT((Y - 1980)/4)+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
ELSEIF Y>=2100 AND Y<2150 THEN
IF M=3 AND N=INT(21.8510+0.242194*(Y-1980)-INT((Y-1980)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="春分の日"
END IF
IF M=3 AND N=INT(21.8510+0.242194*(Y-1980)-INT((Y-1980)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=9 AND N=INT(24.2488+0.242194*(Y-1980)-INT((Y-1980)/4)) THEN
LET DAYCOLOR$="RED"
LET Z$="秋分の日"
END IF
IF M=9 AND N=INT(24.2488+0.242194*(Y-1980)-INT((Y-1980)/4))+1 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF M=4 AND N=29 THEN
LET DAYCOLOR$="RED"
IF Y>=2007 THEN
LET Z$="昭和の日"
ELSEIF Y>=1989 AND Y<2007 THEN
LET Z$="みどりの日"
ELSEIF Y>1948 THEN
LET Z$="天皇誕生日"
END IF
END IF
IF Y>=1973 AND M=4 AND N=30 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF M=5 AND N=3 THEN
LET DAYCOLOR$="RED"
LET Z$="憲法記念日"
END IF
IF Y>=2007 THEN
IF M=5 AND N=4 THEN
LET DAYCOLOR$="RED"
LET Z$="みどりの日"
END IF
ELSEIF Y>=1988 AND Y<2007 THEN
IF M=5 AND N=4 THEN
LET DAYCOLOR$="RED"
LET Z$="国民の休日"
END IF
END IF
IF M=5 AND N=5 THEN
LET DAYCOLOR$="RED"
LET Z$="こどもの日"
END IF
IF Y>=1973 AND M=5 AND N=6 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y>=2003 THEN
IF M=7 AND ((R<=1 AND R+N=16) OR (R>1 AND R+N=23)) THEN
LET DAYCOLOR$="RED"
LET Z$="海の日"
END IF
ELSEIF Y>=1996 AND Y<2003 THEN
IF M=7 AND N=20 THEN
LET DAYCOLOR$="RED"
LET Z$="海の日"
END IF
IF M=7 AND N=21 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF Y>=2016 THEN
IF M=8 AND N=11 THEN
LET DAYCOLOR$="RED"
LET Z$="山の日"
END IF
IF M=8 AND N=12 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF Y>=2003 THEN
IF M=9 AND ((R<=1 AND R+N=16) OR (R>1 AND R+N=23)) THEN
LET DAYCOLOR$="RED"
LET Z$="敬老の日"
END IF
ELSEIF Y>=1966 AND Y<2003 THEN
IF M=9 AND N=15 THEN
LET DAYCOLOR$="RED"
LET Z$="敬老の日"
END IF
IF Y>=1973 AND M=9 AND N=16 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF Y>=2000 THEN
IF M=10 AND ((R<=1 AND R+N=9) OR (R>1 AND R+N=16)) THEN
LET DAYCOLOR$="RED"
LET Z$="体育の日"
END IF
ELSEIF Y>=1966 AND Y<2000 THEN
IF M=10 AND N=10 THEN
LET DAYCOLOR$="RED"
LET Z$="体育の日"
END IF
IF Y>=1973 AND M=10 AND N=11 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
IF M=11 AND N=3 THEN
LET DAYCOLOR$="RED"
LET Z$="文化の日"
END IF
IF M=11 AND N=23 THEN
LET DAYCOLOR$="RED"
LET Z$="敬老感謝の日"
END IF
IF Y>=1973 AND M=11 AND (N=4 OR N=24) AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
IF Y>=1989 THEN
IF M=12 AND N=23 THEN
LET DAYCOLOR$="RED"
LET Z$="天皇誕生日"
END IF
IF M=12 AND N=24 AND MOD(N+R-1,7)=1 THEN
LET DAYCOLOR$="RED"
LET Z$="振替休日"
END IF
END IF
LET D$=DATE$
IF Y=VAL(D$(1:4)) AND M=VAL(D$(5:6)) AND N=VAL(D$(7:8)) THEN LET DAYCOLOR$="CYAN"
END FUNCTION
EXTERNAL FUNCTION QSEI$(TM)
DIM A$(9)
MAT READ A$
LET QSEI$=A$(MOD(TM-1,9)+1)
DATA 九紫火星
DATA 八白土星
DATA 七赤金星
DATA 六白金星
DATA 五黄土星
DATA 四緑木星
DATA 三碧木星
DATA 二黒土星
DATA 一白水星
END FUNCTION
EXTERNAL SUB MOON(X,Y,R,H,N)
DIM XX(73),YY(73)
SET COLOR "GRAY"
DRAW DISK WITH SCALE(R)*SHIFT(X,Y)
SET AREA COLOR "YELLOW"
IF H>15 THEN LET SW=-1 ELSE LET SW=1
LET RR=2*(N-.5)
IF RR>0 THEN
FOR T=0 TO 360 STEP 5
LET B=R
IF T>=90 AND T<=270 THEN LET B=R*RR
LET I=I+1
LET YY(I)=R*SIN(RAD(T))+Y
LET XX(I)=SW*B*COS(RAD(T))+X
NEXT T
ELSE
FOR T=-90 TO 90 STEP 5
LET I=I+1
LET YY(I)=R*SIN(RAD(T))+Y
LET XX(I)=SW*R*COS(RAD(T))+X
NEXT T
LET B=R*ABS(RR)
FOR T=85 TO -90 STEP -5
LET I=I+1
LET YY(I)=R*SIN(RAD(T))+Y
LET XX(I)=SW*B*COS(RAD(T))+X
NEXT T
END IF
IF RR>-1 THEN MAT PLOT AREA :XX,YY
END SUB
!' 角度の正規化を行う。すなわち引数の範囲を０≦θ＜３６０にする
EXTERNAL FUNCTION NORMALIZATION_ANGLE(ANGLE)
LET NORMALIZATION_ANGLE = MOD(ANGLE+360,360)
END FUNCTION
EXTERNAL FUNCTION LONGITUDE_SUN(T) !' 太陽の黄経λsunを計算する
!' 摂動項の計算
LET ANG = NORMALIZATION_ANGLE(31557 * T + 161)
LET TH = 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(29930 * T + 48)
LET TH = TH + 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(2281 * T + 221)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(155 * T + 118)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(33718 * T + 316)
LET TH = TH + 0.0006 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(9038 * T + 64)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(3035 * T + 110)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(65929 * T + 45)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(22519 * T + 352)
LET TH = TH + 0.0013 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(45038 * T + 254)
LET TH = TH + 0.0015 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(445267 * T + 208)
LET TH = TH + 0.0018 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(19 * T + 159)
LET TH = TH + 0.0018 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(32964 * T + 158)
LET TH = TH + 0.002 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(71998.1 * T + 265.1)
LET TH = TH + 0.02 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(35999.05 * T + 267.52)
LET TH = TH - 0.0048 * T * COS(PI * ANG / 180)
LET TH = TH + 1.9147 * COS(PI * ANG / 180)
!' 比例項の計算
LET ANG = NORMALIZATION_ANGLE(36000.7695 * T)
LET ANG = NORMALIZATION_ANGLE(ANG + 280.4659)
LET LONGITUDE_SUN = NORMALIZATION_ANGLE(TH + ANG)
END FUNCTION
EXTERNAL FUNCTION LONGITUDE_MOON(T) !' 月の黄経λmoonを計算する
!' 摂動項の計算
LET ANG = NORMALIZATION_ANGLE(2322131 * T + 191)
LET TH = 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(4067 * T + 70)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(549197 * T + 220)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1808933 * T + 58)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(349472 * T + 337)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(381404 * T + 354)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(958465 * T + 340)
LET TH = TH + 0.0003 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(12006 * T + 187)
LET TH = TH + 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(39871 * T + 223)
LET TH = TH + 0.0004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(509131 * T + 242)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1745069 * T + 24)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1908795 * T + 90)
LET TH = TH + 0.0005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(2258267 * T + 156)
LET TH = TH + 0.0006 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(111869 * T + 38)
LET TH = TH + 0.0006 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(27864 * T + 127)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(485333 * T + 186)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(405201 * T + 50)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(790672 * T + 114)
LET TH = TH + 0.0007 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1403732 * T + 98)
LET TH = TH + 0.0008 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(858602 * T + 129)
LET TH = TH + 0.0009 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1920802 * T + 186)
LET TH = TH + 0.0011 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1267871 * T + 249)
LET TH = TH + 0.0012 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1856938 * T + 152)
LET TH = TH + 0.0016 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(401329 * T + 274)
LET TH = TH + 0.0018 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(341337 * T + 16)
LET TH = TH + 0.0021 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(71998 * T + 85)
LET TH = TH + 0.0021 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(990397 * T + 357)
LET TH = TH + 0.0021 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(818536 * T + 151)
LET TH = TH + 0.0022 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(922466 * T + 163)
LET TH = TH + 0.0023 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(99863 * T + 122)
LET TH = TH + 0.0024 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1379739 * T + 17)
LET TH = TH + 0.0026 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(918399 * T + 182)
LET TH = TH + 0.0027 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1934 * T + 145)
LET TH = TH + 0.0028 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(541062 * T + 259)
LET TH = TH + 0.0037 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1781068 * T + 21)
LET TH = TH + 0.0038 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(133 * T + 29)
LET TH = TH + 0.004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1844932 * T + 56)
LET TH = TH + 0.004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1331734 * T + 283)
LET TH = TH + 0.004 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(481266 * T + 205)
LET TH = TH + 0.005 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(31932 * T + 107)
LET TH = TH + 0.0052 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(926533 * T + 323)
LET TH = TH + 0.0068 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(449334 * T + 188)
LET TH = TH + 0.0079 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(826671 * T + 111)
LET TH = TH + 0.0085 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1431597 * T + 315)
LET TH = TH + 0.01 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1303870 * T + 246)
LET TH = TH + 0.0107 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(489205 * T + 142)
LET TH = TH + 0.011 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1443603 * T + 52)
LET TH = TH + 0.0125 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(75870 * T + 41)
LET TH = TH + 0.0154 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(513197.9 * T + 222.5)
LET TH = TH + 0.0304 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(445267.1 * T + 27.9)
LET TH = TH + 0.0347 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(441199.8 * T + 47.4)
LET TH = TH + 0.0409 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(854535.2 * T + 148.2)
LET TH = TH + 0.0458 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(1367733.1 * T + 280.7)
LET TH = TH + 0.0533 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(377336.3 * T + 13.2)
LET TH = TH + 0.0571 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(63863.5 * T + 124.2)
LET TH = TH + 0.0588 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(966404 * T + 276.5)
LET TH = TH + 0.1144 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(35999.05 * T + 87.53)
LET TH = TH + 0.1851 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(954397.74 * T + 179.93)
LET TH = TH + 0.2136 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(890534.22 * T + 145.7)
LET TH = TH + 0.6583 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(413335.35 * T + 10.74)
LET TH = TH + 1.274 * COS(PI * ANG / 180)
LET ANG = NORMALIZATION_ANGLE(477198.868 * T + 44.963)
LET TH = TH + 6.2888 * COS(PI * ANG / 180)
!' 比例項の計算
LET ANG = NORMALIZATION_ANGLE(481267.8809 * T)
LET ANG = NORMALIZATION_ANGLE(ANG + 218.3162)
LET LONGITUDE_MOON = NORMALIZATION_ANGLE(TH + ANG)
END FUNCTION
!' ユリウス日(JD)から年月日、時分秒(世界時)を計算する
!' この関数で求めた年月日は、グレゴリオ暦法によって表されている
EXTERNAL FUNCTION JD2YMDT$(JD)
LET X0 = INT(JD + 68570)
LET X1 = INT(X0 / 36524.25)
LET X2 = X0 - INT(36524.25 * X1 + 0.75)
LET X3 = INT((X2 + 1) / 365.2425)
LET X4 = X2 - INT(365.25 * X3) + 31
LET X5 = INT(INT(X4) / 30.59)
LET X6 = INT(INT(X5) / 11)
LET GDAY = X4 - INT(30.59 * X5)
LET GMONTH = X5 - 12 * X6 + 2
LET GYEAR = 100 * (X1 - 49) + X3 + X6
!' 2月30日の補正
IF GMONTH = 2 AND GDAY > 28 THEN
IF MOD(GYEAR,100) = 0 AND MOD(GYEAR,400) = 0 THEN
LET GDAY = 29
ELSEIF MOD(GYEAR,4) = 0 AND MOD(GYEAR,100) > 0 THEN
LET GDAY = 29
ELSE
LET GDAY = 28
END IF
END IF
LET X0 = 24 * (JD - INT(JD))
LET GHOUR = INT(X0)
LET GMINUTE = INT((X0 - GHOUR) * 60)
LET GSECOND = INT((X0 - GHOUR - GMINUTE / 60) * 3600 + 0.05)
LET JD2YMDT$ = STR$(GYEAR) & "/" & RIGHT$("0"&STR$(GMONTH),2) & "/" & RIGHT$("0"&STR$(GDAY),2) & " " & RIGHT$("0"&STR$(GHOUR),2) & ":" & RIGHT$("0"&STR$(GMINUTE),2) & ":" & RIGHT$("0"&STR$(GSECOND),2)
END FUNCTION
!' 年月日、時分秒(世界時)からユリウス日(JD)を計算する
EXTERNAL FUNCTION YMDT2JD(GYEAR, GMONTH, GDAY, GHOUR, GMINUTE, GSECOND)
IF GMONTH < 3 THEN
LET CALC_GYEAR = GYEAR - 1
LET CALC_GMONTH = GMONTH + 12
ELSE
LET CALC_GYEAR = GYEAR
LET CALC_GMONTH = GMONTH
END IF
LET Y = INT(365.25 * CALC_GYEAR) + INT(CALC_GYEAR / 400) - INT(CALC_GYEAR / 100)
LET Y = Y + INT(30.59 * (CALC_GMONTH - 2)) + 1721088 + GDAY
LET YMDT2JD = Y + (GHOUR + GMINUTE / 60 + GSECOND / 3600) / 24
END FUNCTION
!' 二十四節季
!' Sekki(x,0) .... 節季日
!' Sekki(x,1) .... 節季
EXTERNAL SUB CALC_SEKKI24(GYEAR)
DIM A$(24)
MAT READ A$
LET YMD = YMDT2JD(GYEAR, 1, 1, 0, 0, 0)
LET J = 0
FOR I = 0 TO 400 STEP 15
LET SEKKI$ = JD2YMDT$(CALC_CHU(YMD + I, 15))
IF VAL(LEFT$(SEKKI$, 4)) = GYEAR THEN
LET SEKKI24$(J, 0) = SEKKI$
LET SEKKI24$(J, 1) = A$(RM_SUN0 / 15+1)
DATA "春分", "清明", "穀雨", "立夏", "小満", "芒種"
DATA "夏至", "小暑", "大暑", "立秋", "処暑", "白露"
DATA "秋分", "寒露", "霜降", "立冬", "小雪", "大雪"
DATA "冬至", "小寒", "大寒", "立春", "雨水", "啓蟄"
LET J = J + 1
END IF
NEXT I
END SUB
!' 新暦に対応する、旧暦を求める
!' 引数 tm .... 計算する日付(ユリウス日)
!' 戻り値 .... kyureki
EXTERNAL SUB CALC_KYUREKI(GYEAR, GMONTH, GDAY)
DIM CHU(0 TO 4), SAKU(0 TO 5), M(0 TO 5, 0 TO 2),ROKU$(6)
LET TM = YMDT2JD(GYEAR, GMONTH, GDAY, 0, 0, 0)
LET CHU(0) = CALC_CHU(TM, 90) !' 計算対象の直前にあたる二分二至の時刻を求める
LET M(0, 0) = INT(RM_SUN0 / 30) + 2 !' 上で求めた二分二至の時の太陽黄経をもとに朔日行列の先頭に月名をセット
FOR I = 1 TO 4
LET CHU(I) = CALC_CHU(CHU(I - 1) + 32, 30)
NEXT I
!' 計算対象の直前にあたる二分二至の直前の朔の時刻を求める
LET SAKU(0) = CALC_SAKU(CHU(0))
!' 朔の時刻を求める
FOR I = 1 TO 5
LET SAKU(I) = CALC_SAKU(SAKU(I - 1) + 30)
!' 前と同じ時刻を計算した場合(両者の差が26日以内)には、初期値を+33日にして再実行させる
IF ABS(INT(SAKU(I - 1)) - INT(SAKU(I))) <= 26 THEN
LET SAKU(I) = CALC_SAKU(SAKU(I - 1) + 35)
END IF
NEXT I
!' saku(1)が二分二至の時刻以前になってしまった場合には、朔をさかのぼり過ぎたと考えて、
!' 朔の時刻を繰り下げて修正する
!' その際、計算もれsaku(4)になっている部分を補うため、朔の時刻を計算する
!' 近日点通過の近辺で朔があると起こる事があるようだ...？
IF INT(SAKU(1)) <= INT(CHU(0)) THEN
FOR I = 0 TO 4
LET SAKU(I) = SAKU(I + 1)
NEXT I
LET SAKU(4) = CALC_SAKU(SAKU(3) + 35)
!' saku(0)が二分二至の時刻以後になってしまった場合には、朔をさかのぼり足りないと見て、
!' 朔の時刻を繰り上げて修正する
!' その際、計算もれsaku(0)になっている部分を補うため、朔の時刻を計算する
!' 春分点の近辺で朔があると起こる事があるようだ...？
ELSEIF INT(SAKU(0)) > INT(CHU(0)) THEN
FOR I = 4 TO 1 STEP -1
LET SAKU(I) = SAKU(I - 1)
NEXT I
LET SAKU(0) = CALC_SAKU(SAKU(0) - 27)
END IF
!' 閏月検索Flagセット 節月で４ヶ月の間に朔が５回あると、閏月がある可能性がある
!' lap=false:平月 lap=true:閏月
IF INT(SAKU(4)) <= INT(CHU(3)) THEN LET LAP=1 ELSE LET LAP=0
!' 朔日行列の作成
!' m(i,0) ... 月名(1:正月 2:２月 3:３月 ....)
!' m(i,1) ... 閏フラグ(false:平月 true:閏月)
!' m(i,2) ... 朔日のjd
!' m(0, 0)はこの関数の始めの方ですでに代入済み
LET M(0, 1) = 0
LET M(0, 2) = INT(SAKU(0))
FOR I = 1 TO 5
IF LAP=1 AND I > 1 THEN
IF CHU(I - 1) <= INT(SAKU(I - 1)) OR CHU(I - 1) >= INT(SAKU(I)) THEN
LET M(I - 1, 0) = M(I - 2, 0)
LET M(I - 1, 1) = 1
LET M(I - 1, 2) = INT(SAKU(I - 1))
LET LAP = 0
END IF
END IF
LET M(I, 0) = M(I - 1, 0) + 1
IF M(I, 0) > 12 THEN
LET M(I, 0) = M(I, 0) - 12
END IF
LET M(I, 2) = INT(SAKU(I))
LET M(I, 1) = 0
NEXT I
!' 朔日行列から旧暦を求める
LET STATE = 0
FOR I = 0 TO 5
IF INT(TM) < INT(M(I, 2)) THEN
LET STATE = 1
EXIT FOR
ELSEIF INT(TM) = INT(M(I, 2)) THEN
LET STATE = 2
EXIT FOR
END IF
NEXT I
IF STATE = 0 OR STATE = 1 THEN
LET I = I - 1
END IF
LET QURUU = M(I, 1)
LET QMONTH = M(I, 0)
LET QDAY = INT(TM) - INT(M(I, 2)) + 1
!'旧暦年の計算 旧暦月が10以上でかつ新暦月より大きい場合には、まだ年を越していないはず...
!'YMD$ = JD2YMDT$(tm)
!'QYear = Val(Left$(YMD$, 4))
!'If QMonth > 9 And QMonth > Val(Mid$(YMD$, 6, 2)) Then
LET QYEAR = GYEAR
IF QMONTH > 9 AND QMONTH > GMONTH THEN
LET QYEAR = QYEAR - 1
END IF
!' 六曜を求める
MAT READ ROKU$
DATA "大安", "赤口", "先勝", "友引", "先負", "仏滅"
LET QROKUYOU$ = ROKU$(MOD((QMONTH + QDAY) ,6) + 1)
!' 十干十二支を求める
LET QJUKKAN$ = CALC_JUKKAN$(TM)
!' リアルタイム月齢を求める
LET QMAGE = TM - SAKU(I)
IF QMAGE < 0 THEN
LET QMAGE = TM - SAKU(I - 1)
END IF
!' 正午月齢を求める
LET QMAGENOON = INT(TM) + 0.5 - SAKU(I)
IF QMAGENOON < 0 THEN
LET QMAGENOON = INT(TM) + 0.5 - SAKU(I - 1)
END IF
!' 輝面比を求める
LET TM1 = INT(TM)
LET TM2 = TM - TM1 - 9 / 24
LET T = (TM2 + 0.5) / 36525 + (TM1 - 2451545) / 36525
LET QILLUMI = (1 - COS(PI * NORMALIZATION_ANGLE(LONGITUDE_MOON(T) - LONGITUDE_SUN(T)) / 180)) * 50
!' 月相を求める 輝面比の計算で求めた変数tを使用
LET QMPHASE = INT(NORMALIZATION_ANGLE(LONGITUDE_MOON(T) - LONGITUDE_SUN(T)) / 360 * 28 + 0.5)
LET QMPHASE = MOD(QMPHASE, 28)
END SUB
!!OPTION ARITHMETIC RATIONAL
DIM M(3,3)
DIM X(3,3)
FOR A=2 TO 9
LET M(1,1)=A
LET X(1,1)=A*A
FOR B=A TO 9
LET M(1,2)=B
LET X(1,2)=B*B
FOR C=B TO 9
LET M(1,3)=C
LET X(1,3)=C*C
FOR D=2 TO 9
LET M(2,1)=D
LET X(2,1)=D*D
FOR E=2 TO 9
LET M(2,2)=E
LET X(2,2)=E*E
FOR F=2 TO 9
LET M(2,3)=F
LET X(2,3)=F*F
FOR G=2 TO 9
LET M(3,1)=G
LET X(3,1)=G*G
FOR H=2 TO 9
LET M(3,2)=H
LET X(3,2)=H*H
FOR I=2 TO 9
LET M(3,3)=I
LET X(3,3)=I*I
IF DET(M)=1 THEN
PRINT DET(X) !debug
IF DET(X)=1 THEN
MAT PRINT M;
STOP
END IF
END IF
NEXT I
NEXT H
NEXT G
NEXT F
NEXT E
NEXT D
NEXT C
NEXT B
NEXT A
END
10進、1000桁モード
:
:
-1975
387
1327
2267
-1505
1
2 2 3
9 7 6
4 3 2
2進、複素数、有理数モード
:
:
217
237
-51
769
1
2 2 3
3 4 2
7 9 6
10進、1000桁モードでは、2進、複素数、有理数モードで求まる値が抜けるようです。
DATA 2,2,3
DATA 3,4,2
DATA 7,9,6
DIM M(3,3),X(3,3)
FOR i=1 TO 3
FOR J=1 TO 3
READ T
LET M(i,J)=T
LET X(i,J)=T*T
NEXT J
NEXT i
IF DET(M)=1 THEN MAT PRINT M;
IF DET(X)=1 THEN MAT PRINT X; !bug bug bug 10進、1000桁モード
IF DET3(M)=1 THEN MAT PRINT M;
IF DET3(X)=1 THEN MAT PRINT X;
END
EXTERNAL FUNCTION DET3(M(,)) !3行3列の行列式の値
LET DET3=M(1,1)*M(2,2)*M(3,3)+M(1,2)*M(2,3)*M(3,1)+M(1,3)*M(2,1)*M(3,2) &
& -M(1,3)*M(2,2)*M(3,1)-M(1,1)*M(2,3)*M(3,2)-M(1,2)*M(2,1)*M(3,3)
END FUNCTION
DATA 2,2,3
DATA 3,4,2
DATA 7,9,6
DIM M(3,3),X(3,3)
FOR i=1 TO 3
FOR J=1 TO 3
READ T
LET M(i,J)=T
LET X(i,J)=T*T
NEXT J
NEXT i
IF DET(M)=1 THEN MAT PRINT M;
IF DET(X)=1 THEN MAT PRINT X; !10進、1000桁モード
IF DET3(M)=1 THEN MAT PRINT M;
IF DET3(X)=1 THEN MAT PRINT X;
END
EXTERNAL FUNCTION DET3(M(,)) !3行3列の行列式の値
LET DET3=M(1,1)*M(2,2)*M(3,3)+M(1,2)*M(2,3)*M(3,1)+M(1,3)*M(2,1)*M(3,2) &
& -M(1,3)*M(2,2)*M(3,1)-M(1,1)*M(2,3)*M(3,2)-M(1,2)*M(2,1)*M(3,3)
END FUNCTION
> 次のプログラムのように展開式を使った関数を用いると、どのモードも結果は一致します。
> 定義した関数DET3は、32ビット整数の範囲で、計算結果は整数として保証されるのでしょうか。
> 偶々、浮動小数点による近似値が、整数（真の値）と一致したと考えるのでしょうか。
>
>
> DATA 2,2,3
> DATA 3,4,2
> DATA 7,9,6
> DIM M(3,3),X(3,3)
> FOR i=1 TO 3
> FOR J=1 TO 3
> READ T
> LET M(i,J)=T
> LET X(i,J)=T*T
> NEXT J
> NEXT i
> IF DET(M)=1 THEN MAT PRINT M;
> IF DET(X)=1 THEN MAT PRINT X; !10進、1000桁モード
> IF DET3(M)=1 THEN MAT PRINT M;
> IF DET3(X)=1 THEN MAT PRINT X;
> END
> EXTERNAL FUNCTION DET3(M(,)) !3行3列の行列式の値
> LET DET3=M(1,1)*M(2,2)*M(3,3)+M(1,2)*M(2,3)*M(3,1)+M(1,3)*M(2,1)*M(3,2) &
> & -M(1,3)*M(2,2)*M(3,1)-M(1,1)*M(2,3)*M(3,2)-M(1,2)*M(2,1)*M(3,3)
> END FUNCTION
>
>
100 input prompt "Xs=":Xs
110 input prompt "Ys=":Ys
120 input prompt "S=":s
130 let pit=s/500
140 LET CT=0
1010 LET Ts=TIME
1020 SET BITMAP SIZE 530,550
1030 SET WINDOW 0,529,0,549
1040 SET POINT STYLE 1
1050 LET x$=STR$(Xs)
1060 LET Y$=STR$(Ys)
1070 LET s$=STR$(s)
1100 LET SS$="Xs="&X$&" :Ys="&Y$&" :S="&s$ ! 左下ＸＹ座標値と座標幅を表示
1110 PLOT TEXT ,AT 5,530 :SS$
2000 for m=0 to 499
2010 for n=0 to 499
2020 LET x=Xs+(m*pit)
2030 LET y=Ys+(n*pit)
2031 let px=x
2032 let py=y
2035 LET a=0
2040 FOR k=1 TO 250 ! この数値を大きくする場合３０００行からの色指標のオーバーに注意
2050 LET Z=x^2+y^2
2060 LET Cx=x^2-y^2+px
2070 LET Cy=2*x*y+py
2080 if Z>4 then gosub 3000
2090 let x=Cx
2100 LET y=Cy
2105 LET Ct=Ct+1
2110 if a=1 then 2220
2200 next k
2210 gosub 4000
2220 next n
2230 next m
2500 GOTO 5000
3000 LET c=k
3020 LET c=c+2
3050 set point color c
3060 PLOT POINTS:m,n
3070 LET a=1
3080 return
4000 rem if a=1 then return
4010 set point color 1
4020 plot points:m,n
4030 RETURN
5000 LET Ct$=STR$(Ct) ! 繰り返し回数と計算時間を表示
5010 LET Te=TIME-Ts
5020 LET T$=STR$(Te)
5030 LET ST$=Ct$&" T="&T$
5040 PLOT TEXT ,AT 5,510 :ST$
6000 CHARACTER INPUT PROMPT " DRAW GRID？（ｙ／ｎ）":D$ ! 結果に１０×１０のグリッドを入れるか？
6010 IF D$="n" THEN 7000
6020 DRAW GRID(50,50)
7000 PAUSE "拡大する範囲を指定してください" ! 正方形領域を取得する
7010 CALL GetSquare(Bx,Ty,Tx,By)
8010 LET Xs=Xs+(S*(Bx/500))
8020 LET Ys=Ys+(S*(By/500))
8030 LET S=S*(ABS(Tx-Bx)/500)
8040 CLEAR
8050 GOTO 130
10000 end
! マウスによる正方形領域取得副プログラム
EXTERNAL SUB GetSquare(l,t,r,b)
ASK LINE STYLE LStyle
SET DRAW MODE NOTXOR
SET LINE STYLE 2
DO
MOUSE POLL l,t,i,j
LOOP WHILE i=0
LET l0=l
LET t0=t
LET r0=l0
LET b0=t0
PLOT LINES: l0,t0; l0,b0; r0,b0; r0,t0; l0,t0
DO WHILE i=1
MOUSE POLL r,b,i,j
LET w=r-l
LET h=t-b
IF ABS(h) < ABS(w) THEN
LET b=t-SGN(h)*ABS(w)
ELSE
LET r=l+SGN(w)*ABS(h)
END IF
IF l0<>l OR r0<>r OR b0<>b OR t0<>t THEN
PLOT LINES: l0,t0; l0,b0; r0,b0; r0,t0; l0,t0
PLOT LINES: l,t; l,b; r,b; r,t; l,t
LET l0=l
LET t0=t
LET r0=r
LET b0=b
END IF
LOOP
WAIT DELAY 1
PLOT LINES: l,t; l,b; r,b; r,t; l,t
SET DRAW MODE OVERWRITE
SET LINE STYLE LStyle
IF l>r THEN SWAP l,r
IF b>t THEN SWAP b,t
END SUB
また、
| a b c | = a| e f |- b| d f | +c| d e |
| d e f | | h i | | g i | | g h |
| g h i |
P1=ei-fh、P2=di-fg、P3=dh-egとすると、
=aP1-bP2+cP3
X=aP1, Y=bP2, Z=cP3 とすると、
=X-Y+Z
LET S=0
FOR E=2 TO 10
FOR i=2 TO 10
FOR F=2 TO 10
FOR H=2 TO 10
LET P1=E*i-F*H
LET Q1=E*i+F*H
FOR D=2 TO 10
FOR G=2 TO 10
LET P2=D*i-F*G
LET Q2=D*i+F*G
LET P3=D*H-E*G
LET Q3=D*H+E*G
FOR A=2 TO i !対称性（180°回転）
LET X=A*P1
LET XX=A*Q1
FOR C=2 TO G !対称性（転置）
LET Z=C*P3
LET ZZ=C*Q3
FOR B=2 TO 10
LET Y=B*P2
LET YY=B*Q2
IF X-Y+Z=1 AND X*XX-Y*YY+Z*ZZ=1 THEN !題意を満たすもの
IF A=i AND C=G THEN !対称性（転置、180°回転）
IF D>=B AND H>=B THEN
PRINT A;B;C
PRINT D;E;F
PRINT G;H;i
PRINT
LET S=S+1
END IF
ELSE
PRINT A;B;C
PRINT D;E;F
PRINT G;H;i
PRINT
LET S=S+1
END IF
END IF
NEXT B
NEXT C
NEXT A
NEXT G
NEXT D
NEXT H
NEXT F
NEXT i
NEXT E
PRINT S; "通り"
END
LET N=15 !枚数の最大
DIM A(N) !数字の並び
LET A(1)=1 !番兵
PUBLIC NUMERIC C !場合の数
LET C=0
CALL try(2,N-1,A,N)
PRINT C; "通り"
PRINT T(N,N); "通り"
END
EXTERNAL SUB try(P,M,A(),N) !バックトラック法で検索する
FOR i=A(P-1) TO M !nを昇順の並びで分割する
LET A(P)=i
IF M-i=0 THEN !分割が終わったなら
DIM B(N) !1からnまでの数 ※フラグ
MAT B=ZER
LET B(A(1))=1 !組み合わせ（動的計画法） 1つ目
LET T=A(1) !※最大値
FOR J=2 TO P !1つずつ選ぶ（2つ目以降）
LET W=A(J)
FOR K=T TO 1 STEP -1 !その数との和
IF B(K)=1 THEN LET B(K+W)=1
NEXT K
LET B(W)=1 !その数のみ
LET T=T+W
NEXT J
FOR K=1 TO N !1からnまでの数字がつくれたか
IF B(K)=0 THEN EXIT FOR
NEXT K
IF K>N THEN !可能なら
LET C=C+1 !結果を表示する
FOR J=1 TO P
PRINT A(J);
NEXT J
PRINT
END IF
ELSE
CALL try(P+1,M-i,A,N) !次へ
END IF
NEXT i
END SUB
EXTERNAL FUNCTION T(n,k) !漸化式
IF k<=1 THEN
LET T=1
ELSE
IF n<2*k-1 THEN
LET T=T(n,INT((n+1)/2))
ELSE
LET T=T(n,k-1)+T(n-k,k)
END IF
END IF
END FUNCTION
LET M=N+1
FOR A=2 TO M-1
IF MOD(M,A)=0 THEN !n+1の約数なら
FOR B=2 TO M/A-1
IF MOD(M/A,B)=0 THEN !(n+1)/aの約数なら
LET C=(M/A)/B
PRINT "1が";STR$(A-1);"個、";
PRINT STR$(A);"が";STR$(B-1);"個、";
PRINT STR$(A*B);"が";STR$(C-1);"個"
END IF
NEXT B
END IF
NEXT A
LET M=N+1
FOR A=2 TO M-1
IF MOD(M,A)=0 THEN !n+1の約数なら
LET M1=M/A
FOR B=2 TO M1-1
IF MOD(M1,B)=0 THEN !(n+1)/aの約数なら
LET M2=M1/B
FOR C=2 TO M2-1
IF MOD(M2,C)=0 THEN !(n+1)/(ab)の約数なら
LET D=M2/C
PRINT "1が";STR$(A-1);"個、";
PRINT STR$(A);"が";STR$(B-1);"個、";
PRINT STR$(A*B);"が";STR$(C-1);"個、";
PRINT STR$(A*B*C);"が";STR$(D-1);"個"
END IF
NEXT C
END IF
NEXT B
END IF
NEXT A
OPTION ARITHMETIC COMPLEX !複素数平面
LET m_=15 !最大角数
LET ma=14 !開始角数
LET m0=0.23 !ボールの Step⊿
LET r=0.7 !ボールの半径
LET r0=5 !計算上の多角形 頂点～中心点 (±1 変化の中央)
DIM p(m_+1), s(m_+1), rec(3 TO m_, m_)
SET WINDOW -7,7, -7,7
SET TEXT background "opaque"
RANDOMIZE 6 !引数を消すと、起動ごとに、再現されない。
FUNCTION apex(i)
IF mlb=1 OR rec(ma,i)=0 THEN LET rec(ma,i)=apex_(i)
LET apex=rec(ma,i)
END FUNCTION
DO
CLEAR
SET DRAW MODE overwrite
SET LINE COLOR "silver"
LET ag=2*PI/ma !標準の(頂点間の中心角) =外角(辺の延長と隣辺の角度)
LET a1=1.5*PI-ag/2 !標準 p(1) の方向。(↓方向－頂点間の中心角／２)
LET p(1)=apex(1)
FOR i=1 TO ma
IF i< ma THEN LET p(i+1)=apex(i+1) ELSE LET p(i+1)=p(1) !各頂点
LET s(i)=p(i+1)-p(i)
PLOT LINES: p(i); p(i+1) !計算用の壁。辺 s(i)
NEXT i
LET s(i)=s(1)
! s3 s4 ４ s3
! p3 ４──３ ５／ ＼３
! s3／ ＼s2 s4│ │s2 s5＼ ／s2 ・・・
! p1───p2 １──２ １─２
! s1 s1 s1
!
SET LINE width 5 !ボール(半径r) の当る外壁
SET LINE COLOR "black" !---------------------------------
LET a=(PI-arg(s(1)/s(ma)))/2 !p(1)内角の1/2
LET d1=r/SIN(a)*EXP(COMPLEX(0,arg(s(ma))-a)) !計算用 多角形頂点 ～外壁 多角形頂点
FOR i=1 TO ma
LET a=(PI-arg(s(i+1)/s(i)))/2 !p(i+1)内角の1/2
LET d2=r/SIN(a)*EXP(COMPLEX(0,arg(s(i))-a)) !計算用 多角形頂点 ～外壁 多角形頂点
PLOT LINES: p(i)+d1; p(i+1)+d2
LET d1=d2
NEXT i
SET LINE width 1
!---
PLOT TEXT,AT 5.8 , 6.26: "停止"
PLOT TEXT,AT 5.62, 5.68: "ボタン"
PLOT LINES: 5.5,5.5; 6.95,5.5; 6.95,6.95 ; 5.5,6.95 ; 5.5,5.5
PLOT TEXT,AT -6.7,-6.9: "左(順送り)右(逆送り)クリック：角数の選択= "& STR$(ma)& " 長押し0.5秒で早送り"
CALL play00
LET bma=ma
IF 0< mlb THEN LET ma=MOD(ma-2,m_-2)+3 ELSE LET ma=MOD(ma-4,m_-2)+3 !角数 Loop 3,4,5,6,,m_,3,4,,
LOOP UNTIL 5.5< mox AND 5.5< moy
DRAW disk WITH SCALE(r)*SHIFT(bb) !停止直前のボール表示
SUB play00
SET DRAW MODE NOTXOR !２度書きで消える NOTXOR モード
SET LINE COLOR 8
LET nb=0
LET b=p(1)*0.999 !ボールの発射位置
LET i=arg(s(1))+SQR(2)*PI/ma/1.1313 !ボールの発射角度
LET m=m0*EXP(COMPLEX(0,i)) !ボールの step ベクトル
LET t0=TIME
DO
DRAW disk WITH SCALE(r)*SHIFT(b) !ボールを書く
PLOT LINES : b; !履歴線を（書く・消す）
SET DRAW mode explicit !画像加工終り、表示の常時更新 (Normal)
!------------
IF 0< t2 THEN WAIT DELAY t2 !t2: 制御出力の休止秒。
LET t1=TIME !t1: 前の周期の終り。※TIME は 約.05秒毎の更新。
LET t2=t2+(.02-MOD(t1-t0,86400))/20 !20ms－検出周期(t1-t0)＝偏差 →t2(積分 Gain=1/20)
LET t0=t1 !t0: 次の周期の始め＝ 前の周期の終り
!------------
LET bb=b
LET b=b+m
FOR n=1 TO ma
IF n<>nb THEN !n=nb 反射完了フラグな為、n=nb 状態の進入×
CALL Reflex !反射処理
IF n=nb THEN EXIT FOR !n=nb 反射完了、b の更新まで全ての反射処理×
END IF
NEXT n
IF mbak=0 OR mlb=0 AND mrb=0 THEN
LET mbak=2*(mlb+mrb)
ELSE
LET mbak=mbak-1.001/5 !左クリック押続け、約0.5秒後オートリピートへ入る
WAIT DELAY .1 !オートリピート間隔
END IF
MOUSE POLL mox,moy,mlb,mrb !マウスの状態取得
SET DRAW mode hidden !画像加工始め、表示更新を一時停止 (Abnormal)
DRAW disk WITH SCALE(r)*SHIFT(bb) !ボールだけを消す
LOOP UNTIL mbak< mrb OR mbak< mlb !左クリックは、Leading Edge 検出
PLOT LINES
END SUB
!-------------------------------------------------------------
!ｎ番辺のベクトル s(n)
! 1/s(n)= 水平に向ける回転移動ベクトルとして使用、
! 常に、水平相対な 姿勢で、交点、反射方向、、を求める
! y =im(m) /re(m) *(x-re(b) )+im(b) …回転前の、ボール軌跡
!im(p1)=im(p2)= y =im(rm)/re(rm)*(x-re(rb))+im(rb) …回転後の、ボール軌跡
!
! *s(n)= 再び元に戻す
!
! ※p1-1e-15, p2+1e-15 の 1e-15 は、真値が p1=x or p2=x
! の場合に、計算丸めで x< p1 or p2< x 区間外になるのを防止
!-------------------------------------------------------------
SUB Reflex
LET rm=m /s(n) !水平な「辺」に相対な m (stepベクトル)
IF 0<=im(rm) THEN EXIT SUB ! rm が「辺」に平行、又は上向き、交点なし
LET rb=b /s(n) ! 「辺」に相対な b (m の延長予測点)
LET rbb=bb /s(n) ! 「辺」に相対な bb (１つ前の b) 描画済み先頭
LET p1=p(n) /s(n) -1e-15 ! 「辺」に相対な下限
LET p2=p(n+1) /s(n) +1e-15 ! 「辺」に相対な上限
IF im(p1)< im(rb) THEN EXIT SUB ! rb が「辺」に未接触、交点なし
IF im(rbb)<=im(p1) THEN EXIT SUB !π< 内角を挟む他領域。rbb が「辺」以下、交点なし
LET x=(im(p1)-im(rb))*re(rm)/im(rm)+re(rb) !rm の延長 直線の「辺」との交点ｘ
IF x< re(p1) OR re(p2)< x THEN EXIT SUB ! 「辺」の区間外、交点なし
LET m=conj(rm) *s(n) !反射方向 conj. stepベクトル m 復元
LET b=COMPLEX(x,im(p1)) *s(n) !延長予測点を、反射点に切詰め、b 復元
LET nb=n !反射辺の番号、履歴
END SUB
private bool numpre()
{ int i,j,k;
for (i=0;i<9;i++)
for (j=0;j<9;j++)
if (tb[i,j]==0)
{ for (k=1;k<10;k++)
{tb[i,j]=k;
if (判定（i,j)) return true;
}
tb[i,j]=0; return false;
}
return true;
}
> private bool 判定(int ix,int iy) //ナンプレ条件の判定（行と列のみ判定）
> { int i,j;int x=tb[ix,iy];
> for(i=0;i<9;i++) if (ix !=i && x==tb[i,iy]) return (false);
> for(i=0;i<9;i++) if (iy !=i && x==tb[ix,i]) return (false);
> return numpre(); // ここが再帰的になる
> }
>
>
> private bool numpre()
> { int i,j,k;
> for (i=0;i<9;i++)
> for (j=0;j<9;j++)
> if (tb[i,j]==0)
> { for (k=1;k<10;k++)
> {tb[i,j]=k;
> if (判定（i,j)) return true;
> }
> tb[i,j]=0; return false;
> }
> return true;
> }
PUBLIC NUMERIC FALSE,TRUE !システム定数
LET FALSE=0
LET TRUE=-1
DATA 0,7,0, 0,0,0, 0,0,5 !難問
DATA 0,0,6, 0,2,0, 0,0,0
DATA 0,9,0, 1,0,0, 3,0,0
DATA 0,0,0, 0,0,4, 0,0,2
DATA 0,8,0, 0,0,0, 0,1,0
DATA 5,0,0, 3,0,0, 0,0,0
DATA 0,0,4, 0,0,7, 0,6,0
DATA 0,0,0, 0,8,0, 1,0,0
DATA 2,0,0, 0,0,0, 0,9,0
PUBLIC NUMERIC tb(0 TO 8, 0 TO 8)
MAT READ tb
LET dummy=numpre(dummy)
END
EXTERNAL FUNCTION check(ix,iy) !ナンプレ条件の判定
LET x=tb(ix,iy)
FOR i=0 TO 8 !行
IF ix<>i AND x=tb(i,iy) THEN
LET check=FALSE
EXIT FUNCTION
END IF
NEXT i
FOR i=0 TO 8 !列
IF iy<>i AND x=tb(ix,i) THEN
LET check=FALSE
EXIT FUNCTION
END IF
NEXT i
LET bx=INT(ix/3)*3 !ブロック
LET by=INT(iy/3)*3
FOR i=0 TO 2
FOR J=0 TO 2
IF (ix<>bx+i OR iy<>by+J) AND x=tb(bx+i,by+J) THEN
LET check=FALSE
EXIT FUNCTION
END IF
NEXT J
NEXT i
LET check=numpre(dummy) !ここが再帰的になる
END FUNCTION
EXTERNAL FUNCTION numpre(dummy)
FOR i=0 TO 8 !9×9
FOR J=0 TO 8
IF tb(i,J)=0 THEN !未定義なら
FOR k=1 TO 9 !1から9までの数を置いてみる
LET tb(i,J)=k
IF check(i,J)<>FALSE THEN !この数でよいなら
LET numpre=TRUE
EXIT FUNCTION
END IF
NEXT k
LET tb(i,J)=0 !元に戻す
LET numpre=FALSE
EXIT FUNCTION
END IF
NEXT J
NEXT i
MAT PRINT tb; !結果を表示する
LET numpre=TRUE
END FUNCTION
DIM CARD(52)
RANDOMIZE
LET M=10000 !'試行回数
FOR K=1 TO M
FOR I=1 TO 52
LET CARD(I)=MOD(I-1,13)+1 !'トランプ52枚
NEXT I
FOR I=1 TO 52
LET J=INT(RND*52)+1
SWAP CARD(I),CARD(J) !'カードシャッフル
NEXT I
LET FL=0 !'フラグをリセット
FOR J=1 TO 52 !'上からカードを引いていく
LET S=S+CARD(J)
IF MOD(J,4)=0 THEN !'4枚目なら
IF ISPRIME(S)=1 THEN '!素数ならループを抜ける
LET FL=1 !'フラグセット
EXIT FOR
END IF
LET S=0
END IF
NEXT J
IF FL=0 THEN LET COUNT=COUNT+1 !'カウントする
NEXT K
PRINT COUNT;COUNT/M
END
EXTERNAL FUNCTION ISPRIME(X) !'素数か
FOR I=2 TO SQR(X)
IF MOD(X,I)=0 THEN
LET ISPRIME=0
EXIT FUNCTION
END IF
NEXT I
LET ISPRIME=1
END FUNCTION
DIM CARD(52),A(13),V(52)
RANDOMIZE
LET M=10000 !'試行回数
FOR K=1 TO M
FOR I=1 TO 52
LET CARD(I)=MOD(I-1,13)+1 !'トランプ52枚
NEXT I
FOR I=1 TO 52
LET J=INT(RND*52)+1
SWAP CARD(I),CARD(J) !'カードシャッフル
NEXT I
LET S=0
LET NUM=0
LET FL=0 !'フラグリセット
FOR J=1 TO 52 !'上からカードを引いていく
LET S=S+CARD(J)
LET NUM=NUM+1
IF NUM=4 THEN !'4枚引いたら
IF ISPRIME(S)=1 THEN
LET FL=1
LET V(NUM)=V(NUM)+1
EXIT FOR
END IF
END IF
IF NUM>=4 THEN !'5枚目以降を引く前に
MAT A=ZER
FOR L=J+1 TO 52
LET A(CARD(L))=A(CARD(L))+1 !'残りのカードを種類ごとにカウント
NEXT L
LET SS=0
FOR L=1 TO 13
IF ISPRIME(S+L)=1 THEN !'次に素数となる数L
LET SS=SS+A(L) !'その数Lのカードの合計枚数
END IF
NEXT L
IF J<52 AND SS/(52-J)>=.5 THEN !'50%以上なら「戦略」を発動。カードは出さない
!' PRINT "戦略";K
LET NUM=0
LET P=P+1 !'戦略発動回数
LET S=0
ELSE
IF ISPRIME(S)=1 THEN !'素数ならループを抜ける
LET FL=1 !'フラグセット
LET V(NUM)=V(NUM)+1 !'その時のカードの枚数
EXIT FOR
END IF
END IF
END IF
NEXT J
IF FL=0 THEN LET COUNT=COUNT+1 !'カウントする
NEXT K
PRINT COUNT;COUNT/M
PRINT P
FOR I=1 TO 52
IF V(I)>0 THEN PRINT I;":";V(I)
NEXT I
END
EXTERNAL FUNCTION ISPRIME(X) !'素数か
FOR I=2 TO SQR(X)
IF MOD(X,I)=0 THEN
LET ISPRIME=0
EXIT FUNCTION
END IF
NEXT I
LET ISPRIME=1
END FUNCTION
DIM CARD(52)
RANDOMIZE
FOR I=1 TO 52
LET CARD(I)=MOD(I-1,13)+1
NEXT I
FOR I=1 TO 52
LET J=INT(RND*52)+1
SWAP CARD(I),CARD(J)
NEXT I
LET S=0
FOR K=1 TO 52
FOR I=1 TO 52
IF CARD(I)<>0 AND ISPRIME(S+CARD(I))=0 THEN EXIT FOR
NEXT I
IF I>52 THEN
PRINT "探索失敗です"
STOP
END IF
LET S=S+CARD(I)
PRINT K;":";CARD(I),S
LET CARD(I)=0
NEXT K
END
EXTERNAL FUNCTION ISPRIME(X)
LET ISPRIME=0
FOR I=2 TO SQR(X)
IF MOD(X,I)=0 THEN EXIT FUNCTION
NEXT I
LET ISPRIME=1
END FUNCTION
DIM MM(12)
CALL GINIT(800,600)
MAT READ MM
DATA 31,28,31,30,31,30,31,31,30,31,30,31
'誕生年(西暦)を設定してください↓
LET BIRTHYEAR=
'誕生月を設定してください↓
LET BIRTHMONTH=
'誕生日を設定してください↓
LET BIRTHDAY=
LET T1=YMDT2JD(BIRTHYEAR,BIRTHMONTH,BIRTHDAY)
LET D$=DATE$
LET YEAR=VAL(D$(1:4))
LET MONTH=VAL(D$(5:6))
LET DAY=VAL(D$(7:8))
IF MONTH=2 AND (MOD(YEAR,100)<>0 AND MOD(YEAR,4)=0 OR MOD(YEAR,400)=0) THEN LET MM(2)=29
LET LENGTH=YMDT2JD(YEAR,MONTH,DAY)-T1
LET TT=LENGTH-DAY
LET PW=23 !'身体
LET SW=28 !'感情
LET IW=33 !'知性
LET PP=MOD(TT,PW)
LET SS=MOD(TT,SW)
LET II=MOD(TT,IW)
LET YS=300
LET XS=100
LET HH=60
LET A$="バイオリズム"
SET TEXT HEIGHT HH
SET TEXT COLOR 7
PLOT TEXT,AT 400-HH*LEN(A$)/2,100:A$
SET LINE COLOR 7
PLOT LINES:XS,YS;100+32*20,YS
PLOT LINES:XS,YS-120;XS+32*20,YS-120;XS+32*20,YS+120;XS,YS+120;XS,YS-120
SET TEXT HEIGHT 10
FOR J=1 TO MM(MONTH)
IF MOD(J,5)=0 THEN
PLOT LINES:XS+20*J,YS-10;XS+20*J,YS+10
PLOT TEXT,AT XS+20*J-5,YS-15:STR$(J)
ELSE
PLOT LINES:XS+20*J,YS-5;XS+20*J,YS+5
END IF
NEXT J
SET LINE COLOR 5
PLOT LINES:XS+20*DAY,YS+15;XS+20*DAY,YS+100
PLOT LINES:XS+20*DAY,YS+15;XS+20*DAY+5,YS+25
PLOT LINES:XS+20*DAY,YS+15;XS+20*DAY-5,YS+25
SET LINE COLOR 1
FOR J=1 TO MM(MONTH) !'身体
LET YY=YS+100*SIN(PI*(PP+J)/PW)
PLOT LINES:XS+J*20,YY;
NEXT J
SET LINE COLOR 2
PLOT LINES
FOR J=1 TO MM(MONTH) !'感情
LET YY=YS+100*SIN(PI*(SS+J)/SW)
PLOT LINES:XS+J*20,YY;
NEXT J
SET LINE COLOR 4
PLOT LINES
FOR J=1 TO MM(MONTH) !'知性
LET YY=YS+100*SIN(PI*(II+J)/IW)
PLOT LINES:XS+J*20,YY;
NEXT J
PLOT LINES
SET TEXT HEIGHT 20
SET LINE COLOR 1
PLOT LINES:XS,450;XS+100,450
PLOT TEXT,AT XS+110,460:"身体"
SET LINE COLOR 2
PLOT LINES:XS,480;XS+100,480
PLOT TEXT,AT XS+110,490:"感情"
SET LINE COLOR 4
PLOT LINES:XS,510;XS+100,510
PLOT TEXT,AT XS+110,520:"知性"
PLOT TEXT,AT 320,460:"誕生日 "&STR$(BIRTHYEAR)&"年"&STR$(BIRTHMONTH)&"月"&STR$(BIRTHDAY)&"日"
PLOT TEXT,AT 320,490:" 今日 "&STR$(YEAR)&"年"&STR$(MONTH)&"月"&STR$(DAY)&"日"
PLOT TEXT,AT 320,520:"経過日数 "&STR$(LENGTH)&"日"
PLOT TEXT,AT XS,550:"曲線と軸が交わる日が要注意日です"
END
EXTERNAL FUNCTION YMDT2JD(GYEAR, GMONTH, GDAY)
IF GMONTH < 3 THEN
LET CALC_GYEAR = GYEAR - 1
LET CALC_GMONTH = GMONTH + 12
ELSE
LET CALC_GYEAR = GYEAR
LET CALC_GMONTH = GMONTH
END IF
LET Y = INT(365.25 * CALC_GYEAR) + INT(CALC_GYEAR / 400) - INT(CALC_GYEAR / 100)
LET YMDT2JD = Y + INT(30.59 * (CALC_GMONTH - 2)) + 1721088 + GDAY
END FUNCTION
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
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
'H26-09-18 複数解あり
data 1,0,0,0,0,0,0,0,0
data 0,6,0,2,0,0,0,0,0
data 0,0,0,0,0,0,3,0,0
data 0,4,0,0,0,0,0,0,0
data 0,0,0,0,5,0,0,0,0
data 0,0,0,0,0,0,0,6,0
data 0,0,7,0,0,0,0,0,0
data 0,0,0,0,0,8,0,0,0
data 0,0,0,0,0,0,0,0,9
dim m(0 to 8,0 to 8) 'ﾎﾞｰﾄﾞ領域
dim q(0 to 8,0 to 8,0 to 8) '置数可能数字ｴﾘﾔ
mat read m '問題を読み込む
dim flag(0 to 8,0 to 8) '既置数済みｻｲﾝ
'初期設定済升目ｻｲﾝｾｯﾄ
for p=0 to 80
row=int(p/9) '行と列に換算する
col=mod(p,9)
if m(row,col)<>0 then
flag(row,col)=1
end if
next p
'置数可能な数字の設定
'初期空白ﾏｽに、置数可能数１～９を仮設定
for i=0 to 8
for j=0 to 8
for k=0 to 8
if flag(i,j)=0 then
q(i,j,k)=k+1
end if
next k
next j
next i
'置数可能数字絞り込み
'既置数済み数字を、置数可能数ｴﾘｱより削除
for p=0 to 80
i=int(p/9)
j=mod(p,9)
bi=int(i/3)*3
bj=int(j/3)*3
if flag(i,j)=1 then
wk=m(i,j) 'wk=初期設定済み升目(i,j)の数字
for iw=0 to 8 '縦行ｻｰﾁ
if flag(iw,j)=0 then 'wkと同じ数字は、置数不可なので
q(iw,j,wk-1)=0 '置数可能数字候補を削除
end if
next iw
for jw=0 to 8 '横行ｻｰﾁ
if flag(i,jw)=0 then 'wkと同じ数字は、置数不可なので
q(i,jw,wk-1)=0 '置数可能数字候補を削除
end if
next jw
'ブロック
for x=0 to 2
for y=0 to 2
if flag(bi+x,bj+y)=0 then
q(bi+x,bj+y,wk-1)=0
end if
next y
next x
end if
next p
'置数可能数左寄せ
'q(i,j,0)=1,q(i,j,3)=3,q(i,j,8)=9 となっていたら
'q(i,j,0)=1,q(i,j,1)=3,q(i,j,2)=9 の様に左詰めにする
for i=0 to 8
for j=0 to 8
if flag(i,j)=0 then
cn2=0
do while cn2<9
cn1=0
do while q(i,j,cn1)<>0
cn1=cn1+1
if cn1=9 then exit do
loop
for k=cn1+1 to 8
q(i,j,k-1)=q(i,j,k)
q(i,j,k)=0
next k
cn2=cn2+1
loop
end if
next j
next i
function checkrule(row,col,k) '既に同じ数があるかどうか確認する
checkrule=0
for y=0 to 8 '列
if m(y,col)=k then exit function '同じ数が見つかったので、ＮＧ
next y
for x=0 to 8 '行
if m(row,x)=k then exit function '同じ数が見つかったので、ＮＧ
next x
'ブロック
bx=int(col/3)*3
by=int(row/3)*3
for x=0 to 2
for y=0 to 2
if m(by+y,bx+x)=k then exit function '同じ数が見つかったので、ＮＧ
next y
next x
checkrule=1 '同じ数値は見つからないので、ＯＫ
end function
'----------------------------------------------------------------
sub draw
set line width 2
set draw mode hidden
'画面ｸﾘﾔ
line(10,10)-(700,700),1,bf
set text color 5
set text font "ＭＳ 明朝",20
'解ｶｳﾝﾀ表示
plot text, at 150,650:"解個数="
plot text, at 400,650,using "######":cnt
'ﾏｽ目ｲﾝﾃﾞｸｽ描画
for i=0 to 8
plot text, at 120+i*50,550,using "###":i
next i
for j=0 to 8
plot text, at 50,500-j*50,using "###":j
next j
'再描画
set text color 5
for p=0 to 80
row=int(p/9) '行と列に換算する
col=mod(p,9)
set text color 5-flag(col,row)*1
plot text, at 120+row*50,500-col*50,using "###":m(col,row)
next p
'升目罫線描画
for i=0 to 8
for j=0 to 8
line(100+(i+1)*50,500-j*50)-(100+(i+1)*50+50,500-(j-1)*50),5,b
next j
next i
'升目ﾌﾞﾛｯｸ境界線描画
for i=0 to 8 step 3
for j=0 to 8 step 3
line(100+(i+1)*50,500-j*50-100)-(100+(i+3)*50+50,500-(j-3)*50-100),4,b
next j
next i
set draw mode explicit
mouse poll xm,ym,left,right
if right=1 then stop
do while left=1
mouse poll xm,ym,left,right
loop
end sub
'----------------------------------------------------------------
sub backtrack(p) '位置pを調査する
local row,col,i
if p<9*9 then 'すべてが埋まるまで継続
row=int(p/9) '行と列に換算する
col=mod(p,9)
if m(row,col)<>0 then '既に数字があれば
call backtrack(p+1) '次の枡へ
else 'なけらば
for i=0 to 8 '
k=q(row,col,i) '置数可能数をｾｯﾄ
if k=0 then i=8 '0は不可なのでﾊﾟｽ
if checkrule(row,col,k)=1 then '矛盾なく置ければ
m(row,col)=k 'ここに置いてみる
call backtrack(p+1) '次の枡へ
'ここへ戻ったら置数不可なので
m(row,col)=0 '取り消す
end if
next i
'call draw '途中経過表示
end if
else 'すべて埋まったら
'mat print using "# # # # # # # # #": m '解をテキスト画面表示する
'print
cnt=cnt+1 '解ｶｳﾝﾀ＋１
call draw
'input aa$
end if
end sub
(
)
EXTERNAL FUNCTION numpre(dummy)
(
)
!１個の解の表示で終らせる
!------------------------------
MAT PRINT tb; !結果を表示する
LET numpre=TRUE !←構造的には、これを、false にするのみ
END FUNCTION !↓見やすくするだけの意味。
!------------------------------
! 複数個の解を全て表示
!------------------------------
LET cnt=cnt+1 !メイン側に、PUBLIC NUMERIC cnt を追加しないと、
PRINT cnt !外部関数内の変数は、原則 localで、cnt 累計不能
MAT PRINT tb; !結果を表示する
PRINT "次の探索中";
!
LET numpre=FALSE !完成しなかった事にして、再サーチさせる
END FUNCTION
!------------------------------
!------------------------------
「lark12_long 氏 投稿から引用」このサンプルは、短時間で７０個、テストに好適
!例題２ 複数解あり
DATA 2,8,4,0,0,0,0,7,9
DATA 1,0,0,0,4,8,5,0,6
DATA 0,9,0,0,0,2,0,0,1
DATA 0,4,8,0,0,0,0,0,0
DATA 0,2,0,0,0,0,0,3,0
DATA 0,0,0,0,0,0,1,0,0
DATA 0,0,0,3,0,0,0,9,0
DATA 0,0,7,6,8,0,0,0,4
DATA 0,5,0,0,0,0,6,1,3
OPTION ARITHMETIC RATIONAL !多桁の整数
PUBLIC NUMERIC C !最大値
DIM A(50) !並び
FOR N=1 TO 50 !第n項まで ※25以上は困難
LET C=9999999999999999
CALL try(1,0,N,A)
PRINT N; C
NEXT N
END
EXTERNAL SUB try(K,S,N,A()) !バックトラック法で検証する
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR B=-1 TO 1 STEP 2 !Σ±k^m
LET SS=S+B*K^2 !※2乗
LET A(K)=B
IF K=N THEN !第n項なら
!!!MAT PRINT A;
IF SS>=0 AND SS<C THEN LET C=SS !最大値を記録する
ELSE
CALL try(K+1,SS,N,A) !次へ
END IF
NEXT B
END SUB
OPTION ARITHMETIC RATIONAL !多桁の整数
LET N=30 !=2014 mod 32
LET M=4 !4 !※4乗
PUBLIC NUMERIC F(3000) !f(x)=x^m
LET S=0 !Σk^m
FOR K=1 TO N
LET T=K^M
LET F(K)=T
LET S=S+T
NEXT K
LET S2=INT(S/2)
PRINT S; S2
PUBLIC NUMERIC C !場合の数
LET C=0
DIM A(N) !演算子の並び
MAT A=ZER
CALL try(2,S2,N,M,A) !※対称性 +1^m±2^m±3^m …
PRINT C; "通り"
END
EXTERNAL SUB try(P,S,N,M,A()) !バックトラック法で検証する
OPTION ARITHMETIC RATIONAL !多桁の整数
FOR K=P TO N !k^m の組み合わせ
LET SS=S-F(K) !f(k)=k^m
IF SS<0 THEN EXIT FOR !これ以降は可能性なし
LET A(K)=1
IF SS=0 THEN !結果を表示する
LET C=C+1
!!MAT PRINT A;
PRINT "PRINT "; !BASIC言語の式を表示する
FOR i=1 TO N
IF A(i)=0 THEN PRINT "+"; ELSE PRINT "-"; !演算子
PRINT STR$(i);"^";STR$(M); !項
IF i<N AND MOD(i,20)=0 THEN !行を分割する
PRINT " &" !行末
PRINT "& "; !継続行
END IF
NEXT i
PRINT
PRINT
ELSE
CALL try(K+1,SS,N,M,A) !次へ
END IF
LET A(K)=0
NEXT K
END SUB
DATA 0,1,1,1,1,1,1,1,1,1 !30=2014 mod 32
DATA 0,1,0,1,1,1,0,0,1,0
DATA 0,0,0,1,0,1,0,0,1,1
10 DATA 0,1,1,0, 1,0,0,1, 1,0,0,1, 0,1,1,0 !+32 thue-morse sequence
DATA 1,0,0,1, 0,1,1,0, 0,1,1,0, 1,0,0,1
PRINT "PRINT "; !BASIC言語の式（PRINT文）を表示する
FOR K=1 TO 30
READ A
IF A=0 THEN PRINT "+"; ELSE PRINT "-";
PRINT USING "####": K;
PRINT "^4";
IF K<30 AND MOD(K,10)=0 THEN
PRINT " &"
PRINT "& ";
END IF
NEXT K
PRINT " &"
PRINT "& &"
PRINT "& ";
FOR J=0 TO 62-1 !=[2014/32]
RESTORE 10
FOR i=1 TO 32
READ A
LET K=J*32+i+30
IF A=0 THEN PRINT "+"; ELSE PRINT "-";
PRINT USING "####": K;
PRINT "^4";
IF K<2014 AND MOD(i,16)=0 THEN
PRINT " &"
PRINT "& ";
END IF
NEXT i
PRINT " &"
PRINT "& ";
NEXT J
PRINT
PRINT "END"
DIM B(0 TO 2^(M+1)-1) !2^(m+1) thue-morse sequence
LET B(0)=0
FOR K=0 TO M
LET T=2^K
FOR J=0 TO T-1 !前半分を反転させる
LET B(J+T)=1-B(J)
NEXT J
NEXT K
MAT PRINT B;
DIM A(0 TO M) !m次の多項式
MAT A=ZER
FOR P=1 TO 2^(M+1)
PRINT "(";STR$(P);"+x)";
IF M>1 THEN PRINT "^";STR$(M);
PRINT " =";
FOR K=M TO 0 STEP -1 !(x+p)^mの展開
LET C=COMB(M,K)*P^K !x^(m-k)の係数
PRINT C;
IF B(P-1)=0 THEN LET A(K)=A(K)+C ELSE LET A(K)=A(K)-C !和
NEXT K
PRINT
DIM B(0 TO 2^(M+1)-1) !2^(m+1) thue-morse sequence
LET B(0)=0
FOR K=0 TO M
LET T=2^K
FOR J=0 TO T-1 !前半分を反転させる
LET B(J+T)=1-B(J)
NEXT J
NEXT K
FOR i=0 TO 2^(M+1)-1
PRINT USING "###":i;
NEXT i
MAT PRINT USING " # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #":B
DIM B(0 TO 2^(M+1)-1)
LET B(0)=0
FOR K=0 TO M
LET T=2^K
FOR J=1 TO 2*(T-1)+1
LET B(J)=BITXOR(J-1,2*(J-1)) !排他的論理和
NEXT J
NEXT K
FOR i=0 TO 2^(M+1)-1
PRINT USING "####":i;
NEXT i
MAT PRINT USING " ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ## ##":B
LET M=4 !m種類
DATA 4,3,2,1 !個数
LET N=4 !n人
DIM B(4)
MAT READ B
PRINT F0(M,B,N); "通り"
PRINT F1(M,B,N); "通り"
END
EXTERNAL FUNCTION H(N,R) !重複組合せ H(n,r)=C(n+r-1,r)
LET H=COMB(N+R-1,R)
END FUNCTION
EXTERNAL FUNCTION F0(M,B(),N) !条件1
LET S=1 !Π[k=1,m]H(n,b[k])
FOR K=1 TO M
LET S=S*H(N,B(K))
NEXT K
LET F0=S
END FUNCTION
EXTERNAL FUNCTION F1(M,B(),N) !条件2
LET S=0 !特定のk人に全部配る Σ[k=1,n-1]C(n,k)F1(k)
FOR K=1 TO N-1
LET S=S+COMB(N,K)*F1(M,B,K)
NEXT K
LET F1=F0(M,B,N)-S
END FUNCTION
別解
aをAに配った個数をaA個と表すとする。
次の連立方程式を解く。
条件2のとき、
a b c d
A: aA bA cA dA ≧1 ←行の和
B: aB bB cB dB ≧1
C: aC bC cC dC ≧1
D: aD bD cD dD ≧1
=4 =3 =2 =1
↑列の和
配る個数は、a,b,c,dの順に分割数を利用して決めていく。
（終わり）
LET M=4 !m種類
DATA 4,3,2,1 !個数
LET N=4 !n人
DIM B(4)
MAT READ B
DIM A(N,M) !並び
PUBLIC NUMERIC C !場合の数
LET C=0
CALL try(1,1, B(1), M,B, N, A)
PRINT C;"通り"
END
EXTERNAL SUB try(x,y,S, M,B(),N, A(,)) !バックトラック法で検索する
IF x=N THEN !最後の人のとき
LET A(x,y)=S !残り全部
IF y=M THEN !最後のもののとき
DIM w(M),Aw(N) !0個の人があるかどうか確認する ※条件2
MAT w=CON !条件1の場合、不要（削除する）
MAT Aw=A*w !行の和
FOR i=1 TO N
IF Aw(i)=0 THEN EXIT FOR
NEXT i
IF i>N THEN !いないなら
LET C=C+1 !結果を表示する
!!MAT PRINT A;
END IF
ELSE
CALL try(1,y+1,B(y+1), M,B,N, A) !次のものへ
END IF
ELSE
FOR i=S TO 0 STEP -1 !x番目の人にy番目のものをi個配る
LET A(x,y)=i
CALL try(x+1,y,S-i, M,B,N, A) !次の人へ
NEXT i
END IF
END SUB
PUBLIC NUMERIC C !場合の数
LET C=0
CALL try(2,R,K,A)
PRINT C; "通り"
END
EXTERNAL SUB try(P,R,K,A())
FOR i=1 TO R
LET D=1 !間隔（公差）
DO
LET T=P
FOR J=1 TO K-1 !等間隔に3つ並ぶ（等差数列）かどうか確認する
LET T=T-D
IF T<1 THEN EXIT DO !これ以降は可能性なし
IF A(T)<>i THEN EXIT FOR
NEXT J
IF J>K-1 THEN EXIT DO !NGの場合
LET D=D+1 !次へ
LOOP
IF J<K THEN !題意を満たすなら
LET A(P)=i
IF P=UBOUND(A) THEN !すべて埋まったなら
LET C=C+1 !結果を表示する
MAT PRINT A;
FOR x=1 TO R !集合ごとに
PRINT " {";
LET FLG=0 !継続フラグ
FOR y=1 TO UBOUND(A)
IF A(y)=x THEN
IF FLG=1 THEN PRINT ","; !最初ならカンマはつけない
PRINT STR$(y);
LET FLG=1
END IF
NEXT y
PRINT "}";
NEXT x
PRINT
ELSE
CALL try(P+1,R,K,A) !次へ
END IF
END IF
NEXT i
END SUB
DIM MX(3),MY(3),NX(3),NY(3)
RANDOMIZE
LET XSIZE=900
LET YSIZE=700
LET SIZE=700
LET TI=1 !'表示時間
CALL GINIT(XSIZE,YSIZE)
SET TEXT HEIGHT 25
SET TEXT JUSTIFY "LEFT" , "TOP"
SET TEXT COLOR 7
LET N=8 !'マスの数 N*N
DIM X(N,N),Y(N,N)
LET RR=SIZE/N/2
LET R=RR/1.5 !'丸の大きさ R=RR～RR/3
FOR I=1 TO N
FOR J=1 TO N
LET X(J,I)=RR+(J-1)*SIZE/N
LET Y(J,I)=RR+(I-1)*SIZE/N
NEXT J
NEXT I
FOR I=0 TO SIZE STEP SIZE/N
CALL LINE(I,0,I,SIZE,7)
CALL LINE(0,I,SIZE,I,7)
NEXT I
LET TY=TIME
PLOT TEXT ,AT 740,300:"残り時間"
DO
CALL BOXFULL(740,330,XSIZE,360,0)
SET TEXT COLOR 7
PLOT TEXT ,AT 740,330:" "&STR$(INT(120-TIME+TY))
LET Z=RND
LET NN=1
IF Z<.4 THEN LET NN=2
IF Z<.1 THEN LET NN=3
FOR K=1 TO NN !'丸の数
LET S=INT(RND*N)+1
LET T=INT(RND*N)+1
LET MX(K)=X(S,T)
LET MY(K)=Y(S,T)
CALL CIRCLEFULL(MX(K),MY(K),R,4)
NEXT K
MAT NX=MX
MAT NY=MY
LET TT=TIME
LET L=0
DO
FOR K=1 TO NN
MOUSE POLL XX,YY,LEFT,RIGHT
IF TIME-TT>TI THEN !'時間オーバーならミス
LET MISS=MISS+NN-L
CALL BOXFULL(740,150,XSIZE,180,0)
SET TEXT COLOR 7
PLOT TEXT ,AT 740,120:" MISS"
PLOT TEXT ,AT 740,150:" "&STR$(MISS)
EXIT DO
END IF
IF SQR((MX(K)-XX)^2+(MY(K)-YY)^2)<R AND LEFT=1 THEN !'時間内に丸を左クリック
CALL CIRCLEFULL(MX(K),MY(K),R,2)
BEEP
LET SC=SC+1
LET L=L+1
LET MX(K)=0
LET MY(K)=0
CALL BOXFULL(740,70,XSIZE,100,0)
SET TEXT COLOR 7
PLOT TEXT ,AT 740,40:"SUCCESS"
PLOT TEXT ,AT 740,70:" "&STR$(SC)
WAIT DELAY .1
IF L=NN THEN EXIT DO
END IF
NEXT K
LOOP
FOR K=1 TO NN
CALL CIRCLEFULL(NX(K),NY(K),R,0)
NEXT K
LET TT=RND*2+TIME
DO
LOOP UNTIL TT-TIME<=0 !'適当な待ち時間
LOOP WHILE TIME-TY<=120 !'プレイ時間 120秒
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
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET AREA COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
DATA 31,30,31,30,31,31,30,31,30,31 !3月,4月,5月,…
!!DATA 31,28,31,30,31,30,31,31,30,31,30,31 !平年
!!DATA 31,29,31,30,31,30,31,31,30,31,30,31 !うるう年
LET S=0
FOR M=3 TO 12 !各月
!!FOR M=1 TO 12 !各月
READ A !日数を得る
FOR i=1 TO MOD(S,7) !開始位置を前の月に合わせる
PRINT " ";
NEXT i
FOR D=1 TO A !日にちを記入する
PRINT USING "###": D;
IF MOD(S+D,7)=0 THEN
IF D<=7 THEN PRINT USING " ##月": M ELSE PRINT !週単位
END IF
NEXT D
PRINT
LET S=S+A
NEXT M
!!PRINT S !検算
END
!ナンバープレース探索プログラムを、速くする。
!
!再帰なし、再帰あり１，２，３の、４タイプを、まとめた。
!処理は、分岐無しで直線状に行き来しており、再帰なしの Normal の方が？
!-------------------------------------------------------------------
DEBUG ON
OPTION ARITHMETIC NATIVE
DECLARE FUNCTION numplace, numpla1, numpla2, numpla3, OUTPUT_, checkout$
LET crlf$= CHR$(13)& CHR$(10)
OPTION BASE 0
DIM tb(8,8), copy(8,8) !問題を置く配列
DIM i0(80),j0(80) !１）
DIM u3(80,3),v3(80,3) !２）
DIM q(80,9) !３）
DIM qp(80) !Normal型 専用。q() の各消費量( 初期値 0)
!--------------
! 実行前の準備
!--------------
SUB pre_ready
!------------------------------------------------
!１）空白の座標だけを、高速に調査できるように、
! 連続 番号で、座標を並べた i0(s),j0(s) 作成
!------------------------------------------------
LET s9=-1
FOR i=0 TO 8
FOR j=0 TO 8
IF tb(i,j)=0 THEN
LET s9=s9+1
LET i0(s9)=i
LET j0(s9)=j
END IF
NEXT j
NEXT i
!------------------------------------------------------
!２）空白の座標の全てについて、
! 各々、所属する３ｘ３枠で、その縦横列５個所を除く、
! 他４箇所の 座標を並べた u3(s,0~3),v3(s,0~3) 作成
!------------------------------------------------------
FOR s=0 TO s9
LET i=i0(s)
LET j=j0(s)
LET p=0
FOR u=INT(i/3)*3 TO INT(i/3)*3 +2
FOR v=INT(j/3)*3 TO INT(j/3)*3 +2
IF u<>i AND v<>j THEN
LET u3(s,p)=u
LET v3(s,p)=v
LET p=p+1
END IF
NEXT v
NEXT u
NEXT s
!---------------------------------------------
!３）空白の座標の全てについて、
! 初期値の有る個所から 受ける制限で、
! 取り得る数を、予め格納する q(s,0~9) 作成
!---------------------------------------------
FOR s=0 TO s9
LET p=0
FOR k=1 TO 9
!------------ 縦横列チェック
FOR w=0 TO 8
IF k=tb(w,j0(s)) OR k=tb(i0(s),w) THEN EXIT FOR !false
NEXT w
IF 8< w THEN
!------------ 3x3 枠の残り４箇所チェック
IF k=tb(u3(s,0),v3(s,0)) OR k=tb(u3(s,1),v3(s,1)) THEN !false
ELSEIF k=tb(u3(s,2),v3(s,2)) OR k=tb(u3(s,3),v3(s,3)) THEN !false
ELSE !OK.
LET q(s,p)=k
LET p=p+1
END IF
END IF
NEXT k
LET q(s,p)=0 !終端マーク
NEXT s
END SUB
!----------------------------------------------
! メイン プログラム
!----------------------------------------------
MAT READ tb
! MAT tb=TRN(tb) !転置( 長時間かかる問題が、転置すると一瞬で終る事もある)
CALL pre_ready !準備
PRINT "問題"
MAT PRINT tb; !問題表示
MAT copy=tb
!
LET z$="0132" !実行する型だけを、任意な順と個数 並べる
!
FOR sel=1 TO LEN(z$)
MAT tb=copy
LET cnt=0
SELECT CASE z$(sel:sel)
CASE "0"
LET T$="Normal型" !再帰を使わない。１番の最高速
LET t0=TIME
LET res= numplace
LET t1=TIME-t0
CASE "1"
LET T$="再帰１型" !単一文の再帰型。２番速
LET t0=TIME
LET res= numpla1(0)
LET t1=TIME-t0
CASE "2"
LET T$="再帰２型" !２つの文にまたがる再帰型。最も遅い４番速
LET t0=TIME
LET res= numpla2(0)
LET t1=TIME-t0
CASE "3"
LET T$="再帰３型" !再帰２型の速度向上型。３番速
LET t0=TIME
LET res= numpla3(0)
LET t1=TIME-t0
END SELECT
IF res=0 THEN PRINT "false after (";cnt;"通り)"
PRINT USING T$& " 実行時間#####.### sec":MOD( t1,86400)
PRINT
NEXT sel
PRINT "終了"
!単一解。又は、複数解の全表示。
!---------------
FUNCTION OUTPUT_
LET cnt=cnt+1
PRINT "(";cnt;")";checkout$(tb) !正誤の確認 再検査( NG.なら、戻らず停止)
MAT PRINT tb;
LET OUTPUT_=1 !●( 引数=1：１解で終了。引数=0：複数解 )
END FUNCTION
!複数解の場合で 高速に その個数を調べる時
!----------------
!FUNCTION OUTPUT_
! LET cnt=cnt+1
! IF MOD(cnt,1000)=0 THEN PRINT "(";cnt;")"
! LET OUTPUT_=0 !●( 引数=1：１解で終了。引数=0：複数解 )
!END FUNCTION
!----------------------------------------------
! 問題を解く本体( 再帰無し Normal型 )
!----------------------------------------------
FUNCTION numplace
MAT qp=ZER
FOR s=0 TO s9
LET i=i0(s)
LET j=j0(s)
FOR p=qp(s) TO 9 ! s ごとの候補 q() のポインター p
LET k=q(s,p) !候補の数字 k
IF k=0 THEN EXIT FOR !NG. k の使い切り
!------------ 縦横列チェック
FOR w=0 TO 8
IF k=tb(w,j) OR k=tb(i,w) THEN EXIT FOR !next k
NEXT w
IF 8< w THEN
!------------ 3x3 枠の残り４箇所チェック
IF k=tb(u3(s,0),v3(s,0)) OR k=tb(u3(s,1),v3(s,1)) THEN !next k
ELSEIF k=tb(u3(s,2),v3(s,2)) OR k=tb(u3(s,3),v3(s,3)) THEN !next k
ELSE
LET tb(i,j)=k
IF s=s9 THEN LET k=OUTPUT_ !●１つ完成
LET qp(s)=p+1 !次の開始 p 記憶( 再帰では同位置に戻り
EXIT FOR !next p を通るので qp()自体、不要)
END IF !next k
END IF !next k
NEXT p
IF k=0 THEN
!------------ NG. k の使い切り
LET tb(i,j)=0
LET qp(s)=0
LET s=s-2 !1つ手前の s で、やり直し
IF s< -1 THEN EXIT FOR !探索限界で、終了
END IF
NEXT s
LET numplace=k
END FUNCTION
!----------------------------------------------
! 問題を解く本体( 再帰型１)
!----------------------------------------------
FUNCTION numpla1(s)
IF s9< s THEN
LET numpla1=OUTPUT_ !●１つ完成
ELSE
local i,j,p
LET numpla1=1 !preset true
LET i=i0(s)
LET j=j0(s)
FOR p=0 TO 8
LET k=q(s,p)
IF k=0 THEN EXIT FOR
!------------ 縦横列チェック
FOR w=0 TO 8
IF k=tb(w,j) OR k=tb(i,w) THEN EXIT FOR ! next k
NEXT w
IF 8< w THEN
!------------ 3x3 枠の残り４箇所チェック
IF k=tb(u3(s,0),v3(s,0)) OR k=tb(u3(s,1),v3(s,1)) THEN !next k
ELSEIF k=tb(u3(s,2),v3(s,2)) OR k=tb(u3(s,3),v3(s,3)) THEN !next k
ELSE
LET tb(i,j)=k
IF 0< numpla1(s+1) THEN EXIT FUNCTION
END IF
END IF
NEXT p
!------------ NG. k の使い切り
LET tb(i,j)=0
LET numpla1=0
END IF
END FUNCTION
!----------------------------------------------
! 問題を解く本体( 再帰型２)
!----------------------------------------------
FUNCTION numpla2(s)
IF s9< s THEN
LET numpla2=OUTPUT_ !●１つ完成
ELSE
local p
LET numpla2=1 !preset true
FOR p=0 TO 8
LET k=q(s,p)
IF k=0 THEN EXIT FOR
IF 0< test(s,k) THEN EXIT FUNCTION
NEXT p
!------------ NG. k の使い切り
LET tb(i0(s),j0(s))=0
LET numpla2=0
END IF
END FUNCTION
FUNCTION test(s,k)
LET test=0
LET i=i0(s)
LET j=j0(s)
!------------ 縦横列チェック
FOR w=0 TO 8
IF k=tb(w,j) OR k=tb(i,w) THEN EXIT FUNCTION ! next k
NEXT w
!------------ 3x3 枠の残り４箇所チェック
IF k=tb(u3(s,0),v3(s,0)) OR k=tb(u3(s,1),v3(s,1)) THEN EXIT FUNCTION ! next k
IF k=tb(u3(s,2),v3(s,2)) OR k=tb(u3(s,3),v3(s,3)) THEN EXIT FUNCTION ! next k
!------------
LET tb(i,j)=k
LET test=numpla2(s+1)
END FUNCTION
!----------------------------------------------
! 問題を解く本体( 再帰型３) 再帰２の速度向上
!----------------------------------------------
FUNCTION numpla3(s)
IF s9< s THEN
LET numpla3=OUTPUT_ !●１つ完成
ELSE
LET numpla3=1
IF 0< test3(s) THEN EXIT FUNCTION
!------------ NG. k の使い切り
LET tb(i0(s),j0(s))=0
LET numpla3=0
END IF
END FUNCTION
FUNCTION test3(s)
local p
LET test3=0 !preset false
FOR p=0 TO 8
LET k=q(s,p)
IF k=0 THEN EXIT FUNCTION !NG.
LET i=i0(s)
LET j=j0(s)
!------------ 縦横列チェック
FOR w=0 TO 8
IF k=tb(w,j) OR k=tb(i,w) THEN EXIT FOR ! next k
NEXT w
IF 8< w THEN
!------------ 3x3 枠の残り４箇所チェック
IF k=tb(u3(s,0),v3(s,0)) OR k=tb(u3(s,1),v3(s,1)) THEN ! next k
ELSEIF k=tb(u3(s,2),v3(s,2)) OR k=tb(u3(s,3),v3(s,3)) THEN ! next k
!------------
ELSE
LET tb(i,j)=k
LET test3=numpla3(s+1)
END IF
END IF
NEXT p
END FUNCTION
!----------------------------------------------
! tb(,) の解が 規則通りに並んでいるかを 検査
!----------------------------------------------
FUNCTION checkout$(tb(,))
local i,j
LET w$=""
FOR k=1 TO 9
FOR z=0 TO 8 STEP 3
LET i1=0
LET i2=0
LET i3=0
FOR w=z TO z+2
!------------ 横列チェック
FOR j=8 TO 0 STEP -1
IF k=tb(w,j) THEN EXIT FOR !ok
NEXT j
IF j< 0 THEN LET w$=w$& crlf$& STR$(w+1)& "行目、横方向に "& STR$(k)& " 無し"
!------------ 縦列チェック
FOR i=8 TO 0 STEP -1
IF k=tb(i,w) THEN EXIT FOR !ok
NEXT i
IF i< 0 THEN LET w$=w$& crlf$& STR$(w+1)& "列目、縦方向に "& STR$(k)& " 無し"
!------------ 3x3 チェック
IF 6<=i THEN
LET i3=1
ELSEIF 3<=i THEN
LET i2=1
ELSEIF 0<=i THEN
LET i1=1
END IF
NEXT w
IF i1=0 THEN LET w$=w$& crlf$& "(1行,"& STR$(z+1)& "列)┏ から右下3x3に "& STR$(k)& " 無し"
IF i2=0 THEN LET w$=w$& crlf$& "(4行,"& STR$(z+1)& "列)┏ から右下3x3に "& STR$(k)& " 無し"
IF i3=0 THEN LET w$=w$& crlf$& "(7行,"& STR$(z+1)& "列)┏ から右下3x3に "& STR$(k)& " 無し"
NEXT z
NEXT k
IF w$="" THEN
LET checkout$="OK"
ELSE
PRINT w$
MAT PRINT tb;
PRINT T$;" (";cnt;")";"でエラー、以降の中止"
STOP
END IF
END FUNCTION
! http://www.sudoku.name/index-jp.php
!( #5300 )上級＋＋ ※1 通りの解を持つ
DATA 3,0,0,0,0,2,0,0,0
DATA 0,0,6,0,0,0,0,9,0
DATA 0,0,9,0,0,4,0,0,3
DATA 0,9,0,0,0,0,0,0,5
DATA 0,5,0,8,0,0,0,6,0
DATA 8,0,0,0,3,0,0,1,0
DATA 2,0,0,9,0,0,3,0,0
DATA 0,6,0,0,0,0,4,0,0
DATA 0,0,0,1,0,0,0,0,7
! http://www.sudoku.name/index-jp.php
!( #5425 )上級＋＋ ※(7行,2列)を、1→0 に改変、21 通りの解を持つ
DATA 0,8,0, 0,0,0, 4,0,0
DATA 6,0,0, 2,0,0, 0,0,0
DATA 0,9,0, 4,0,0, 0,2,0
DATA 9,0,0, 0,0,6, 1,0,0
DATA 0,0,2, 9,0,0, 5,0,0
DATA 0,0,3, 0,0,0, 0,0,6
DATA 0,0,0, 0,0,4, 0,3,0
DATA 0,0,0, 0,0,7, 0,0,5
DATA 0,0,5, 0,0,0, 0,7,0
１）DIM q(80,8) → DIM q(80,9)
２）q(s,0~9) 作成 に、LET q(s,p)=0 !終端マーク ← 追加。
３）FUNCTION numplace の冒頭に、MAT qp=ZER ← 追加。
４）FUNCTION numplace 前半、FOR p=qp(s) TO 8 → FOR p=qp(s) TO 9
５）FUNCTION numplace 後半、IF k=0 OR 8< p THEN → IF k=0 THEN
!C曲線と2進法
LET N=7 !n次
SET WINDOW -15,10,-20,5
!!DRAW grid
LET X=0 !開始位置を原点とする
LET Y=0
PLOT LINES: X,Y;
FOR i=0 TO 2^N-1
LET T=i
LET S=0 !1の個数 mod 4
DO WHILE T>0
LET S=MOD(S+MOD(T,2),4)
LET T=INT(T/2)
LOOP
PRINT S
SELECT CASE S !各方向へ移動する
CASE 0 !左
LET X=X-1
CASE 1 !上
LET Y=Y+1
CASE 2 !右
LET X=X+1
CASE 3 !下
LET Y=Y-1
CASE ELSE
END SELECT
PLOT LINES: X,Y;
NEXT i
END
!ドラゴン曲線と2進法
LET N=8 !n次
SET WINDOW -20,10,-15,15
!!DRAW grid
LET X=0 !開始位置を原点とする
LET Y=0
PLOT LINES: X,Y;
FOR i=0 TO 2^N-1
LET T=i
LET S=0 !桁数 mod 4
LET W0=-1
DO WHILE T>0
LET W=MOD(T,2)
IF W<>W0 THEN !ただし、同じ数字が連続する場合、まとめて1桁と数える
LET S=MOD(S+1,4)
LET W0=W
END IF
LET T=INT(T/2)
LOOP
PRINT S
SELECT CASE S !各方向へ移動する
CASE 0 !左
LET X=X-1
CASE 1 !上
LET Y=Y+1
CASE 2 !右
LET X=X+1
CASE 3 !下
LET Y=Y-1
CASE ELSE
END SELECT
PLOT LINES: X,Y;
NEXT i
END
CALL GINIT(640,400)
OPTION BASE 0
LET L=300
INPUT PROMPT "LEVEL=":NO
LET Y0=100
LET X0=400
LET R=45*NO
LET N=NO+1
DIM NN(N+1),LL(N+1)
DO
LET R=R+45
DO WHILE N>0
LET NN(SP)=N
LET LL(SP)=L
LET SP=SP+1
LET N=N-1
LET L=L/SQR(2)
LET R=R-90
LOOP
LET SP=SP-1
LET N=NN(SP)
LET L=LL(SP)
IF N=1 THEN
IF R>=360 THEN LET R=MOD(R+360,360)
LET X=X0+COS(R*PI/180)*L
LET Y=Y0-SIN(R*PI/180)*L
CALL LINE(X0,Y0,X,Y,7)
LET X0=X
LET Y0=Y
END IF
LET N=N-1
LET R=R+45
LET L=L/SQR(2)
LOOP WHILE SP>0
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
!C曲線と2進法
OPTION ARITHMETIC COMPLEX !複素平面
LET N=7 !n次
SET WINDOW -10,15,-20,5
!!DRAW grid
LET Z=0 !開始位置を原点とする
PLOT LINES: Z;
FOR i=0 TO 2^N-1
LET T=i
LET S=0 !1の個数
DO WHILE T>0
LET S=S+MOD(T,2)
LET T=INT(T/2)
LOOP
PRINT i; S; BSTR$(i,2)
LET Z=Z+EXP(COMPLEX(0,1)*2*PI*S/4) !各方向へ移動する
PLOT LINES: Z;
NEXT i
END
ドラゴン曲線
!ドラゴン曲線と2進法
OPTION ARITHMETIC COMPLEX !複素平面
LET N=8 !n次
SET WINDOW -10,20,-15,15
!!DRAW grid
LET Z=0 !開始位置を原点とする
PLOT LINES: Z;
FOR i=0 TO 2^N-1
LET T=i
LET S=0 !桁数
LET W0=-1 !1つ前の数字
DO WHILE T>0
LET W=MOD(T,2)
IF W<>W0 THEN !ただし、同じ数字が連続する場合、まとめて1桁と数える
LET S=S+1
LET W0=W
END IF
LET T=INT(T/2)
LOOP
PRINT i; S; BSTR$(i,2)
LET Z=Z+EXP(COMPLEX(0,1)*2*PI*S/4) !各方向へ移動する
PLOT LINES: Z;
NEXT i
END
その２
!ドラゴン曲線と2進法
OPTION ARITHMETIC COMPLEX !複素平面
LET N=8 !n次
SET WINDOW -10,20,-15,15
!!DRAW grid
LET Z=0 !開始位置を原点とする
PLOT LINES: Z;
FOR i=0 TO 2^N-1
LET T=i
IF T>0 THEN
DO WHILE MOD(T,2)=0 !2で割り切れる間は割っていく
LET T=T/2
LOOP
IF MOD(T,4)=1 THEN LET S=S+1 ELSE LET S=S-1
ELSE
LET S=0 !桁数 ※0から連続処理する場合
END IF
PRINT i; S; BSTR$(i,2)
LET Z=Z+EXP(COMPLEX(0,1)*2*PI*S/4) !各方向へ移動する
PLOT LINES: Z;
NEXT i
END
その３ k番目の折り目に着目する
!ドラゴン曲線と2進法
OPTION ARITHMETIC COMPLEX !複素平面
LET N=8 !n次
SET WINDOW -10,20,-15,15
!!DRAW grid
LET Z=0 !開始位置を原点とする
PLOT LINES: Z;
LET S=0
FOR K=1 TO 2^N
LET Z=Z+EXP(COMPLEX(0,1)*2*PI*S/4) !各方向へ移動する
PLOT LINES: Z;
LET P=BITAND(K,-K) !k番目の折り目 1:山折り、0:谷折り
LET T=BITAND(P,BITNOT(INT(K/2)))/P !※32bit整数の範囲
IF T=1 THEN LET S=S+1 ELSE LET S=S-1
PRINT K; T; S; BSTR$(K,2)
NEXT K
END
LET N=3 !n次
DIM a(0 TO N) !係数 a[n]*x^n+a[n-1]*x^(n-1)+ … + a[1]*x+a[0]
DATA 1,-3,0,1 !1-3x+x^3
MAT READ a
LET w0=a(N) !x^n+a[n-1]/a[n]*x^(n-1)+ … + a[1]/a[n]*x+a[0]/a[n]の形へ
FOR i=0 TO N
LET a(i)=a(i)/w0
NEXT i
DIM x(N) !n個の根
LET r=1 !初期値を仮定する
FOR i=1 TO N
LET r0=ABS(N*a(i))^(1/i)
IF r<r0 THEN LET r=r0
NEXT i
FOR i=1 TO N !半径rの円に等間隔に配置する
LET x(i)=-a(N-1)/N+r*EXP(2*PI/N*(i-3/4)*COMPLEX(0,1)) !アーバスの初期値
NEXT i
DO
LET e=0
FOR i=1 TO N
LET f=1 ! !分子 f(zi) ※a(n)=1
FOR j=N-1 TO 0 STEP -1 !ホーナー法 f(z)=( … ((z+a[n-1])*z+a[n-2])*z+a[n-3])* … +a[1])*z+a[0]
LET f=f*x(i)+a(j)
NEXT j
LET p=1 !分母 Π[j=1,N,i≠j](zi-zj)
FOR j=1 TO N
IF j<>i THEN LET p=p*(x(i)-x(j)) !p*(zi-zj)
NEXT j
IF ABS(p)=0 THEN !分子÷分母
PRINT "０では割れません。"
STOP
END IF
LET t=f/p
LET norm=ABS(t)
IF e<norm THEN LET e=norm !最大値
LET x(i)=x(i)-t !k回目の近似根 zi[k+1]=zi[k]-f(zi[k])/Π[j=1,N,i≠j](zi[k]-zj[k])
NEXT i
LET N=3
DIM x(0 TO N-1) !n個の解
LET x(0)=2*COS(2*PI/9) !α[0]
LET x(1)=2*COS(4*PI/9) !α[1]
LET x(2)=2*COS(8*PI/9) !α[2]
DIM A(N,N),b(N)
FOR i=0 TO N-1 !解の巡回 g(α)=A+Bα+ … +Cα^(n-1)
FOR J=0 TO N-1 !g(α[0])、g(α[1])、…
LET A(i+1,J+1)=x(i)^J
NEXT J
LET b(i+1)=x(MOD(i+1,N)) !g(α[0])=α[1]、g(α[1])=α[2]、…
NEXT i
DIM y(N),iA(N,N) !連立方程式Ay=bを解く
MAT iA=INV(A)
MAT y=iA*b
MAT PRINT y; !A,B,…,C
END
EXTERNAL FUNCTION pow(x,y) !べき乗 x^y
OPTION ARITHMETIC COMPLEX !複素数
LET pow=EXP(y*LOG(x)) !x^y
END FUNCTION
EXTERNAL SUB Solve2EQU(A,B, x1,x2) !2次方程式 x^2+Ax+B=0を解く
OPTION ARITHMETIC COMPLEX !複素数
LET L1=-A !α+β
LET L2=SQR(A^2-4*B) !α-β
LET x1=(L1+L2)/2
LET x2=(L1-L2)/2
END SUB
EXTERNAL SUB Solve3EQU(A,B,C, x1,x2,x3) !3次方程式 x^3+Ax^2+Bx+C=0を解く
OPTION ARITHMETIC COMPLEX !複素数
LET w=EXP(COMPLEX(0,1)*2*PI/3) !w ※1の原始3乗根
CALL Solve2EQU(2*A^3-9*A*B+27*C,(A^2-3*B)^3, t1,t2) !t^2+Pt+Q=0の2つの解
LET L1=-A !α+β+γ
LET L2=pow(t1,1/3) !α+ωβ+ω^2γ
LET L3=pow(t2,1/3) !α+ω^2β+ωγ
LET x1=(L1+ L2+ L3)/3
LET x2=(L1+w^2*L2+ w*L3)/3
LET x3=(L1+ w*L2+w^2*L3)/3
END SUB
EXTERNAL SUB Solve4EQU(A,B,C,D, x1,x2,x3,x4) !4次方程式 x^4+Ax^3+Bx^2+Cx+D=0を解く
OPTION ARITHMETIC COMPLEX !複素数
CALL Solve3EQU(-(3*A^2-8*B),3*A^4-16*A^2*B+16*B^2+16*A*C-64*D,-(A^3-4*A*B+8*C)^2, t1,t2,t3) !t^3+Pt^2+Qt+R=0の3つの解
LET L1=-A !α+β+γ+δ
FOR S1=-1 TO 1 STEP 2 !±を確定させる
LET L2=S1*SQR(t1) !α+β-γ-δ
FOR S2=-1 TO 1 STEP 2
LET L3=S2*SQR(t2) !α-β+γ-δ
FOR S3=-1 TO 1 STEP 2
LET L4=S3*SQR(t3) !α-β-γ+δ
LET x1=(L1+L2+L3+L4)/4
LET x2=(L1+L2-L3-L4)/4
LET x3=(L1-L2+L3-L4)/4
LET x4=(L1-L2-L3+L4)/4
IF ABS((((x1+A)*x1+B)*x1+C)*x1+D)<1E-13 THEN EXIT SUB !※調整が必要である
NEXT S3
NEXT S2
NEXT S1
PRINT "論理エラーです。"
STOP
END SUB
!--------------------------------------
EXTERNAL SUB Solve3EQU2(A,B,C, x1,x2,x3) !3次方程式 x^3+Ax^2+Bx+C=0を解く
OPTION ARITHMETIC COMPLEX !複素数
LET w=EXP(COMPLEX(0,1)*2*PI/3) !w ※1の原始3乗根
DIM M(3,3),x(3),n(3) !連立方程式 Mx=n
LET M(1,1)=1 !α+β+γ
LET M(1,2)=1
LET M(1,3)=1
LET M(2,1)=1 !α+ωβ+ω^2γ
LET M(2,2)=w
LET M(2,3)=w^2
LET M(3,1)=1 !α+ω^2β+ωγ
LET M(3,2)=w^2
LET M(3,3)=w
CALL Solve2EQU(2*A^3-9*A*B+27*C,(A^2-3*B)^3, t1,t2) !t^2+Pt+Q=0の2つの解
LET n(1)=-A
LET n(2)=pow(t1,1/3) !3乗根
LET n(3)=pow(t2,1/3)
DIM iM(3,3) !連立方程式を解く
MAT iM=INV(M)
MAT x=iM*n
LET x1=x(1)
LET x2=x(2)
LET x3=x(3)
END SUB
EXTERNAL SUB Solve4EQU2(A,B,C,D, x1,x2,x3,x4) !4次方程式 x^4+Ax^3+Bx^2+Cx+D=0を解く
OPTION ARITHMETIC COMPLEX !複素数
DIM M(4,4),x(4),n(4) !連立方程式 Mx=n
DATA 1, 1, 1, 1 !α+β+γ+δ
DATA 1, 1,-1,-1 !α+β-γ-δ
DATA 1,-1, 1,-1 !α-β+γ-δ
DATA 1,-1,-1, 1 !α-β-γ+δ
MAT READ M
CALL Solve3EQU2(-(3*A^2-8*B),3*A^4-16*A^2*B+16*B^2+16*A*C-64*D,-(A^3-4*A*B+8*C)^2, t1,t2,t3) !t^3+Pt^2+Qt+R=0の3つの解
LET n(1)=-A
FOR S1=-1 TO 1 STEP 2 !±を確定させる
LET n(2)=S1*SQR(t1) !α+β-γ-δ
FOR S2=-1 TO 1 STEP 2
LET n(3)=S2*SQR(t2) !α-β+γ-δ
FOR S3=-1 TO 1 STEP 2
LET n(4)=S3*SQR(t3) !α-β-γ+δ
DIM iM(4,4) !連立方程式を解く
MAT iM=INV(M)
MAT x=iM*n
LET x1=x(1)
LET x2=x(2)
LET x3=x(3)
LET x4=x(4)
IF ABS((((x1+A)*x1+B)*x1+C)*x1+D)<1E-13 THEN EXIT SUB !※調整が必要である
NEXT S3
NEXT S2
NEXT S1
PRINT "論理エラーです。"
STOP
END SUB
OPTION ARITHMETIC COMPLEX
SET WINDOW -.05, 1.05, -.15, .4
FOR n=0 TO 10
CLEAR
!----------------------
! ２進数 描画（上）
!----------------------
SET VIEWPORT 0,1, 1/2,1
DRAW grid(.1,.1)
LET Rn=1/SQR(3)^n !n次の縮小率
LET rot0= EXP(COMPLEX(0, PI/6*MOD(n,2))) !奇偶n次の、始点角 単位ベクトル
LET rot= EXP(COMPLEX(0, PI/3*(1-2*MOD(n,2)))) ! 〃 ステップ角 単位ベクトル
!---
LET s=rot0 !始点角
LET z=s
PLOT LINES: 0; z*Rn; !始点0~z(i=0)
FOR i=1 TO 2^n-1
IF MOD( LOG(bitAND(i,-i))/LOG(2), 2)=0 THEN LET s=s*rot ELSE LET s=s/rot^2
LET z=z+s
PLOT LINES: z*Rn; !ｚ*(縮小率)
NEXT i
!----------------------
! 比較の 再帰描画（下）
!----------------------
SET VIEWPORT 0,1, 0,1/2
DRAW grid(.1,.1)
PLOT label,AT.03,.3:"比較の再帰 次数 "& STR$(n)
DRAW koch(n)
pause 1
NEXT n
PICTURE koch(k)
IF 0< k THEN
DRAW koch(k-1) WITH SCALE(1,-1)*ROTATE(PI/6)*SCALE(1/SQR(3))
DRAW koch(k-1) WITH SHIFT(-1)*ROTATE(PI/6)*SCALE(1,-1)*SCALE(1/SQR(3))*SHIFT(1)
ELSE
PLOT LINES: 0;1
END IF
END PICTURE
PUBLIC NUMERIC XSIZE,YSIZE,XS(4),YS(4),LOC,HELP,LT,FL,XX,YY,R,RR,TI,TY,MX,MY
PUBLIC STRING Z$(4)
LET XSIZE=700
LET YSIZE=700
CALL GINIT(XSIZE,YSIZE)
LET M=40 !'迷路サイズ 2*M*2*N
LET N=40
LET HELP=3 !'MAP表示回数
LET LOC=2 !'現在位置表示回数
DIM MAP(0 TO 2*M,0 TO 2*N)
FOR I=1 TO 4
READ XS(I),YS(I),Z$(I)
NEXT I
DATA 0,-1,上
DATA -1,0,左
DATA 0,1,下
DATA 1,0,右
CALL MAKEMAZE(MAP,M,N)
IF MAP(1,1)<>0 OR MAP(2*M-1,2*N-1)<>0 THEN STOP !'エラー
LET TY=INT(TIME)
DO
LOOP WHILE TY=INT(TIME)
LET TY=INT(TIME)
LET XX=1
LET YY=1
LET R=1
DO
LET I0=-3
LET I1=3
LET J0=-3
LET J1=3
LET Y=50
SELECT CASE R !'画面表示
CASE 1,3
IF R=3 THEN
SWAP I0,I1
SWAP J0,J1
END IF
FOR I=I0 TO I1 STEP SGN(I1-I0)
LET X=XSIZE/2-175
FOR J=J0 TO J1 STEP SGN(J1-J0)
IF XX+J>=0 AND YY+I>=0 AND XX+J<=2*M AND YY+I<=2*N THEN
LET C=MAP(XX+J,YY+I)
IF C=2 THEN LET C=0
CALL BOXFULL(X,Y,X+50,Y+50,C)
IF XX+J=2*M-1 AND YY+I=2*N-1 THEN
SET TEXT HEIGHT 50
SET TEXT COLOR 6
SET TEXT JUSTIFY "LEFT","TOP"
PLOT TEXT,AT X,Y:"Ｇ" !'ゴール目印
END IF
ELSE
CALL BOXFULL(X,Y,X+50,Y+50,7)
END IF
LET X=X+50
NEXT J
LET Y=Y+50
NEXT I
CASE 2,4
IF R=2 THEN
SWAP J0,J1
ELSE
SWAP I0,I1
END IF
FOR I=I0 TO I1 STEP SGN(I1-I0)
LET X=XSIZE/2-175
FOR J=J0 TO J1 STEP SGN(J1-J0)
IF XX+I>=0 AND YY+J>=0 AND XX+I<=2*N AND YY+J<=2*M THEN
LET C=MAP(XX+I,YY+J)
IF C=2 THEN LET C=0
CALL BOXFULL(X,Y,X+50,Y+50,C)
IF XX+I=2*M-1 AND YY+J=2*N-1 THEN
SET TEXT HEIGHT 50
SET TEXT COLOR 6
SET TEXT JUSTIFY "LEFT","TOP"
PLOT TEXT,AT X,Y:"Ｇ"
END IF
ELSE
CALL BOXFULL(X,Y,X+50,Y+50,7)
END IF
LET X=X+50
NEXT J
LET Y=Y+50
NEXT I
END SELECT
CALL BOX(XSIZE/2-175,50,XSIZE/2+175,400,2)
CALL PUTCHARACTER(XSIZE/2-25,200,1.5)
CALL DISPLOC
IF LOC=0 AND FM=0 THEN
CALL BOXFULL(0,YSIZE-150,150,YSIZE,0)
LET FM=1
END IF
CALL DISPTIME
IF XX=2*M-1 AND YY=2*N-1 THEN !'ゴール到達
SET TEXT HEIGHT 70
SET TEXT COLOR 6
SET TEXT JUSTIFY "LEFT","TOP"
PLOT TEXT ,AT 20,50:"Congratulations"
STOP
END IF
IF HELP<>HH OR LOC<>LL THEN
CALL BOXFULL(0,250,160,350,0)
SET TEXT JUSTIFY "LEFT","TOP"
SET TEXT HEIGHT 20
PLOT TEXT ,AT 0,250:"MAP 残 "&STR$(HELP)
PLOT TEXT ,AT 0,280:"位置 残 "&STR$(LOC)
LET HH=HELP
LET LL=LOC
END IF
LET S$=GETKEY$(XSIZE/2,YSIZE-150,100)
IF S$<>"" THEN WAIT DELAY .1
IF S$="4" THEN LET R=R+1
IF S$="6" THEN LET R=R-1
IF S$="2" THEN LET R=R+2
IF R>4 THEN LET R=R-4
IF R<1 THEN LET R=R+4
IF S$="8" AND MAP(XX+XS(R),YY+YS(R))<>7 THEN
LET XX=XX+XS(R)
LET YY=YY+YS(R)
END IF
IF S$="M" AND HELP>0 THEN !'MAP表示
CALL DISPLAYMAP(MAP,M,N,XX,YY)
LET TT=INT(TIME)
DO
LOOP WHILE TT=INT(TIME)
LET TT=INT(TIME)
DO
MOUSE POLL DMX,DMY,LEFT,RIGHT
LOOP UNTIL INT(TIME)-TT>=HELP*4 OR LEFT=1 OR RIGHT=1 !'クリックするか、時間待ち
CLEAR
LET HELP=HELP-1
END IF
IF S$="L" THEN
LET LT=INT(TIME)
LET FL=0
LET LOC=LOC-1
END IF
IF XX<0 THEN LET XX=0
IF YY<0 THEN LET YY=0
IF XX>2*M THEN LET XX=2*M
IF YY>2*N THEN LET YY=2*N
LET MAP(XX,YY)=2 !'足跡を残す(赤色)
LOOP
END
EXTERNAL SUB MAKEMAZE(MAP(,),M,N) !'迷路作成
RANDOMIZE
MAT MAP=ZER
LET S=(M-1)*(N-1)
FOR I=0 TO 2*M
LET MAP(I,0)=7
LET MAP(I,2*N)=7
NEXT I
FOR I=0 TO 2*N
LET MAP(0,I)=7
LET MAP(2*M,I)=7
NEXT I
DO
DO
LET X=INT(RND*(M+1))
LET Y=INT(RND*(N+1))
LET X0=X*2
LET Y0=Y*2
LOOP WHILE MAP(X0,Y0)=0
LET R=INT(RND*4)+1
LET XN=X0+XS(R)*2
LET YN=Y0+YS(R)*2
IF XN>0 AND XN<2*M AND YN>0 AND YN<2*N AND MAP(XN,YN)=0 THEN
IF X0=XN THEN
FOR K=Y0 TO YN STEP SGN(YN-Y0)
LET MAP(X0,K)=7
NEXT K
ELSE
FOR K=X0 TO XN STEP SGN(XN-X0)
LET MAP(K,Y0)=7
NEXT K
END IF
LET X0=XN
LET Y0=YN
LET S=S-1
END IF
LOOP WHILE S>0
END SUB
EXTERNAL SUB DISPLAYMAP(MAP(,),M,N,XX,YY) !'地図表示
CLEAR
FOR I=0 TO 2*N
FOR J=0 TO 2*M
LET C=MAP(J,I)
IF J=XX AND I=YY THEN LET C=4 !'現在の位置(緑)
IF J=2*M-1 AND I=2*N-1 THEN LET C=6 !'ゴール(黄)
CALL BOXFULL(J*XSIZE/(2*M+1),I*YSIZE/(2*N+1),(J+1)*XSIZE/(2*M+1),(I+1)*YSIZE/(2*N+1),C)
NEXT J
NEXT I
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
SET COLOR MIX(242) 112/255,40/255,24/255
SET COLOR MIX(243) 8/255,40/255,56/255
SET COLOR MIX(244) 248/255,112/255,64/255
SET COLOR MIX(245) 40/255,88/255,248/255
SET COLOR MIX(246) 192/255,56/255,32/255
SET COLOR MIX(247) 248/255,248/255,248/255
SET COLOR MIX(248) 0/255,48/255,168/255
SET COLOR MIX(249) 192/255,104/255,80/255
SET COLOR MIX(250) 88/255,56/255,24/255
SET COLOR MIX(251) 248/255,200/255,184/255
SET COLOR MIX(252) 192/255,128/255,40/255
SET COLOR MIX(253) 144/255,144/255,160/255
SET COLOR MIX(254) 80/255,48/255,24/255
SET COLOR MIX(255) 248/255,208/255,88/255
CLEAR
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET AREA COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
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 LINE(XS,YS,XE,YE,C)
SET LINE COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL FUNCTION AREA3(X1,Y1,X2,Y2,X3,Y3,PX,PY) !'PX,PYが三角形内か
LET T=TRIANGLE(X1,Y1,X2,Y2,X3,Y3)
LET A=TRIANGLE(X1,Y1,X2,Y2,PX,PY)
LET B=TRIANGLE(X2,Y2,X3,Y3,PX,PY)
LET C=TRIANGLE(X1,Y1,X3,Y3,PX,PY)
IF A+B+C=T THEN LET AREA3=-1 ELSE LET AREA3=0
END FUNCTION
EXTERNAL FUNCTION AREA4(X1,Y1,X2,Y2,X3,Y3,X4,Y4,PX,PY)
LET A=AREA3(X1,Y1,X2,Y2,X3,Y3,PX,PY)
IF A<>0 THEN
LET AREA4=-1
EXIT FUNCTION
END IF
LET B=AREA3(X1,Y1,X4,Y4,X3,Y3,PX,PY)
IF B<>0 THEN LET AREA4=-1 ELSE LET AREA4=0
END FUNCTION
EXTERNAL FUNCTION TRIANGLE(X1,Y1,X2,Y2,X3,Y3) !'三角形の面積
LET TRIANGLE=ABS(X1*Y2+X2*Y3+X3*Y1-X2*Y1-X3*Y2-Y3*X1)/2
END FUNCTION
EXTERNAL FUNCTION GETKEY$(X,Y,SIZE) !'マウス入力
SET AREA COLOR 4
SET TEXT COLOR 7
PLOT AREA:X,Y-SIZE;X-SIZE,Y;X,Y+SIZE;X+SIZE,Y
IF HELP>0 THEN PLOT AREA:XSIZE-150,YSIZE-150;XSIZE,YSIZE-150;XSIZE,YSIZE;XSIZE-150,YSIZE
IF LOC>0 THEN PLOT AREA:0,YSIZE-150;150,YSIZE-150;150,YSIZE;0,YSIZE
CALL LINE(X-SIZE/2,Y-SIZE/2,X+SIZE/2,Y+SIZE/2,7)
CALL LINE(X+SIZE/2,Y-SIZE/2,X-SIZE/2,Y+SIZE/2,7)
SET TEXT JUSTIFY "CENTER","HALF"
SET TEXT HEIGHT SIZE/3
LET X1=X-SIZE/2
LET Y1=Y-SIZE/2
LET X2=X1
LET Y2=Y+SIZE/2
LET X3=X+SIZE/2
LET Y3=Y2
LET X4=X3
LET Y4=Y1
PLOT TEXT ,AT X,Y-SIZE/2: "前"
PLOT TEXT ,AT X-SIZE/2,Y: "左"
PLOT TEXT ,AT X+SIZE/2,Y: "右"
PLOT TEXT ,AT X,Y+SIZE/2: "後"
IF HELP>0 THEN PLOT TEXT ,AT XSIZE-75,YSIZE-75:"MAP"
IF LOC>0 THEN
SET TEXT JUSTIFY "LEFT","HALF"
SET TEXT HEIGHT SIZE/4
PLOT TEXT ,AT 0,YSIZE-75:"現在位置"
END IF
SET AREA COLOR 2
SET TEXT JUSTIFY "CENTER","HALF"
LET GETKEY$=""
DO
MOUSE POLL X0,Y0,LEFT,RIGHT
LOOP WHILE LEFT=1 OR RIGHT=1
DO
CALL DISPTIME
CALL DISPLOC
MOUSE POLL X0,Y0,LEFT,RIGHT
LOOP UNTIL LEFT=1 OR RIGHT=1
IF AREA4(X,Y-SIZE,X1,Y1,X,Y,X4,Y4,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X,Y-SIZE;X1,Y1;X,Y;X4,Y4
PLOT TEXT ,AT X,Y-SIZE/2: "前"
LET GETKEY$="8"
END IF
IF AREA4(X1,Y1,X-SIZE,Y,X2,Y2,X,Y,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X1,Y1;X-SIZE,Y;X2,Y2;X,Y
PLOT TEXT ,AT X-SIZE/2,Y: "左"
LET GETKEY$="4"
END IF
IF AREA4(X,Y,X2,Y2,X,Y+SIZE,X3,Y3,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X,Y;X2,Y2;X,Y+SIZE;X3,Y3
PLOT TEXT ,AT X,Y+SIZE/2: "後"
LET GETKEY$="2"
END IF
IF AREA4(X4,Y4,X,Y,X3,Y3,X+SIZE,Y,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X4,Y4;X,Y;X3,Y3;X+SIZE,Y
PLOT TEXT ,AT X+SIZE/2,Y: "右"
LET GETKEY$="6"
END IF
IF HELP>0 AND AREA4(XSIZE-150,YSIZE-150,XSIZE,YSIZE-150,XSIZE,YSIZE,XSIZE-150,YSIZE,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :XSIZE-150,YSIZE-150;XSIZE,YSIZE-150;XSIZE,YSIZE;XSIZE-150,YSIZE
PLOT TEXT ,AT XSIZE-75,YSIZE-75:"MAP"
LET GETKEY$="M"
END IF
IF LOC>0 AND AREA4(0,YSIZE-150,150,YSIZE-150,150,YSIZE,0,YSIZE,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :0,YSIZE-150;150,YSIZE-150;150,YSIZE;0,YSIZE
SET TEXT JUSTIFY "LEFT","HALF"
PLOT TEXT ,AT 0,YSIZE-75:"現在位置"
LET GETKEY$="L"
END IF
END FUNCTION
EXTERNAL SUB DISPTIME !'時間表示
IF INT(TIME)<>TI THEN
LET TI=INT(TIME)
CALL BOXFULL(XSIZE-150,200,XSIZE,300,0)
SET TEXT COLOR 7
SET TEXT HEIGHT 20
SET TEXT JUSTIFY "LEFT","TOP"
PLOT TEXT ,AT XSIZE-150,200:"経過時間"
PLOT TEXT ,AT XSIZE-100,240:STR$(INT(TIME-TY))&"s"
END IF
END SUB
EXTERNAL SUB DISPLOC !'位置表示
IF INT(TIME)-LT<55 THEN LET C=7 ELSE LET C=2
IF LOC>0 AND INT(TIME)-LT<60 AND (MX<>XX OR MY<>YY OR R<>RR) THEN
SET TEXT COLOR C
SET TEXT HEIGHT 20
SET TEXT JUSTIFY "LEFT","TOP"
CALL BOXFULL(XSIZE-150,40,XSIZE,120,0)
PLOT TEXT ,AT XSIZE-150,40:"現在位置"
PLOT TEXT ,AT XSIZE-120,80:"("&STR$(XX)&","&STR$(YY)&")"
CALL BOXFULL(0,0,140,140,0)
CALL LINE(50,80,110,80,C)
CALL LINE(80,50,80,110,C)
SET TEXT JUSTIFY "CENTER","HALF"
PLOT TEXT ,AT 40,80:Z$(MOD(R,4)+1)
PLOT TEXT ,AT 120,80:Z$(MOD(R+2,4)+1)
PLOT TEXT ,AT 80,40:Z$(R)
PLOT TEXT ,AT 80,120:Z$(MOD(R+1,4)+1)
LET MX=XX
LET MY=YY
LET RR=R
END IF
IF INT(TIME)-LT>60 AND FL=0 THEN
CALL BOXFULL(XSIZE-150,0,XSIZE,120,0)
CALL BOXFULL(0,0,140,140,0)
LET FL=1
END IF
END SUB
EXTERNAL SUB PUTCHARACTER(XX,YY,SIZE)
LET X=XX
LET Y=YY
DO
READ IF MISSING THEN EXIT DO: A$
FOR J=1 TO LEN(A$) STEP 2
LET C=BVAL(A$(J:J+1),16)
CALL BOXFULL(X,Y,X+SIZE,Y+SIZE,C)
LET X=X+SIZE
NEXT J
LET X=XX
LET Y=Y+SIZE
LOOP
DATA "0000F2F2000000000000F3F3F2F2F4F4F4F4F2F2F3F3000000000000F2F20000"
DATA "0000F2F2000000000000F3F3F2F2F4F4F4F4F2F2F3F3000000000000F2F20000"
DATA "F2F2F4F4F2F20000F3F3F5F5F5F5F4F4F4F4F5F5F5F5F3F30000F2F2F4F4F2F2"
DATA "F2F2F4F4F2F20000F3F3F5F5F5F5F4F4F4F4F5F5F5F5F3F30000F2F2F4F4F2F2"
DATA "F2F2F4F4F4F4F2F2F5F5F3F3F3F3F3F3F3F3F3F3F3F3F5F5F2F2F4F4F4F4F2F2"
DATA "F2F2F4F4F4F4F2F2F5F5F3F3F3F3F3F3F3F3F3F3F3F3F5F5F2F2F4F4F4F4F2F2"
DATA "F2F2F6F6F4F4F7F7F3F3F5F5F5F5F5F5F5F5F5F5F5F5F3F3F4F4F4F4F6F6F2F2"
DATA "F2F2F6F6F4F4F7F7F3F3F5F5F5F5F5F5F5F5F5F5F5F5F3F3F4F4F4F4F6F6F2F2"
DATA "0000F2F2F4F4F7F7F8F8F5F5F3F3F3F3F3F3F3F3F5F5F8F8F4F4F4F4F2F20000"
DATA "0000F2F2F4F4F7F7F8F8F5F5F3F3F3F3F3F3F3F3F5F5F8F8F4F4F4F4F2F20000"
DATA "0000F2F2F6F6F7F7F3F3F8F8F8F8F8F8F8F8F8F8F8F8F3F3F6F6F6F6F2F20000"
DATA "0000F2F2F6F6F7F7F3F3F8F8F8F8F8F8F8F8F8F8F8F8F3F3F6F6F6F6F2F20000"
DATA "00000000F2F2F7F7F8F8F9F9FAFAFBFBFBFBFAFAF9F9F8F8F2F2F2F200000000"
DATA "00000000F2F2F7F7F8F8F9F9FAFAFBFBFBFBFAFAF9F9F8F8F2F2F2F200000000"
DATA "000000000000F7F7F9F9FBFBFAFAF9F9F9F9FAFAF9F9F9F9F3F3000000000000"
DATA "000000000000F7F7F9F9FBFBFAFAF9F9F9F9FAFAF9F9F9F9F3F3000000000000"
DATA "000000000000F7F7F3F3FBFBFBFBFBFBFBFBFBFBF9F9F8F8F5F5FCFC00000000"
DATA "000000000000F7F7F3F3FBFBFBFBFBFBFBFBFBFBF9F9F8F8F5F5FCFC00000000"
DATA "00000000F2F2FDFDF8F8FEFEFBFBFBFBFBFBF9F9FEFEF5F5FFFFF8F8F2F20000"
DATA "00000000F2F2FDFDF8F8FEFEFBFBFBFBFBFBF9F9FEFEF5F5FFFFF8F8F2F20000"
DATA "0000F2F2FFFFFFFFFCFCF5F5FEFEFEFEFEFEFEFEFFFFFFFFF5F5F8F8F2F20000"
DATA "0000F2F2FFFFFFFFFCFCF5F5FEFEFEFEFEFEFEFEFFFFFFFFF5F5F8F8F2F20000"
DATA "0000F2F2FBFBF9F9F3F3F3F3F5F5F5F5F5F5F5F5FFFFF5F5F5F5F8F8F6F6F2F2"
DATA "0000F2F2FBFBF9F9F3F3F3F3F5F5F5F5F5F5F5F5FFFFF5F5F5F5F8F8F6F6F2F2"
DATA "F2F2F4F4FBFBF9F9F8F8F8F8F3F3F8F8F8F8F8F8FFFFF5F5F5F5FCFCF6F6F2F2"
DATA "F2F2F4F4FBFBF9F9F8F8F8F8F3F3F8F8F8F8F8F8FFFFF5F5F5F5FCFCF6F6F2F2"
DATA "F2F2F4F4F3F3F3F3F4F4F4F4F3F3F5F5F5F5F3F3F8F8FFFFFCFCF3F3F4F4F2F2"
DATA "F2F2F4F4F3F3F3F3F4F4F4F4F3F3F5F5F5F5F3F3F8F8FFFFFCFCF3F3F4F4F2F2"
DATA "F2F2F4F40000F3F3F5F5F8F8F8F8F3F3F3F3F4F4F4F4F6F6F3F30000F4F4F2F2"
DATA "F2F2F4F40000F3F3F5F5F8F8F8F8F3F3F3F3F4F4F4F4F6F6F3F30000F4F4F2F2"
DATA "0000F2F200000000F3F3F3F3F3F300000000F3F3F5F5F5F5F3F30000F2F20000"
DATA "0000F2F200000000F3F3F3F3F3F300000000F3F3F5F5F5F5F3F30000F2F20000"
END SUB
PUBLIC NUMERIC XSIZE,YSIZE,XS(4),YS(4),LOC,HELP,LT,FL,XX,YY,TI,TY,MX,MY,LL
LET XSIZE=700
LET YSIZE=700
CALL GINIT(XSIZE,YSIZE)
LET M=40
LET N=40
LET HELP=3
LET LOC=2
LET XA=XSIZE/2-175
LET XB=XSIZE/2+175
LET YA=50
LET YB=400
DIM MAP(0 TO 2*M,0 TO 2*N)
FOR I=1 TO 4
READ XS(I),YS(I)
NEXT I
DATA 0,-1
DATA -1,0
DATA 0,1
DATA 1,0
CALL MAKEMAZE(MAP,M,N)
IF MAP(1,1)<>0 OR MAP(2*M-1,2*N-1)<>0 THEN STOP
LET TY=INT(TIME)
DO
LOOP WHILE TY=INT(TIME)
LET TY=INT(TIME)
LET XX=1
LET YY=1
IF MAP(1,2)=0 THEN LET R=3
IF MAP(2,1)=0 THEN LET R=4
DO
SET VIEWPORT XA/XSIZE,XB/XSIZE,(YSIZE-YB)/YSIZE,(YSIZE-YA)/YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
CALL BOXFULL(0,0,XSIZE,YSIZE,0)
CALL 壁
FOR I=0 TO 3 !'MAPデータ走査,画面表示(3マス先まで)
SELECT CASE R
CASE 1
IF YY-I-1>=0 THEN LET P0=MAP(XX,YY-1-I) ELSE LET P0=7
IF XX-1>=0 AND YY-I>=0 THEN LET L0=MAP(XX-1,YY-I) ELSE LET L0=7
IF XX+1<=2*M AND YY-I>=0 THEN LET R0=MAP(XX+1,YY-I) ELSE LET R0=7
CASE 2
IF XX-I-1>=0 THEN LET P0=MAP(XX-I-1,YY) ELSE LET P0=7
IF YY+1<=2*N AND XX-I>=0 THEN LET L0=MAP(XX-I,YY+1) ELSE LET L0=7
IF YY-1>=0 AND XX-I>=0 THEN LET R0=MAP(XX-I,YY-1) ELSE LET R0=7
CASE 3
IF YY+I+1<=2*N THEN LET P0=MAP(XX,YY+I+1) ELSE LET P0=7
IF XX+1<=2*M AND YY+I<=2*N THEN LET L0=MAP(XX+1,YY+I) ELSE LET L0=7
IF XX-1>=0 AND YY+I<=2*N THEN LET R0=MAP(XX-1,YY+I) ELSE LET R0=7
CASE 4
IF XX+I+1<=2*M THEN LET P0=MAP(XX+I+1,YY) ELSE LET P0=7
IF XX+I<=2*M AND YY-1>=0 THEN LET L0=MAP(XX+I,YY-1) ELSE LET L0=7
IF XX+I<=2*M AND YY+1<=2*N THEN LET R0=MAP(XX+I,YY+1) ELSE LET R0=7
END SELECT
IF P0<>7 AND L0<>7 THEN CALL 左折路(I)
IF P0<>7 AND R0<>7 THEN CALL 右折路(I)
IF P0=7 AND L0<>7 AND R0<>7 THEN
CALL T字路(I)
EXIT FOR
ELSEIF P0=7 AND L0<>7 AND R0=7 THEN
CALL 左曲がり(I)
EXIT FOR
ELSEIF P0=7 AND R0<>7 AND L0=7 THEN
CALL 右曲がり(I)
EXIT FOR
ELSEIF P0=7 AND L0=7 AND R0=7 THEN
CALL 行き止まり(I)
EXIT FOR
END IF
NEXT I
CALL BOX(0,0,XSIZE,YSIZE,2)
SET VIEWPORT 0,1,0,1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
CALL DISPLOC
IF LOC=0 AND FM=0 THEN
CALL BOXFULL(0,YSIZE-150,150,YSIZE,0)
LET FM=1
END IF
CALL DISPTIME
IF XX=2*M-1 AND YY=2*N-1 THEN !'ゴール到達
SET TEXT HEIGHT 70
SET TEXT COLOR 6
SET TEXT JUSTIFY "LEFT","TOP"
PLOT TEXT ,AT 20,50:"Congratulations"
STOP
END IF
CALL BOXFULL(0,250,160,350,0)
SET TEXT JUSTIFY "LEFT","TOP"
SET TEXT HEIGHT 20
SET TEXT COLOR 7
PLOT TEXT ,AT 0,250:"MAP 残 "&STR$(HELP)
PLOT TEXT ,AT 0,280:"位置 残 "&STR$(LOC)
LET S$=GETKEY$(XSIZE/2,YSIZE-150,100)
IF S$<>"" THEN WAIT DELAY .1
IF S$="4" THEN LET R=R+1
IF S$="6" THEN LET R=R-1
IF S$="2" THEN LET R=R+2
IF R>4 THEN LET R=R-4
IF R<1 THEN LET R=R+4
IF S$="8" AND MAP(XX+XS(R),YY+YS(R))<>7 THEN
LET XX=XX+XS(R)
LET YY=YY+YS(R)
END IF
IF S$="M" AND HELP>0 THEN !'MAP表示
CALL DISPLAYMAP(MAP,M,N,XX,YY)
LET TT=INT(TIME)
DO
LOOP WHILE TT=INT(TIME)
LET TT=INT(TIME)
DO
MOUSE POLL DMX,DMY,LEFT,RIGHT
LOOP UNTIL INT(TIME)-TT>=HELP*4 OR LEFT=1 OR RIGHT=1 !'クリックするか、時間待ち
CLEAR
LET HELP=HELP-1
END IF
IF S$="L" THEN
LET LT=INT(TIME)
LET FL=0
LET LOC=LOC-1
END IF
IF XX<0 THEN LET XX=0
IF YY<0 THEN LET YY=0
IF XX>2*M THEN LET XX=2*M
IF YY>2*N THEN LET YY=2*N
LET MAP(XX,YY)=2 !'足跡を残す(赤色)
LOOP
END
EXTERNAL SUB 壁
LET XM=XSIZE/2
LET YM=YSIZE/2
PLOT LINES:0,0;XM-20,YM-20
PLOT LINES:0,YSIZE;XM-20,YM+20
PLOT LINES:XSIZE,0;XM+20,YM-20
PLOT LINES:XSIZE,YSIZE;XM+20,YM+20
PLOT LINES:XM-20,YM-20;XM-20,YM+20
PLOT LINES:XM+20,YM-20;XM+20,YM+20
END SUB
EXTERNAL SUB 行き止まり(N)
IF N=0 THEN
CALL BOXFULL(0,0,XSIZE,YSIZE,0)
PLOT LINES:0,0;20,20
PLOT LINES:XSIZE,0;XSIZE-20,20
PLOT LINES:XSIZE,YSIZE;XSIZE-20,YSIZE-20
PLOT LINES:0,YSIZE;20,YSIZE-20
PLOT LINES:20,20;XSIZE-20,20;XSIZE-20,YSIZE-20;20,YSIZE-20;20,20
ELSE
LET L=80*N
LET SIZE=-L/8+340/8
CALL BOXFULL(L,0,XSIZE-L,YSIZE,0)
PLOT LINES:L,L;XSIZE-L,L
PLOT LINES:L,YSIZE-L;XSIZE-L,YSIZE-L
PLOT LINES:L,L;L,YSIZE-L
PLOT LINES:XSIZE-L,L;XSIZE-L,YSIZE-L
END IF
END SUB
EXTERNAL SUB T字路(N)
LET L=80*N
LET SIZE=-L/8+340/8
CALL BOXFULL(L,0,XSIZE-L,YSIZE,0)
PLOT LINES:L,L+SIZE;XSIZE-L,L+SIZE
PLOT LINES:L,YSIZE-L-SIZE;XSIZE-L,YSIZE-L-SIZE
PLOT LINES:L,L;L,YSIZE-L
PLOT LINES:XSIZE-L,L;XSIZE-L,YSIZE-L
END SUB
EXTERNAL SUB 右曲がり(N)
LET R=XSIZE-N*80
LET SIZE=R/8-260/8
CALL BOXFULL(R,0,XSIZE-R+SIZE,YSIZE,0)
PLOT LINES:R,R-SIZE;XSIZE-R+SIZE,R-SIZE
PLOT LINES:R,YSIZE-R+SIZE;XSIZE-R+SIZE,YSIZE-R+SIZE
PLOT LINES:R,R;R,YSIZE-R
PLOT LINES:XSIZE-R+SIZE,YSIZE-R+SIZE;XSIZE-R+SIZE,R-SIZE
END SUB
EXTERNAL SUB 左曲がり(N)
LET L=N*80
LET SIZE=-L/8+340/8
CALL BOXFULL(L,0,XSIZE-L-SIZE,YSIZE,0)
PLOT LINES:L,L+SIZE;XSIZE-L-SIZE,L+SIZE
PLOT LINES:L,YSIZE-L-SIZE;XSIZE-L-SIZE,YSIZE-L-SIZE
PLOT LINES:L,L;L,YSIZE-L
PLOT LINES:XSIZE-L-SIZE,YSIZE-L-SIZE;XSIZE-L-SIZE,L+SIZE
END SUB
EXTERNAL SUB 左折路(N)
LET L=N*80
LET SIZE=-L/8+340/8
CALL BOXFULL(L,0,L+SIZE,YSIZE,0)
PLOT LINES:L,L;L,YSIZE-L
PLOT LINES:L,L+SIZE;L+SIZE,L+SIZE
PLOT LINES:L,YSIZE-L-SIZE;L+SIZE,YSIZE-L-SIZE
PLOT LINES:L+SIZE,L+SIZE;L+SIZE,YSIZE-L-SIZE
END SUB
EXTERNAL SUB 右折路(N)
LET R=XSIZE-N*80
LET SIZE=R/8-260/8
CALL BOXFULL(R,0,R-SIZE,YSIZE,0)
PLOT LINES:R,R;R,YSIZE-R
PLOT LINES:R,R-SIZE;R-SIZE,R-SIZE
PLOT LINES:R,YSIZE-R+SIZE;R-SIZE,YSIZE-R+SIZE
PLOT LINES:R-SIZE,YSIZE-R+SIZE;R-SIZE,R-SIZE
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
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 LINE COLOR 7
SET AREA COLOR 0
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET AREA COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
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 MAKEMAZE(MAP(,),M,N) !'迷路作成
RANDOMIZE
MAT MAP=ZER
LET S=(M-1)*(N-1)
FOR I=0 TO 2*M
LET MAP(I,0)=7
LET MAP(I,2*N)=7
NEXT I
FOR I=0 TO 2*N
LET MAP(0,I)=7
LET MAP(2*M,I)=7
NEXT I
DO
DO
LET X=INT(RND*(M+1))
LET Y=INT(RND*(N+1))
LET X0=X*2
LET Y0=Y*2
LOOP WHILE MAP(X0,Y0)=0
LET R=INT(RND*4)+1
LET XN=X0+XS(R)*2
LET YN=Y0+YS(R)*2
IF XN>0 AND XN<2*M AND YN>0 AND YN<2*N AND MAP(XN,YN)=0 THEN
IF X0=XN THEN
FOR K=Y0 TO YN STEP SGN(YN-Y0)
LET MAP(X0,K)=7
NEXT K
ELSE
FOR K=X0 TO XN STEP SGN(XN-X0)
LET MAP(K,Y0)=7
NEXT K
END IF
LET X0=XN
LET Y0=YN
LET S=S-1
END IF
LOOP WHILE S>0
END SUB
EXTERNAL SUB DISPLAYMAP(MAP(,),M,N,XX,YY)
SET VIEWPORT 0,1,0,1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
CLEAR
FOR I=0 TO 2*N
FOR J=0 TO 2*M
LET C=MAP(J,I)
IF J=XX AND I=YY THEN LET C=4
IF J=2*M-1 AND I=2*N-1 THEN LET C=6
CALL BOXFULL(J*XSIZE/(2*M+1),I*YSIZE/(2*N+1),(J+1)*XSIZE/(2*M+1),(I+1)*YSIZE/(2*N+1),C)
NEXT J
NEXT I
END SUB
EXTERNAL FUNCTION AREA3(X1,Y1,X2,Y2,X3,Y3,PX,PY)
LET T=TRIANGLE(X1,Y1,X2,Y2,X3,Y3)
LET A=TRIANGLE(X1,Y1,X2,Y2,PX,PY)
LET B=TRIANGLE(X2,Y2,X3,Y3,PX,PY)
LET C=TRIANGLE(X1,Y1,X3,Y3,PX,PY)
IF A+B+C=T THEN LET AREA3=-1 ELSE LET AREA3=0
END FUNCTION
EXTERNAL FUNCTION AREA4(X1,Y1,X2,Y2,X3,Y3,X4,Y4,PX,PY)
LET A=AREA3(X1,Y1,X2,Y2,X3,Y3,PX,PY)
IF A<>0 THEN
LET AREA4=-1
EXIT FUNCTION
END IF
LET B=AREA3(X1,Y1,X4,Y4,X3,Y3,PX,PY)
IF B<>0 THEN LET AREA4=-1 ELSE LET AREA4=0
END FUNCTION
EXTERNAL FUNCTION TRIANGLE(X1,Y1,X2,Y2,X3,Y3)
LET TRIANGLE=ABS(X1*Y2+X2*Y3+X3*Y1-X2*Y1-X3*Y2-Y3*X1)/2
END FUNCTION
EXTERNAL FUNCTION GETKEY$(X,Y,SIZE)
SET AREA COLOR 4
SET TEXT COLOR 7
PLOT AREA:X,Y-SIZE;X-SIZE,Y;X,Y+SIZE;X+SIZE,Y
IF HELP>0 THEN PLOT AREA:XSIZE-150,YSIZE-150;XSIZE,YSIZE-150;XSIZE,YSIZE;XSIZE-150,YSIZE
IF LOC>0 THEN PLOT AREA:0,YSIZE-150;150,YSIZE-150;150,YSIZE;0,YSIZE
CALL LINE(X-SIZE/2,Y-SIZE/2,X+SIZE/2,Y+SIZE/2,7)
CALL LINE(X+SIZE/2,Y-SIZE/2,X-SIZE/2,Y+SIZE/2,7)
SET TEXT JUSTIFY "CENTER","HALF"
SET TEXT HEIGHT SIZE/3
LET X1=X-SIZE/2
LET Y1=Y-SIZE/2
LET X2=X1
LET Y2=Y+SIZE/2
LET X3=X+SIZE/2
LET Y3=Y2
LET X4=X3
LET Y4=Y1
PLOT TEXT ,AT X,Y-SIZE/2: "前"
PLOT TEXT ,AT X-SIZE/2,Y: "左"
PLOT TEXT ,AT X+SIZE/2,Y: "右"
PLOT TEXT ,AT X,Y+SIZE/2: "後"
IF HELP>0 THEN PLOT TEXT ,AT XSIZE-75,YSIZE-75:"MAP"
IF LOC>0 THEN
SET TEXT JUSTIFY "LEFT","HALF"
SET TEXT HEIGHT SIZE/4
PLOT TEXT ,AT 0,YSIZE-75:"現在位置"
END IF
SET AREA COLOR 2
SET TEXT JUSTIFY "CENTER","HALF"
LET GETKEY$=""
DO
MOUSE POLL X0,Y0,LEFT,RIGHT
LOOP WHILE LEFT=1 OR RIGHT=1
DO
CALL DISPTIME
CALL DISPLOC
MOUSE POLL X0,Y0,LEFT,RIGHT
LOOP UNTIL LEFT=1 OR RIGHT=1
IF AREA4(X,Y-SIZE,X1,Y1,X,Y,X4,Y4,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X,Y-SIZE;X1,Y1;X,Y;X4,Y4
PLOT TEXT ,AT X,Y-SIZE/2: "前"
LET GETKEY$="8"
END IF
IF AREA4(X1,Y1,X-SIZE,Y,X2,Y2,X,Y,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X1,Y1;X-SIZE,Y;X2,Y2;X,Y
PLOT TEXT ,AT X-SIZE/2,Y: "左"
LET GETKEY$="4"
END IF
IF AREA4(X,Y,X2,Y2,X,Y+SIZE,X3,Y3,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X,Y;X2,Y2;X,Y+SIZE;X3,Y3
PLOT TEXT ,AT X,Y+SIZE/2: "後"
LET GETKEY$="2"
END IF
IF AREA4(X4,Y4,X,Y,X3,Y3,X+SIZE,Y,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :X4,Y4;X,Y;X3,Y3;X+SIZE,Y
PLOT TEXT ,AT X+SIZE/2,Y: "右"
LET GETKEY$="6"
END IF
IF HELP>0 AND AREA4(XSIZE-150,YSIZE-150,XSIZE,YSIZE-150,XSIZE,YSIZE,XSIZE-150,YSIZE,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :XSIZE-150,YSIZE-150;XSIZE,YSIZE-150;XSIZE,YSIZE;XSIZE-150,YSIZE
PLOT TEXT ,AT XSIZE-75,YSIZE-75:"MAP"
LET GETKEY$="M"
END IF
IF LOC>0 AND AREA4(0,YSIZE-150,150,YSIZE-150,150,YSIZE,0,YSIZE,X0,Y0)<>0 AND LEFT=1 THEN
PLOT AREA :0,YSIZE-150;150,YSIZE-150;150,YSIZE;0,YSIZE
SET TEXT JUSTIFY "LEFT","HALF"
PLOT TEXT ,AT 0,YSIZE-75:"現在位置"
LET GETKEY$="L"
END IF
END FUNCTION
EXTERNAL SUB DISPTIME
IF INT(TIME)<>TI THEN
LET TI=INT(TIME)
CALL BOXFULL(XSIZE-150,200,XSIZE,300,0)
SET TEXT COLOR 7
SET TEXT HEIGHT 20
SET TEXT JUSTIFY "LEFT","TOP"
PLOT TEXT ,AT XSIZE-150,200:"経過時間"
PLOT TEXT ,AT XSIZE-100,240:STR$(INT(TIME-TY))&"s"
END IF
END SUB
EXTERNAL SUB DISPLOC
IF INT(TIME)-LT<55 THEN LET C=7 ELSE LET C=2
IF LOC>0 AND INT(TIME)-LT<60 AND (MX<>XX OR MY<>YY OR INT(TIME)-LT<>LL) THEN
SET TEXT COLOR C
SET TEXT HEIGHT 20
SET TEXT JUSTIFY "LEFT","TOP"
CALL BOXFULL(XSIZE-150,40,XSIZE,120,0)
PLOT TEXT ,AT XSIZE-150,40:"現在位置"
PLOT TEXT ,AT XSIZE-120,80:"("&STR$(XX)&","&STR$(YY)&")"
LET MX=XX
LET MY=YY
LET LL=INT(TIME)-LT
END IF
IF INT(TIME)-LT>60 AND FL=0 THEN
CALL BOXFULL(XSIZE-150,0,XSIZE,120,0)
LET FL=1
END IF
END SUB
PUBLIC NUMERIC 罠,宝,階段
DIM 敵数(0 TO 10)
RANDOMIZE
CALL GINIT(700,700)
SET TEXT JUSTIFY "LEFT" , "TOP"
SET TEXT BACKGROUND "OPAQUE"
SET TEXT COLOR 7
LET M=120 !'迷路サイズ 2*M*2*N
LET N=120
LET LEVEL=1 !'初期レベル
LET 罠=-999
LET 宝=-99
LET 階段=-12345
DIM MAP(3,0 TO 2*M,0 TO 2*N)
CALL MAKEMAZE(MAP,M,N)
MAT READ 敵数
DATA 35,30,25,20,16,15,13,10,7,3,1 !'レベルごとの敵数
FOR FLOOR=1 TO 3
FOR I=1 TO 20
DO
LET X=INT(RND*2*M)+1
LET Y=INT(RND*2*N)+1
LOOP UNTIL MAP(FLOOR,X,Y)=0
LET MAP(FLOOR,X,Y)=宝 !'宝位置設定
NEXT I
FOR I=1 TO 15
DO
LET X=INT(RND*2*M)+1
LET Y=INT(RND*2*N)+1
LOOP UNTIL MAP(FLOOR,X,Y)=0
LET MAP(FLOOR,X,Y)=罠 !'罠位置設定
NEXT I
READ LS,LE
DATA 0,2 !'1F
DATA 3,6 !'2F
DATA 7,10 !'3F
FOR LEV=LS TO LE !'階層ごとに敵レベル設定
FOR I=1 TO 敵数(LEV)
DO
LET X=INT(RND*2*M)+1
LET Y=INT(RND*2*N)+1
LOOP UNTIL MAP(FLOOR,X,Y)=0
LET MAP(FLOOR,X,Y)=-10*(LEV+1)
NEXT I
NEXT LEV
NEXT FLOOR
FOR I=1 TO 10 !'階段設定 1階と2階
DO
LET X=INT(RND*2*M)+1
LET Y=INT(RND*2*N)+1
LOOP UNTIL MAP(1,X,Y)=0 AND MAP(2,X,Y)=0
LET MAP(1,X,Y)=階段
LET MAP(2,X,Y)=階段
NEXT I
FOR I=1 TO 10 !'階段設定 2階と3階
DO
LET X=INT(RND*2*M)+1
LET Y=INT(RND*2*N)+1
LOOP UNTIL MAP(2,X,Y)=0 AND MAP(3,X,Y)=0
LET MAP(2,X,Y)=階段
LET MAP(3,X,Y)=階段
NEXT I
CLEAR
LET FLOOR=1
CALL BOX(40,440,500,670,7)
DO
LET XX=INT(RND*2*M)+1 !'初期位置
LET YY=INT(RND*2*N)+1
LOOP UNTIL MAP(FLOOR,XX,YY)=0
DO !'メインループ
CALL DISPLAY(MAP,XX,YY,FLOOR,M,N)
CALL 情報表示(XX,YY,LEVEL,FLOOR)
LET S$=INKEY$(1)
IF POS("4Ll:",S$)>0 AND MAP(FLOOR,XX-1,YY)<>7 THEN LET XX=XX-1
IF POS("6Rr]",S$)>0 AND MAP(FLOOR,XX+1,YY)<>7 THEN LET XX=XX+1
IF POS("2Dd\",S$)>0 AND MAP(FLOOR,XX,YY+1)<>7 THEN LET YY=YY+1
IF POS("8Uu[",S$)>0 AND MAP(FLOOR,XX,YY-1)<>7 THEN LET YY=YY-1
IF POS("Mm "&CHR$(13),S$)>0 THEN
CALL 地図表示(MAP,FLOOR,M,N,XX,YY)
CLEAR
CALL BOX(40,440,500,670,7)
END IF
IF XX<0 THEN LET XX=0
IF YY<0 THEN LET YY=0
IF XX>2*M THEN LET XX=2*M
IF YY>2*N THEN LET YY=2*N
CALL DISPLAY(MAP,XX,YY,FLOOR,M,N)
LET C=MAP(FLOOR,XX,YY)
LET FL=0
IF C=宝 THEN
CALL 文章表示("宝を見つけた")
LET Z=RND
LET T=(LEVEL-1)/9
IF Z<.1*(2*T+1) AND LEVEL<10 THEN
CALL 文章表示("レベルが上がった")
LET LEVEL=LEVEL+1
ELSEIF Z<.4 THEN
CALL 文章表示("武器を手に入れた")
ELSEIF Z<.5 THEN
CALL 文章表示("薬を手に入れた")
ELSEIF Z<.7 THEN
LET H=INT(RND*100*LEVEL)
CALL 文章表示("体力が"&STR$(H)&"回復した")
ELSEIF Z<.9 THEN
LET H=INT(RND*100*LEVEL)
CALL 文章表示("ゴールド"&STR$(H)&"手に入れた")
END IF
LET MAP(FLOOR,XX,YY)=0
ELSEIF C=罠 THEN
CALL 文章表示("敵の罠に捕まった")
IF RND<.5 THEN
LET H=INT(RND*100)
CALL 文章表示("体力が"&STR$(H)&"減った")
END IF
LET MAP(FLOOR,XX,YY)=0
ELSEIF C=階段 AND FL=0 THEN
CALL 文章表示("階段を見つけた")
CALL 文章表示("どうしますか?")
IF FLOOR=1 THEN
CALL 文章表示("階段を上る(1) そのまま(2)")
DO
LET D$=INKEY$(1)
LOOP UNTIL D$="1" OR D$="2"
IF D$="1" THEN LET FLOOR=2
LET FL=1
ELSEIF FLOOR=3 THEN
CALL 文章表示("階段を下りる(1) そのまま(2)")
DO
LET D$=INKEY$(1)
LOOP UNTIL D$="1" OR D$="2"
IF D$="1" THEN LET FLOOR=2
LET FL=1
ELSE
IF MAP(1,XX,YY)=階段 AND MAP(2,XX,YY)=階段 THEN
CALL 文章表示("階段を下りる(1) そのまま(2)")
DO
LET D$=INKEY$(1)
LOOP UNTIL D$="1" OR D$="2"
IF D$="1" THEN LET FLOOR=1
LET FL=1
ELSE
CALL 文章表示("階段を上る(1) そのまま(2)")
DO
LET D$=INKEY$(1)
LOOP UNTIL D$="1" OR D$="2"
IF D$="1" THEN LET FLOOR=3
LET FL=1
END IF
END IF
ELSEIF C<0 AND MOD(-C,10)=0 THEN
LET LEV=-C/10-1
CALL 文章表示("LEVEL"&STR$(LEV)&"の敵が現れた。")
CALL 文章表示("どうしますか?")
CALL 文章表示("戦う(1) 逃げる(2)")
DO
LET D$=INKEY$(1)
LOOP UNTIL D$="1" OR D$="2"
IF D$="1" THEN
IF LEVEL<LEV THEN !'即死
CALL 文章表示("あなたは死にました")
CALL 文章表示("GAME OVER")
STOP
ELSEIF LEVEL>LEV THEN !'瞬殺
CALL 文章表示("敵を倒した")
LET Z=RND
LET T=(LEVEL-1)/9
IF Z<.1*(2*T+1) AND LEVEL<10 THEN
CALL 文章表示("レベルが上がった")
LET LEVEL=LEVEL+1
ELSEIF Z<.4 THEN
CALL 文章表示("武器を手に入れた")
ELSEIF Z<.8 THEN
LET H=INT(RND*100*LEVEL)
CALL 文章表示("ゴールド"&STR$(H)&"手に入れた")
END IF
ELSE
CALL 文章表示("戦闘が始まった")
DO
LET Z=RND
IF Z<.3 THEN
CALL 文章表示("敵を倒した")
IF LEV=10 THEN
CALL 文章表示("あなたは敵の親玉を倒した")
CALL 文章表示("Congratulations !!")
CALL 文章表示("GAME OVER")
STOP
END IF
LET T=(LEVEL-1)/9
IF Z<.15*(2*T+1) AND LEVEL<10 THEN
CALL 文章表示("レベルが上がった")
LET LEVEL=LEVEL+1
END IF
EXIT DO
ELSEIF Z<.5 THEN
LET H=INT(RND*100)
CALL 文章表示(STR$(H)&"のダメージを受けた")
ELSEIF Z<.8 THEN
LET H=INT(RND*100*LEVEL)
CALL 文章表示("敵に"&STR$(H)&"のダメージを与えた")
END IF
LOOP
END IF
LET MAP(FLOOR,XX,YY)=0 !'遭遇するとクリア
ELSE
IF LEV>=9 AND LEV>=LEVEL THEN
CALL 文章表示("だめだ、逃げ切れない")
CALL 文章表示("あなたは死にました")
CALL 文章表示("GAME OVER")
STOP
ELSE
LET MAP(FLOOR,XX,YY)=0
DO !'逃げるとワープ?
LET XX=INT(RND*2*M)
LET YY=INT(RND*2*N)
LOOP UNTIL MAP(FLOOR,XX,YY)=0
CALL 文章表示("逃げ切れた")
END IF
END IF
END IF
IF C<>階段 THEN LET MAP(FLOOR,XX,YY)=2 !'足跡を残す
LOOP
END
EXTERNAL SUB DISPLAY(MAP(,,),XX,YY,FLOOR,M,N)
SET TEXT HEIGHT 40
FOR I=-3 TO 3
LET X=0
FOR J=-4 TO 4
IF XX+J>=0 AND YY+I>=0 AND XX+J<=2*M AND YY+I<=2*N THEN
LET C=MAP(FLOOR,XX+J,YY+I)
IF C=階段 THEN
SET TEXT COLOR 5
PLOT TEXT ,AT X,Y:"階"
ELSEIF C=宝 THEN
SET TEXT COLOR 6
PLOT TEXT ,AT X,Y:"宝"
ELSE
IF C<0 OR C=2 THEN LET C=0
CALL BOXFULL(X,Y,X+50,Y+50,C)
END IF
ELSE
CALL BOXFULL(X,Y,X+50,Y+50,1)
END IF
LET X=X+50
NEXT J
LET Y=Y+50
NEXT I
CALL BOX(0,0,450,350,2)
CALL PUTCHARACTER(200,150,3)
END SUB
EXTERNAL SUB MAKEMAZE(MAP(,,),M,N) !'迷路作成
RANDOMIZE
DIM XS(4),YS(4)
SET TEXT HEIGHT 20
FOR I=1 TO 4
READ XS(I),YS(I)
NEXT I
DATA -1,0
DATA 1,0
DATA 0,1
DATA 0,-1
FOR FLOOR=1 TO 3
LET S=(M-1)*(N-1)
LET SS=S
CALL BOXFULL(230,230,500,260,0)
PLOT TEXT ,AT 230,230:"迷路作成中です..."&STR$(FLOOR)
CALL BOXFULL(150,270,550,300,8)
FOR I=0 TO 2*M
LET MAP(FLOOR,I,0)=7
LET MAP(FLOOR,I,2*N)=7
NEXT I
FOR I=0 TO 2*N
LET MAP(FLOOR,0,I)=7
LET MAP(FLOOR,2*M,I)=7
NEXT I
DO
DO
LET X=INT(RND*(M+1))
LET Y=INT(RND*(N+1))
LET X0=X*2
LET Y0=Y*2
LOOP WHILE MAP(FLOOR,X0,Y0)=0
LET R=INT(RND*4)+1
LET XN=X0+XS(R)*2
LET YN=Y0+YS(R)*2
IF XN>0 AND XN<2*M AND YN>0 AND YN<2*N AND MAP(FLOOR,XN,YN)=0 THEN
IF X0=XN THEN
FOR K=Y0 TO YN STEP SGN(YN-Y0)
LET MAP(FLOOR,X0,K)=7
NEXT K
ELSE
FOR K=X0 TO XN STEP SGN(XN-X0)
LET MAP(FLOOR,K,Y0)=7
NEXT K
END IF
LET X0=XN
LET Y0=YN
LET S=S-1
END IF
IF MOD(INT((SS-S)/SS*100),10)=0 THEN CALL BOXFULL(150,270,150+INT((SS-S)/SS*400),300,4)
LOOP WHILE S>0
CALL BOXFULL(150,270,550,300,4)
NEXT FLOOR
WAIT DELAY .1
END SUB
EXTERNAL SUB 地図表示(MAP(,,),FLOOR,M,N,ZX,ZY)
LET XX=ZX
IF XX-17<0 THEN LET XX=ABS(XX-17)+1
LET YY=ZY
IF YY-17<0 THEN LET YY=ABS(YY-17)+1
SET TEXT HEIGHT 15
DO
LET Y=0
CLEAR
FOR I=-17 TO 17
LET X=0
FOR J=-17 TO 17
IF XX+J>=0 AND YY+I>=0 AND XX+J<=2*M AND YY+I<=2*N THEN
LET C=MAP(FLOOR,XX+J,YY+I)
IF C=罠 THEN
SET TEXT COLOR 3
PLOT TEXT ,AT X,Y:"罠"
ELSEIF C=宝 THEN
SET TEXT COLOR 6
PLOT TEXT ,AT X,Y:"宝"
ELSEIF C=階段 THEN
SET TEXT COLOR 5
PLOT TEXT ,AT X,Y:"階"
ELSEIF MOD(-C,10)=0 THEN
LET LEV=-C/10-1
SET TEXT COLOR LEV+1
PLOT TEXT ,AT X,Y:"敵" !'LEV=0..青 LEV=1..赤 LEV=2..紫 LEV=3..緑
END IF
IF XX+J=ZX AND YY+I=ZY THEN LET C=4
IF C>=0 THEN CALL BOXFULL(X,Y,X+20,Y+20,C)
ELSE
CALL BOXFULL(X,Y,X+20,Y+20,1)
END IF
LET X=X+20
NEXT J
LET Y=Y+20
NEXT I
LET S$=INKEY$(1)
IF POS("4Ll:",S$)>0 THEN LET XX=XX-10
IF POS("6Rr]",S$)>0 THEN LET XX=XX+10
IF POS("2Dd\",S$)>0 THEN LET YY=YY+10
IF POS("8Uu[",S$)>0 THEN LET YY=YY-10
IF S$=" " OR S$=CHR$(13) THEN EXIT DO
IF XX=<0 THEN LET XX=0
IF XX>=2*M THEN LET XX=2*M
IF YY<=0 THEN LET YY=0
IF YY>=2*N THEN LET YY=2*N
LOOP
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
SET COLOR MIX(9) BVAL("A4",16)/255,BVAL("91",16)/255,BVAL("76",16)/255
SET COLOR MIX(10) BVAL("E2",16)/255,BVAL("CB",16)/255,BVAL("A6",16)/255
SET COLOR MIX(11) BVAL("6F",16)/255,BVAL("55",16)/255,BVAL("31",16)/255
CLEAR
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
SET AREA COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
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 LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB 文章表示(X$)
DIM M(460,200)
CALL BOX(40,440,500,670,0)
ASK PIXEL ARRAY (40,465) M
CALL BOXFULL(40,440,500,670,0)
MAT PLOT CELLS, IN 40,440;499,639:M
CALL BOX(40,440,500,670,7)
SET TEXT COLOR 7
SET TEXT HEIGHT 18
PLOT TEXT ,AT 40,640:X$
END SUB
EXTERNAL SUB 情報表示(XX,YY,LEVEL,FLOOR)
CALL BOXFULL(490,40,680,250,0)
CALL BOX(490,40,680,250,7)
SET TEXT COLOR 7
SET TEXT HEIGHT 20
PLOT TEXT ,AT 500,40:"LEVEL "&STR$(LEVEL)
PLOT TEXT ,AT 500,70:STR$(FLOOR)&"階"
PLOT TEXT ,AT 500,100:"座標("&STR$(XX)&","&STR$(YY)&")"
END SUB
EXTERNAL FUNCTION INKEY$(X)
SELECT CASE X
CASE 0
LET LEFTKEY$=CHR$(37)&"4Ll"
LET RIGHTKEY$=CHR$(39)&"6Rr"
LET UPKEY$=CHR$(38)&"8Uu"
LET DOWNKEY$=CHR$(40)&"2Dd"
LET CRKEY$=" "&CHR$(13)&" "&CHR$(13)
DO
FOR I=1 TO 4
LET L=GetKeyState(ORD(LEFTKEY$(I:I)))
LET U=GetKeyState(ORD(UPKEY$(I:I)))
LET R=GetKeyState(ORD(RIGHTKEY$(I:I)))
LET D=GetKeyState(ORD(DOWNKEY$(I:I)))
LET S=GetKeyState(ORD(CRKEY$(I:I)))
IF L<0 OR U<0 OR R<0 OR D<0 OR S<0 THEN EXIT DO !'キーを押すまで
NEXT I
LOOP
DO
LET FL=0
FOR I=1 TO 4
LET LL=GetKeyState(ORD(LEFTKEY$(I:I)))
LET UU=GetKeyState(ORD(UPKEY$(I:I)))
LET RR=GetKeyState(ORD(RIGHTKEY$(I:I)))
LET DD=GetKeyState(ORD(DOWNKEY$(I:I)))
LET SS=GetKeyState(ORD(CRKEY$(I:I)))
IF LL<0 OR UU<0 OR RR<0 OR DD<0 OR SS<0 THEN LET FL=1 !'キーを離すまで
NEXT I
LOOP WHILE FL=1
IF L<0 THEN LET INKEY$="4"
IF U<0 THEN LET INKEY$="8"
IF R<0 THEN LET INKEY$="6"
IF D<0 THEN LET INKEY$="2"
IF S<0 THEN LET INKEY$=" "
CASE 1
CHARACTER INPUT CLEAR:S$
LET INKEY$=S$
END SELECT
END FUNCTION
EXTERNAL SUB PUTCHARACTER(XX,YY,SIZE)
LET Y=YY
LET X=XX
FOR I=1 TO 16
READ A$
FOR J=1 TO 16
LET C=BVAL(A$(J:J),16)
CALL BOXFULL(X,Y,X+SIZE,Y+SIZE,C)
LET X=X+SIZE
NEXT J
LET X=XX
LET Y=Y+SIZE
NEXT I
DATA 0000000000000000
DATA 0000000770000000
DATA 0000000990000000
DATA 0700077777700000
DATA 0700799779970000
DATA 0700700990070000
DATA 0700999999990000
DATA 07091A0AA0A19000
DATA 070009AAAA977700
DATA 0707719009711170
DATA 6669911111716170
DATA 0AA1199669711170
DATA 0990011111177700
DATA 0000077777700000
DATA 00000BB00BB00000
DATA 00000BB00BB00000
END SUB
EXTERNAL FUNCTION pow(x,y) !べき乗 x^y
OPTION ARITHMETIC COMPLEX !複素数
IF x=0 THEN LET pow=0 ELSE LET pow=EXP(y*LOG(x)) !x^y
END FUNCTION
EXTERNAL SUB Solve2EQU(A,B, x1,x2) !2次方程式 x^2+Ax+B=0 を解く
OPTION ARITHMETIC COMPLEX !複素数
LET x1=-SQR(A^2-4*B)/2 -A/2
LET x2= SQR(A^2-4*B)/2 -A/2
END SUB
EXTERNAL SUB Solve3EQU(A,B,C, x1,x2,x3) !3次方程式 x^3+Ax^2+Bx+C=0 を解く
OPTION ARITHMETIC COMPLEX !複素数
LET w=EXP(COMPLEX(0,1)*2*PI/3) !w ※1の原始3乗根
LET P=-A^2/3+B !チルンハウス変換 x=X-A/3
LET Q=2*A^3/27-A*B/3+C
CALL Solve2EQU(-Q,(-P)^3/27, t1,t2) !解の1つ
LET r1=pow(t1,1/3)
LET r2=(-P)/(3*r1) !(-P)=3yzより
LET x1=-( r1+ r2) -A/3
LET x2=-( w*r1+w^2*r2) -A/3
LET x3=-(w^2*r1+ w*r2) -A/3
END SUB
EXTERNAL SUB Solve4EQU(A,B,C,D, x1,x2,x3,x4) !4次方程式 x^4+Ax^3+Bx^2+Cx+D=0 を解く
OPTION ARITHMETIC COMPLEX !複素数
LET P=-3*A^2/8+B !チルンハウス変換 x=X-A/4
LET Q=A^3/8-A*B/2+C
LET R=-3*A^4/256+A^2*B/16-A*C/4+D
CALL Solve3EQU(P/2,P^2/16-R/4,-Q^2/64, t1,t2,t3) !3つの解
FOR S1=-1 TO 1 STEP 2 !±を確定させる
LET r1=S1*SQR(t1)
FOR S2=-1 TO 1 STEP 2
LET r2=S2*SQR(t2)
FOR S3=-1 TO 1 STEP 2
LET r3=S3*SQR(t3)
LET x1=-( r1+r2+r3) -A/4
LET x2=-( r1-r2-r3) -A/4
LET x3=-(-r1+r2-r3) -A/4
LET x4=-(-r1-r2+r3) -A/4
IF ABS(8*r1*r2*r3-Q)<1E-13 THEN EXIT SUB !※調整が必要である
NEXT S3
NEXT S2
NEXT S1
PRINT "論理エラーです。"
STOP
END SUB
! 例 p=a^2*b+3*a*b+2*b
! p(0 TO 3, 0 TO 2) として、
! 係数 変数
! 項＼ 0 a b
! 0: 3 - -
! 1: 1 2 1
! 2: 3 1 1
! 3: 2 0 1
!表示関連
EXTERNAL SUB PolyPrint(p(,)) !多変数多項式を表示する
OPTION ARITHMETIC RATIONAL
LET K=p(0,0) !項の数
IF K>0 THEN
FOR i=1 TO K !各項について
LET t=p(i,0) !係数の部分
IF t<>0 THEN !０は非表示
LET FLG=0
IF t>0 THEN !符号を演算子として表示する
IF i>1 THEN PRINT "+"; !第1項目は表示しない
ELSE
PRINT "-";
END IF
LET t=ABS(t) !定数の部分
IF t<>1 THEN !１は非表示
CALL DispNum(t)
LET FLG=1 !分子を表示した
END IF
LET s=0
FOR e=1 TO N !次数の部分
IF p(i,e)>0 THEN !べき乗数が正の場合
CALL DispVar(v$(e:e),p(i,e))
LET FLG=1 !分子を表示した
ELSEIF p(i,e)<0 THEN
LET s=s+1
END IF
NEXT e
IF s>0 THEN !べき乗数が負の場合、分数で表示する
IF FLG=0 THEN PRINT "1"; !分子が定数±１のとき
IF s>1 THEN PRINT "/("; ELSE PRINT "/";
FOR e=1 TO N !次数の部分
IF p(i,e)<0 THEN CALL DispVar(v$(e:e),ABS(p(i,e)))
NEXT e
IF s>1 THEN PRINT ")";
LET FLG=1 !分母を表示した
END IF
IF FLG=0 THEN PRINT "1"; !定数±１のみのとき
END IF
NEXT i
IF K=1 AND p(1,0)=0 THEN PRINT "0"; !定数項０のみのとき
ELSE
PRINT "NUL"; !未定義である
END IF
END SUB
EXTERNAL SUB DispNum(t) !数値を表示する ※1,(-2),(3/4),(-5/6)など
OPTION ARITHMETIC RATIONAL
IF t=INT(t) AND t>=0 THEN !非負の整数なら
PRINT STR$(t);
ELSE !負の整数、有理数なら
PRINT "(";STR$(t);")";
END IF
END SUB
EXTERNAL SUB DispVar(x$,t) !x^t形式で変数を表示する
OPTION ARITHMETIC RATIONAL
IF t<>0 THEN !x^0は非表示
PRINT x$; !変数
IF t<>1 THEN !x^1の1は非表示
PRINT "^"; !次数
CALL DispNum(t)
END IF
END IF
END SUB
EXTERNAL SUB PolyPrintCollect(p(,),x$) !変数xの多項式とみなして表示する
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
CALL PolyCopy(p, t) !次数の昇順に並べる
LET e=idx(x$)
LET K=t(0,0)
FOR i=1 TO K-1 !バブルソート O(n^2)
LET A=t(i,e)
FOR J=i+1 TO K
LET B=t(J,e)
IF A>B THEN !iとjを交換する
LET A=B
FOR m=0 TO N !swap it
LET t(K+1,m)=t(i,m) !iを作業領域へ
NEXT m
FOR m=0 TO N
LET t(i,m)=t(J,m) !j→i
NEXT m
FOR m=0 TO N
LET t(J,m)=t(K+1,m) !i（作業領域）→j
NEXT m
END IF
NEXT J
NEXT i
DIM s(0 TO MAX_TERM, 0 TO N)
LET u=t(1,e)
LET i=1
DO
PRINT "+("; !同類項（次数が同じ値のもの）で括る
LET J=0
DO
LET J=J+1
FOR m=0 TO N !copy it
LET s(J,m)=t(i,m)
NEXT m
LET s(J,e)=0 !この次数は除く
LET i=i+1 !次へ
LET w=t(i,e)
LOOP WHILE i<=K AND w=u !異なる次数が現れたら
LET s(0,0)=J
CALL PolyPrint(s) !表示する
PRINT ")";
CALL DispVar(x$,u) !この次数の変数を表示する
LET M=p(0,0) !項の数
FOR J=1 TO q(0,0) !項を末尾に加える
FOR e=0 TO N !次数、係数
LET r(M+J,e)=q(J,e)
NEXT e
NEXT J
LET r(0,0)=M+q(0,0) !項の数
CALL PolySimplify(r) !同類項をまとめる、0サプレス
END SUB
EXTERNAL SUB PolySubtract(p(,),q(,), r(,)) !減算 r=p-q ※r≠p、r≠qの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
CALL PolyMultiplyC(q,-1, t) !(-1)倍
CALL PolyAdd(p,t, r) !p-q
END SUB
EXTERNAL SUB PolyMultiply(p(,),q(,), r(,)) !乗算 r=p*q ※r≠p、r≠qの配列を指定する
OPTION ARITHMETIC RATIONAL
LET M=0
FOR i=1 TO p(0,0) !項と項をかける
FOR J=1 TO q(0,0)
LET M=M+1
FOR e=1 TO N !次数
LET r(M,e)=p(i,e)+q(J,e)
NEXT e
LET r(M,0)=p(i,0)*q(J,0) !係数
NEXT J
NEXT i
LET r(0,0)=M !項の数
CALL PolySimplify(r) !同類項をまとめる、0サプレス
END SUB
EXTERNAL SUB PolyMultiplyC(p(,),k, r(,)) !乗算（定数倍） r=k*p
OPTION ARITHMETIC RATIONAL
LET M=p(0,0)
FOR i=1 TO M
FOR e=1 TO N !次数
LET r(i,e)=p(i,e)
NEXT e
LET r(i,0)=k*p(i,0) !係数
NEXT i
LET r(0,0)=M !項の数
END SUB
EXTERNAL SUB PolyDivide(p(,), f1(,), r(,)) !除算（単項式による） r=p/f1
OPTION ARITHMETIC RATIONAL
LET M=p(0,0)
FOR i=1 TO M
FOR e=1 TO N !次数
LET r(i,e)=p(i,e)-f1(1,e)
NEXT e
LET r(i,0)=p(i,0)/f1(1,0) !係数
NEXT i
LET r(0,0)=M !項の数
END SUB
EXTERNAL SUB PolyCommonFactor(p(,), f1(,)) !共通因数を得る（共通因数で括る）
OPTION ARITHMETIC RATIONAL
LET G=p(1,0) !copy it
FOR e=1 TO N
LET f1(1,e)=p(1,e)
NEXT e
FOR i=2 TO p(0,0)
LET G=gcd(G,p(i,0)) !係数
FOR e=1 TO N !次数
LET f1(1,e)=MIN(f1(1,e),p(i,e))
NEXT e
NEXT i
LET f1(1,0)=G
LET f1(0,0)=1 !項の数
END SUB
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=ABS(a)
END FUNCTION
!演算関連2
EXTERNAL SUB PolyComposition(p(,),x$,q(,), r(,)) !合成関数 P(x=Q) ※r≠p、r≠qの配列を指定する
OPTION ARITHMETIC RATIONAL
MAT r=ZER
LET r(0,0)=1 !定数０
LET r(1,0)=0
CALL PolyDegree(p,x$, mx,mn) !次数の最大値、最小値を得る
DIM T2(0 TO MAX_TERM, 0 TO N), T3(0 TO MAX_TERM, 0 TO N)
FOR ii=mx TO mn STEP -1 !ホーナー法による
CALL PolyMultiply(r,q, T3) !T[n]*X+T[n-1]
CALL PolyCoefficient(p,x$,ii, T2) !係数 ※多項式
CALL PolyAdd(T3,T2, r)
NEXT ii
FOR ii=0 TO mn-1 !残り部分
CALL PolyMultiply(r,q, T3)
CALL PolyCopy(T3,r)
NEXT ii
END SUB
EXTERNAL SUB PolyPowN(f(,),K, fk(,)) !べき乗 f^k
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
MAT fk=ZER !定数 1
LET fk(0,0)=1
LET fk(1,0)=1
FOR i=1 TO K
CALL PolyMultiply(fk,f, t) !fk=fk*f
CALL PolyCopy(t, fk)
NEXT i
END SUB
!deg(f)≧deg(g)≧0、gの最高次の係数は単項式 として、f÷g=商q余りr を求める
EXTERNAL SUB PolyQuotientRemainder(f(,),g(,),x$, q(,),r(,)) !f÷g=商q余りr
OPTION ARITHMETIC RATIONAL
DIM t1(0 TO MAX_TERM, 0 TO N), t2(0 TO MAX_TERM, 0 TO N)
DIM p(0 TO MAX_TERM, 0 TO N), u(0 TO MAX_TERM, 0 TO N)
CALL PolyDegree(f,x$, mx1,mn1) !次数を得る
CALL PolyDegree(g,x$, mx2,mn2)
MAT q=ZER !q,rの初期値
LET q(0,0)=1
CALL PolyCopy(f, r)
CALL PolyCoefficient(g,x$,mx2, p) !P
FOR i=mx1 TO mx2 STEP -1 !筆算による
CALL PolyCoefficient(r,x$,i, u) !A
LET e=idx(x$)
FOR J=0 TO u(0,0) !x^k倍
LET u(J,e)=u(J,e)+(i-mx2)
NEXT J
CALL PolyDivide(u,p, u) !Q=A/P
CALL PolyAdd(q,u, t2) !q=ΣQ
CALL PolyCopy(t2, q)
CALL PolyMultiply(u,g, t1) !r=r-Qg
CALL PolySubtract(r,t1, t2)
CALL PolyCopy(t2, r)
NEXT i
CALL PolySimplify(r) !0に注意する
END SUB
!共通ルーチン
EXTERNAL SUB PolyCopy(p(,), q(,)) !コピーする LET q=p
OPTION ARITHMETIC RATIONAL
LET K=p(0,0) !項の数
FOR i=1 TO K
FOR e=0 TO N !係数、次数
LET q(i,e)=p(i,e)
NEXT e
NEXT i
LET q(0,0)=K !項の数
END SUB
EXTERNAL SUB PolySimplify(r(,)) !同類項をまとめるなどの簡約化を行う
OPTION ARITHMETIC RATIONAL
LET K=r(0,0) !項の数
LET W=0
FOR i=1 TO K
LET T=r(i,0) !係数が０のものを篩う
IF T<>0 THEN
FOR j=i+1 TO K !同類項を探す
CALL IsEqualDegree(r,i, r,j, rc) !次数が同じなら、同類項！
IF rc<>0 THEN
LET T=T+r(j,0) !前方へ吸収する
LET r(j,0)=0 !後方は削除する
END IF
NEXT j
IF T<>0 THEN !係数が０なら、無効！
LET W=W+1
LET r(W,0)=T !係数
IF i>W THEN !前方へ吸収する ※ガーベジ・コレクション
FOR e=1 TO N !次数
LET r(W,e)=r(i,e)
NEXT e
END IF
END IF
END IF
NEXT i
IF W=0 THEN
LET r(0,0)=1 !定数０
FOR e=0 TO N
LET r(1,e)=0
NEXT e
ELSE
LET r(0,0)=W !項の数
END IF
END SUB
EXTERNAL SUB PolySimplify2(r(,)) !同類項をまとめるなどの簡約化を行う ※i^2=-1、ω^2+ω+1=0 を適用する
OPTION ARITHMETIC RATIONAL
LET K=r(0,0) !項の数
LET W=K
FOR i=1 TO K !虚数i、ωの条件式を適用する ※x^k=Aのとき、x^m≡A^int(m/k) x^mod(m,k)
LET e=idx("i") !虚数i
IF e>0 THEN
LET T=INT(r(i,e)/2) !i^2=-1を適用する ※i^3=-iなど
LET r(i,0)=(-1)^MOD(T,2)*r(i,0) !係数
LET r(i,e)=MOD(r(i,e),2) !次数
END IF
LET e=idx("w") !ω（x^3-1=0の3つの解の内、虚数解の1つをωとする）
IF e>0 THEN
LET r(i,e)=MOD(r(i,e),3) !ω^3=1を適用する ※ω^5=ω^2など
!ω^2+ω+1=0を適用する。すなわち、Aω^2=-Aω-Aとする。
IF r(i,e)=2 THEN !Aω^2なら
LET r(i,0)=-r(i,0) !係数 -Aω
LET r(i,e)=1 !次数
LET W=W+1 !-Aを後方に追加する
FOR J=0 TO N !copy it
LET r(W,J)=r(i,J)
NEXT J
LET r(W,e)=0
END IF
END IF
NEXT i
LET r(0,0)=W !項の数
CALL PolySimplify(r) !a+bi、a+bω（a+bω+cω^2）の形へ
END SUB
EXTERNAL SUB PolyCoefficient(p(,),x$,m, t(,)) !変数xにおけるm次の係数（多項式）を得る
OPTION ARITHMETIC RATIONAL
LET K=0
LET J=idx(x$) !桁位置を確認する
FOR i=1 TO p(0,0) !すべての項を検索する
IF p(i,J)=m THEN !同じ次数なら
LET K=K+1
FOR e=0 TO N !copy it
LET t(K,e)=p(i,e)
NEXT e
LET t(K,J)=0 !該当する変数は除く
END IF
NEXT i
IF K=0 THEN
LET t(0,0)=1 !定数０
FOR e=0 TO N
LET t(1,e)=0
NEXT e
ELSE
LET t(0,0)=K !項の数
END IF
END SUB
EXTERNAL SUB PolyDegree(p(,),x$, mx,mn) !変数xにおける次数の最大値と最小値を得る
OPTION ARITHMETIC RATIONAL
LET e=idx(x$) !桁位置を確認する
LET mx=p(1,e) !最大
LET mn=p(1,e) !最小
FOR i=2 TO p(0,0) !すべての項を検索する
IF p(i,e)>mx THEN LET mx=p(i,e)
IF p(i,e)<mn THEN LET mn=p(i,e)
NEXT i
END SUB
EXTERNAL FUNCTION idx(x$) !変数a,b,c,…を1,2,3,…へ
OPTION ARITHMETIC RATIONAL
LET idx=POS(v$,x$)
END FUNCTION
EXTERNAL SUB IsEqualDegree(p(,),i, q(,),j, rc) !多項式pの第i項の次数と多項式qの第j項の次数が等しいかどうか確認する
OPTION ARITHMETIC RATIONAL
LET rc=0
FOR e=1 TO N !次数が等しくないなら
IF p(i,e)<>q(j,e) THEN EXIT SUB
NEXT e
LET rc=1 !等しい
END SUB
EXTERNAL SUB IsConst(p(,),i, rc) !多項式pの第i項が定数かどうか確認する
OPTION ARITHMETIC RATIONAL
LET rc=0
FOR e=1 TO N !次数が０以外なら
IF p(i,e)<>0 THEN EXIT SUB
NEXT e
LET rc=1 !定数
END SUB
EXTERNAL SUB PolySet(s$, a(,)) !多項式を符号化する
OPTION ARITHMETIC RATIONAL
MAT a=ZER
LET p=1 !文字位置
LET K=1 !項数
CALL GetToken(p,s$, t$) !1番目の単項式の±は符号とみなす
LET s=1 !符号
IF t$="+" THEN
LET p=p+1 !eat it
ELSEIF t$="-" THEN
LET p=p+1 !eat it
LET s=-1
END IF
CALL GetToken(p,s$, t$) !トークン
IF t$="" THEN
PRINT "符号のみで項がありません。"; p
STOP
END IF
DO WHILE t$<>"" !終端以外なら
IF s=0 THEN
IF t$="+" THEN !+演算子
LET s=1
ELSEIF t$="-" THEN !-演算子
LET s=-1
END IF
LET p=p+1 !eat it
LET K=K+1
ELSE
LET a(K,0)=s
DO
IF t$<>"" AND idx(t$)>0THEN !変数なら
LET p=p+1 !eat it
LET t=idx(t$)
CALL GetToken(p,s$, t$)
LET v=1
IF t$="^" THEN !べき乗
LET p=p+1 !eat it
CALL GetRational(p,s$, v)
END IF
LET a(K,t)=a(K,t)+v
ELSE
CALL GetRational(p,s$, v) !係数
LET a(K,0)=a(K,0)*v
END IF
CALL GetToken(p,s$, t$)
LOOP UNTIL t$="+" OR t$="-" OR t$="" !±演算子、終端が現れるまで
LET s=0 !次は±演算子である
END IF
CALL GetToken(p,s$, t$) !トークン
LOOP
IF s<>0 THEN
PRINT "項がありません。"; p
STOP
END IF
LET a(0,0)=K !項数
END SUB
EXTERNAL SUB GetToken(p,s$, t$) !1文字を得る
OPTION ARITHMETIC RATIONAL
LET t$=s$(p:p)
DO WHILE t$=" " !空白文字はスキップする
LET p=p+1
LET t$=s$(p:p)
LOOP
END SUB
EXTERNAL SUB GetRational(p,s$, v) !n,(±m/n)形式の数を得る
OPTION ARITHMETIC RATIONAL
CALL GetToken(p,s$, t$)
IF t$="(" THEN !負の数、有理数
LET p=p+1 !eat it
CALL GetToken(p,s$, t$)
LET s=1 !符号を得る
IF t$="+" THEN
LET p=p+1 !eat it
END IF
IF t$="-" THEN
LET p=p+1 !eat it
LET s=-1
END IF
CALL GetInteger(p,s$, v1)
!!!PRINT s; v1
LET v2=1
CALL GetToken(p,s$, t$)
IF t$="/" THEN !有理数なら、分母を得る
LET p=p+1 !eat it
CALL GetInteger(p,s$, v2)
!!!PRINT v2
END IF
LET v=s*v1/v2
CALL GetToken(p,s$, t$)
IF t$<>")" THEN
PRINT ")がありません。"; p
STOP
END IF
LET p=p+1 !eat it
ELSE !正の整数
CALL GetInteger(p,s$, v)
END IF
END SUB
EXTERNAL SUB GetInteger(p,s$, v) !正の整数を得る
OPTION ARITHMETIC RATIONAL
CALL GetToken(p,s$, t$)
IF t$<"0" OR t$>"9" THEN
PRINT "数字ではありません。"; p
STOP
END IF
LET v=0
DO WHILE t$>="0" AND t$<="9" !連続する数字列を10進法の数とみなす
LET v=v*10+VAL(t$)
LET p=p+1
LET t$=s$(p:p)
LOOP
END SUB
EXTERNAL SUB MtxSet(p(,),x, a(,,)) !行列の要素に登録する LET a(x)=p
OPTION ARITHMETIC RATIONAL
LET K=p(0,0) !項の数を得る
FOR i=1 TO K
FOR e=0 TO N !係数、次数
LET a(x,i,e)=p(i,e)
NEXT e
NEXT i
LET a(x,0,0)=K !項の数
END SUB
EXTERNAL SUB MtxGet(a(,,),x, p(,)) !行列の要素を得る LET p=a(x)
OPTION ARITHMETIC RATIONAL
LET K=a(x,0,0) !項の数を得る
FOR i=1 TO K
FOR e=0 TO N !係数、次数
LET p(i,e)=a(x,i,e)
NEXT e
NEXT i
LET p(0,0)=K !項の数
END SUB
!表示関連
EXTERNAL SUB MtxPrint(P,Q,a(,,)) !行列を表示する
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO P-1 !i行
FOR J=0 TO Q-1 !j列
CALL MtxGet(a,Q*i+J, t)
CALL PolyPrint(t)
PRINT " ";
NEXT J
PRINT
NEXT i
END SUB
!演算関連
EXTERNAL SUB MtxZER(P,Q,a(,,)) !0にする A=O
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
CALL PolySet("0", t)
FOR i=0 TO P*Q-1
CALL MtxSet(t,i, a)
NEXT i
END SUB
EXTERNAL SUB MtxIDN(M,a(,,)) !単位行列 A=E
OPTION ARITHMETIC RATIONAL
DIM t0(0 TO MAX_TERM, 0 TO N), t1(0 TO MAX_TERM, 0 TO N)
CALL PolySet("0", t0)
CALL PolySet("1", t1)
FOR i=0 TO M-1 !i行
FOR J=0 TO M-1 !j列
IF J=i THEN CALL MtxSet(t1,M*i+J, a) ELSE CALL MtxSet(t0,M*i+J, a)
NEXT J
NEXT i
END SUB
EXTERNAL SUB MtxCopy(P,Q,a(,,), b(,,)) !コピーする B=A
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO P*Q-1
CALL MtxGet(a,i, t)
CALL MtxSet(t,i, b)
NEXT i
END SUB
EXTERNAL SUB MtxAdd(P,Q,a(,,),b(,,), c(,,)) !和 C=A+B ※C≠A、C≠Bの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM x(0 TO MAX_TERM, 0 TO N), y(0 TO MAX_TERM, 0 TO N), s(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO P*Q-1
CALL MtxGet(a,i, x)
CALL MtxGet(b,i, y)
CALL PolyAdd(x,y, s)
CALL MtxSet(s,i, c)
NEXT i
END SUB
EXTERNAL SUB MtxSub(P,Q,a(,,),b(,,), c(,,)) !差 C=A-B ※C≠A、C≠Bの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM x(0 TO MAX_TERM, 0 TO N), y(0 TO MAX_TERM, 0 TO N), s(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO P*Q-1
CALL MtxGet(a,i, x)
CALL MtxGet(b,i, y)
CALL PolySubtract(x,y, s)
CALL MtxSet(s,i, c)
NEXT i
END SUB
EXTERNAL SUB MtxMul(P,Q,R,a(,,),b(,,), c(,,)) !積 C=AB ※C≠A、C≠Bの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM x(0 TO MAX_TERM, 0 TO N), y(0 TO MAX_TERM, 0 TO N)
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO P-1 !i行
FOR J=0 TO R-1 !j列
MAT s=ZER !Σ
LET s(0,0)=1
FOR K=0 TO Q-1
CALL MtxGet(a,Q*i+K, x) !p,q
CALL MtxGet(b,R*K+J, y) !q,r
CALL PolyMultiply(x,y, t)
CALL PolyAdd(s,t, x)
CALL PolyCopy(x,s)
NEXT K
CALL MtxSet(s,R*i+J, c) !p,r
NEXT J
NEXT i
END SUB
EXTERNAL SUB MtxTRN(P,Q,a(,,), t(,,)) !転置 ※T≠Aの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM x(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO P-1 !行
FOR J=0 TO Q-1 !列
CALL MtxGet(a,Q*i+J, x)
CALL MtxSet(x,P*J+i, t)
NEXT J
NEXT i
END SUB
EXTERNAL SUB MtxTR(M,a(,,), t(,)) !トレース tr(A) ※T≠Aの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM x(0 TO MAX_TERM, 0 TO N), y(0 TO MAX_TERM, 0 TO N)
MAT t=ZER !定数 0
LET t(0,0)=1
FOR i=0 TO M-1 !i対角線の和
CALL MtxGet(a,M*i+i, x)
CALL PolyAdd(t,x, y)
CALL PolyCopy(y, t)
NEXT i
END SUB
DIM a2(0 TO (M-1)^2-1, 0 TO MAX_TERM, 0 TO N)
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N), u(0 TO MAX_TERM, 0 TO N)
FOR R=0 TO M-1 !1列目で展開する
LET X=0
FOR i=0 TO M-1 !小行列式をつくる
FOR J=1 TO M-1
IF i=R THEN !行が同じなら、除く
ELSE
CALL MtxGet(a,M*i+J, s)
CALL MtxSet(s,X, a2)
LET X=X+1
END IF
NEXT J
NEXT i
CALL MtxDET(M-1,a2, t) !再帰呼び出し
CALL MtxGet(a,M*R, s)
CALL PolyMultiply(s,t, u)
IF MOD(R,2)=0 THEN CALL PolyAdd(d,u, t) ELSE CALL PolySubtract(d,u, t) !Σ
CALL PolyCopy(t,d)
NEXT R
ELSE
CALL MtxGet(a,0, d) !1×1の場合
END IF
END SUB
PUBLIC STRING v$ !変数の定義 ※必要なものだけの列記でもよい
LET v$="wabcdpqxyzi"
PUBLIC NUMERIC N !変数の数
LET N=LEN(v$)
PUBLIC NUMERIC MAX_TERM !最大の項数
LET MAX_TERM=500
!------------------------------ ここまでがサブルーチン
!最小多項式
DATA " a+b-c" !α1
DATA " a-b+c" !α2
DATA " a-b-c" !α3
DATA "-a+b+c" !α4
DATA "-a+b-c" !α5
DATA "-a-b+c" !α6
DATA "-a-b-c" !α7
DATA " a+b+c" !α8
DIM f(0 TO MAX_TERM, 0 TO N), g(0 TO MAX_TERM, 0 TO N), h(0 TO MAX_TERM, 0 TO N)
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N)
CALL PolySet("1", s) !Πfk
FOR i=1 TO 8
READ s$
DIM g(0 TO MAX_TERM, 0 TO N)
CALL PolySet("a^3-3a+1", g)
CALL PolyPrint(g) !結果を表示する
PRINT
DIM t(0 TO MAX_TERM, 0 TO N)
CALL PolyMultiply(f1,f2, t)
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL PolyQuotientRemainder(t,g,"a", q,r)
CALL PolyPrintCollect(q,"a") !結果を表示する
PRINT
CALL PolyPrintCollect(r,"a") !結果を表示する
PRINT
OPTION ARITHMETIC RATIONAL
DATA 1,-1,-2 !A
DATA -4, 1,-1
DATA 1,-1, 1
DATA 1, 0, 0 !b
DIM A(3,3),x(3),b(3) !Ax=b
MAT READ A
MAT READ b
DIM iA(3,3) !solve it
MAT iA=INV(A)
MAT x=iA*b
MAT PRINT x;
END
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL PolyQuotientRemainder(f,g,"a", q,r)
CALL PolyPrintCollect(q,"a") !結果を表示する
PRINT
CALL PolyPrintCollect(r,"a") !結果を表示する
PRINT
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N), c(0 TO MAX_TERM, 0 TO N)
CALL PolyExtendedGCD(f,g,"a", s,t,c)
CALL PolyPrint(s) !結果を表示する
PRINT
CALL PolyPrint(t) !結果を表示する
PRINT
CALL PolyPrint(c) !結果を表示する
PRINT
END
!拡張ユークリッド互除法 f(x)S(x)+g(x)T(x)=Kgcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。
EXTERNAL SUB PolyExtendedGCD(a(,),b(,),x$, s(,),t(,),c(,)) !拡張ユークリッド互除法
OPTION ARITHMETIC RATIONAL
IF b(0,0)=1 AND b(1,0)=0 THEN !!--- IF b=0 THEN
!!--- s=1 !※f(x)*1+0*0=f(x)とする
CALL PolySet("1", s)
!!--- t=0
CALL PolySet("0", t)
!!--- c=a
CALL PolyCopy(a, c)
ELSE
!!--- q=INT(a/b), r=MOD(a,b)
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL isConst(a,1, rc1)
CALL isConst(b,1, rc2)
IF (a(0,0)=1 AND rc1<>0) AND (b(0,0)=1 AND rc2<>0) THEN !定数項のみなら
MAT q=ZER
LET q(1,0)=INT(a(1,0)/b(1,0))
LET q(0,0)=1
MAT r=ZER
LET r(1,0)=MOD(a(1,0),b(1,0))
LET r(0,0)=1
ELSE
CALL PolyQuotientRemainder(a,b,x$, q,r)
END IF
!!--- CALL ExGCD(b,r, u,v,c) !k=n-1,…,3,2 まで続ける
!!--- s=v
DIM u(0 TO MAX_TERM, 0 TO N)
CALL PolyExtendedGCD(b,r,x$, u,s,c)
!!--- t=u-v*q
DIM w(0 TO MAX_TERM, 0 TO N)
CALL PolyMultiply(s,q, w)
CALL PolySubtract(u, w, t)
END IF
END SUB
LET M=3
DATA "a", "b", "c"
DATA "d", "e", "f"
DATA "g", "h", "i"
DIM a(0 TO M*M-1, 0 TO MAX_TERM, 0 TO N)
DIM f(0 TO MAX_TERM, 0 TO N)
FOR i=0 TO M*M-1
READ s$
CALL PolySet(s$, f)
CALL MtxSet(f,i, a)
NEXT i
DIM d(0 TO MAX_TERM, 0 TO N)
CALL MtxDET(M,a, d) !|A|の値
CALL PolyPrint(d)
PRINT
PRINT
!逆行列 ※|A|倍、余因子行列A~を表示する
DIM w(0 TO (M-1)*(M-1)-1, 0 TO MAX_TERM, 0 TO N)
FOR i=0 TO M-1 !i行
FOR J=0 TO M-1 !j列
CALL MtxAij(M,a,J,i, w) !Ajiに注意する
CALL MtxDET(M-1,w, d)
CALL PolyMultiplyC(d,(-1)^(i+j), d) !余因子
CALL PolyPrint(d)
PRINT " ";
NEXT J
PRINT
NEXT i
END
EXTERNAL SUB MtxAij(M,a(,,),i,J, aij(,,)) !行列Aのi,j成分を除いた行列Aij
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
LET K=0
FOR y=0 TO M-1
IF y<>i THEN !i行を除く
FOR x=0 TO M-1
IF x<>J THEN !j列を除く
CALL MtxGet(a,M*y+x, t) !copy it
CALL MtxSet(t,K, aij)
LET K=K+1
END IF
NEXT x
END IF
NEXT y
END SUB
DIM t(0 TO MAX_TERM, 0 TO N), q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL MtxGet(t1,1, t) !分母
CALL PolyQuotientRemainder(t,f,"a", q,r)
CALL PolyPrint(r) !結果を表示する
PRINT
CALL MtxSet(r,1, t1) !分母を置き換える
PRINT
!---------------------------------------------
DIM q3(0 TO 1, 0 TO MAX_TERM, 0 TO N)
CALL QSet("1","a^2-2a+1", q3)
DIM q2(0 TO 1, 0 TO MAX_TERM, 0 TO N)
CALL QSet("1","a^2+a-2", q2)
DIM t2(0 TO 1, 0 TO MAX_TERM, 0 TO N)
CALL QSub(q3,q2, t2)
CALL PolyPrintQ(t2)
PRINT
DIM t3(0 TO 1, 0 TO MAX_TERM, 0 TO N)
CALL QAdd(t1,t2, t3)
CALL PolyPrintQ(t3)
PRINT
CALL QSimplify(t3,"a")
CALL PolyPrintQ(t3)
PRINT
END
!mPOLYQ.LIB
!分数式 p=f/g ※分子p(0,,)、分母p(1,,)
EXTERNAL SUB QSet(a$,b$, q(,,)) ! !分数式を符号化する q=a/b
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
CALL PolySet(a$, t) !分子
CALL MtxSet(t,0, q)
CALL PolySet(b$, t) !分母
CALL MtxSet(t,1, q)
END SUB
EXTERNAL SUB NUMER(x(,,), f(,)) !xの分子（numerator）
OPTION ARITHMETIC RATIONAL
CALL MtxGet(x,0, f)
END SUB
EXTERNAL SUB DENOM(x(,,), f(,)) !xの分母（denominator）
OPTION ARITHMETIC RATIONAL
CALL MtxGet(x,1, f)
END SUB
!表示関連
EXTERNAL SUB PolyPrintQ(w(,,)) !分数式を表示する
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N)
CALL MtxGet(w,0, t) !分子
CALL PolyPrint(t)
PRINT " / ";
CALL MtxGet(w,1, t) !分母
CALL PolyPrint(t)
END SUB
!演算関連
EXTERNAL SUB QCopy(a(,,), b(,,)) !コピーする LET b=a
OPTION ARITHMETIC RATIONAL
CALL MtxCopy(1,2,a, b)
END SUB
EXTERNAL SUB QInv(a(,,), b(,,)) !逆数 b=1/a
OPTION ARITHMETIC RATIONAL
DIM p(0 TO MAX_TERM, 0 TO N), q(0 TO MAX_TERM, 0 TO N)
CALL MtxGet(a,0, p) !p/q
CALL MtxGet(a,1, q)
CALL MtxSet(q,0, b) !q/p
CALL MtxSet(p,1, b)
END SUB
EXTERNAL SUB QAdd(a(,,),b(,,), c(,,)) !加算 c=a+b ※c≠a、c≠bの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N), w(0 TO 3, 0 TO MAX_TERM, 0 TO N)
CALL MtxGet(b,0, t) !bの分子
CALL MtxSet(t,2, w)
CALL MtxGet(b,1, t) !bの分母
CALL MtxSet(t,0, w)
CALL MtxSet(t,3, w)
CALL PolySet("0", t) !( a0 a1 )( b1 0 ) = ( a0b1+a1b0 a1b1 )
CALL MtxSet(t,1, w) ! ( b0 b1 )
CALL MtxMul(1,2,2,a,w, c)
END SUB
EXTERNAL SUB QSub(a(,,),b(,,), c(,,)) !減算 c=a-b ※c≠a、c≠bの配列を指定する
OPTION ARITHMETIC RATIONAL
DIM t(0 TO MAX_TERM, 0 TO N), w(0 TO 1, 0 TO MAX_TERM, 0 TO N)
CALL MtxGet(b,0, t) !分子を(-1)倍する
CALL PolyMultiplyC(t,-1, t)
CALL MtxSet(t,0, w)
CALL MtxGet(b,1, t)
CALL MtxSet(t,1, w)
CALL QAdd(a,w, c) !a-b
END SUB
EXTERNAL SUB QMul(a(,,),b(,,), c(,,)) !乗算 c=ab
OPTION ARITHMETIC RATIONAL
DIM p(0 TO MAX_TERM, 0 TO N), q(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N)
CALL MtxGet(a,0, p) !分子 a0b0
CALL MtxGet(b,0, q)
CALL PolyMultiply(p,q, t)
CALL MtxSet(t,0, c)
CALL MtxGet(a,1, p) !分母 a1b1
CALL MtxGet(b,1, q)
CALL PolyMultiply(p,q, t)
CALL MtxSet(t,1, c)
END SUB
EXTERNAL SUB QDiv(a(,,),b(,,), c(,,)) !除算 c=a/b
OPTION ARITHMETIC RATIONAL
DIM w(0 TO 1, 0 TO MAX_TERM, 0 TO N)
CALL QInv(b, w)
CALL QMul(a,w, c) !a(1/b)
END SUB
EXTERNAL SUB QPowN(a(,,),K, b(,,)) !べき乗 a^k
OPTION ARITHMETIC RATIONAL
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N)
CALL MtxGet(a,0, t) !分子
CALL PolyPowN(t,K, s)
CALL MtxSet(s,0, b)
CALL MtxGet(a,1, t) !分母
CALL PolyPowN(t,K, s)
CALL MtxSet(s,1, b)
END SUB
EXTERNAL SUB QSimplify(a(,,),x$) !約分する
OPTION ARITHMETIC RATIONAL
DIM f(0 TO MAX_TERM, 0 TO N), g(0 TO MAX_TERM, 0 TO N)
CALL MtxGet(a,0, f) !分子を得る
CALL MtxGet(a,1, g) !分母を得る
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N), c(0 TO MAX_TERM, 0 TO N)
CALL PolyExtendedGCD(f,g,x$, s,t,c) !拡張ユークリッド互除法 fs+gt=c
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL PolyQuotientRemainder(g,c,x$, q,r) !分母 g/c
CALL PolyCommonFactor(q, t) !係数を調整する
CALL PolyQuotientRemainder(q,t,x$, s,r)
CALL MtxSet(s,1, a)
CALL PolyQuotientRemainder(f,c,x$, q,r) !分子 f/c
CALL PolyQuotientRemainder(q,t,x$, s,r)
CALL MtxSet(s,0, a)
END SUB
!--------------------------
!拡張ユークリッド互除法 f(x)S(x)+g(x)T(x)=Kgcd(f(x),g(x))=C(x)となるS(x),T(x),C(x)を求める。
EXTERNAL SUB PolyExtendedGCD(a(,),b(,),x$, s(,),t(,),c(,)) !拡張ユークリッド互除法
OPTION ARITHMETIC RATIONAL
IF b(0,0)=1 AND b(1,0)=0 THEN !!--- IF b=0 THEN
!!--- s=1 !※f(x)*1+0*0=f(x)とする
CALL PolySet("1", s)
!!--- t=0
CALL PolySet("0", t)
!!--- c=a
CALL PolyCopy(a, c)
ELSE
!!--- q=INT(a/b), r=MOD(a,b)
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL isConst(a,1, rc1)
CALL isConst(b,1, rc2)
IF (a(0,0)=1 AND rc1<>0) AND (b(0,0)=1 AND rc2<>0) THEN !定数項のみなら
MAT q=ZER
LET q(1,0)=INT(a(1,0)/b(1,0))
LET q(0,0)=1
MAT r=ZER
LET r(1,0)=MOD(a(1,0),b(1,0))
LET r(0,0)=1
ELSE
CALL PolyQuotientRemainder(a,b,x$, q,r)
END IF
!!--- CALL ExGCD(b,r, u,v,c) !k=n-1,…,3,2 まで続ける
!!--- s=v
DIM u(0 TO MAX_TERM, 0 TO N)
CALL PolyExtendedGCD(b,r,x$, u,s,c)
!!--- t=u-v*q
DIM w(0 TO MAX_TERM, 0 TO N)
CALL PolyMultiply(s,q, w)
CALL PolySubtract(u, w, t)
END IF
END SUB
Maxima 5.31.2 http://maxima.sourceforge.net
using Lisp GNU Common Lisp (GCL) GCL 2.6.8 (a.k.a. GCL)
Distributed under the GNU Public License. See the file COPYING.
Dedicated to the memory of William Schelter.
The function bug_report() provides bug reporting information.
(%i1) display2d:false;
(%o1) false
(%i2) algebraic: ture;
(%o2) ture
(%i3) ratsimp(1/(sqrt(a)+sqrt(b)+sqrt(c)));
(%o3) (sqrt(c)*(c-b+2*sqrt(a)*sqrt(b)-a)+sqrt(b)*(-c+b-a)+sqrt(a)
*(-c-b+a))
/(c^2+(-2*b-2*a)*c+b^2-2*a*b+a^2)
(%i4) ratsimp(1/(sqrt(a)+sqrt(b)+sqrt(c)+sqrt(d)));
(%o4) (sqrt(d)*(d^3+sqrt(c)*(sqrt(a)*(2*d^2+(-4*c+4*b-4*a)*d+2*c^2
+(4*b-4*a)*c-6*b^2+4*a*b
+2*a^2)
+sqrt(b)*(2*d^2+(-4*c-4*b+4*a)*d+2*c^2
+(4*a-4*b)*c+2*b^2+4*a*b
-6*a^2))
+sqrt(a)*sqrt(b)
*(2*d^2+(4*c-4*b-4*a)*d-6*c^2+(4*b+4*a)*c
+2*b^2-4*a*b+2*a^2)+(-3*c-3*b-3*a)*d^2
+(3*c^2+(2*b+2*a)*c+3*b^2+2*a*b+3*a^2)*d-c^3+(b+a)*c^2
+(b^2-10*a*b+a^2)*c-b^3+a*b^2+a^2*b-a^3)
+sqrt(c)*(-d^3+(3*c+b+a)*d^2
+sqrt(a)*sqrt(b)
*(-6*d^2+(4*c+4*b+4*a)*d+2*c^2+(-4*b-4*a)*c+2*b^2
-4*a*b+2*a^2)
+(-3*c^2+(2*b+2*a)*c+b^2-10*a*b+a^2)*d+c^3+(-3*b-3*a)*c^2
+(3*b^2+2*a*b+3*a^2)*c-b^3+a*b^2+a^2*b-a^3)
+sqrt(b)*(-d^3+(c+3*b+a)*d^2+(c^2+(2*b-10*a)*c-3*b^2+2*a*b+a^2)*d-c^3
+(3*b+a)*c^2+(-3*b^2+2*a*b+a^2)*c+b^3-3*a*b^2+3*a^2*b-a^3)
+sqrt(a)*(-d^3+(c+b+3*a)*d^2+(c^2+(2*a-10*b)*c+b^2+2*a*b-3*a^2)*d-c^3
+(b+3*a)*c^2+(b^2+2*a*b-3*a^2)*c-b^3+3*a*b^2-3*a^2*b+a^3))
/(d^4+(-4*c-4*b-4*a)*d^3+(6*c^2+(4*b+4*a)*c+6*b^2+4*a*b+6*a^2)*d^2
+(-4*c^3+(4*b+4*a)*c^2+(4*b^2-40*a*b+4*a^2)*c-4*b^3+4*a*b^2+4*a^2*b
-4*a^3)
*d+c^4+(-4*b-4*a)*c^3+(6*b^2+4*a*b+6*a^2)*c^2
+(-4*b^3+4*a*b^2+4*a^2*b-4*a^3)*c+b^4-4*a*b^3+6*a^2*b^2-4*a^3*b
+a^4)
(%i5) ratsimp(1/(a^(1/2)+b^(1/3)));
(%o5) -(b^(1/3)*(sqrt(a)*b-a^2)-a*b+(a^(3/2)-b)*b^(2/3)+a^(5/2))/(b^2
-a^3)
(%i6) ratsimp(1/(a^(1/3)+b^(1/3)));
(%o6) (b^(2/3)-a^(1/3)*b^(1/3)+a^(2/3))/(b+a)
(%i7) ratsimp(1/(a^(1/3)+b^(1/3)+c^(1/3)));
(%o7) -(c^(1/3)*(b^(1/3)*(c^2+(2*b-a)*c+b^2-a*b-2*a^2)
+a^(1/3)*(c^2+(2*a-b)*c-2*b^2-a*b+a^2)
+a^(2/3)*b^(2/3)*(-6*c+3*b+3*a))
+c^(2/3)*(-c^2+a^(1/3)*b^(2/3)*(3*c+3*b-6*a)
+a^(2/3)*b^(1/3)*(3*c-6*b+3*a)+(-2*b-2*a)*c-b^2+7*a*b-a^2)
+a^(2/3)*(-c^2+(7*b-2*a)*c-b^2-2*a*b-a^2)
+b^(2/3)*(-c^2+(7*a-2*b)*c-b^2-2*a*b-a^2)
+a^(1/3)*b^(1/3)*(-2*c^2+(-b-a)*c+b^2+2*a*b+a^2))
/(c^3+(3*b+3*a)*c^2+(3*b^2-21*a*b+3*a^2)*c+b^3+3*a*b^2+3*a^2*b+a^3)
LET A=2
LET B=3
LET SS=SGN(A-B)
PRINT "1/(SQR(";A;")+SQR(";B;"))"
PRINT "=(";SIGN$(SS);"SQR(";A;")";SIGN$(-SS);"SQR(";B;"))/";ABS(A-B)
PRINT
LET A=2
LET B=3
LET C=5
PRINT "1/(SQR(";A;")+SQR(";B;")+SQR(";C;"))"
LET SS=SGN((A+B-C)^2-4*A*B)
PRINT "=(";SS*(A-B-C);"*SQR(";A;")";SIGN$(SS*(-A+B-C));"*SQR(";B;")";SIGN$(SS*(A+B-C));"*SQR(";C;")";SIGN$(SS);"2*SQR(";A*B*C;"))/";ABS((A+B-C)^2-4*A*B)
END
EXTERNAL FUNCTION SIGN$(X)
IF ABS(X)=1 THEN
IF X<0 THEN LET SIGN$="-" ELSE LET SIGN$="+"
ELSE
IF X<0 THEN LET SIGN$="-"&STR$(-X) ELSE LET SIGN$="+"&STR$(X)
END IF
END FUNCTION
DECLARE EXTERNAL FUNCTION COMB
OPTION BASE 0
DIM X(8),T(8)
!'最小多項式
!'(x-(a+b+c))(x-(a+b-c))(x-(a-b+c))(x-(a-b-c))(x-(-a+b+c))(x-(-a+b-c))(x-(-a-b+c))(x-(-a-b-c))
!'(x-a)(x-b)=x^2-(a+b)x+ab
!'(x-a)(x-b)(x-c)=x^3-(a+b+c)x^2+(ab+bc+ca)x-abc
!'(x-a)(x-b)(x-c)(x-d)=x^4-(a+b+c+d)x^3+(ab+ac+ad+bc+bd+cd)x^2-(abc+abd+bcd+acd)x+abcd
LET A=SQR(2)
LET B=SQR(3)
LET C=SQR(5)
FOR I=1 TO -1 STEP -2
FOR J=1 TO -1 STEP -2
FOR K=1 TO -1 STEP -2
LET N=N+1
LET X(N)=I*A+J*B+K*C
PRINT "(X";SIGN$(-X(N));")";
NEXT K
NEXT J
NEXT I
PRINT
FOR I=N TO 0 STEP-1
LET K=(-1)^(N-I)*COMB(X,N,N-I,T,1)
IF ABS(K)<1E-6 THEN LET K=0
IF ABS(FP(K))<1E-6 THEN LET K=SGN(K)*INT(ABS(K))
IF I=1 THEN
PRINT SIGN$(K);"*X";
ELSEIF I=N THEN
PRINT "X^";STR$(I);
ELSEIF I>0 THEN
IF K<>0 THEN PRINT SIGN$(K);"*X^";STR$(I);
ELSE
PRINT SIGN$(K)
END IF
NEXT I
END
EXTERNAL FUNCTION SIGN$(X)
IF ABS(X)=1 THEN
IF X<0 THEN LET SIGN$="-" ELSE LET SIGN$=""
ELSE
IF X<0 THEN LET SIGN$="-"&STR$(ABS(X)) ELSE LET SIGN$="+"&STR$(X)
END IF
END FUNCTION
EXTERNAL FUNCTION COMB(X(),N,R,A(),K)
IF R=0 THEN
LET S=1
FOR I=1 TO N
IF A(I)=1 THEN LET S=S*X(I)
NEXT I
LET COMB=S
ELSE
FOR I=K TO N-R+1
LET A(I)=1
LET SS=SS+COMB(X,N,R-1,A,I+1)
LET A(I)=0
NEXT I
LET COMB=SS
END IF
END FUNCTION
LET N=6
DIM A$(N,N),B$(N),Y$(N),X$(N,N)
FOR I=1 TO N
LET B$(I)="Y("&STR$(I)&")"
FOR J=1 TO N
LET A$(I,J)="X("&STR$(I)&","&STR$(J)&")"
NEXT J
NEXT I
PRINT "行列式"
FOR I=2 TO N
PRINT "DET"&STR$(I)&"=";
PRINT DET$(I,A$)
PRINT
NEXT I
PRINT
FOR I=2 TO N
PRINT "逆行列";I;"*";I
CALL INV(I,A$,X$)
FOR J=1 TO I
FOR K=1 TO I
PRINT "X("&STR$(J)&","&STR$(K)&")=";X$(J,K)
NEXT K
NEXT J
PRINT
NEXT I
PRINT
FOR I=2 TO N
MAT Y$=NUL$
CALL CRAMER(I,A$,B$,Y$)
PRINT STR$(I);"元連立一次方程式"
FOR J=1 TO I
PRINT "X(";STR$(J);")=";Y$(J)
NEXT J
PRINT
NEXT I
END
EXTERNAL FUNCTION DET$(N,X$(,))
IF N=1 THEN
LET DET$=X$(1,1)
EXIT FUNCTION
ELSEIF N=2 THEN
LET DET$=X$(1,1)&"*"&X$(2,2)&"-"&X$(2,1)&"*"&X$(1,2)
EXIT FUNCTION
END IF
DIM D$(N),A$(N-1,N-1)
FOR K=1 TO N
FOR I=1 TO N-1
FOR J=1 TO N-1
IF I>=K THEN
LET A$(I,J)=X$(I+1,J+1)
ELSE
LET A$(I,J)=X$(I,J+1)
END IF
NEXT J
NEXT I
LET D$(K)=DET$(N-1,A$)
NEXT K
FOR I=1 TO N
IF D$(I)(1:1)="+" THEN LET D$(I)(1:1)=""
IF MOD(I,2)=1 THEN
LET S$=S$&"+"&X$(I,1)&"*("&D$(I)&")"
ELSE
LET S$=S$&"-"&X$(I,1)&"*("&D$(I)&")"
END IF
NEXT I
IF S$(1:1)="+" THEN LET S$(1:1)=""
LET DET$=S$
END FUNCTION
EXTERNAL SUB INV(N,A$(,),B$(,))
DIM X$(N-1,N-1)
LET D$=DET$(N,A$)
FOR I=1 TO N
FOR J=1 TO N
LET P=0
LET Q=0
FOR K=1 TO N
IF I<>K THEN
LET P=P+1
LET Q=0
FOR L=1 TO N
IF J<>L THEN
LET Q=Q+1
LET X$(P,Q)=A$(K,L)
END IF
NEXT L
END IF
NEXT K
IF (-1)^(I+J)=-1 THEN LET SIGN$="-" ELSE LET SIGN$=""
LET B$(I,J)=SIGN$&"("&DET$(N-1,X$)&")/("&D$&")"
NEXT J
NEXT I
FOR I=1 TO N-1
FOR J=I+1 TO N
SWAP B$(I,J),B$(J,I)
NEXT J
NEXT I
END SUB
EXTERNAL SUB CRAMER(N,X$(,),Y$(),D$())
DIM A$(N,N)
FOR I=1 TO N
FOR J=1 TO N
LET A$(I,J)=X$(I,J)
NEXT J
NEXT I
LET DD$=DET$(N,A$)
FOR K=1 TO N
FOR I=1 TO N
FOR J=1 TO N
IF J=K THEN LET A$(I,J)=Y$(I) ELSE LET A$(I,J)=X$(I,J)
NEXT J
NEXT I
IF DD$(1:1)="+" THEN LET DD$(1:1)=""
LET D$(K)="("&DET$(N,A$)&")/("&DD$&")"
NEXT K
END SUB
> LET A=2
> LET B=3
> LET C=5
> PRINT "1/(SQR(";A;")+SQR(";B;")+SQR(";C;"))"
> LET SS=SGN((A+B-C)^2-4*A*B)
> PRINT "=(";SS*(A-B-C);"*SQR(";A;")";SIGN$(SS*(-A+B-C));"*SQR(";B;")";SIGN$(SS*(A+B-C));"*SQR(";C;")";SIGN$(SS);"2*SQR(";A*B*C;"))/";ABS((A+B-C)^2-4*A*B)
> END
>
> EXTERNAL FUNCTION SIGN$(X)
> IF ABS(X)=1 THEN
> IF X<0 THEN LET SIGN$="-" ELSE LET SIGN$="+"
> ELSE
> IF X<0 THEN LET SIGN$="-"&STR$(-X) ELSE LET SIGN$="+"&STR$(X)
> END IF
> END FUNCTION
>
LET A=7
LET B=11
LET C=13
PRINT "1/(SQR(";A;")+SQR(";B;")+SQR(";C;"))"
LET SS=SGN((A+B-C)^2-4*A*B)
IF MOD(A-B-C,2)=0 AND MOD(-A+B-C,2)=0 AND MOD(C-A-B,2)=0 AND MOD((A+B-C)^2-4*A*B,2)=0 THEN LET S=2 ELSE LET S=1
PRINT "(";SIGN$(SS*(A-B-C)/S);"SQR(";A;")";SIGN$(SS*(-A+B-C)/S);"SQR(";B;")";SIGN$(SS*(C-A-B)/S);"SQR(";C;")";SIGN$(SS*2/S);"SQR(";A*B*C;"))/";ABS((A+B-C)^2-4*A*B)/S
END
EXTERNAL FUNCTION SIGN$(X)
IF ABS(X)=1 THEN
IF X<0 THEN LET SIGN$="-" ELSE LET SIGN$="+"
ELSE
IF X<0 THEN LET SIGN$="-"&STR$(-X)&"*" ELSE LET SIGN$="+"&STR$(X)&"*"
END IF
END FUNCTION
PUBLIC STRING v$ !変数の定義 ※必要なものだけの列記でもよい
LET v$="ABCDEFPQRxyz"
PUBLIC NUMERIC N !変数の数
LET N=LEN(v$)
PUBLIC NUMERIC MAX_TERM !最大の項数
LET MAX_TERM=50
!------------------------------ ここまでがサブルーチン
DIM f(0 TO MAX_TERM, 0 TO N), g(0 TO MAX_TERM, 0 TO N)
CALL PolySet("Ax+By-P", f)
CALL PolySet("Cx+Dy-Q", g)
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL PolyQuotientRemainder(f,g,"x", q,r) !※←←←←←
CALL PolyPrint(q) !商
PRINT
CALL PolyPrint(r) !余り
PRINT
!整形する
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N)
CALL PolySet("C", s) !除数のyの係数より ※←←←←←
CALL PolyMultiply(r,s, t)
CALL PolyPrintCollect(t,"y") !結果を表示する ※←←←←←
PRINT
PUBLIC STRING v$ !変数の定義 ※必要なものだけの列記でもよい
LET v$="ABCDPQRxy"
PUBLIC NUMERIC N !変数の数
LET N=LEN(v$)
PUBLIC NUMERIC MAX_TERM !最大の項数
LET MAX_TERM=50
!------------------------------ ここまでがサブルーチン
DIM f(0 TO MAX_TERM, 0 TO N), g(0 TO MAX_TERM, 0 TO N)
CALL PolySet("x^2+y^2+Ax+By+C", f)
CALL PolySet("Px+Qy+R", g)
DIM q(0 TO MAX_TERM, 0 TO N), r(0 TO MAX_TERM, 0 TO N)
CALL PolyQuotientRemainder(f,g,"y", q,r) !※←←←←←
CALL PolyPrint(q) !商
PRINT
CALL PolyPrint(r) !余り
PRINT
!整形する
DIM s(0 TO MAX_TERM, 0 TO N), t(0 TO MAX_TERM, 0 TO N)
CALL PolySet("Q^2", s) !除数のyの係数より ※←←←←←
CALL PolyMultiply(r,s, t)
CALL PolyPrintCollect(t,"x") !結果を表示する ※←←←←←
PRINT
OPTION ARITHMETIC RATIONAL !多桁整数
FOR P=2 TO 100
IF P=prmdiv(P) THEN !PrimeQ
PRINT P
END IF
NEXT P
END
!ubasic.LIBより抜粋
EXTERNAL FUNCTION prmdiv(n) !1より大きな最小の約数 ※nは1より大きな整数
OPTION ARITHMETIC RATIONAL !多桁整数
IF MOD(n,2)=0 THEN !２の倍数
LET prmdiv=2
ELSEIF MOD(n,3)=0 THEN !３の倍数
LET prmdiv=3
ELSE
FOR i=5 TO INTSQR(n) STEP 6
IF MOD(n,i)=0 THEN !5,11,17,23,29,…
LET prmdiv=i
EXIT FUNCTION
ELSEIF MOD(n,i+2)=0 THEN !7,13,19,25,31,…
LET prmdiv=i+2
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
NEXT i
LET prmdiv=n !その数自身
END IF
END FUNCTION
100 DECLARE EXTERNAL SUB test
110 ! エラトステネスの篩
120 DIM s(1000)
130 MAT s=ZER
140 FOR i=2 TO 1000
150 IF s(i)=0 THEN
160 CALL test(i)
170 FOR j=i^2 TO 1000 STEP i
180 LET s(j)=1
190 NEXT j
200 END IF
210 NEXT i
220 END
1000 EXTERNAL SUB test(p)
1010 PRINT p
1020 END SUB
100 DECLARE EXTERNAL FUNCTION Primes.NextPrime
110 DO
120 PRINT nextPrime
130 LOOP
140 END
1000 MODULE Primes
1010 PUBLIC FUNCTION NextPrime
1020 SHARE NUMERIC s(2 TO 100000), CurPrime
1030 MAT s=ZER
1040 LET CurPrime=1
1050 EXTERNAL FUNCTION NextPrime
1060 DO
1070 LET CurPrime=CurPrime+1
1080 LOOP UNTIL s(CurPrime)=0
1090 LET NextPrime=CurPrime
1100 FOR j=CurPrime^2 TO 100000 STEP CurPrime
1110 LET s(j)=1
1120 NEXT j
1130 END FUNCTION
1140 END MODULE
100 DECLARE EXTERNAL SUB Primes.NextPrime
110 DECLARE EXTERNAL NUMERIC Primes.CurPrime
120 DO
130 CALL NextPrime
140 PRINT CurPrime
150 LOOP
160 END
1000 MODULE Primes
1010 PUBLIC SUB NextPrime
1020 PUBLIC NUMERIC CurPrime
1030 SHARE NUMERIC s(2 TO 100000)
1040 MAT s=ZER
1050 LET CurPrime=1
1060 EXTERNAL SUB NextPrime
1070 DO
1080 LET CurPrime=CurPrime+1
1090 LOOP UNTIL s(CurPrime)=0
1100 FOR j=CurPrime^2 TO 100000 STEP CurPrime
1110 LET s(j)=1
1120 NEXT j
1130 END SUB
1140 END MODULE
REM 関数 NextPrime(n) … nより大きい最小の素数。nは整数でなくともよい。
DECLARE EXTERNAL FUNCTION Primes.NextPrime
LET p=1
FOR i=1 TO 30
LET p=NextPrime(p)
PRINT p
NEXT i
RANDOMIZE
FOR i=1 TO 30
LET a=INT(100000*RND)
LET p=NextPrime(a)
PRINT a;p
NEXT i
PRINT NextPrime(99990) ! maxn=100000のときの最大素数は99991。これより大きい引数はエラー。
END
!
MODULE Primes
PUBLIC FUNCTION NextPrime
SHARE NUMERIC s(33333),maxn,MaxPrime ! 配列sのサイズは変更可能だが、必ず定数で指定。
LET maxn=3*SIZE(s)+1 ! maxnまでの素数に対応
MAT s=ZER
WHEN EXCEPTION IN
FOR i=8 TO maxn STEP 10 ! 5の倍数
LET s(i)=1
LET s(i+3)=1
NEXT i
USE
END WHEN
LET MaxPrime=5
! j=5,7,11,13,17,19,23,25,29,31,35,37,41,43,47,49,53,55,59,61,65,67,71,73,77,79
! INT(j/3)=1,2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
!s(INT(j/3))=0,0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 0
EXTERNAL FUNCTION NextPrime(n)
IF n<5 THEN
LET NextPrime=5
IF n<3 THEN LET NextPrime=3
IF n<2 THEN LET NextPrime=2
EXIT FUNCTION
END IF
LET n=INT(n)
LET k=MOD(n,6)
IF k<>1 AND k<>5 THEN LET n=n-ABS(k-1)
IF n<=MaxPrime^2 THEN CALL PrimeCheck(n)
!
IF MOD(MaxPrime,6)=1 THEN LET add=4 ELSE LET add=2
WHEN EXCEPTION IN
DO ! エラトステネスの篩
LET ex=1
DO
LET MaxPrime=MaxPrime+add
LET add=6-add
LOOP UNTIL s(INT(MaxPrime/3))=0
LET ex=0
FOR j=MaxPrime^2 TO maxn STEP 6*MaxPrime
LET s(INT(j/3))=1
IF MOD(j+2*MaxPrime,3)>0 THEN LET s(INT((j+2*MaxPrime)/3))=1 ELSE LET s(INT((j+4*MaxPrime)/3))=1
NEXT j
LOOP UNTIL MaxPrime>=INT(SQR(n))
USE
IF ex=1 THEN EXIT FUNCTION ! エラー NextPrime=0
END WHEN
CALL PrimeCheck(n)
SUB PrimeCheck(p) ! pより大きい素数の検索
IF MOD(p,6)=1 THEN LET add=4 ELSE LET add=2
WHEN EXCEPTION IN
DO
LET p=p+add
LET add=6-add
LOOP UNTIL s(INT(p/3))=0
LET NextPrime=p
USE ! エラー NextPrime=0
END WHEN
EXIT FUNCTION
END SUB
END FUNCTION
END MODULE
LET XSIZE=400
LET YSIZE=400
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
RANDOMIZE
FOR I=0 TO 15 !'適当にパレットを変更
LET R=RND
LET G=RND
LET B=RND
SET COLOR MIX(I) R,G,B
NEXT I
LET N=0
FOR R=200 TO 20 STEP -20
SET COLOR N
DRAW DISK WITH SCALE(R)*SHIFT(200,200)
LET N=N+1
NEXT R
GSAVE "TEST.bmp","4bit" !'16色モードでBMP保存する
END
