OPTION ARITHMETIC COMPLEX
DIM Y(10)
CALL GINIT(800,800)
LET X=COMPLEX(1,0) !'←ここの数字を変えて下さい
LET Z=SQR(ABS(X))*1.1
SET WINDOW -Z,Z,-Z,Z
FOR N=2 TO 10
CLEAR
DRAW GRID(Z/11,Z/11)
LET R=ABS(X)^(1/N)
LET TH=ANGLE(RE(X),IM(X))
FOR J=1 TO N
LET Y(J)=R*EXP(SQR(-1)*((TH+2*PI*J)/N)) !'ド・モアブルの定理
PRINT J;":";Y(J),Y(J)^N
NEXT J
PRINT
FOR J=1 TO N
SET COLOR 4
DRAW DISK WITH SCALE(.02)*SHIFT(Y(J))
SET COLOR 2
PLOT LINES:Y(J);
NEXT J
PLOT LINES:Y(1)
IF N<10 THEN
INPUT PROMPT "HIT RETURN KEY":A$
!' PAUSE
END IF
NEXT N
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 2
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
(※どうしても実行が遅い時はBasicAcc or BasicAcc2(旧 ParactBasic)をご使用ください)
OPTION ARITHMETIC COMPLEX
LET XSIZE=800 !'画像サイズ
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET LEFT=-1.5 !'計算領域
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET KS=100 !'計算精度(計算回数) ※要調整
LET EPS=1E-5 !'収束判定精度 ※要調整
DIM Z(8)
LET Z(1)=COMPLEX(1,0) !'Z^8-17*Z^4+16の解
LET Z(2)=COMPLEX(-1,0)
LET Z(3)=COMPLEX(0,1)
LET Z(4)=COMPLEX(0,-1)
LET Z(5)=COMPLEX(2,0)
LET Z(6)=COMPLEX(-2,0)
LET Z(7)=COMPLEX(0,2)
LET Z(8)=COMPLEX(0,-2)
DO
CLEAR
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF(X,1) !'NEWTON法(2次収束式)
!'LET XX=X+(4*FUNC(X)^3*DIFF(X,3)-24*FUNC(X)^2*DIFF(X,1)*DIFF(X,2)+24*FUNC(X)*DIFF(X,1)^3)/(FUNC(X)^3*DIFF(X,4)-8*FUNC(X)^2*DIFF(X,1)*DIFF(X,3)-6*FUNC(X)^2*DIFF(X,2)^2+36*FUNC(X)*DIFF(X,1)^2*DIFF(X,2)-24*DIFF(X,1)^4) !'5次収束式
USE
CALL PSET(ZR,ZI,255) !'発散!?
EXIT FOR
END WHEN
LET FL=0
FOR I=1 TO 8
IF ABS(XX-Z(I))<EPS THEN !'収束判定
CALL PSET(ZR,ZI,I)
LET FL=1 !'フラグ
EXIT FOR
END IF
NEXT I
IF FL=1 THEN EXIT FOR
NEXT K
NEXT ZI
NEXT ZR
PAUSE "拡大する範囲を指定してください"
CALL GETSQUARE(LEFT,TOP,RIGHT,BOTTOM)
PRINT "LET LEFT=";LEFT !'計算区間を表示 (コピペして再計算)
PRINT "LET RIGHT=";RIGHT
PRINT "LET BOTTOM=";BOTTOM
PRINT "LET TOP=";TOP
PRINT "LET KS=";KS
PRINT "LET EPS=";EPS
PRINT
IF LEFT=RIGHT THEN EXIT DO
LOOP
END
EXTERNAL FUNCTION FUNC(Z)
OPTION ARITHMETIC COMPLEX
LET FUNC=Z^8-17*Z^4+16
END FUNCTION
EXTERNAL FUNCTION DIFF(X,N) !'再帰呼び出しによる高階数値微分
OPTION ARITHMETIC COMPLEX
LET H=1/256 !' H=1/2^n の形
!'LET H=1/1024
IF N=0 THEN
LET DIFF=FUNC(X)
EXIT FUNCTION
ELSE
LET DIFF=(DIFF(X+H,N-1)-DIFF(X-H,N-1))/(2*H) !'3点微分
!'LET DIFF=(-DIFF(X+2*H,N-1)+8*DIFF(X+H,N-1)-8*DIFF(X-H,N-1)+DIFF(X-2*H,N-1))/(12*H) !'5点微分
!'LET DIFF=(DIFF(X+3*H,N-1)-9*DIFF(X+2*H,N-1)+45*DIFF(X+H,N-1)-45*DIFF(X-H,N-1)+9*DIFF(X-2*H,N-1)-DIFF(X-3*H,N-1))/(60*H) !'7点微分
!'LET DIFF=(-3*DIFF(X+4*H,N-1)+32*DIFF(X+3*H,N-1)-168*DIFF(X+2*H,N-1)+672*DIFF(X+H,N-1)-672*DIFF(X-H,N-1)+168*DIFF(X-2*H,N-1)-32*DIFF(X-3*H,N-1)+3*DIFF(X-4*H,N-1))/(840*H) !'9点微分
END IF
END FUNCTION
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
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
SET COLOR MIX(255) .5,.5,.5
CLEAR
END SUB
EXTERNAL SUB GETSQUARE(L,T,R,B)
OPTION ARITHMETIC COMPLEX
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
EXTERNAL FUNCTION CSIN(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CSIN=(EXP(Z*I)-EXP(-Z*I))/2/I
END FUNCTION
EXTERNAL FUNCTION CCOS(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CCOS=(EXP(Z*I)+EXP(-Z*I))/2
END FUNCTION
EXTERNAL FUNCTION CTAN(Z)
OPTION ARITHMETIC COMPLEX
LET CTAN=CSIN(Z)/CCOS(Z)
END FUNCTION
EXTERNAL FUNCTION CACOS(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CACOS=-I*LOG(Z+I*SQR(1-Z*Z))
!' LET CACOS=I*LOG(Z-I*SQR(1-Z*Z))
END FUNCTION
EXTERNAL FUNCTION CASIN(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CASIN=-I*LOG(I*Z+SQR(1-Z*Z))
END FUNCTION
EXTERNAL FUNCTION CATAN(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CATAN=I/2*LOG((I+Z)/(I-Z))
!' LET CATAN=I/2*(LOG(1-I*Z)-LOG(1+I*Z))
END FUNCTION
EXTERNAL FUNCTION CACOSEC(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CACOSEC=-I*LOG(I/Z+SQR(1-1/Z/Z))
END FUNCTION
EXTERNAL FUNCTION CASEC(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CASEC=-LOG((1+SQR(1-Z*Z))/Z)/I
!'LET CASEC=-I*LOG(I*SQR(1-1/Z/Z)+1/Z)
END FUNCTION
EXTERNAL FUNCTION CACOTAN(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CACOTAN=I/2*LOG((Z-I)/(Z+I))
!'LET CACOTAN=I/2*(LLOG(1-I/Z)-LLOG(1+I/Z))
END FUNCTION
EXTERNAL FUNCTION CSEC(Z)
OPTION ARITHMETIC COMPLEX
LET CSEC=1/CCOS(Z)
END FUNCTION
EXTERNAL FUNCTION CCOSEC(Z)
OPTION ARITHMETIC COMPLEX
LET CCOSEC=1/CSIN(Z)
END FUNCTION
EXTERNAL FUNCTION CSINH(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CSINH=-I*CSIN(Z*I)
!'LET CSINH=(EXP(Z)-EXP(-Z))/2
END FUNCTION
EXTERNAL FUNCTION CCOSH(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CCOSH=CCOS(Z*I)
!'LET CCOSH=(EXP(Z)+EXP(-Z))/2
END FUNCTION
EXTERNAL FUNCTION CTANH(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CTANH=-I*CTAN(Z*I)
END FUNCTION
EXTERNAL FUNCTION CCOTAN(Z)
OPTION ARITHMETIC COMPLEX
LET CCOTAN=1/CTAN(Z)
END FUNCTION
EXTERNAL FUNCTION CSECH(Z)
OPTION ARITHMETIC COMPLEX
LET CSECH=1/CCOSH(Z)
END FUNCTION
EXTERNAL FUNCTION CCOSECH(Z)
OPTION ARITHMETIC COMPLEX
LET CCOSECH=1/CSINH(Z)
END FUNCTION
EXTERNAL FUNCTION CCOTANH(Z)
OPTION ARITHMETIC COMPLEX
LET CCOTANH=1/CTANH(Z)
END FUNCTION
EXTERNAL FUNCTION CASINH(Z)
OPTION ARITHMETIC COMPLEX
LET CASINH=LOG(Z+SQR(Z*Z+1))
END FUNCTION
EXTERNAL FUNCTION CACOSH(Z)
OPTION ARITHMETIC COMPLEX
LET I=SQR(-1)
LET CACOSH=LOG(Z+SQR(Z+1)*SQR(Z-1))
END FUNCTION
EXTERNAL FUNCTION CATANH(Z)
OPTION ARITHMETIC COMPLEX
LET CATANH=LOG((1+Z)/(1-Z))/2
END FUNCTION
EXTERNAL FUNCTION CACOTANH(Z)
OPTION ARITHMETIC COMPLEX
LET CACOTANH=LOG((Z+1)/(Z-1))/2
END FUNCTION
EXTERNAL FUNCTION CACOSECH(Z)
OPTION ARITHMETIC COMPLEX
LET CACOSECH=LOG(1/Z+SQR(1/Z/Z+1))
END FUNCTION
EXTERNAL FUNCTION CASECH(Z)
OPTION ARITHMETIC COMPLEX
LET CASECH=LOG(1/Z+SQR(1/Z+1)*SQR(1/Z-1))
END FUNCTION
OPTION ARITHMETIC COMPLEX
LET XSIZE=800
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET LEFT=-1.5
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET EPS=1E-5
LET KS=100
CLEAR
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
LET X0=1
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-((X0-X)/(FUNC(X0)-FUNC(X)))*FUNC(X) !'SCANT法
LET X0=X
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^8-X^6+2*X^5+X^4+3*X^2-X+1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)^2/(FUNC(FUNC(X)+X)-FUNC(X)) !'STEFFENSEN法
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
!'LET FUNC=X^3-3^X
!'LET FUNC=EXP(X*LOG(X))-1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
LET X0=XX
LET X2=0
LET X1=(X0+X2)/2
FOR K=1 TO KS
WHEN EXCEPTION IN
LET TT=(X2-X1)/(X2-X0)*(FUNC(X2)-FUNC(X0))/(FUNC(X2)-FUNC(X1))*FUNC(X1)/FUNC(X0) !'OSTROWSKI法
LET X3=(X1-X0*TT)/(1-TT)
LET X0=X1
LET X1=X2
LET X2=X3
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(FUNC(X3))<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)*DIFF(X,1)/(DIFF(X,1)^2-DIFF(X,2)*FUNC(X))
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
EXTERNAL FUNCTION DIFF(X,N) !'再帰呼び出しによる高階数値微分
OPTION ARITHMETIC COMPLEX
LET H=1/256 !' H=1/2^n の形
!'LET H=1/1024
IF N=0 THEN
LET DIFF=FUNC(X)
EXIT FUNCTION
ELSE
LET DIFF=(DIFF(X+H,N-1)-DIFF(X-H,N-1))/(2*H) !'3点微分
!'LET DIFF=(-DIFF(X+2*H,N-1)+8*DIFF(X+H,N-1)-8*DIFF(X-H,N-1)+DIFF(X-2*H,N-1))/(12*H) !'5点微分
!'LET DIFF=(DIFF(X+3*H,N-1)-9*DIFF(X+2*H,N-1)+45*DIFF(X+H,N-1)-45*DIFF(X-H,N-1)+9*DIFF(X-2*H,N-1)-DIFF(X-3*H,N-1))/(60*H) !'7点微分
!'LET DIFF=(-3*DIFF(X+4*H,N-1)+32*DIFF(X+3*H,N-1)-168*DIFF(X+2*H,N-1)+672*DIFF(X+H,N-1)-672*DIFF(X-H,N-1)+168*DIFF(X-2*H,N-1)-32*DIFF(X-3*H,N-1)+3*DIFF(X-4*H,N-1))/(840*H) !'9点微分
END IF
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
WHEN EXCEPTION IN
LET X=XX
LET H=1
DO
LET H=H/2
LOOP UNTIL ABS(H*FUNC(X))<3
LET XX=X-H*FUNC(X) !'原始反復法
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET L=DIFF(X,1)*(FUNC(X)-FUNC(X-FUNC(X)/DIFF(X,1)))
IF L=0 THEN
LET XX=X
ELSE
LET XX=X-FUNC(X)^2/L !'改良ニュートン法
END IF
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET U=2
LET COUNT=0
DO
LET U=U/2
LET COUNT=COUNT+1
WHEN EXCEPTION IN
LET XX=X-U*FUNC(X)/DIFF(X,1) !'減速ニュートン法
USE
EXIT FOR
END WHEN
LOOP UNTIL ABS(FUNC(XX))<(1-U/2)*ABS(FUNC(X)) OR COUNT>=100
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/(DIFF(X,1)-DIFF(X,2)/2*FUNC(X)/DIFF(X,1)-DIFF(X,3)/6*(FUNC(X)/DIFF(X,1))^2-DIFF(X,4)/24*(FUNC(X)/DIFF(X,1))^3) !'拡張ニュートン法?
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^10-1
END FUNCTION
EXTERNAL FUNCTION DIFF(X,N)
OPTION ARITHMETIC COMPLEX
SELECT CASE N
CASE 1
LET DIFF=10*X^9
CASE 2
LET DIFF=10*9*X^8
CASE 3
LET DIFF=10*9*8*X^7
CASE 4
LET DIFF=10*9*8*7*X^6
END SELECT
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
LET X0=XX
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF(X0,1) !'修正ニュートン法?
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET X0=COMPLEX(ZR,ZI)
LET X1=FUNC(X0)
FOR K=1 TO KS
WHEN EXCEPTION IN
LET X2=X1+(X1-X0)/((X0-FUNC(X0))/(X1-FUNC(X1))-1) !'WEGSTEIN法
LET X0=X1
LET X1=X2
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(FUNC(X2)-X2)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
WHEN EXCEPTION IN
LET FUNC=X^3+X-1 !' f(x)+x
USE
END WHEN
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET X0=COMPLEX(ZR,ZI)
FOR K=1 TO KS
WHEN EXCEPTION IN
LET X1=FUNC(X0)
LET X2=FUNC(X1)
LET X3=X0-(X1-X0)*(X1-X0)/(X2-2*X1+X0) !' エイトケン法
LET X0=X3
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(FUNC(X0)-X0)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3+X-1 !' f(x)+x
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=(FUNC(X)+X)/2 !'相加平均
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=1/X^2 !' x^3-1=0 → x^3=1 → x=1/x^2
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-H(X)/DH(X) !'ハリー法
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
EXTERNAL FUNCTION H(X)
OPTION ARITHMETIC COMPLEX
LET H=FUNC(X)/SQR(DIFF(X,1))
END FUNCTION
EXTERNAL FUNCTION DH(X)
OPTION ARITHMETIC COMPLEX
LET DH=SQR(DIFF(X,1))-FUNC(X)*DIFF(X,2)/(2*DIFF(X,1)*SQR(DIFF(X,1)))
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=FUNC(X) !'逐次代入法
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS((X+1)*(X+1)*(X+1)-3)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=2/(X*X+3*X+3) !'X=3^(1/3)-1 → (X+1)^3=3 → X*(X^2+3*X+3)=2 → X=2/(X^2+3*X+3)
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF(X,1)*(1+FUNC(X)*DIFF(X,2)/2/DIFF(X,1)^2) !'HOUSEHOLDER法
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
EXTERNAL FUNCTION DIFF(X,N) !'高階数値微分
OPTION ARITHMETIC COMPLEX
LET H=1/128
IF MOD(N,2)=1 THEN LET SIGN=-1 ELSE LET SIGN=1
FOR I=0 TO N
LET S=S+(-1)^I*COMB(N,I)*FUNC(X-(N-2*I)*H)*SIGN
NEXT I
LET DIFF=S/((2*H)^N)
END FUNCTION
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=FUNC(X) !'定点法
IF ABS(XX-X)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X) !' X^8-X^6+2*X^5+X^4+3*X^2-X+1=0 → 3*X^2=-X^8+X^6-2*X^5-X^4+X-1
OPTION ARITHMETIC COMPLEX
LET FUNC=SQR((-X^8+X^6-2*X^5-X^4+X-1)/3)
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET X1=COMPLEX(ZR,ZI)
LET X2=(1+X1)/2
LET X3=1
FOR K=1 TO KS
WHEN EXCEPTION IN
LET Q=(X3-X2)/(X2-X1)
LET A=Q*FUNC(X3)-Q*(1+Q)*FUNC(X2)+Q^2*FUNC(X1)
LET B=(2*Q+1)*FUNC(X3)-(1+Q)^2*FUNC(X2)+Q^2*FUNC(X1)
LET C=(1+Q)*FUNC(X3)
LET DD=B^2-4*A*C
IF ABS(B+SQR(DD))>ABS(B-SQR(DD)) THEN
LET X4=X3-(X3-X2)*2*C/(B+SQR(DD)) !'Muller法
ELSE
LET X4=X3-(X3-X2)*2*C/(B-SQR(DD))
END IF
LET X1=X2
LET X2=X3
LET X3=X4
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(FUNC(X4))<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^8-X^6+2*X^5+X^4+3*X^2-X+1
END FUNCTION
------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
PUBLIC NUMERIC N
LET XSIZE=800
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET LEFT=-1.5
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET EPS=1E-5
LET KS=100
LET N=3
CLEAR
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET L=(N-1)*(N*H(X)-G(X)^2)
!'IF ABS(G(X)+L)>ABS(G(X)-L) THEN
LET XX=X-N/(G(X)+L) !' Laguerre法
!'ELSE
!' LET XX=X-N/(G(X)-L)
!'END IF
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^N-1
END FUNCTION
EXTERNAL FUNCTION DIFF(X)
OPTION ARITHMETIC COMPLEX
LET DIFF=N*X^(N-1)
END FUNCTION
EXTERNAL FUNCTION DIFF2(X)
OPTION ARITHMETIC COMPLEX
LET DIFF2=N*(N-1)*X^(N-2)
END FUNCTION
EXTERNAL FUNCTION G(X)
OPTION ARITHMETIC COMPLEX
LET G=FUNC(X)/DIFF(X)
END FUNCTION
EXTERNAL FUNCTION H(X)
OPTION ARITHMETIC COMPLEX
LET H=G(X)^2-DIFF2(X)/FUNC(X)
END FUNCTION
------------------------------------------------------------------------------
OPTION ARITHMETIC COMPLEX
PUBLIC NUMERIC N,R
LET XSIZE=800
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET LEFT=-1.5
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET EPS=1E-5
LET KS=100
LET N=3
LET R=1
CLEAR
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=H(X) !'Lambert's法
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^N-R
END FUNCTION
EXTERNAL FUNCTION H(X)
OPTION ARITHMETIC COMPLEX
LET H=((N-1)*X^N+(N+1)*R)/((N+1)*X^N+(N-1)*R)*X
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET X1=COMPLEX(ZR,ZI)
LET X2=(1+X1)/2
LET X3=0
FOR K=1 TO KS
WHEN EXCEPTION IN
LET XX=X2+P(X1,X2,X3)/Q(X1,X2,X3) !'Brent's法
LET X3=X2
LET X2=X1
LET X1=XX
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(FUNC(XX))<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
EXTERNAL FUNCTION P(X1,X2,X3)
OPTION ARITHMETIC COMPLEX
LET P=S(X1,X2)*(T(X1,X3)*(R(X2,X3)-T(X1,X3))*(X3-X2)-(1-R(X2,X3))*(X2-X1))
END FUNCTION
EXTERNAL FUNCTION Q(X1,X2,X3)
OPTION ARITHMETIC COMPLEX
LET Q=(T(X1,X3)-1)*(R(X2,X3)-1)*(S(X1,X2)-1)
END FUNCTION
EXTERNAL FUNCTION R(X2,X3)
OPTION ARITHMETIC COMPLEX
LET R=FUNC(X2)/FUNC(X3)
END FUNCTION
EXTERNAL FUNCTION S(X1,X2)
OPTION ARITHMETIC COMPLEX
LET S=FUNC(X2)/FUNC(X1)
END FUNCTION
EXTERNAL FUNCTION T(X1,X3)
OPTION ARITHMETIC COMPLEX
LET T=FUNC(X1)/FUNC(X3)
END FUNCTION
------------------------------------------------------------------------------
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET X1=COMPLEX(ZR,ZI)
LET X2=1
FOR K=1 TO KS
WHEN EXCEPTION IN
LET XX=X1-(X2-X1)/(FUNC(X2)-FUNC(X1))*FUNC(X1) !'Method of False Position法
LET X2=XX
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(FUNC(XX))<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^8-X^6+2*X^5+X^4+3*X^2-X+1
END FUNCTION
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM XX(3),X(3),S$(5),ST(6)
LET XSIZE=800 !'画像サイズ
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
MAT READ S$
LOCATE CHOICE(S$) : N
DATA "X-Y平面 Z=A,W=B"
DATA "X-Z平面 Y=A,W=B"
DATA "X-W平面 Y=A,Z=B"
DATA "Y-Z平面 X=A,W=B"
DATA "Y-W平面 X=A,Z=B"
DATA "Z-W平面 X=A,Y=B"
LOCATE VALUE(1) ,RANGE -1.5 TO 1.5 ,AT 0: A
LOCATE VALUE(2) ,RANGE -1.5 TO 1.5 ,AT 0: B
SELECT CASE N
CASE 1
PRINT "X-Y平面 Z=";A;", W=";B
CASE 2
PRINT "X-Z平面 Y=";A;", W=";B
CASE 3
PRINT "X-W平面 Y=";A;", Z=";B
CASE 4
PRINT "Y-Z平面 X=";A;", W=";B
CASE 5
PRINT "Y-W平面 X=";A;", Z=";B
CASE 6
PRINT "Z-W平面 X=";A;", Y=";B
END SELECT
LET LEFT=-1.5
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET KS=100
LET EPS=1E-5
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
MAT READ ST
DATA 1,7,11,13,17,19,23
FOR I=6 TO 0 STEP -1
FOR ZR=LEFT TO RIGHT STEP DX*ST(I)
FOR ZI=BOTTOM TO TOP STEP DY*ST(I)
SELECT CASE N
CASE 1
CALL QSET(XX,ZR,ZI,A,B) !' X-Y平面 Z=A,W=B 切断面
CASE 2
CALL QSET(XX,ZR,A,ZI,B) !' X-Z平面 Y=A,W=B 切断面
CASE 3
CALL QSET(XX,ZR,A,B,ZI) !' X-W平面 Y=A,Z=B 切断面
CASE 4
CALL QSET(XX,A,ZR,ZI,B) !' Y-Z平面 X=A,W=B 切断面
CASE 5
CALL QSET(XX,A,ZR,B,ZI) !' Y-W平面 X=A,Z=B 切断面
CASE 6
CALL QSET(XX,A,B,ZR,ZI) !' Z-W平面 X=A,Y=B 切断面
END SELECT
FOR K=1 TO KS
MAT X=XX
CALL NEWTON(X,XX) !' xx=x-f(x)/f'(x) ニュートン法
IF QABS(XX,X)<EPS THEN !'収束判定
CALL PSET(ZR,ZI,MOD(K,7)+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
NEXT I
END
EXTERNAL FUNCTION QABS(X(),Y())
OPTION ARITHMETIC NATIVE
FOR I=0 TO 3
LET A=A+(X(I)-Y(I))^2
NEXT I
LET QABS=SQR(A)
END FUNCTION
EXTERNAL SUB NEWTON (X(),XX())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM A(3,3),Y1(3),Y2(3)
RESTORE
FOR I=3 TO 0 STEP -1
FOR J=0 TO 3
READ A(I,J)
NEXT J
NEXT I
DATA 1,0,0,0 !'(1+0i+0j+0k)*X^3
DATA 0,0,0,0 !'(0+0i+0j+0k)*X^2
DATA 0,0,0,0 !'(0+0i+0j+0k)*X
DATA -1,0,0,0 !'(-1+0i+0j+0k)
CALL HORNER(3,A,X,Y1) !' f(X)=X^3-1
CALL DERIVATIVE(3,A) !' 微分
CALL HORNER(2,A,X,Y2) !' f'(X)=3*X^2
CALL QDIV(Y1,Y2) !' (X^3-1)/(3*X^2)
MAT XX=X
CALL QSUB(XX,Y1) !' XX=X-(X^3-1)/(3*X^2)
END SUB
EXTERNAL SUB QSET(XX(),X,Y,Z,W)
OPTION ARITHMETIC NATIVE
LET XX(0)=X
LET XX(1)=Y
LET XX(2)=Z
LET XX(3)=W
END SUB
EXTERNAL SUB HORNER(N,A(,),X(),Y())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM AA(3)
CALL QSET(Y,A(N,0),A(N,1),A(N,2),A(N,3))
FOR I=N-1 TO 0 STEP -1
CALL QMUL(Y,X) !'Y=Y*X
CALL QSET(AA,A(I,0),A(I,1),A(I,2),A(I,3))
CALL QADD(Y,AA) !' Y=Y+A
NEXT I
END SUB
EXTERNAL SUB QMUL(A(),B())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM SS(3)
LET SS(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
LET SS(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2)
LET SS(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1)
LET SS(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0)
MAT A=SS
END SUB
EXTERNAL SUB QDIV(A(),B())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM BB(3)
CALL QINV(BB,B)
CALL QMUL(A,BB)
MAT A=(1/(B(0)^2+B(1)^2+B(2)^2+B(3)^2))*A
END SUB
EXTERNAL SUB QADD(A(),B())
OPTION ARITHMETIC NATIVE
MAT A=A+B
END SUB
EXTERNAL SUB QSUB(A(),B())
OPTION ARITHMETIC NATIVE
MAT A=A-B
END SUB
EXTERNAL SUB QINV(ZZ(),Z())
OPTION ARITHMETIC NATIVE
LET ZZ(0)=Z(0)
LET ZZ(1)=-Z(1)
LET ZZ(2)=-Z(2)
LET ZZ(3)=-Z(3)
END SUB
EXTERNAL SUB DERIVATIVE(N,A(,)) !'微分
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM B(N,3)
FOR I=N TO 1 STEP-1
FOR J=0 TO 3
LET B(I-1,J)=I*A(I,J)
NEXT J
NEXT I
FOR I=N TO 0 STEP -1
FOR J=0 TO 3
LET A(I,J)=B(I,J)
NEXT J
NEXT I
END SUB
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC NATIVE
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
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
SET COLOR MIX(255) .5,.5,.5
CLEAR
END SUB
OPTION ARITHMETIC COMPLEX
INPUT PROMPT "指数":k
LET q=2
SET WINDOW -q ,q,-q,q
DRAW GRID(.5,.5)
DEF f(z1)=z1^k-1
SELECT CASE k ! 誤差範囲の選択
CASE 1
LET d=10^(-6)
CASE 2 TO 6
LET d=10^(-3)
CASE 7 TO 10
LET d=3.2*10^(-3)
CASE 11 TO 13
LET d=6*10^(-3)
CASE IS <=24 ! k>=14 では重複がある
LET d=10^(-2)
CASE IS <=42
LET d=2*10^(-2)
CASE ELSE ! k>=43 では欠落がある
LET d=5*10^(-2)
END SELECT
LET count=0
FOR o=-1000 TO 1000 STEP 1
LET o2=o/1000
FOR p=-1000 TO 1000 STEP 1
LET p2=p/1000
LET z1=COMPLEX(o2,p2)
! PRINT o2,p2,"-----",z1
LET A=f(z1)
IF ABS(re(A))<=d AND ABS(im(A))<=d THEN ! 誤差考慮
PRINT o2;p2;" ----- ";z1
PRINT STR$(z1);"^";STR$(k);"-1 = ";STR$(A)
PLOT POINTS: re(z1),im(z1)
LET count=count+1
END IF
NEXT p
NEXT o
PRINT count;"通り"
DIM Z(8)
LET Z(1)=COMPLEX(1,0) !'(z^4-1)*(z^4+16)の解
LET Z(2)=COMPLEX(-1,0)
LET Z(3)=COMPLEX(0,1)
LET Z(4)=COMPLEX(0,-1)
LET Z(5)=COMPLEX(1,1)
LET Z(6)=COMPLEX(-1,1)
> わがKidsが練習としてf(z)=Z^8-17*Z^4+16のしばっち・プログラムを一部変えてf(z)=z^8+15*Z^4-16にチャレンジです。この複素関数は６Roots、±１、±i、±(1+i)そして±(1-i)
>
> ですので下記の６つのRootsを入れました。
>
> DIM Z(8)
> LET Z(1)=COMPLEX(1,0) !'(z^4-1)*(z^4+16)の解
> LET Z(2)=COMPLEX(-1,0)
> LET Z(3)=COMPLEX(0,1)
> LET Z(4)=COMPLEX(0,-1)
> LET Z(5)=COMPLEX(1,1)
> LET Z(6)=COMPLEX(-1,1)
> 関数は
> LET FUNC=(z^4-1)*(z^4+16)=z^8+15*z^4-16
>
> とします。
DIM Z(8)
LET Z(1)=COMPLEX(1,0) !'f(z)=z^8+3*z^4-4の解
LET Z(2)=COMPLEX(-1,0)
LET Z(3)=COMPLEX(0,1)
LET Z(4)=COMPLEX(0,-1)
LET Z(5)=COMPLEX(1,1)
LET Z(6)=COMPLEX(-1,-1)
LET Z(7)=COMPLEX(1,-1)
LET Z(8)=COMPLEX(-1,1)
DIM Z(8)
LET Z(1)=COMPLEX(-2,0) !'f(z)=(z^2+4)*(z^2-4*z+5)*(z+2)の解
LET Z(2)=COMPLEX(0,2)
LET Z(3)=COMPLEX(0,-2)
LET Z(4)=COMPLEX(2,1)
LET Z(5)=COMPLEX(2,-1)
OPTION ARITHMETIC COMPLEX
LET XSIZE=800 !'画像サイズ
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET LEFT=-1.5 !'計算領域
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET KS=100
LET EPS=1E-5
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
DIM Z(8)
LET Z(1)=COMPLEX(1,0) !'f(z)=z^8+3*z^4-4の解
LET Z(2)=COMPLEX(-1,0)
LET Z(3)=COMPLEX(0,1)
LET Z(4)=COMPLEX(0,-1)
LET Z(5)=COMPLEX(1,1)
LET Z(6)=COMPLEX(-1,-1)
LET Z(7)=COMPLEX(1,-1)
LET Z(8)=COMPLEX(-1,1)
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF(X,1)
USE
CALL PSET(ZR,ZI,255) !'発散!?
EXIT FOR
END WHEN
LET FL=0
FOR I=1 TO 8
IF ABS(XX-Z(I))<EPS THEN !'収束判定
CALL PSET(ZR,ZI,I)
LET FL=1 !'フラグ
EXIT FOR
END IF
NEXT I
IF FL=1 THEN EXIT FOR
NEXT K
NEXT ZI
NEXT ZR
PRINT "マウスで左クリックしてください。右クリックで終了"
SET LINE WIDTH 3
DO
DO
MOUSE POLL ZR,ZI,L,R
LOOP UNTIL L<>0 OR R<>0
IF R<>0 THEN EXIT DO
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF(X,1)
USE
EXIT FOR
END WHEN
IF ABS(XX-X)<EPS THEN
CALL ARROW(ZR,ZI,RE(XX),IM(XX),200) !'矢印を描く
EXIT FOR
END IF
NEXT K
LOOP
END
EXTERNAL FUNCTION FUNC(Z)
OPTION ARITHMETIC COMPLEX
LET FUNC=Z^8+3*Z^4-4
END FUNCTION
EXTERNAL FUNCTION DIFF(X,N) !'解析解
OPTION ARITHMETIC COMPLEX
SELECT CASE N
CASE 1
LET DIFF=8*X^7+12*X^3
CASE 2
LET DIFF=56*X^6+36*X^2
END SELECT
END FUNCTION
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
OPTION ARITHMETIC COMPLEX
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB ARROW(X1,Y1,X2,Y2,C)
OPTION ARITHMETIC COMPLEX
OPTION ANGLE DEGREES
CALL LINE(X1,Y1,X2,Y2,C)
LET TH=180-ANGLE(X1-X2,Y1-Y2)
LET L=SQR((X2-X1)^2+(Y2-Y1)^2)/10
LET X3=X2+L*COS(TH+160)
LET Y3=Y2-L*SIN(TH+160)
LET X4=X2+L*COS(TH-160)
LET Y4=Y2-L*SIN(TH-160)
CALL LINE(X2,Y2,X3,Y3,C)
CALL LINE(X2,Y2,X4,Y4,C)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
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
SET COLOR MIX(255) 128/255,128/255,128/255
CLEAR
END SUB
PRINT "マウスで左クリックしてください。右クリックで終了"
SET LINE WIDTH 3
DO
DO
MOUSE POLL ZR,ZI,L,R
LOOP UNTIL L<>0 OR R<>0
IF R<>0 THEN EXIT DO
DO
MOUSE POLL ZR,ZI,L,R
LOOP WHILE L<>0
LET XX=COMPLEX(ZR,ZI)
PRINT
PRINT "初期値:";XX
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF(X,1)
SET LINE COLOR 200
PLOT LINES:RE(X),IM(X);RE(XX),IM(XX)
!' CALL ARROW(RE(X),IM(X),RE(XX),IM(XX),200)
PRINT K;":";XX
USE
EXIT FOR
END WHEN
IF ABS(XX-X)<EPS THEN
!' CALL ARROW(ZR,ZI,RE(XX),IM(XX),200) !'矢印を描く
EXIT FOR
END IF
NEXT K
LOOP
END
OPTION ARITHMETIC COMPLEX
LET XSIZE=800 !'画像サイズ
LET YSIZE=800
CALL GINIT(XSIZE,YSIZE)
LET LEFT=-1.5 !'計算領域
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET T=.15
LET XS=.5-T !'描画エリア
LET XE=.5+T
LET YS=.5-T
LET YE=.5+T
LET DX=(RIGHT-LEFT)/(XSIZE*(XE-XS))
LET DY=(TOP-BOTTOM)/(YSIZE*(YE-YS))
LOCATE VALUE NOWAIT(1),RANGE -3 TO 3,AT 1:R1
LOCATE VALUE NOWAIT(2),RANGE -3 TO 3,AT 0:I1
LOCATE VALUE NOWAIT(3),RANGE 1 TO 100,AT 50:KS
LOCATE VALUE NOWAIT(4),RANGE 0 TO 0.5,AT .25:EPS
DO
LOCATE VALUE NOWAIT(1):R1 !'パラメータ
LOCATE VALUE NOWAIT(2):I1
LOCATE VALUE NOWAIT(3):KS
LOCATE VALUE NOWAIT(4):EPS
LET KS=INT(KS)
SET VIEWPORT 0,1,.7,1
SET WINDOW 0,1,0,1
SET TEXT HEIGHT .15
CALL BOXFULL(0,0,1,1,0) !'文字を消す
SET COLOR 7 !'以下パラメータ表示
PLOT TEXT ,AT 0,.8:"R="&STR$(R1)&MID$("-++",2+SGN(I1),1)&STR$(ABS(I1))&"i"
PLOT TEXT ,AT 0,.6:"計算回数:"&STR$(KS)
PLOT TEXT ,AT 0,.4:"計算精度:"&STR$(EPS)
SET VIEWPORT XS,XE,YS,YE
SET LINE WIDTH 2
CALL BOX(0,0,1,1,7) !'枠を描く
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
MOUSE POLL X1,Y1,LL,RR
IF LL<>0 OR RR<>0 THEN !'マウスボタンを押し続ける
LET FF=1
SET VIEWPORT 0,1,0,1 !'リサイズ
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
CLEAR
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
END IF
LET R=COMPLEX(R1,I1) !'Relaxation Factor
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
CALL PSET(ZR,ZI,0) !'消去
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-R*FUNC(X)/DIFF(X)
USE
CALL PSET(ZR,ZI,255)
EXIT FOR
END WHEN
IF ABS(XX-X)<EPS THEN !'収束判定
LET C=MOD(K,7)+1
CALL PSET(ZR,ZI,C)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
LOOP UNTIL FF=1
END
EXTERNAL FUNCTION FUNC(Z)
OPTION ARITHMETIC COMPLEX
LET FUNC=Z^3+3*Z-4
END FUNCTION
EXTERNAL FUNCTION DIFF(X)
OPTION ARITHMETIC COMPLEX
LET DIFF=3*X^2+3
END FUNCTION
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
OPTION ARITHMETIC COMPLEX
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
EXTERNAL SUB BOX(XS,YS,XE,YE,C)
OPTION ARITHMETIC COMPLEX
CALL LINE(XS,YS,XE,YS,C)
CALL LINE(XE,YS,XE,YE,C)
CALL LINE(XE,YE,XS,YE,C)
CALL LINE(XS,YE,XS,YS,C)
END SUB
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
OPTION ARITHMETIC COMPLEX
SET COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2;X1,Y1
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
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
SET COLOR MIX(255) 128/255,128/255,128/255
CLEAR
END SUB
OPTION ARITHMETIC COMPLEX
LET XSIZE=800
LET YSIZE=800
LET KS=50
LET LEFT=-2
LET RIGHT=1
LET BOTTOM=-1.3
LET TOP=1.7
CALL GINIT(XSIZE,YSIZE)
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
FOR X=LEFT TO RIGHT STEP DX
FOR Y=BOTTOM TO TOP STEP DY
LET Z=COMPLEX(X,Y)
FOR K=1 TO KS
LET Z=Z^3+COMPLEX(1.503,-0.8046)*Z^2 !'LEFT=-2,RIGHT=1,BOTTOM=-1.3,TOP=1.7
!' LET Z=Z^3+COMPLEX(0,2.12)*Z^2 !'LEFT=-1.7,RIGHT=1.7,BOTTOM=-2.5,TOP=.9
IF ABS(Z)>2 THEN
CALL PSET(X,Y,MOD(K,7)+1)
EXIT FOR
END IF
NEXT K
!' IF ABS(Z)<2 THEN CALL PSET(X,Y,255)
NEXT Y
NEXT X
END
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
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(255) 128/255,128/255,128/255
CLEAR
END SUB
OPTION ARITHMETIC COMPLEX
LET LEFT=-2.5 !'計算範囲
LET RIGHT=2.5
LET BOTTOM=-2.5
LET TOP=2.5
LET XSIZE=400
LET YSIZE=400
CALL GINIT(XSIZE,YSIZE)
DIM S$(8)
MAT READ S$
DATA "200*200","300*300","400*400","500*500","600*600","700*700","800*800","1000*1000"
LOCATE VALUE NOWAIT(1),RANGE 1 TO 200,AT 30:KS !'計算精度
LOCATE VALUE NOWAIT(2),RANGE -1.5 TO 1.5,AT .5:R1
LOCATE VALUE NOWAIT(3),RANGE -1.5 TO 1.5,AT .5:I1
LOCATE VALUE NOWAIT(4),RANGE -1.5 TO 1.5,AT .5:R2
LOCATE VALUE NOWAIT(5),RANGE -1.5 TO 1.5,AT .5:I2
LOCATE VALUE NOWAIT(6),RANGE -1.5 TO 1.5,AT .5:R3
LOCATE VALUE NOWAIT(7),RANGE -1.5 TO 1.5,AT .5:I3
LOCATE VALUE NOWAIT(8),RANGE -1.5 TO 1.5,AT 0:R4
LOCATE VALUE NOWAIT(9),RANGE -1.5 TO 1.5,AT 0:I4
LOCATE VALUE NOWAIT(10),RANGE -1.5 TO 1.5,AT 0:R5
LOCATE VALUE NOWAIT(11),RANGE -1.5 TO 1.5,AT 0:I5
LOCATE VALUE NOWAIT(12),RANGE -1.5 TO 1.5,AT 0:R6
LOCATE VALUE NOWAIT(13),RANGE -1.5 TO 1.5,AT 0:I6
LOCATE VALUE NOWAIT(14),RANGE -1.5 TO 1.5,AT 0:R7
LOCATE VALUE NOWAIT(15),RANGE -1.5 TO 1.5,AT 0:I7
LOCATE VALUE NOWAIT(16),RANGE -1.5 TO 1.5,AT 0:R8
LOCATE VALUE NOWAIT(17),RANGE -1.5 TO 1.5,AT 0:I8
LOCATE VALUE NOWAIT(18),RANGE -1.5 TO 1.5,AT 0:R9
LOCATE VALUE NOWAIT(19),RANGE -1.5 TO 1.5,AT 0:I9
DO
IF FF<>0 THEN
LOCATE CHOICE(S$) : N
SELECT CASE N
CASE 1
LET XSIZE=200
LET YSIZE=200
CASE 2
LET XSIZE=300
LET YSIZE=300
CASE 3
LET XSIZE=400
LET YSIZE=400
CASE 4
LET XSIZE=500
LET YSIZE=500
CASE 5
LET XSIZE=600
LET YSIZE=600
CASE 6
LET XSIZE=700
LET YSIZE=700
CASE 7
LET XSIZE=800
LET YSIZE=800
CASE 8
LET XSIZE=1000
LET YSIZE=1000
END SELECT
CALL GINIT(XSIZE,YSIZE)
PRINT "画像サイズ";XSIZE;"*";YSIZE
LET FF=0
END IF
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
PRINT "横:";LEFT;"～";RIGHT
PRINT "縦:";BOTTOM;"～";TOP
PRINT
CLEAR
DO
LOCATE VALUE NOWAIT(1):KS
LOCATE VALUE NOWAIT(2):R1
LOCATE VALUE NOWAIT(3):I1
LOCATE VALUE NOWAIT(4):R2
LOCATE VALUE NOWAIT(5):I2
LOCATE VALUE NOWAIT(6):R3
LOCATE VALUE NOWAIT(7):I3
LOCATE VALUE NOWAIT(8):R4
LOCATE VALUE NOWAIT(9):I4
LOCATE VALUE NOWAIT(10):R5
LOCATE VALUE NOWAIT(11):I5
LOCATE VALUE NOWAIT(12):R6
LOCATE VALUE NOWAIT(13):I6
LOCATE VALUE NOWAIT(14):R7
LOCATE VALUE NOWAIT(15):I7
LOCATE VALUE NOWAIT(16):R8
LOCATE VALUE NOWAIT(17):I8
LOCATE VALUE NOWAIT(18):R9
LOCATE VALUE NOWAIT(19):I9
FOR X=LEFT TO RIGHT STEP DX
FOR Y=BOTTOM TO TOP STEP DY
IF GetKeyState(9)<0 THEN !'TABキー
LET FF=1
EXIT DO
ELSEIF GetKeyState(27)<0 THEN !'ESCキー
STOP
END IF
CALL PSET(X,Y,0)
LET Z=COMPLEX(X,Y)
FOR K=1 TO KS
LET Z=COMPLEX(R9,I9)*Z^8+COMPLEX(R8,I8)*Z^7+COMPLEX(R7,I7)*Z^6+COMPLEX(R6,I6)*Z^5+COMPLEX(R5,I5)*Z^4+COMPLEX(R4,I4)*Z^3+COMPLEX(R3,I3)*Z^2+COMPLEX(R2,I2)*Z+COMPLEX(R1,I1)
IF ABS(Z)>2 THEN
CALL PSET(X,Y,MOD(K,7)+1)
EXIT FOR
END IF
NEXT K
MOUSE POLL X1,Y1,L,R
IF R<>0 THEN EXIT DO !'右クリック
IF L<>0 THEN
SET DRAW MODE NOTXOR
SET LINE STYLE 2
DO
PLOT LINES:X1,Y1;X2,Y2
PLOT LINES:X1,Y1;X2,Y2
MOUSE POLL X2,Y2,LL,RR
LOOP WHILE LL<>0 !'左ドラッグ
LET RIGHT=RIGHT-(X2-X1) !'平行移動
LET LEFT=LEFT-(X2-X1)
LET TOP=TOP-(Y2-Y1)
LET BOTTOM=BOTTOM-(Y2-Y1)
PRINT "移動量 X:";X2-X1;"Y:";Y2-Y1
SET DRAW MODE OVERWRITE
EXIT DO
END IF
NEXT Y
NEXT X
LOOP
IF R<>0 THEN
PAUSE "拡大する範囲を指定してください"
CALL GETSQUARE(LEFT,TOP,RIGHT,BOTTOM) !'左ドラッグで範囲指定
IF LEFT=RIGHT THEN EXIT DO
END IF
LOOP
PRINT "終了します"
END
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
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 GETSQUARE(L,T,R,B)
OPTION ARITHMETIC COMPLEX
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
OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC NUMERIC XSIZE,YSIZE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM VM(XSIZE,YSIZE),S$(2)
ASK PIXEL ARRAY(0,0) VM
PRINT "元画像サイズ ";XSIZE;"＊";YSIZE
MAT READ S$
DATA "NEAR","BILINEAR","BICUBIC"
LOCATE CHOICE(S$) :MODE
LOCATE VALUE ,RANGE 0.1 TO 3,AT 1 : SCALE
LET BIWIDTH=INT(XSIZE*SCALE)
LET BIHEIGHT=INT(YSIZE*SCALE)
PRINT "画像サイズ ";BIWIDTH;"＊";BIHEIGHT
PRINT S$(MODE-1)
PRINT "倍率 ";SCALE
CLEAR
SET BITMAP SIZE BIWIDTH,BIHEIGHT
SET WINDOW 0,BIWIDTH-1,BIHEIGHT-1,0
FOR Y=0 TO BIHEIGHT-1
FOR X=0 TO BIWIDTH-1
LET XX=X/SCALE
LET YY=Y/SCALE
SELECT CASE MODE
CASE 1
CALL NEAR(XX,YY,VM,R,G,B)
CASE 2
CALL BILINEAR(XX,YY,VM,R,G,B)
CASE 3
CALL BICUBIC(XX,YY,VM,R,G,B)
END SELECT
CALL PSET(X,Y,R,G,B)
NEXT X
NEXT Y
END
EXTERNAL SUB NEAR(X,Y,IMAGE(,),R,G,B) !'ニアレストネイバー法
OPTION ARITHMETIC NATIVE
IF X>=0 AND X<=XSIZE-1 THEN
LET XX=INT(X+.5)
ELSE
LET XX=MAX(0,MIN(XSIZE-1,X))
END IF
IF Y>=0 AND Y<=YSIZE-1 THEN
LET YY=INT(Y+.5)
ELSE
LET YY=MAX(0,MIN(YSIZE-1,Y))
END IF
LET C=IMAGE(XX,YY)
CALL RGB(C,R,G,B)
LET R=MAX(0,MIN(255,R))
LET G=MAX(0,MIN(255,G))
LET B=MAX(0,MIN(255,B))
END SUB
EXTERNAL SUB BILINEAR(X,Y,IMAGE(,),RR,GG,BB) !'バイリニア法
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=0 TO 1
LET R0=0
LET G0=0
LET B0=0
FOR K=0 TO 1
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+(ABS(1-K)-XX*SGN_(1-K))*R
LET G0=G0+(ABS(1-K)-XX*SGN_(1-K))*G
LET B0=B0+(ABS(1-K)-XX*SGN_(1-K))*B
NEXT K
LET R1=R1+(ABS(1-L)-YY*SGN_(1-L))*R0
LET G1=G1+(ABS(1-L)-YY*SGN_(1-L))*G0
LET B1=B1+(ABS(1-L)-YY*SGN_(1-L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL SUB BICUBIC(X,Y,IMAGE(,),RR,GG,BB) !'バイキュービック法
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-1 TO 2
LET R0=0
LET G0=0
LET B0=0
FOR K=-1 TO 2
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+SINC(ABS(K)-XX*SGN_(K))*R
LET G0=G0+SINC(ABS(K)-XX*SGN_(K))*G
LET B0=B0+SINC(ABS(K)-XX*SGN_(K))*B
NEXT K
LET R1=R1+SINC(ABS(L)-YY*SGN_(L))*R0
LET G1=G1+SINC(ABS(L)-YY*SGN_(L))*G0
LET B1=B1+SINC(ABS(L)-YY*SGN_(L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL FUNCTION SINC(X)
OPTION ARITHMETIC NATIVE
LET X=ABS(X)
IF X<1 THEN
LET SINC=1-2*X*X+X*X*X
ELSEIF X<2 THEN
LET SINC=4-8*X+5*X*X-X*X*X
ELSE
LET SINC=0
END IF
END FUNCTION
!EXTERNAL FUNCTION SINC(X)
!IF X=0 THEN
! LET SINC=1
!ELSE
! LET SINC=SIN(PI*X)/(PI*X)
!END IF
!END FUNCTION
EXTERNAL FUNCTION SGN_(X)
OPTION ARITHMETIC NATIVE
IF X<=0 THEN LET SGN_=-1 ELSE LET SGN_=1
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC NUMERIC XSIZE,YSIZE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM VM(XSIZE,YSIZE),S$(5)
ASK PIXEL ARRAY(0,0) VM
PRINT "元画像サイズ ";XSIZE;"＊";YSIZE
MAT READ S$
LOCATE CHOICE(S$) : N
LOCATE VALUE ,RANGE 0.1 TO 3,AT 1 : SCALE
DATA "lanczos(2)","lanczos(3)","lanczos(4)","lanczos(5)","lanczos(6)","lanczos(7)"
LET BIWIDTH=INT(XSIZE*SCALE)
LET BIHEIGHT=INT(YSIZE*SCALE)
PRINT "画像サイズ ";BIWIDTH;"＊";BIHEIGHT
PRINT S$(N-1)
PRINT "倍率 ";SCALE
CLEAR
SET BITMAP SIZE BIWIDTH,BIHEIGHT
SET WINDOW 0,BIWIDTH-1,BIHEIGHT-1,0
FOR Y=0 TO BIHEIGHT-1
FOR X=0 TO BIWIDTH-1
LET XX=X/SCALE
LET YY=Y/SCALE
CALL LANCZOS(N+1,XX,YY,VM,RR,GG,BB)
CALL PSET(X,Y,RR,GG,BB)
NEXT X
NEXT Y
END
EXTERNAL SUB LANCZOS(N,X,Y,IMAGE(,),RR,GG,BB) !'ランチョス法 lanczos(n)
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-N+1 TO N
LET R0=0
LET G0=0
LET B0=0
FOR K=-N+1 TO N
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+CALC(ABS(K)-XX*SGN_(K),N)*R
LET G0=G0+CALC(ABS(K)-XX*SGN_(K),N)*G
LET B0=B0+CALC(ABS(K)-XX*SGN_(K),N)*B
NEXT K
LET R1=R1+CALC(ABS(L)-YY*SGN_(L),N)*R0
LET G1=G1+CALC(ABS(L)-YY*SGN_(L),N)*G0
LET B1=B1+CALC(ABS(L)-YY*SGN_(L),N)*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
!EXTERNAL FUNCTION SINC(X)
!OPTION ARITHMETIC NATIVE
!IF X=0 THEN
! LET SINC=1
!ELSE
! LET SINC=SIN(PI*X)/(PI*X)
!END IF
!END FUNCTION
EXTERNAL FUNCTION CALC(X,N)
OPTION ARITHMETIC NATIVE
IF X=0 THEN
LET CALC=1
ELSE
LET CALC=N*SIN(PI*X)*SIN(X*PI/N)/(X*PI)^2
!' LET CALC=SINC(X)*SINC(X/N)
END IF
END FUNCTION
EXTERNAL FUNCTION SGN_(X)
OPTION ARITHMETIC NATIVE
IF X<=0 THEN LET SGN_=-1 ELSE LET SGN_=1
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC NUMERIC XSIZE,YSIZE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM VM(XSIZE,YSIZE),S$(4)
ASK PIXEL ARRAY(0,0) VM
PRINT "元画像サイズ ";XSIZE;"＊";YSIZE
DATA SPLINE2,SPLINE3,SPLINE4,SPLINE5,SPLINE6
MAT READ S$
LOCATE CHOICE(S$) : MODE
LOCATE VALUE ,RANGE 0.1 TO 3,AT 1 : SCALE
LET BIWIDTH=INT(XSIZE*SCALE)
LET BIHEIGHT=INT(YSIZE*SCALE)
PRINT "画像サイズ ";BIWIDTH;"＊";BIHEIGHT
PRINT S$(MODE-1)
PRINT "倍率 ";SCALE
CLEAR
SET BITMAP SIZE BIWIDTH,BIHEIGHT
SET WINDOW 0,BIWIDTH-1,BIHEIGHT-1,0
FOR Y=0 TO BIHEIGHT-1
FOR X=0 TO BIWIDTH-1
LET XX=X/SCALE
LET YY=Y/SCALE
SELECT CASE MODE+1
CASE 2
CALL SPLINE2(XX,YY,VM,RR,GG,BB) !'スプライン法
CASE 3
CALL SPLINE3(XX,YY,VM,RR,GG,BB)
CASE 4
CALL SPLINE4(XX,YY,VM,RR,GG,BB)
CASE 5
CALL SPLINE5(XX,YY,VM,RR,GG,BB)
CASE 6
CALL SPLINE6(XX,YY,VM,RR,GG,BB)
END SELECT
CALL PSET(X,Y,RR,GG,BB)
NEXT X
NEXT Y
END
EXTERNAL SUB SPLINE2(X,Y,IMAGE(,),RR,GG,BB)
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-1 TO 2
LET R0=0
LET G0=0
LET B0=0
FOR K=-1 TO 2
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+SPLINE16(ABS(K)-XX*SGN_(K))*R
LET G0=G0+SPLINE16(ABS(K)-XX*SGN_(K))*G
LET B0=B0+SPLINE16(ABS(K)-XX*SGN_(K))*B
NEXT K
LET R1=R1+SPLINE16(ABS(L)-YY*SGN_(L))*R0
LET G1=G1+SPLINE16(ABS(L)-YY*SGN_(L))*G0
LET B1=B1+SPLINE16(ABS(L)-YY*SGN_(L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL FUNCTION SPLINE16(X)
OPTION ARITHMETIC NATIVE
LET X=ABS(X)
IF X<=1 THEN
LET SPLINE16=X^3 - 9/5*X^2 - 1/ 5*X + 1
ELSEIF X<=2 THEN
LET SPLINE16=-1/3*X^3 + 9/5*X^2 - 46/15*X + 8/5
ELSE
LET SPLINE16=0
END IF
END FUNCTION
EXTERNAL SUB SPLINE3(X,Y,IMAGE(,),RR,GG,BB)
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-2 TO 3
LET R0=0
LET G0=0
LET B0=0
FOR K=-2 TO 3
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+SPLINE36(ABS(K)-XX*SGN_(K))*R
LET G0=G0+SPLINE36(ABS(K)-XX*SGN_(K))*G
LET B0=B0+SPLINE36(ABS(K)-XX*SGN_(K))*B
NEXT K
LET R1=R1+SPLINE36(ABS(L)-YY*SGN_(L))*R0
LET G1=G1+SPLINE36(ABS(L)-YY*SGN_(L))*G0
LET B1=B1+SPLINE36(ABS(L)-YY*SGN_(L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL FUNCTION SPLINE36(X)
OPTION ARITHMETIC NATIVE
LET X=ABS(X)
IF X<=1 THEN
LET SPLINE36=13/11*X^3 - 453/209*X^2 - 3/209*X + 1
ELSEIF X<=2 THEN
LET SPLINE36=-6/11*X^3 + 612/209*X^2 - 1038/209*X + 540/209
ELSEIF X<=3 THEN
LET SPLINE36=1/11*X^3 - 159/209*X^2 + 434/209*X - 384/209
ELSE
LET SPLINE36=0
END IF
END FUNCTION
EXTERNAL SUB SPLINE4(X,Y,IMAGE(,),RR,GG,BB)
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-3 TO 4
LET R0=0
LET G0=0
LET B0=0
FOR K=-3 TO 4
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+SPLINE64(ABS(K)-XX*SGN_(K))*R
LET G0=G0+SPLINE64(ABS(K)-XX*SGN_(K))*G
LET B0=B0+SPLINE64(ABS(K)-XX*SGN_(K))*B
NEXT K
LET R1=R1+SPLINE64(ABS(L)-YY*SGN_(L))*R0
LET G1=G1+SPLINE64(ABS(L)-YY*SGN_(L))*G0
LET B1=B1+SPLINE64(ABS(L)-YY*SGN_(L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL FUNCTION SPLINE64(X)
OPTION ARITHMETIC NATIVE
LET X=ABS(X)
IF X<=1 THEN
LET SPLINE64=49/41*X^3 - 6387/2911*X^2 - 3/2911*X + 1
ELSEIF X<=2 THEN
LET SPLINE64=-24/41*X^3 + 9144/2911*X^2 - 15504/2911*X + 8064/2911
ELSEIF X<=3 THEN
LET SPLINE64=6/41*X^3 - 3564/2911*X^2 + 9726/2911*X - 8604/2911
ELSEIF X<=4 THEN
LET SPLINE64=-1/41*X^3 + 807/2911*X^2 - 3022/2911*X + 3720/2911
ELSE
LET SPLINE64=0
END IF
END FUNCTION
EXTERNAL SUB SPLINE5(X,Y,IMAGE(,),RR,GG,BB)
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-4 TO 5
LET R0=0
LET G0=0
LET B0=0
FOR K=-4 TO 5
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+SPLINE100(ABS(K)-XX*SGN_(K))*R
LET G0=G0+SPLINE100(ABS(K)-XX*SGN_(K))*G
LET B0=B0+SPLINE100(ABS(K)-XX*SGN_(K))*B
NEXT K
LET R1=R1+SPLINE100(ABS(L)-YY*SGN_(L))*R0
LET G1=G1+SPLINE100(ABS(L)-YY*SGN_(L))*G0
LET B1=B1+SPLINE100(ABS(L)-YY*SGN_(L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL FUNCTION SPLINE100(X)
OPTION ARITHMETIC NATIVE
LET X=ABS(X)
IF X<=1 THEN
LET SPLINE100= 61/ 51*X^3 - 9893/4505*X^2 - 1/13515*X + 1
ELSEIF X<=2 THEN
LET SPLINE100=-10/ 17*X^3 + 2844/ 901*X^2 - 4822/ 901*X + 2508/ 901
ELSEIF X<=3 THEN
LET SPLINE100=8/ 51*X^3 - 5912/4505*X^2 + 9680/ 2703*X - 14272/4505
ELSEIF X<=4 THEN
LET SPLINE100=-2/ 51*X^3 + 2008/4505*X^2 - 22558/13515*X + 9256/4505
ELSEIF X<=5 THEN
LET SPLINE100=1/153*X^3 - 423/4505*X^2 + 18098/40545*X - 632/ 901
ELSE
LET SPLINE100=0
END IF
END FUNCTION
EXTERNAL SUB SPLINE6(X,Y,IMAGE(,),RR,GG,BB)
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
FOR L=-5 TO 6
LET R0=0
LET G0=0
LET B0=0
FOR K=-5 TO 6
IF X0+K<XSIZE AND Y0+L<YSIZE AND X0+K>=0 AND Y0+L>=0 THEN LET C=IMAGE(X0+K,Y0+L) ELSE LET C=0
CALL RGB(C,R,G,B)
LET R0=R0+SPLINE144(ABS(K)-XX*SGN_(K))*R
LET G0=G0+SPLINE144(ABS(K)-XX*SGN_(K))*G
LET B0=B0+SPLINE144(ABS(K)-XX*SGN_(K))*B
NEXT K
LET R1=R1+SPLINE144(ABS(L)-YY*SGN_(L))*R0
LET G1=G1+SPLINE144(ABS(L)-YY*SGN_(L))*G0
LET B1=B1+SPLINE144(ABS(L)-YY*SGN_(L))*B0
NEXT L
LET RR=MAX(0,MIN(255,R1))
LET GG=MAX(0,MIN(255,G1))
LET BB=MAX(0,MIN(255,B1))
END SUB
EXTERNAL FUNCTION SPLINE144(X)
OPTION ARITHMETIC NATIVE
LET X=ABS(X)
IF X<=1 THEN
LET SPLINE144=683/571*X^3 - 1240203/564719*X^2 - 3/564719*X + 1
ELSEIF X<=2 THEN
LET SPLINE144=-336/571*X^3 + 1783152/564719*X^2 - 3023328/564719*X + 1572480/564719
ELSEIF X<=3 THEN
LET SPLINE144=90/571*X^3 - 744660/564719*X^2 + 2032110/564719*X - 1797660/564719
ELSEIF X<=4 THEN
LET SPLINE144=-24/571*X^3 + 269784/564719*X^2 - 1010256/564719*X + 1243584/564719
ELSEIF X<=5 THEN
LET SPLINE144=6/571*X^3 - 85248/564719*X^2 + 405258/564719*X - 636840/564719
ELSEIF X<=6 THEN
LET SPLINE144=-1/571*X^3 + 17175/564719*X^2 - 98926/564719*X + 188880/564719
ELSE
LET SPLINE144=0
END IF
END FUNCTION
EXTERNAL FUNCTION SGN_(X)
OPTION ARITHMETIC NATIVE
IF X<=0 THEN LET SGN_=-1 ELSE LET SGN_=1
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC COMPLEX
OPTION BASE 0
LET XSIZE=1000 !'画像サイズ
LET YSIZE=1000
CALL GINIT(XSIZE,YSIZE)
DIM COUNT(XSIZE,YSIZE),FL(100)
LET KS=800
LET C=COMPLEX(-0.74543,0.11301)
LET R=(1+SQR(1+4*ABS(C)))/2
LET LEFT=-R
LET RIGHT=R
LET TOP=R
LET BOTTOM=-R
SET TEXT BACKGROUND "OPAQUE"
SET TEXT JUSTIFY "LEFT" , "TOP"
DO
SET COLOR COLORINDEX(1,1,1)
SET TEXT HEIGHT (TOP-BOTTOM)/5
MAT FL=ZER
LET KMAX=0
LET KMIN=0
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
CLEAR
LET DX=(RIGHT-LEFT)/XSIZE
LET DY=(TOP-BOTTOM)/YSIZE
FOR ZR=LEFT TO RIGHT STEP DX
LET P=INT((ZR-LEFT)/(RIGHT-LEFT)*100)
IF FL(INT(P/5))=0 THEN
PLOT TEXT ,AT LEFT,TOP:STR$(P)&"%"
LET FL(INT(P/5))=1
END IF
FOR ZI=BOTTOM TO TOP STEP DY
LET Z=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET Z=Z*Z+C
IF ABS(Z)>R THEN EXIT FOR
NEXT K
LET X=PIXELX(ZR)
LET Y=PIXELY(ZI)
LET COUNT(X,Y)=K
LET KMAX=MAX(KMAX,K)
NEXT ZI
NEXT ZR
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET X=PIXELX(ZR)
LET Y=PIXELY(ZI)
LET K=COUNT(X,Y)
LET Z=COMPLEX(ZR,ZI)
CALL PSET(ZR,ZI,255*(K-KMIN)/(KMAX-KMIN),255*(1-(K-KMIN)/(KMAX-KMIN)),255*MIN(1,ABS(Z)/R))
NEXT ZI
NEXT ZR
PAUSE "拡大する範囲を指定してください"
CALL GETSQUARE(LEFT,TOP,RIGHT,BOTTOM)
IF LEFT=RIGHT THEN EXIT DO
LOOP
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MIX(0) 0,0,0
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC COMPLEX
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GETSQUARE(L,T,R,B)
OPTION ARITHMETIC COMPLEX
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
> プログラムを手直しして、解を４つほど並べて解決と思ったらしい。
>
> LET Z1=COMPLEX(PI/2,0)
> LET Z2=COMPLEX(-PI/2,0)
> LET z3=COMPLEX(3*PI/2,0)
> LET z4=COMPLEX(-3*PI/2,0)
>
> EXTERNAL FUNCTION FUNC(X)
> OPTION ARITHMETIC COMPLEX
> LET FUNC=ccos(x)
> END FUNCTION
>
> ところが原点に近づくほど遠くのアトラクターの収束領域になるので、下図のようにのような黒領域になって正しく表示されません。すべての解nπ-π/2（n:整数）をLet文で並べるわけにもいかないので、どのように解決できますか？
OPTION ARITHMETIC NATIVE
OPTION BASE 0
RANDOMIZE
PUBLIC NUMERIC FLG(255)
DIM R(255),G(255),B(255)
SET COLOR MODE "REGULAR"
FOR I=0 TO 255
ASK COLOR MIX(I) R(I),G(I),B(I) !'パレット読み出し
LET R(I)=INT(R(I)*255)
LET G(I)=INT(G(I)*255)
LET B(I)=INT(B(I)*255)
NEXT I
CALL GINIT(900,800)
DO
CLEAR
LET XSIZE=600
LET YSIZE=500
LET STY=INT(YSIZE/16)
LET STX=INT(XSIZE/16)
CALL DRAWPALLET(XSIZE,YSIZE,STX,STY,R,G,B) !'カラーパレットの描画
LET X1=700
LET Y1=30
LET X2=850
LET Y2=75
LET DY1=70
LET DY2=140
CALL DRAWBOTTON(X1,Y1,X2,Y2,DY1, "MODE 1","MODE 2") !'ボタンを描く
CALL DRAWBOTTON(X1,Y1+DY2,X2,Y2+DY2,70,"MODE 3","終 了")
IF CODE=0 THEN
LET X=STX
LET Y=STY
ELSE
LET X=MOD(CODE,16)*STX+STX+5
LET Y=INT(CODE/16)*STY+STY+5
END IF
DO
IF X>=STX AND X<=STX+16*STX AND Y>=STY AND Y<=STY+16*STY THEN !'座標で振り分け
LET CODE=INT((Y-STY)/STY)*16+INT((X-STX)/STX) !'設定用のコード
CALL DRAWCOLORCODE(X,Y,STX,STY,CODE,R,G,B)
ELSEIF X>X1 AND X<X2 AND Y>Y1 AND Y<Y2 THEN !' MODE 1をクリック
CALL DRAWMODE(1,17*STX,17*STY,CODE,R,G,B)
EXIT DO
ELSEIF X>X1 AND X<X2 AND Y>Y1+DY1 AND Y<Y2+DY1 THEN !' MODE 2をクリック
CALL DRAWMODE(2,17*STX,17*STY,CODE,R,G,B)
EXIT DO
ELSEIF X>X1 AND X<X2 AND Y>Y1+DY2 AND Y<Y2+DY2 THEN !' MODE 3をクリック
CALL DRAWMODE(3,17*STX,17*STY,CODE,R,G,B)
EXIT DO
ELSEIF X>X1 AND X<X2 AND Y>Y1+DY2+70 AND Y<Y2+DY2+70 THEN !' 終了をクリック
SELECT CASE CONFIRM$("登録のみ出力しますか?")
CASE "YES"
FOR I=0 TO 255
IF FLG(I)<>0 THEN !'登録したコードのみ
PRINT "SET COLOR MIX(";STR$(I);") ";STR$(R(I));"/255,";STR$(G(I));"/255,";STR$(B(I));"/255" !'BASICコード出力
END IF
NEXT I
CASE "NO"
SELECT CASE CONFIRM$("全色出力しますか?")
CASE "YES"
FOR I=0 TO 255
PRINT "SET COLOR MIX(";STR$(I);") ";STR$(R(I));"/255,";STR$(G(I));"/255,";STR$(B(I));"/255"
NEXT I
CASE "NO"
CALL MESSAGEBOX("出力を取り消しました")
END SELECT
END SELECT
STOP
END IF
DO
MOUSE POLL X,Y,LL,RR
LOOP UNTIL LL<>0 OR RR<>0 OR GETKEYSTATE(9)<0 !'クリックするかTABキーを押すまで待つ
DO
MOUSE POLL X,Y,LL,RR
LOOP WHILE LL<>0 OR RR<>0 OR GETKEYSTATE(9)<0 !'指が離れるまで待つ
LOOP
LOOP
END
EXTERNAL SUB DRAWBOTTON(X1,Y1,X2,Y2,DY,A$,B$) !'ボタンを描く
OPTION ARITHMETIC NATIVE
CALL BOXFULL(X1,Y1,X2,Y2,128,128,128)
IF B$<>"" THEN CALL BOXFULL(X1,Y1+DY,X2,Y2+DY,128,128,128)
SET TEXT HEIGHT 38
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT X1,Y1:A$
IF B$<>"" THEN PLOT TEXT ,AT X1,Y1+DY:B$
END SUB
EXTERNAL SUB ERASEBOTTON(X1,Y1,X2,Y2,DY) !'ボタンを消す
OPTION ARITHMETIC NATIVE
CALL BOXFULL(X1,Y1,X2,Y2,255,255,255)
CALL BOXFULL(X1,Y1+DY,X2,Y2+DY,255,255,255)
END SUB
EXTERNAL SUB DRAWCOLORCODE(X,Y,STX,STY,K,R(),G(),B()) !'コード情報出力
OPTION ARITHMETIC NATIVE
CALL BOXFULL(STX,540,899,799,255,255,255)
SET TEXT COLOR COLORINDEX(0,0,0)
SET TEXT HEIGHT 28
PLOT TEXT ,AT STX,540:"登録CODE:"&RIGHT$("0"&BSTR$(K,16),2)&"("&STR$(K)&")"
SET TEXT HEIGHT 26
PLOT TEXT ,AT STX,574:"R="&STR$(R(K))&" G="&STR$(G(K))&" B="&STR$(B(K))
CALL BOXFULL(STX,610,336,770,R(K),G(K),B(K))
IF FLG(K)<>0 THEN
SET TEXT HEIGHT 45
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT 415,650:"登録済"
ELSE
SET TEXT HEIGHT 45
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT 415,650:"未登録"
END IF
END SUB
EXTERNAL SUB DRAWMODE(MODE,XSIZE,YSIZE,K,R(),G(),B()) !'MODE 1～3を処理
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
LET X1=700
LET Y1=30
LET X2=850
LET Y2=75
LET DY1=70
LET DY2=140
CALL DRAWBOTTON(X1,Y1,X2,Y2,DY1,"登録","戻る")
CALL ERASEBOTTON(X1,Y1+DY2,X2,Y2+DY2,DY1)
SELECT CASE MODE !'モードにより色選択用の画面を描画する
CASE 1
LET S=255
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL HSV2RGB(INT(X/XSIZE*360),S,255-INT(Y/YSIZE*255),RR,GG,BB)
CALL PSET(X,Y,RR,GG,BB)
NEXT X
NEXT Y
CASE 2
LET V=255
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
IF X=INT(XSIZE/2) AND Y=INT(YSIZE/2) THEN LET H=0 ELSE LET H=MOD(ANGLE(X-XSIZE/2,Y-YSIZE/2)+360,360)
LET S=INT(SQR((X-XSIZE/2)^2+(Y-YSIZE/2)^2)/SQR((XSIZE/2)^2+(YSIZE/2)^2)*255)
IF S>255 THEN LET S=255
CALL HSV2RGB(H,S,V,RR,GG,BB)
CALL PSET(X,Y,RR,GG,BB)
NEXT X
NEXT Y
CASE 3
OPTION BASE 0
LET XSIZE=600
LET YSIZE=500
LET STY=INT(YSIZE/16)
LET STX=INT(XSIZE/16)
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG" !'画像ファイル読み込み
IF N$="" THEN
CALL MESSAGEBOX("キャンセルしました")
EXIT SUB
END IF
GLOAD N$
LET BIWIDTH=PIXELX(1)+1
LET BIHEIGHT=PIXELY(1)+1
SET BITMAP SIZE BIWIDTH,BIHEIGHT
SET WINDOW 0,BIWIDTH-1,BIHEIGHT-1,0
DIM VM(BIWIDTH,BIHEIGHT)
ASK PIXEL ARRAY(0,0) VM
CALL GINIT(900,800)
CALL DRAWBOTTON(X1,Y1,X2,Y2,DY1,"登録","戻る")
CALL DRAWCOLORCODE(STX,STY,STX,STY,K,R,G,B)
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
CALL BILINEAR(BIWIDTH,BIHEIGHT,X*BIWIDTH/XSIZE,Y*BIHEIGHT/YSIZE,VM,RR,GG,BB)
CALL PSET(X,Y,RR,GG,BB)
NEXT X
NEXT Y
END SELECT
LET RR=-1
LET GG=-1
LET BB=-1
DO
DO
MOUSE POLL XX,YY,L1,R1 !'マウス操作
IF SPECIAL=0 THEN CALL GETPOINT(XX,YY,R0,G0,B0) ELSE CALL GETCOLOR(R0,G0,B0)
SET DRAW MODE HIDDEN
SET TEXT HEIGHT 10
CALL BOXFULL(740,670,899,690,255,255,255)
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT 740,670:"(R,G,B)=("&USING$("###",R0)&","&USING$("###",G0)&","&USING$("###",B0)&")" !'カラーピッカー表示
CALL BOXFULL(750,700,850,770,R0,G0,B0)
SET DRAW MODE EXPLICIT
CALL MOUSECURSOR(MX,MY)
IF MX>=0 AND MX<=899 AND MY>=0 AND MY<=799 THEN LET SPECIAL=0 ELSE LET SPECIAL=1
LOOP UNTIL L1<>0 OR R1<>0 OR GETKEYSTATE(9)<0 !'クリックするかTABキーを押す
IF XX<=XSIZE AND YY<=YSIZE OR GETKEYSTATE(9)<0 THEN !'座標で振り分け
IF SPECIAL=0 THEN CALL GETPOINT(XX,YY,RR,GG,BB) ELSE CALL GETCOLOR(RR,GG,BB)
SET TEXT COLOR COLORINDEX(0,0,0)
SET TEXT HEIGHT 28
PLOT TEXT ,AT 350,670:"→"
CALL BOXFULL(400,572,770,603,255,255,255)
SET TEXT COLOR COLORINDEX(0,0,0)
SET TEXT HEIGHT 26
PLOT TEXT ,AT 400,574:"R="&STR$(RR)&" G="&STR$(GG)&" B="&STR$(BB)
CALL BOXFULL(400,610,700,770,RR,GG,BB)
ELSEIF XX>X1 AND XX<X2 AND YY>Y1 AND YY<Y2 THEN !'登録ボタン処理
IF RR>=0 AND GG>=0 AND BB>=0 THEN
SELECT CASE CONFIRM$("登録しますか?")
CASE "YES"
LET R(K)=RR
LET G(K)=GG
LET B(K)=BB
LET FLG(K)=1
SET TEXT HEIGHT 30
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT 650,440:"登録しました"
WAIT DELAY 2
EXIT DO
CASE "NO"
SET TEXT HEIGHT 20
SET TEXT COLOR COLORINDEX(0,0,0)
PLOT TEXT ,AT 650,440:"キャンセルしました"
WAIT DELAY 2
EXIT DO
END SELECT
ELSE
CALL MESSAGEBOX("色が選択されていません")
END IF
ELSEIF XX>X1 AND XX<X2 AND YY>Y1+70 AND YY<Y2+70 THEN !'戻るボタン処理
CALL MESSAGEBOX("キャンセルしました")
EXIT DO
END IF
DO
MOUSE POLL XX,YY,L1,R1
LOOP WHILE L1<>0 OR R1<>0 OR GETKEYSTATE(9)<0 !'指が離れるまで待つ
LOOP
END SUB
EXTERNAL SUB DRAWPALLET(XSIZE,YSIZE,STX,STY,R(),G(),B()) !'パレット描画
OPTION ARITHMETIC NATIVE
SET TEXT HEIGHT 16
SET TEXT COLOR COLORINDEX(0,0,0)
SET TEXT JUSTIFY "LEFT" , "TOP"
SET LINE WIDTH 3
FOR X=0 TO 15
PLOT TEXT ,AT STX*1.2+X*STX,STY*.4:RIGHT$("0"&BSTR$(X,16),2)
NEXT X
FOR Y=0 TO 15
PLOT TEXT ,AT STX*.4,STY*1.2+Y*STY:RIGHT$("0"&BSTR$(Y*16,16),2)
NEXT Y
FOR Y=0 TO 15
FOR X=0 TO 15
LET K=INT(Y*16+X)
CALL BOXFULL(X*STX+STX,Y*STY+STY,(X+1)*STX+STX,(Y+1)*STY+STY,R(K),G(K),B(K))
IF FLG(K)<>0 THEN
LET R0=INT(RND*256) !'色が被らないように
LET G0=INT(RND*256)
LET B0=INT(RND*256)
CALL LINE(X*STX+STX,Y*STY+STY,(X+1)*STX+STX,(Y+1)*STY+STY,R0,G0,B0) !'登録済には×印
CALL LINE((X+1)*STX+STX,Y*STY+STY,X*STX+STX,(Y+1)*STY+STY,R0,G0,B0)
END IF
NEXT X
NEXT Y
END SUB
EXTERNAL SUB HSV2RGB(H,S,V,R,G,B) !'HSVカラーをRGBカラーに変換
OPTION ARITHMETIC NATIVE
IF S=0 THEN
LET R=V
LET G=V
LET B=V
EXIT SUB
END IF
LET T=V-S*V/255
LET HH=H
IF H>=300 OR H<60 THEN
IF H>=300 THEN LET HH=360-HH
IF H<60 THEN LET HH=-HH
LET HH=HH/60
LET RR=0
IF HH<0 THEN
LET BB=1
LET GG=HH+BB
ELSE
LET GG=1
LET BB=GG-HH
END IF
END IF
IF H>=60 AND H<180 THEN
LET HH=HH-120
LET HH=HH/60
LET GG=0
IF HH<0 THEN
LET BB=1
LET RR=HH+BB
ELSE
LET RR=1
LET BB=RR-HH
END IF
END IF
IF H>=180 AND H<300 THEN
LET HH=HH-240
LET HH=HH/60
LET BB=0
IF HH<0 THEN
LET RR=1
LET GG=HH+RR
ELSE
LET GG=1
LET RR=GG-HH
END IF
END IF
LET R=-RR*(V-T)+V
LET R=INT(R)
LET G=-GG*(V-T)+V
LET G=INT(G)
LET B=-BB*(V-T)+V
LET B=INT(B)
END SUB
EXTERNAL SUB BILINEAR(XSIZE,YSIZE,X,Y,IMAGE(,),R,G,B) !'バイリニア法
OPTION ARITHMETIC NATIVE
LET XX=X-INT(X)
LET YY=Y-INT(Y)
LET X0=INT(X)
LET Y0=INT(Y)
LET C1=IMAGE(X0,Y0)
IF X0+1<=XSIZE THEN LET C2=IMAGE(X0+1,Y0)
IF Y0+1<=YSIZE THEN LET C3=IMAGE(X0,Y0+1)
IF X0+1<=XSIZE AND Y0+1<=YSIZE THEN LET C4=IMAGE(X0+1,Y0+1)
CALL RGB(C1,R1,G1,B1)
CALL RGB(C2,R2,G2,B2)
CALL RGB(C3,R3,G3,B3)
CALL RGB(C4,R4,G4,B4)
LET R=(1-YY)*((1-XX)*R1+XX*R2)+YY*((1-XX)*R3+XX*R4)
LET G=(1-YY)*((1-XX)*G1+XX*G2)+YY*((1-XX)*G3+XX*G4)
LET B=(1-YY)*((1-XX)*B1+XX*B2)+YY*((1-XX)*B3+XX*B4)
LET R=MAX(0,MIN(255,R))
LET G=MAX(0,MIN(255,G))
LET B=MAX(0,MIN(255,B))
END SUB
EXTERNAL SUB MESSAGEBOX(M$)
OPTION ARITHMETIC NATIVE
LET N=MESSBOX(0,M$,"BASIC",0)
FUNCTION MESSBOX(OWNER,TEXT$,CAPTION$,FLAG)
ASSIGN "user32.dll","MessageBoxA"
END FUNCTION
END SUB
EXTERNAL SUB MOUSECURSOR(MX,MY)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET PNT$=REPEAT$("#",2*4)
LET RC=GETCURSORPOS(PNT$)
LET RC=SCREENTOCLIENT(WINHANDLE("GRAPHICS"),PNT$)
LET MX=INT32(PNT$,0)
LET MY=INT32(PNT$,4)
END SUB
EXTERNAL SUB GETCOLOR(R,G,B)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET PNT$=REPEAT$("#",2*4)
LET RC=GETCURSORPOS(PNT$)
LET MX=INT32(PNT$,0)
LET MY=INT32(PNT$,4)
LET HDC=GETDC(0)
LET C=GETPIXEL(HDC,MX,MY)
LET DMY=RELEASEDC(0,HDC)
CALL RGB(C,R,G,B)
END SUB
EXTERNAL FUNCTION SCREENTOCLIENT(HWND, LPPOINT$)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"ScreenToClient"
END FUNCTION
EXTERNAL FUNCTION GETCURSORPOS(LPPOINT$)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"GetCursorPos"
END FUNCTION
EXTERNAL FUNCTION GETPIXEL(HDC,X,Y)
OPTION ARITHMETIC NATIVE
ASSIGN "gdi32.dll" ,"GetPixel"
END FUNCTION
EXTERNAL FUNCTION GETDC(HDC)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"GetDC"
END FUNCTION
EXTERNAL FUNCTION RELEASEDC(HWND,HDC)
OPTION ARITHMETIC NATIVE
ASSIGN "user32.dll" ,"ReleaseDC"
END FUNCTION
EXTERNAL FUNCTION INT32(S$,P)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET N=0
FOR I=1 TO 4
LET N=N+256^(I-1)*ORD(S$(P+I:P+I))
NEXT I
IF N<2^31 THEN LET INT32=N ELSE LET INT32=N-2^32
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB BOX(XS,YS,XE,YE,R,G,B)
OPTION ARITHMETIC NATIVE
CALL LINE(XS,YS,XE,YS,R,G,B)
CALL LINE(XE,YS,XE,YE,R,G,B)
CALL LINE(XE,YE,XS,YE,R,G,B)
CALL LINE(XS,YE,XS,YS,R,G,B)
END SUB
EXTERNAL SUB LINE(X0,Y0,X1,Y1,R,G,B)
OPTION ARITHMETIC NATIVE
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES:X0,Y0;X1,Y1
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB BOXFULL(X0,Y0,X1,Y1,R,G,B)
OPTION ARITHMETIC NATIVE
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT AREA:X0,Y0;X1,Y0;X1,Y1;X0,Y1;X0,Y0
END SUB
function colourDistance
parameters: h, s, v: real: components of the HSV colour space;
distance: real: the distance estimate calculated during iteration;
pixelWidth: real: the width represented by a pixel on the screen;
boundaryFraction: real: value > 0 used to control prominence of the boundary
Finding Complex Roots of a Function
Basin colouring for Newtonian fractals requires us to know the roots of the function before we generate the fractal.
We can also anticipate a future requirement of identifying critical points of a function for generating Mandelbrot sets. Therefore, we need a generic root finding algorithm. This algorithm uses - what else? - Newton's method.
definition rootObject
properties: x: the real component of z;
y: the imaginary component of z;
r: the modulus of z;
theta: the angle of z
function findRoots
parameters: f: a pointer to a function that takes a complex number, z, and computes f(z);
fprime: a pointer to a function that takes a complex number, z, and computes f?(z)
constants: XMAX, XMIN, YMAX, YMIN: the limits of the complex plane to be tested
let:
eV = 1e-8,
// For checking suspiciously small real / imaginary components
delta = eV * 100,
// For comparing roots found
tolerance = delta * 100,
rSpan = XMAX - XMIN,
iSpan = YMAX - YMIN,
// If we don't find a root after n iterations, give up and move on
iterations = 100,
// We'll test this many points in the x- and y- axes
points = 30,
rInt = rSpan / points,
iInt = iSpan / points,
roots = [];
// Test a reasonably large sample of points in the plane; assuming that we only have to
// do this when we regenerate a fractal, we can use a conservatively large value to minimize
// the chances of failing to find distinct roots that are close to each other
for (i = 0..points) {
for(j = 0..points) {
let:
x = XMIN + i * rInt,
y = YMIN + j * iInt,
diff = 1,
iter = 0;
while (iter < iterations AND diff > eV) {
// Get the numerator and denominator
[nomX, nomY] = f(x, y);
[denomX, denomY] = fprime(x, y);
// Divide f(z) by f'(z) - multiply through by conjugate of denominator
tmp = nomX * denomX + nomY * denomY;
nomY = nomY * denomX - nomX * denomY;
nomX = tmp;
denomX = denomX * denomX + denomY * denomY;
if (!denomX) {
// Try another number
break;
}
// Now we can divide
_x = x - nomX / denomX;
_y = y - nomY / denomX;
// Get the differences from last round
diffX = x - _x;
diffY = y - _y;
diff = sqrt(diffX * diffX + diffY * diffY);
// Set up the next guess
x = _x;
y = _y;
++iter;
}
if (diff < eV) {
let:
newRoot = TRUE;
// Zero suspiciously small real / imaginary components so that the roots can
// be sorted deterministically
if (abs(x) < delta) {
x = 0;
}
if (abs(y) < delta) {
y = 0;
}
for (k = 0..LENGTH(roots)) {
if (complexCompare(x, y, roots[k].x, roots[k].y, tolerance)) {
newRoot = FALSE;
break;
}
}
if (newRoot) {
push(roots, rootObject{ x : x, y : y, r : sqrt(x * x + y * y), theta : atan2(y, x) });
}
}
}
}
!Copyright(C) 2010 かりん All Rights Reserved. http://web-box.jp/rgbkarin/fractal.txt
!１０進ＢＡＳＩＣ専用
!任意の範囲をドラッグ＋正方形クリックで拡大操作
!
!カラーコード 193色(RGB)
data 000000
data FF0000,FF0800,FF1000,FF1800,FF2000,FF2800,FF3000,FF3800,FF4000,FF4800,FF5000,FF5800,FF6000,FF6800,FF7000,FF7800
data FF8000,FF8800,FF9000,FF9800,FFA000,FFA800,FFB000,FFB800,FFC000,FFC800,FFD000,FFD800,FFE000,FFE800,FFF000,FFF800
data FFFF00,F8FF00,F0FF00,E8FF00,E0FF00,D8FF00,D0FF00,C8FF00,C0FF00,B8FF00,B0FF00,A8FF00,A0FF00,98FF00,90FF00,88FF00
data 80FF00,78FF00,70FF00,68FF00,60FF00,58FF00,50FF00,48FF00,40FF00,38FF00,30FF00,28FF00,20FF00,18FF00,10FF00,08FF00
data 00FF00,00FF08,00FF10,00FF18,00FF20,00FF28,00FF30,00FF38,00FF40,00FF48,00FF50,00FF58,00FF60,00FF68,00FF70,00FF78
data 00FF80,00FF88,00FF90,00FF98,00FFA0,00FFA8,00FFB0,00FFB8,00FFC0,00FFC8,00FFD0,00FFD8,00FFE0,00FFE8,00FFF0,00FFF8
data 00FFFF,00F8FF,00F0FF,00E8FF,00E0FF,00D8FF,00D0FF,00C8FF,00C0FF,00B8FF,00B0FF,00A8FF,00A0FF,0098FF,0090FF,0088FF
data 0080FF,0078FF,0070FF,0068FF,0060FF,0058FF,0050FF,0048FF,0040FF,0038FF,0030FF,0028FF,0020FF,0018FF,0010FF,0008FF
data 0000FF,0800FF,1000FF,1800FF,2000FF,2800FF,3000FF,3800FF,4000FF,4800FF,5000FF,5800FF,6000FF,6800FF,7000FF,7800FF
data 8000FF,8800FF,9000FF,9800FF,A000FF,A800FF,B000FF,B800FF,C000FF,C800FF,D000FF,D800FF,E000FF,E800FF,F000FF,F800FF
data FF00FF,FF00F8,FF00F0,FF00E8,FF00E0,FF00D8,FF00D0,FF00C8,FF00C0,FF00B8,FF00B0,FF00A8,FF00A0,FF0098,FF0090,FF0088
data FF0080,FF0078,FF0070,FF0068,FF0060,FF0058,FF0050,FF0048,FF0040,FF0038,FF0030,FF0028,FF0020,FF0018,FF0010,FF0008
declare sub shift_sfn
declare sub fpr_sfn
declare sub select_area
declare sub updateparam
declare sub draw_area
declare sub tdraw_area
declare sub flood_area
declare sub draw_point
declare sub pointdraw
declare sub draw_side
declare sub draw_inside
declare sub draw_srline
declare sub printdata
set point style 1
set color mode "native"
set draw mode explicit
option base 0
option arithmetic complex
declare function fcos !複素数拡張 cos() 関数
declare function fsin !複素数拡張 sin() 関数
let cnum = 193 !色数(64×3＋1)
let kcn = cnum-1
let kcolor = 1/255 !RGB指数変換定数(24bits)
dim ind(kcn) !色指標用配列
let undolimit = 100
let ul = undolimit
let lv = 0
dim graphics(ul)
dim realpartmin(ul),imaginarypartmin(ul)
dim realpartmax(ul),imaginarypartmax(ul)
dim repeatlimit(ul),uupdate(ul)
!━━━━━━━━━━━━━━━━━━━━━━━━━━━カラーコードを色指標に変換━━━━━━━━━━━━━━━━━━━━
for g1 = 0 to kcn
read cl$
let r = bval(cl$(1:2),16)*kcolor
let g = bval(cl$(3:4),16)*kcolor
let b = bval(cl$(5:6),16)*kcolor
let ind(g1) = colorindex(r,g,b)
next g1
!━━━━━━━━━━━━━━━━━━━━━━━━━━━境界走査―境界描画と境界判定━━━━━━━━━━━━━━━━━━━
sub draw_side
for gx = mgx to mgxp
let gxf = gx1 + krg*gx
let gy = mgy
let gyf = gy1 + krg*gy
call draw_point!<--------------------------------draw_point -> pointdraw で判定
let gy = mgyp
let gyf = gy1 + krg*gy
call draw_point!<--------------------------------draw_point -> pointdraw で判定
next gx
for gy = mgy1 to mgym
let gyf = gy1 + krg*gy
let gx = mgx
let gxf = gx1 + krg*gx
call draw_point!<--------------------------------draw_point -> pointdraw で判定
let gx = mgxp
let gxf = gx1 + krg*gx
call draw_point!<--------------------------------draw_point -> pointdraw で判定
next gy
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━境界走査―内部の描画━━━━━━━━━━━━━━━━━━━━━━━
sub draw_inside(grx,gry)
let mgy = mgyt*grc
let mgyp = mgy+gry-1
let mgy1 = mgy+1
let mgym = mgyp-1
let sign = 1
call draw_side!<------------------------------------境界の計算、描画と判定
if sign = 1 then!-----------------------------------境界点がすべて非収束か非発散の場合内部も同様とみなす
call flood_area(mgx,mgy,mgx+grx-1,mgy+gry-1,ind(0))
else!<----------------------------------------------sign = 0 のときの内部計算と描画
for gx = mgx1 to mgxm
let gxf = gx1 + krg*gx
for gy = mgy1 to mgym
let gyf = gy1 + krg*gy
call draw_point
next gy
next gx
end if
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━境界走査―各列描画━━━━━━━━━━━━━━━━━━━━━━━━
sub draw_srline(grx1,gry1,gry2)
set draw mode hidden
let mgx = mgxt*grc
let mgxp = mgx+grx1-1
let mgx1 = mgx+1
let mgxm = mgxp-1
call flood_area(mgx,0,mgxp,wx,colorindex(1,1,1))!<---塗りつぶしを上手くするために描画する部分を消す
for mgyt = 0 to div
call draw_inside(grx1,gry1)
next mgyt
!---------------------------------------------------画像サイズが境界サイズで割り切れない場合の余り部分の描画
if gmod = 1 then
call draw_inside(grx1,gry2)
end if
set draw mode explicit
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━収束回数による色分けと点の描画━━━━━━━━━━━━━━━━━━
sub pointdraw
!------------------------------------------------------収束しないまたは振動の場合
if k = pn then
let nb = 0
else
!---------------------------------------------------収束または発散した場合 k が収束か発散までの反復回数
let nb = mod(k,kcn) + 1
let sign = 0!<-----------------------------------収束か発散した点が存在したとき sign = 0 として内部計算も行う
end if
set color ind(nb)
plot points :gx,gy
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━数列 z(n) の収束、振動及び発散の判定と描画━━━━━━━━━━━━
sub draw_point
when exception in
let c = complex(gxf,gyf)
call fpr_sfn
let zd = 1
let k = 1
!------------------------------------------------収束、発散の判定文
do while k =< num and abs(zd) > mindt and abs(zd) < maxdt
let gz = z
call shift_sfn
let zd = z-gz
let k = k + 1
loop
!------------------------------------------------
call pointdraw
use
call pointdraw
end when
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━拡大範囲選択の四角の描画━━━━━━━━━━━━━━━━━━━━━
sub tdraw_area
call draw_area(x1,y1,x1+trangex,y1+trangey,colorindex(0,0,1))
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━描画データの表示━━━━━━━━━━━━━━━━━━━━━━━━━
sub printdata
print "実部 "&str$(gx1)&"≦Re≦"&str$(gx2)
print "虚部 "&str$(gy1)&"≦Im≦"&str$(gy2)
print "幅 "&str$(xrange)
print "中心座標 ("&str$(lpx1)&","&str$(lpy1)&")"
print "色数 "&str$(cnum)&"色"
print "画像サイズ "&str$(wx)&"pixel×"&str$(wx)&"pixel"
print "境界走査幅 "&str$(grc)&"pixel"
print "計算回数 "&str$(num)&"回"
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━拡大部分の選択と画像保存、終了の操作をする━━━━━━━━━━━━
sub select_area
let left = 0
let right = 0
do while left = 0 and right = 0
mouse poll dx1,dy1,left,right
loop
if right = 1 then
if lu <> 1 then
let lu = lu - 1
set draw mode hidden
gload "~table"&str$(lu)&".bmp"
set draw mode explicit
set draw mode notxor
let wx = graphics(lu)
set window 0,wx-1,0,wx-1
end if
end if
if left = 1 then
set draw mode notxor
let x1 = dx1
let y1 = dy1
let x2 = x1
let y2 = y1
let update = 1
let trangex = 0
let trangey = 0
call tdraw_area
set draw mode hidden
do while left = 1
mouse poll x3,y3,left,right
if x3 <> x2 or y3 <> y2 then
set draw mode hidden
call tdraw_area
let trange = max(abs(x1-x3),abs(y1-y3))
let trangex = sgn(x3-x1)*trange
let trangey = sgn(y3-y1)*trange
set draw mode explicit
call tdraw_area
let x2 = x3
let y2 = y3
end if
loop
if x1 = x2 and y1 = y2 then
if lu <> lv then
let lu = lu + 1
set draw mode hidden
gload "~table"&str$(lu)&".bmp"
set draw mode explicit
set draw mode notxor
let wx = graphics(lu)
set window 0,wx-1,0,wx-1
end if
exit sub
end if
let left = 0
let right = 0
do while left = 0 and right = 0
mouse poll x4,y4,left,right
loop
let gx41 = sgn(x4-x1)
let tx41 = sgn(x4-x1-trangex)
let gy41 = sgn(y4-y1)
let ty41 = sgn(y4-y1-trangey)
if left = 1 then
if gx41 <> tx41 and gy41 <> ty41 then
let cont = 1
else
let cont = 0
call tdraw_area
end if
end if
if right = 1 then
if gx41 <> tx41 and gy41 <> ty41 then
call updateparam
let cont = 1
else
let cont = 0
call tdraw_area
do while right = 1
mouse poll x5,y5,left,right
loop
end if
end if
end if
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━描画範囲変更に伴う各値の更新━━━━━━━━━━━━━━━━━━━
sub updateparam
input prompt "繰り返しの回数、画像サイズ、境界走査サイズ":num,wx,grc
let cont = 1
if mod(wx,grc) <> 0 then
let gmod = 1
let grm = mod(wx,grc)
else
let gmod = 0
end if
let uupdate(lu) = 1
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
!------------------------------------------------------初期値
let wx = 556 !グラフィックス画面の横画素数
let wy = wx !グラフィックス画面の縦画素数
let num = 256 !反復計算回数の上限
let lpx1_ = 0.0000001!グラフィックス画面の中心の実座標
let lpy1_ = 0.0000001!グラフィックス画面の中心の虚座標
let xrange_ = 8 !グラフィックス画面に割り当てる複素平面の範囲（初回描画時）
let mindt = 1e-10 !|z(n)-z(n+1)|=<mindtの時収束と判定する
let maxdt = 1e+10 !|z(n)-z(n+1)|>=maxdtの時発散と判定する
let grc = 10 !描画中再描画するまで計算するライン数
let grt = 1 !描画ラインカウント変数
let grm = 0
let lpx1 = lpx1_
let lpy1 = lpy1_
let xrange = xrange_
let zd = 1 !|z(n)-z(n+1)|を代入する変数
let gmod = 0
set bitmap size wx,wx
let gx1 = lpx1 - xrange/2
let gy1 = lpy1 - xrange/2
let gx2 = lpx1 + xrange/2
let gy2 = lpy1 + xrange/2
let count = 0
let wx_ = wx+1
let i = complex(0,1) !虚数単位
if mod(wx,grc) <> 0 then
let gmod = 1
let grm = mod(wx,grc)
end if
call printdata
!━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
do while count <> 1
set draw mode overwrite
if wx <> wx_ then set bitmap size wx,wx
set window 0,wx-1,0,wx-1
let wx_ = wx
let krg = xrange/wx
let pn = num + 1
let start_time = time
let div = int(wx/grc)-1
let lv = lv + 1
let graphics(lv) = wx
let realpartmin(lv) = gx1
let imaginarypartmin(lv) = gy1
let realpartmax(lv) = gx2
let imaginarypartmax(lv) = gy2
let repeatlimit(lv) = num
!---------------------------------------------------描画総括
for mgxt = 0 to div
call draw_srline(grc,grc,grm)
next mgxt
if gmod = 1 then
call draw_srline(grm,grc,grm)
end if
!---------------------------------------------------拡大操作
set draw mode explicit
set draw mode notxor
print "計算時間 "&str$(round(time-start_time,3))&"秒"
print
gsave "~table"&str$(lv)&".bmp"
let lu = lv
let cont = 0
do while cont = 0
do while left = 1 or right = 1
mouse poll dxu,dyu,left,right
loop
call select_area
loop
if lv <> lu and uupdate(lu) = 0 then
let lv = lu
let wx = graphics(lu)
let gx1 = realpartmin(lu)
let gy1 = imaginarypartmin(lu)
let gx2 = realpartmax(lu)
let gy2 = imaginarypartmax(lu)
let num = repeatlimit(lu)
let krg = abs(gx1-gx2)/wx
end if
!---------------------------------------------------描画範囲変更に伴う各値の更新
if update = 1 then
let gx1_= gx1
let gy1_= gy1
let gx1 = gx1_+min(x1,x1+trangex)*krg
let gy1 = gy1_+min(y1,y1+trangey)*krg
let gx2 = gx1_+max(x1,x1+trangex)*krg
let gy2 = gy1_+max(y1,y1+trangey)*krg
let lpx1 = (gx1+gx2)/2
let lpy1 = (gy1+gy2)/2
let xrange = abs(trangex)*krg
let update = 0
end if
!---------------------------------------------------
call printdata
let uupdate(lu) = 0
loop
!━━━━━━━━━━━━━━━━━━━━━━━━━━━長方形を作る━━━━━━━━━━━━━━━━━━━━━━━━━━━
sub draw_area(x1,y1,x2,y2,cind)
set color cind
plot lines : x1,y1 ; x1,y2 ; x2,y2 ; x2,y1 ; x1,y1
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━長方形塗りつぶし━━━━━━━━━━━━━━━━━━━━━━━━━
sub flood_area(x1,y1,x2,y2,cind)
set area color cind
plot area : x1,y1 ; x1,y2 ; x2,y2 ; x2,y1 ; x1,y1
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━複素三角関数━━━━━━━━━━━━━━━━━━━━━━━━━━━
function fsin(z_)
let fsin = (exp(i*z_)-exp(-i*z_))/(2*i)
end function
function fcos(z_)
let fcos = (exp(i*z_)+exp(-i*z_))/2
end function
!━━━━━━━━━━━━━━━━━━━━━━━━━━━数列z(n)の反復式━━━━━━━━━━━━━━━━━━━━━━━━━
sub shift_sfn
let z2 = z*z
LET z = z-(z3*z2+z*z2*c+c)/(5*z2*z2+3*z2*c)
end sub
!━━━━━━━━━━━━━━━━━━━━━━━━━━━数列z(n)の初期値と複素数の変換式━━━━━━━━━━━━━━━━━
sub fpr_sfn
! let c = c
let z = -c/2 !数列z(n)の初期値
end sub
end
LET XSIZE=50
LET YSIZE=50
INPUT PROMPT "MODE(0 - 41)=":MODE
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 3.0"
PRINT #1:"plane"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_GRID"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;1
PRINT #1:"POINTS";XSIZE*YSIZE;"float"
LET XS=-5
LET YS=-5
LET XE=5
LET YE=5
LET STX=(XE-XS)/XSIZE
LET STY=(YE-YS)/YSIZE
LET SCALE=10
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET Z=FUNC(MODE,XS+X*STX,YS+Y*STY)
PRINT #1:X;Y;Z
NEXT X
NEXT Y
PRINT #1:"POINT_DATA";XSIZE*YSIZE
PRINT #1:"SCALARS value float"
PRINT #1:"LOOKUP_TABLE default"
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET Z=FUNC(MODE,XS+X*STX,YS+Y*STY) !'スカラー値(Z値)
PRINT #1:Z
NEXT X
NEXT Y
CLOSE #1
END
EXTERNAL FUNCTION FUNC(MODE,X,Y) !'3次元陽関数 z=f(x,y)
SELECT CASE MODE
CASE 0
LET FUNC=COS(5*SQR(X*X+Y*Y))
CASE 1
LET FUNC=X*Y*(X^2-Y^2)
CASE 2
LET FUNC=(X^2-Y^2)/2
CASE 3
LET FUNC=EXP(-X^2-Y^2)*(X^2+Y^2)
CASE 4
IF(X^2-1)*(X^2-9)*(Y^2-1)*(Y^2-9)>0 THEN
LET FUNC=2
ELSE
LET FUNC=0
END IF
CASE 5
LET Z=4-X^2-Y^2
IF Z>0 THEN LET FUNC=SQR(Z) ELSE LET FUNC=0
CASE 6
LET Z=2*(X^2+Y^2-3)
IF Z>0 THEN LET FUNC=SQR(Z) ELSE LET FUNC=0
CASE 7
LET FUNC=EXP(-Y)*SIN(3*X)
CASE 8
LET FUNC=MIN(3,X^2+Y^2-4)
CASE 9
LET Z=1-X^2
IF Z>0 THEN LET Z=SQR(Z) ELSE LET Z=0
LET FUNC=MIN(Z,Y^2)
CASE 10
IF X=0 AND Y=0 THEN
LET FUNC=0
ELSE
LET FUNC=X*Y/(X^2+Y^2)
END IF
CASE 11
LET FUNC=LOG(X^2+Y^2+.1)
CASE 12
LET FUNC=MAX(X^2+Y^2-(X^2+Y^2+Y)^2,-2)
CASE 13
LET FUNC=MIN(MAX(X^3-3*X*Y+Y^3,-4),0)
CASE 14
LET FUNC=SIN(X)*SIN(Y)*SIN(X+Y)
CASE 15
LET FUNC=COS(PI*X)*COS(PI*Y)
CASE 16
LET FUNC=COS(3*X*Y)
CASE 17
LET FUNC=SQR(COS(X)^2+SINH(Y)^2)
CASE 18
LET Z=1-X^2
IF Z>0 THEN LET Z=SQR(Z) ELSE LET Z=0
LET FUNC=MIN(Z,.5*(1.5*X-Y)^2)
CASE 19
LET Z=1-(SQR(X^2+Y^2)-1.5)^2
IF Z>0 THEN LET FUNC=SQR(Z) ELSE LET FUNC=0
CASE 20
LET FUNC=6-4*SQR(X^2+Y^2)
CASE 21
LET Z=1-X^2
LET ZZ=1-Y^2
IF Z>0 THEN LET Z=SQR(Z) ELSE LET Z=0
IF ZZ>0 THEN LET ZZ=SQR(ZZ) ELSE LET ZZ=0
LET FUNC=MAX(Z,ZZ)
CASE 22
LET Z=1-(SQR(X^2+Y^2)-1.5)^2
LET ZZ=.7-X^2
IF Z>0 THEN LET Z=SQR(Z) ELSE LET Z=0
IF ZZ>0 THEN LET ZZ=SQR(ZZ) ELSE LET ZZ=0
LET FUNC=MAX(Z,ZZ)
CASE 23
LET FUNC=EXP(-X^2+Y^2)
CASE 24
LET Z=1-X^2
IF Z>0 THEN LET Z=SQR(Z) ELSE LET Z=0
LET FUNC=MIN(Z,.25*(Y^2-2.5)^2)
CASE 25
IF X=0 OR Y=0 THEN
LET FUNC=1
ELSE
LET FUNC=SIN(X*Y)/X/Y
END IF
CASE 26
LET Z=1-.25*(Y-SIN(X))^2
IF Z>0 THEN LET FUNC=SQR(Z) ELSE LET FUNC=0
CASE 27
LET FUNC=2*ABS(COS(X*PI)*COS(Y*PI))^3
CASE 28
LET FUNC=(X^3+Y^3)/10
CASE 29
LET FUNC=SQR(X^2+(Y+1)^2)*SQR(X^2+(Y-1)^2)
CASE 30
LET FUNC=X^3-X*Y^2
CASE 31
LET FUNC=SIN(X*Y)
CASE 32
LET FUNC=3*EXP(-.5*((X-3*INT(X/3)-1.5)^2+(Y-3*INT(Y/3)-1.5)^2))*COS(PI*((X-3*INT(X/3)-1.5)^2+(Y-3*INT(Y/3)-1.5)^2))
CASE 33
LET FUNC=EXP(.5*X)*SIN(Y)
CASE 34
IF X>0 AND Y>0 THEN
LET FUNC=0
ELSE
LET FUNC=6*EXP(-X^2-Y^2)*(X^2+Y^2)
END IF
CASE 35
LET Z=4-(X-2*INT((X+1)/2))^2-(Y-2*INT((Y+1)/2))^2
IF Z>0 THEN LET FUNC=SQR(Z) ELSE LET FUNC=0
CASE 36
LET FUNC=SIN(Y)+SIN(2*X)+SIN(3*Y)+SIN(4*X)+SIN(5*Y)
CASE 37
LET FUNC=COS(X)+COS(2*Y)+COS(3*X)+COS(4*Y)+COS(5*X)
CASE 38
LET FUNC=SIN(X)-COS(Y)+SIN(3*X)+COS(3*Y)+SIN(5*X)-COS(5*Y)
CASE 39
LET FUNC=(X^2+SQR(2)*X*Y+Y^2-4)*(X^2-SQR(2)*X*Y+Y^2-4)
CASE 40
LET FUNC=(Y^2-X^4+X^6)*(X^2-Y^4+Y^6)
CASE 41
LET FUNC=SIN(2*X)*COS(Y)/2
CASE 42
!' LET FUNC=IM(EXP(-COMPLEX(X,Y))) !'複素数モード
END SELECT
END FUNCTION
LET XSIZE=945
LET YSIZE=125
CALL GINIT(XSIZE,YSIZE)
SET TEXT HEIGHT 100
SET TEXT COLOR 255
SET TEXT JUSTIFY "LEFT" , "TOP"
PLOT TEXT,AT 0,YSIZE:"(仮称)十進BASIC"
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 3.0"
PRINT #1:"letter"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_GRID"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;1
PRINT #1:"POINTS";XSIZE*YSIZE;"float"
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET C=GETPOINT(X,Y) !'濃度値を高さへ
IF C<0 THEN LET C=0
PRINT #1:X;Y;C
NEXT X
NEXT Y
PRINT #1:"POINT_DATA";XSIZE*YSIZE
PRINT #1:"SCALARS height double"
PRINT #1:"LOOKUP_TABLE default"
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET C=GETPOINT(X,Y)
IF C<0 THEN LET C=0
PRINT #1:C
NEXT X
NEXT Y
CLOSE #1
END
EXTERNAL FUNCTION GETPOINT(X,Y)
ASK PIXEL VALUE(X,Y) C
LET GETPOINT=C
END FUNCTION
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0 , XSIZE-1 , 0,YSIZE-1
SET COLOR MODE "REGULAR"
SET POINT STYLE 1
FOR I=0 TO 255
SET COLOR MIX(I) I/255,I/255,I/255
NEXT I
CLEAR
END SUB
INPUT PROMPT "LEVEL(1 - 5)=":LEV
LET N=4^LEV !'個数
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 3.0"
PRINT #1:"sierpinski"
PRINT #1:"ASCII"
PRINT #1:"DATASET UNSTRUCTURED_GRID"
PRINT #1:"POINTS";N;"float"
CALL RECURSIVE(LEV,X,Y,Z,2^LEV)
PRINT #1:"CELL_TYPES";N
FOR I=1 TO N
PRINT #1:1 !'点を表す
NEXT I
PRINT #1:"POINT_DATA";N
PRINT #1:"SCALARS distance float"
PRINT #1:"LOOKUP_TABLE default"
LET FLG=1
CALL RECURSIVE(LEV,X,Y,Z,2^LEV)
CLOSE #1
SUB RECURSIVE(LEV,X,Y,Z,L) !'シェルピンスキー
IF LEV=0 THEN
IF FLG=0 THEN PRINT #1:X;Y;Z ELSE PRINT #1:SQR(X^2+Y^2+Z^2)
ELSE
CALL RECURSIVE(LEV-1,X,Y,Z+L,L/2)
CALL RECURSIVE(LEV-1,X+L*COS(0*PI/180),Y+L*SIN(0*PI/180),Z,L/2)
CALL RECURSIVE(LEV-1,X+L*COS(120*PI/180),Y+L*SIN(120*PI/180),Z,L/2)
CALL RECURSIVE(LEV-1,X+L*COS(240*PI/180),Y+L*SIN(240*PI/180),Z,L/2)
END IF
END SUB
END
INPUT PROMPT "LEVEL(1 - 3)=":LEV
LET N=20^LEV !'データ個数
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 3.0"
PRINT #1:"menger sponge"
PRINT #1:"ASCII"
PRINT #1:"DATASET UNSTRUCTURED_GRID"
PRINT #1:"POINTS";N;"float"
CALL RECURSIVE(LEV,X,Y,Z,3^LEV)
PRINT #1:"CELL_TYPES";N
FOR I=1 TO N
PRINT #1:1
NEXT I
PRINT #1:"POINT_DATA";N
PRINT #1:"SCALARS distance float"
PRINT #1:"LOOKUP_TABLE default"
LET FLG=1
CALL RECURSIVE(LEV,X,Y,Z,3^LEV)
CLOSE #1
SUB RECURSIVE(N,X,Y,Z,L) !'メンガー
IF N=0 THEN
IF FLG=0 THEN PRINT #1:X;Y;Z ELSE PRINT #1:SQR(X^2+Y^2+Z^2)
ELSE
CALL RECURSIVE(N-1,X-L/3,Y+L/3,Z+L/3,L/3)
CALL RECURSIVE(N-1,X,Y+L/3,Z+L/3,L/3)
CALL RECURSIVE(N-1,X+L/3,Y+L/3,Z+L/3,L/3)
CALL RECURSIVE(N-1,X-L/3,Y,Z+L/3,L/3)
CALL RECURSIVE(N-1,X+L/3,Y,Z+L/3,L/3)
CALL RECURSIVE(N-1,X-L/3,Y-L/3,Z+L/3,L/3)
CALL RECURSIVE(N-1,X,Y-L/3,Z+L/3,L/3)
CALL RECURSIVE(N-1,X+L/3,Y-L/3,Z+L/3,L/3)
CALL RECURSIVE(N-1,X-L/3,Y+L/3,Z-L/3,L/3)
CALL RECURSIVE(N-1,X,Y+L/3,Z-L/3,L/3)
CALL RECURSIVE(N-1,X+L/3,Y+L/3,Z-L/3,L/3)
CALL RECURSIVE(N-1,X-L/3,Y,Z-L/3,L/3)
CALL RECURSIVE(N-1,X+L/3,Y,Z-L/3,L/3)
CALL RECURSIVE(N-1,X-L/3,Y-L/3,Z-L/3,L/3)
CALL RECURSIVE(N-1,X,Y-L/3,Z-L/3,L/3)
CALL RECURSIVE(N-1,X+L/3,Y-L/3,Z-L/3,L/3)
CALL RECURSIVE(N-1,X-L/3,Y+L/3,Z,L/3)
CALL RECURSIVE(N-1,X+L/3,Y+L/3,Z,L/3)
CALL RECURSIVE(N-1,X-L/3,Y-L/3,Z,L/3)
CALL RECURSIVE(N-1,X+L/3,Y-L/3,Z,L/3)
END IF
END SUB
END
OPTION BASE 0
READ XS,XE,YS,YE,ZS,ZE,N
DATA 5,-5,5,-5,5,-5,30
LET L=2 !'n乗
DIM ZA(3),AA(3),X(N^3),Y(N^3),Z(N^3)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 3.0"
PRINT #1:"moire"
PRINT #1:"ASCII"
PRINT #1:"DATASET UNSTRUCTURED_GRID"
PRINT #1:"POINTS";N^3;"float"
FOR ZZ=0 TO N-1
FOR YY=0 TO N-1
FOR XX=0 TO N-1
LET X0=XS+XX*(XE-XS)/N
LET Y0=YS+YY*(YE-YS)/N
LET Z0=ZS+ZZ*(ZE-ZS)/N
LET ZA(0)=1
LET ZA(1)=0
LET ZA(2)=0
LET ZA(3)=0
LET AA(0)=X0
LET AA(1)=Y0
LET AA(2)=Z0
LET AA(3)=0
FOR I=1 TO L !'L乗する
CALL MUL(ZA,ZA,AA) !'ZA=ZA*AA モアレ模様
NEXT I
PRINT #1:ZA(0);ZA(1);ZA(2)
LET K=K+1
LET X(K)=ZA(0)
LET Y(K)=ZA(1)
LET Z(K)=ZA(2)
NEXT XX
NEXT YY
NEXT ZZ
PRINT #1:"CELL_TYPES";N^3
FOR I=1 TO N^3
PRINT #1:1
NEXT I
PRINT #1:"POINT_DATA";N^3
PRINT #1:"SCALARS distance float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=1 TO K
PRINT #1:SQR(X(I)^2+Y(I)^2+Z(I)^2)
NEXT I
CLOSE #1
END
EXTERNAL SUB MUL(S(),A(),B())
OPTION BASE 0
DIM SS(3)
LET SS(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
LET SS(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2)
LET SS(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1)
LET SS(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0)
MAT S=SS
END SUB
LET N=40
DIM XX(15000),YY(15000),ZZ(15000),A(-N TO N,-N TO N),B(-N TO N,-N TO N)
LET A(0,0)=1
LET K=1
LET XX(K)=0
LET YY(K)=N-1
LET ZZ(K)=0
FOR Y=N-2 TO 0 STEP-1
FOR X=-N+1 TO N-1
FOR Z=-N+1 TO N-1
LET B(X,Z)=MOD(A(X-1,Z-1)+A(X-1,Z+1)+A(X+1,Z+1)+A(X+1,Z-1),2)
!'LET B(X,Z)=MOD(A(X-1,Z-1)+A(X-1,Z)+A(X-1,Z+1)+A(X,Z-1)+A(X,Z)+A(X,Z+1)+A(X+1,Z-1)+A(X+1,Z)+A(X+1,Z+1),2)
IF B(X,Z)<>0 THEN
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
END IF
NEXT Z
NEXT X
MAT A=B
MAT B=ZER
NEXT Y
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 3.0"
PRINT #1:"cellular automaton"
PRINT #1:"ASCII"
PRINT #1:"DATASET UNSTRUCTURED_GRID"
PRINT #1:"POINTS";K;"float"
FOR I=1 TO K
PRINT #1:XX(I);YY(I);ZZ(I)
NEXT I
PRINT #1:"CELL_TYPES";K
FOR I=1 TO K
PRINT #1:1
NEXT I
PRINT #1:"POINT_DATA";K
PRINT #1:"SCALARS distance float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=1 TO K
PRINT #1:SQR(XX(I)^2+YY(I)^2+ZZ(I)^2)
NEXT I
CLOSE #1
END
RANDOMIZE
FILE GETSAVENAME F$,"csvファイル|*.csv"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".CSV")=0 THEN LET F$=F$&".csv"
OPEN #1:NAME F$,RECTYPE INTERNAL !'内部形式で書き込み
ERASE #1
WRITE #1:"X-VALUE","Y-VALUE","Z-VALUE","SCALAR" !'1行目は見出し。データは2行目から
FOR I=1 TO 100
LET X=INT(RND*100)
LET Y=INT(RND*100)
LET Z=INT(RND*100)
LET V=INT(RND*3+1)
WRITE #1:X,Y,Z,V
NEXT I
CLOSE #1
END
OPTION BASE 0
OPTION ANGLE DEGREES
LET N=720
DIM X(N),Y(N),Z(N)
RANDOMIZE
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 4.0"
PRINT #1:"lissajous"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";N;"double"
LET A=INT(RND*20)+1
LET B=INT(RND*20)+1
LET C=INT(RND*20)+1
LET D=INT(RND*360)
FOR I=0 TO N-1
LET X(I)=COS(A*I/2) !'リサジュー曲線
LET Y(I)=SIN(B*I/2)
LET Z(I)=COS(C*I/2+D)
PRINT #1:X(I);Y(I);Z(I) !'座標値
NEXT I
PRINT #1:"LINES";N;3*N
FOR I=0 TO N-1 !'線でつないでいく(meshデータ)
IF I=N-1 THEN
PRINT #1:2;N-1;0
ELSE
PRINT #1:2;I;I+1
END IF
NEXT I
PRINT #1:"POINT_DATA";N
PRINT #1:"SCALARS distance float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=0 TO N-1
PRINT #1:SQR(X(I)^2+Y(I)^2+Z(I)^2)
NEXT I
CLOSE #1
END
OPTION ANGLE DEGREES
LET N=720
RANDOMIZE
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 4.0"
PRINT #1:"rose"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";N;"double"
LET A=INT(RND*20)+1
LET B=INT(RND*20)+1
FOR I=0 TO N-1
LET X=SIN(A*I/2)*COS(B*I/2)
LET Z=SIN(A*I/2)*SIN(B*I/2)
LET Y=COS(A*I/2)
PRINT #1:X;Y;Z
NEXT I
PRINT #1:"LINES";N;3*N
FOR I=0 TO N-1
IF I=N-1 THEN
PRINT #1:2;N-1;0
ELSE
PRINT #1:2;I;I+1
END IF
NEXT I
CLOSE #1
END
OPTION ANGLE DEGREES
PUBLIC NUMERIC XX(2730),YY(2730),ZZ(2730),K !' 2+8*(4^(LEV-1)-1)/3
INPUT PROMPT "LEVEL(2<=LEV<=6)=":LEV
CALL TREE(LEV,0,0,0,0,2^LEV,0,2^LEV)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 4.0"
PRINT #1:"tree"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";K;"double"
FOR I=1 TO K
PRINT #1:XX(I);YY(I);ZZ(I)
NEXT I
PRINT #1:"LINES";K/2;3*K/2
FOR I=0 TO K-1 STEP 2
PRINT #1:2;I;I+1
NEXT I
CLOSE #1
END
EXTERNAL SUB TREE(N,XS,YS,ZS,XE,YE,ZE,L)
IF N>0 THEN
LET K=K+1 !'個数
LET XX(K)=XS !'座標値を記録
LET YY(K)=YS
LET ZZ(K)=ZS
LET K=K+1
LET XX(K)=XE
LET YY(K)=YE
LET ZZ(K)=ZE
LET X=XE-XS
LET Y=YE-YS
LET Z=ZE-ZS
IF X<>0 THEN
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE+L/2,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE-L/2,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE+L/2,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE-L/2,ZE,L/2)
END IF
IF Y<>0 THEN
CALL TREE(N-1,XE,YE,ZE,XE+L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE-L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE+L/2,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE,ZE-L/2,L/2)
END IF
IF Z<>0 THEN
CALL TREE(N-1,XE,YE,ZE,XE+L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE-L/2,YE,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE+L/2,ZE,L/2)
CALL TREE(N-1,XE,YE,ZE,XE,YE-L/2,ZE,L/2)
END IF
END IF
END SUB
OPTION ANGLE DEGREES
OPTION BASE 0
DIM XX(20),YY(20),ZZ(20)
LET LL=1
FOR TH=0 TO 359 STEP 72
LET XX(K)=LL*COS((TH+18))
LET ZZ(K)=LL*SIN((TH+18))
LET YY(K)=LL*(SQR(5)+3)/4
LET K=K+1
NEXT TH
FOR TH=0 TO 359 STEP 72
LET XX(K)=LL*(SQR(5)+1)/2*COS((TH+18))
LET ZZ(K)=LL*(SQR(5)+1)/2*SIN((TH+18))
LET YY(K)=LL*(SQR(5)-1)/4
LET K=K+1
NEXT TH
FOR TH=0 TO 359 STEP 72
LET XX(K)=LL*(SQR(5)+1)/2*COS((TH+54))
LET ZZ(K)=LL*(SQR(5)+1)/2*SIN((TH+54))
LET YY(K)=-LL*(SQR(5)-1)/4
LET K=K+1
NEXT TH
FOR TH=0 TO 359 STEP 72
LET XX(K)=LL*COS((TH+54))
LET ZZ(K)=LL*SIN((TH+54))
LET YY(K)=-LL*(SQR(5)+3)/4
LET K=K+1
NEXT TH
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"dodecahedron"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";K;"float"
FOR I=0 TO K-1
PRINT #1:XX(I);YY(I);ZZ(I)
NEXT I
PRINT #1:"POLYGONS";36;36*4
FOR I=1 TO 36
READ A,B,C
PRINT#1:3;A;B;C
NEXT I
CLOSE #1
DATA 0,1,2
DATA 0,2,3
DATA 0,3,4
DATA 5,10,6
DATA 5,6,1
DATA 5,1,0
DATA 6,11,7
DATA 6,7,2
DATA 6,2,1
DATA 7,12,8
DATA 7,8,3
DATA 7,3,2
DATA 8,13,9
DATA 8,9,4
DATA 8,4,3
DATA 9,14,5
DATA 9,5,0
DATA 9,0,4
DATA 15,16,11
DATA 15,11,6
DATA 15,6,10
DATA 16,17,12
DATA 16,12,7
DATA 16,7,11
DATA 17,18,13
DATA 17,13,8
DATA 17,8,12
DATA 18,19,14
DATA 18,14,9
DATA 18,9,13
DATA 19,15,10
DATA 19,10,5
DATA 19,5,14
DATA 19,18,17
DATA 19,17,16
DATA 19,16,15
END
OPTION BASE 0
DIM XX(11),YY(11),ZZ(11)
LET LL=1
LET K=12
LET G=(SQR(5)-1)/2
LET XX(0)=LL
LET YY(0)=LL*G
LET ZZ(0)=0
LET XX(1)=-LL
LET YY(1)=LL*G
LET ZZ(1)=0
LET XX(2)=-LL
LET YY(2)=-LL*G
LET ZZ(2)=0
LET XX(3)=LL
LET YY(3)=-LL*G
LET ZZ(3)=0
LET XX(4)=0
LET YY(4)=LL
LET ZZ(4)=LL*G
LET XX(5)=0
LET YY(5)=-LL
LET ZZ(5)=LL*G
LET XX(6)=0
LET YY(6)=-LL
LET ZZ(6)=-LL*G
LET XX(7)=0
LET YY(7)=LL
LET ZZ(7)=-LL*G
LET XX(8)=LL*G
LET YY(8)=0
LET ZZ(8)=LL
LET XX(9)=LL*G
LET YY(9)=0
LET ZZ(9)=-LL
LET XX(10)=-LL*G
LET YY(10)=0
LET ZZ(10)=-LL
LET XX(11)=-LL*G
LET YY(11)=0
LET ZZ(11)=LL
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"icosahedron"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";K;"float"
FOR I=0 TO K-1
PRINT #1:XX(I);YY(I);ZZ(I)
NEXT I
PRINT #1:"POLYGONS";20;20*4
FOR I=1 TO 20
READ A,B,C
PRINT#1:3;A;B;C
NEXT I
CLOSE #1
DATA 0,8,3
DATA 3,9,0
DATA 1,10,2
DATA 2,11,1
DATA 4,0,7
DATA 7,1,4
DATA 5,2,6
DATA 6,3,5
DATA 8,4,11
DATA 11,5,8
DATA 9,6,10
DATA 10,7,9
DATA 0,4,8
DATA 0,9,7
DATA 1,11,4
DATA 1,7,10
DATA 2,5,11
DATA 2,10,6
DATA 3,8,5
DATA 3,6,9
END
INPUT PROMPT "長さ L1=":L1
!'INPUT PROMPT "長さ L2(L1>L2)=":L2
INPUT PROMPT "高さ=":H
LET X1=COS(PI/2) !'半径1とする 頂点1番
LET Y1=SIN(PI/2)
LET X2=COS(PI/2+2*PI/5) !'頂点2番
LET Y2=SIN(PI/2+2*PI/5)
LET X3=COS(PI/2+2*PI/5*2) !'頂点3番
LET Y3=SIN(PI/2+2*PI/5*2)
LET XN=COS(PI/2+2*PI/5*4) !'頂点N番
LET YN=SIN(PI/2+2*PI/5*4)
CALL CROSS(X1,Y1,X3,Y3,X2,Y2,XN,YN,XX,YY) !'頂点1と頂点3を結ぶ直線,頂点2と頂点N番とを結ぶ直線との交点
LET RR=SQR(XX^2+YY^2) !'原点からの距離(比率)
LET L2=L1*RR
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"star"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";11;"float"
FOR TH=0 TO 359 STEP 72
LET X=L1*COS(TH*PI/180)
LET Z=L1*SIN(TH*PI/180)
LET Y=0
PRINT #1:X;Y;Z
NEXT TH
FOR TH=0 TO 359 STEP 72
LET X=L2*COS((TH+36)*PI/180)
LET Z=L2*SIN((TH+36)*PI/180)
LET Y=0
PRINT #1:X;Y;Z
NEXT TH
PRINT #1:0,H,0
PRINT #1:"POLYGONS";18;72
PRINT #1:"3 0 9 5"
PRINT #1:"3 1 5 6"
PRINT #1:"3 2 6 7"
PRINT #1:"3 3 7 8"
PRINT #1:"3 4 8 9"
PRINT #1:"3 5 6 7"
PRINT #1:"3 5 7 8"
PRINT #1:"3 5 8 9"
PRINT #1:"3 10 9 0"
PRINT #1:"3 10 0 5"
PRINT #1:"3 10 5 1"
PRINT #1:"3 10 1 6"
PRINT #1:"3 10 6 2"
PRINT #1:"3 10 2 7"
PRINT #1:"3 10 7 3"
PRINT #1:"3 10 3 8"
PRINT #1:"3 10 8 4"
PRINT #1:"3 10 4 9"
CLOSE #1
END
EXTERNAL SUB CROSS(X1,Y1,X2,Y2,X3,Y3,X4,Y4,X,Y)
!'点(X1,Y1)と点(X2,Y2)を結ぶ直線
!'点(X3,Y3)と点(X4,Y4)を結ぶ直線
!'との交点(X,Y)を求める
LET A=(Y2-Y1)/(X2-X1)
LET B=(Y4-Y3)/(X4-X3)
LET X=(Y3-Y1+A*X1-B*X3)/(A-B)
LET Y=A*X+Y1
END SUB
OPTION BASE 0
RANDOMIZE
LET N=360 !'分割数
DIM X1(N),Y1(N),Z1(N),X2(N),Y2(N),Z2(N)
LET A=INT(RND*7)+1
DO
LET B=INT(RND*7)+1
LOOP WHILE A=B
LET R=INT(RND*10)+3
FOR I=0 TO N
LET ALPHA=I*2
LET X1(I)=(A+R*SIN(ALPHA/2*PI/180))*COS(ALPHA*PI/180) !'メビウスの帯
LET Y1(I)=(A+R*SIN(ALPHA/2*PI/180))*SIN(ALPHA*PI/180)
LET Z1(I)=A+R*COS(ALPHA/2*PI/180)
LET X2(I)=(B+R*SIN(ALPHA/2*PI/180))*COS(ALPHA*PI/180)
LET Y2(I)=(B+R*SIN(ALPHA/2*PI/180))*SIN(ALPHA*PI/180)
LET Z2(I)=B+R*COS(ALPHA/2*PI/180)
NEXT I
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"moebius"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";2*(N+1);"float"
FOR I=0 TO N
PRINT #1:X1(I);Y1(I);Z1(I)
PRINT #1:X2(I);Y2(I);Z2(I)
NEXT I
PRINT #1:"POLYGONS";N;5*N
FOR I=0 TO 2*N-1 STEP 2
PRINT #1:4;I;I+2;I+3;I+1 !'meshデータ
NEXT I
PRINT #1:"POINT_DATA";2*(N+1)
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=0 TO N
PRINT #1:Z1(I)
PRINT #1:Z2(I)
NEXT I
CLOSE #1
END
OPTION BASE 0
OPTION ANGLE DEGREES
RANDOMIZE
LET N=40 !'分割数
LET M=40
DIM X(N,M),Y(N,M),Z(N,M)
INPUT PROMPT "MODE(0 - 2)=":MODE
SELECT CASE MODE
CASE 0
LET RR=INT(RND*200)+45
LET R=INT(RND*40)+5
FOR J=0 TO M !'トーラス
FOR I=0 TO N
LET ALPHA=I*360/N
LET BETA=J*360/M
LET X(I,J)=(RR+R*COS(ALPHA))*COS(BETA)
LET Y(I,J)=(RR+R*COS(ALPHA))*SIN(BETA)
LET Z(I,J)=R*SIN(ALPHA)
NEXT I
NEXT J
CASE 1
LET R1=INT(RND*200)+45
LET R2=INT(RND*50)
LET R=INT(RND*40)+5
LET RR=INT(RND*40)+5
LET K=INT(RND*10)+1
FOR J=0 TO M !'変形トーラス
FOR I=0 TO N
LET ALPHA=I*360/N
LET BETA=J*360/M
LET X(I,J)=(R1+R*COS(ALPHA))*(R2+RR*COS(K*BETA))*COS(BETA)
LET Y(I,J)=(R1+R*COS(ALPHA))*(R2+RR*COS(K*BETA))*SIN(BETA)
LET Z(I,J)=R*SIN(ALPHA)*(R2+RR*COS(K*BETA))
NEXT I
NEXT J
CASE 2
LET RR=INT(RND*200)+45
LET R=INT(RND*40)+5
LET R1=INT(RND*30)
LET K=INT(RND*10)+1
FOR J=0 TO M !'歪んだトーラス
FOR I=0 TO N
LET ALPHA=I*360/N
LET BETA=J*360/M
LET X(I,J)=(RR+R*COS(ALPHA))*COS(BETA)
LET Y(I,J)=(RR+R*COS(ALPHA))*SIN(BETA)
LET Z(I,J)=R*SIN(ALPHA)+R1*SIN(K*BETA)
NEXT I
NEXT J
END SELECT
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"torus"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";4*N*M;"float"
FOR J=0 TO M-1
FOR I=0 TO N-1
PRINT #1:X(I+1,J+1);Y(I+1,J+1);Z(I+1,J+1) !'座標値書き込み
PRINT #1:X(I+1,J);Y(I+1,J);Z(I+1,J)
PRINT #1:X(I,J);Y(I,J);Z(I,J)
PRINT #1:X(I,J+1);Y(I,J+1);Z(I,J+1)
NEXT I
NEXT J
PRINT #1:"POLYGONS";N*M;5*N*M
FOR I=0 TO 4*N*M-1 STEP 4
PRINT #1:4;I;I+1;I+2;I+3 !'meshデータ
NEXT I
PRINT #1:"POINT_DATA";4*N*M
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
FOR J=0 TO M-1
FOR I=0 TO N-1
PRINT #1:Z(I+1,J+1)
PRINT #1:Z(I+1,J)
PRINT #1:Z(I,J)
PRINT #1:Z(I,J+1)
NEXT I
NEXT J
CLOSE #1
END
LET N=40 !'分割数
DIM XX(N*(N-1)+2),YY(N*(N-1)+2),ZZ(N*(N-1)+2)
INPUT PROMPT "MODE(0 - 39)=":MODE
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"flower sphere"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";N*(N-1)+2;"float"
LET ALPHA=0
LET BETA=0
LET RR=FUNC(MODE,ALPHA,BETA)
LET X=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)
LET Z=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)
LET Y=RR*COS(ALPHA*PI/180)
PRINT #1:X;Y;Z
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
FOR ALPHA=180/N TO 179 STEP 180/N
FOR BETA=0 TO 359 STEP 360/N
LET RR=FUNC(MODE,ALPHA,BETA)
LET X=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)
LET Z=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)
LET Y=RR*COS(ALPHA*PI/180)
PRINT #1:X;Y;Z
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
NEXT BETA
NEXT ALPHA
LET ALPHA=180
LET BETA=0
LET RR=FUNC(MODE,ALPHA,BETA)
LET X=-RR*SIN(ALPHA*PI/180)*COS(BETA*PI/180)
LET Z=RR*SIN(ALPHA*PI/180)*SIN(BETA*PI/180)
LET Y=RR*COS(ALPHA*PI/180)
PRINT #1:X;Y;Z
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
PRINT #1:"POLYGONS";N*N;8*N+N*(N-2)*5
FOR I=1 TO N !'meshデータ
IF I=N THEN
PRINT #1:3;1;0;N
ELSE
PRINT #1:3;0;I;I+1
END IF
NEXT I
FOR I=1 TO N*(N-2)
IF MOD(I,N)=0 THEN
PRINT #1:4;I;I+N;I+1;I-N+1
ELSE
PRINT #1:4;I;I+N;I+N+1;I+1
END IF
NEXT I
FOR I=N*(N-2)+1 TO N*(N-1)
IF I=N*(N-1) THEN
PRINT #1:3;N*(N-1);N*(N-1)+1;N*(N-2)+1
ELSE
PRINT #1:3;I;N*(N-1)+1;I+1
END IF
NEXT I
PRINT #1:"POINT_DATA";N*(N-1)+2
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=1 TO K
PRINT #1:ZZ(I)
NEXT I
CLOSE #1
END
EXTERNAL FUNCTION FUNC(MODE,TT,SS) !' r=f(θ,φ)
LET T=TT*PI/180
LET S=SS*PI/180
SELECT CASE MODE
CASE 0
LET FUNC=1
CASE 1
LET FUNC=SGN(COS(T))*ABS(COS(T))^.1
CASE 2
LET FUNC=ABS(COS(T))
CASE 3
LET FUNC=T*2
CASE 4
LET FUNC=T^2
CASE 5
LET FUNC=2*SIN(T)
CASE 6
LET FUNC=COS(SQR(T))
CASE 7
LET FUNC=MAX(SIN(T),ABS(COS(T)))
CASE 8
LET FUNC=MAX(SIN(T),ABS(COS(T)^8))
CASE 9
LET FUNC=MIN(SIN(T),ABS(COS(T)))
CASE 10
LET FUNC=0.8+2*SIN(T/2)+SIN(5*S)/5
CASE 11
LET FUNC=3-3*SIN(T/2)+SIN(5*S)/20
CASE 12
LET FUNC=1+(1-COS(2*T))*(1-COS(S))
CASE 13
LET FUNC=ABS(SIN(2*T)*SIN(2*S))
CASE 14
LET FUNC=2+COS(10*S)^2/10+SIN(15*T)^2/10
CASE 15
LET FUNC=2-SGN(COS(T))/5
CASE 16
LET FUNC=SGN(SIN(T)-.995)/1.1+2
CASE 17
LET FUNC=SGN(COS(T)-.975)+3
CASE 18
LET FUNC=5/6*(1-COS(10*T))*(1-COS(8*S))
CASE 19
LET FUNC=1+COS(3*S)
CASE 20
LET FUNC=3-SGN(SIN(10*T)*SIN(10*S))
CASE 21
LET FUNC=3+2*(COS(4*S)*COS(4*T))
CASE 22
LET FUNC=((1+0.5*COS(5*S))*(1-COS(5*S))+.1)*SIN(T)
CASE 23
LET FUNC=MIN(20,MAX(5,SEC(6*T)*SEC(6*S)))
CASE 24
LET FUNC=2*(SIN(5*S)+4)*SIN(T)
CASE 25
LET FUNC=ABS(SIN(5*T)*SIN(5*S))
CASE 26
LET FUNC=ABS(COS(S))
CASE 27
LET FUNC=1+COS(S)*COS(T)
CASE 28
LET FUNC=1+COS(S)
CASE 29
LET FUNC=2+SIN(3*S)*SIN(3*T)*SIN(3*S+3*T)
CASE 30
LET FUNC=2+.5*COS(50*S)*COS(25*T)
CASE 31
LET FUNC=COS(10*S)^2+SIN(15*T)^2
CASE 32
LET FUNC=4+.5*COS(25*S)*COS(50*T)
CASE 33
LET FUNC=ABS(COS(5*S)*COS(5*T))
CASE 34
LET FUNC=3+COS(20*T)/10
CASE 35
LET FUNC=COS(3*S-2*T)
CASE 36
LET FUNC=COS(2*S+3*T)
CASE 37
LET FUNC=3+COS(S*T*3)
CASE 38
LET Z=400-(SS-60*INT((SS+30)/60))^2-(TT-60*INT((TT+30)/60))^2
IF Z>0 THEN
LET FUNC=SQR(Z)+50
ELSE
LET FUNC=50
END IF
CASE 39
LET FUNC=10+S*T*(S^2-T^2)/2
END SELECT
END FUNCTION
OPTION ANGLE DEGREES
RANDOMIZE
LET N=40 !'分割数
LET NN=RND*8
LET MM=RND*8
DIM XX(N*(N-1)+2),YY(N*(N-1)+2),ZZ(N*(N-1)+2)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"hyper ellipse"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";N*(N-1)+2;"float"
LET ALPHA=0
LET BETA=0
LET X=-SGN(SIN(ALPHA))*ABS(SIN(ALPHA))^NN*SGN(COS(BETA))*ABS(COS(BETA))^MM
LET Y=SGN(COS(ALPHA))*ABS(COS(ALPHA))^NN
LET Z=SGN(SIN(ALPHA))*ABS(SIN(ALPHA))^NN*SGN(SIN(BETA))*ABS(SIN(BETA))^MM
PRINT #1:X;Y;Z
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
FOR ALPHA=180/N TO 179 STEP 180/N
FOR BETA=0 TO 359 STEP 360/N
LET X=-SGN(SIN(ALPHA))*ABS(SIN(ALPHA))^NN*SGN(COS(BETA))*ABS(COS(BETA))^MM
LET Y=SGN(COS(ALPHA))*ABS(COS(ALPHA))^NN
LET Z=SGN(SIN(ALPHA))*ABS(SIN(ALPHA))^NN*SGN(SIN(BETA))*ABS(SIN(BETA))^MM
PRINT #1:X;Y;Z
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
NEXT BETA
NEXT ALPHA
LET ALPHA=180
LET BETA=0
LET X=-SGN(SIN(ALPHA))*ABS(SIN(ALPHA))^NN*SGN(COS(BETA))*ABS(COS(BETA))^MM
LET Y=SGN(COS(ALPHA))*ABS(COS(ALPHA))^NN
LET Z=SGN(SIN(ALPHA))*ABS(SIN(ALPHA))^NN*SGN(SIN(BETA))*ABS(SIN(BETA))^MM
PRINT #1:X;Y;Z
LET K=K+1
LET XX(K)=X
LET YY(K)=Y
LET ZZ(K)=Z
PRINT #1:"POLYGONS";N*N;8*N+N*(N-2)*5
FOR I=1 TO N
IF I=N THEN
PRINT #1:3;1;0;N
ELSE
PRINT #1:3;0;I;I+1
END IF
NEXT I
FOR I=1 TO N*(N-2)
IF MOD(I,N)=0 THEN
PRINT #1:4;I;I+N;I+1;I-N+1
ELSE
PRINT #1:4;I;I+N;I+N+1;I+1
END IF
NEXT I
FOR I=N*(N-2)+1 TO N*(N-1)
IF I=N*(N-1) THEN
PRINT #1:3;N*(N-1);N*(N-1)+1;N*(N-2)+1
ELSE
PRINT #1:3;I;N*(N-1)+1;I+1
END IF
NEXT I
PRINT #1:"POINT_DATA";N*(N-1)+2
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=1 TO K
PRINT #1:ZZ(I)
NEXT I
CLOSE #1
END
OPTION BASE 0
OPTION ANGLE DEGREES
RANDOMIZE
LET N=40 !'分割数
DIM X(N,N),Y(N,N),Z(N,N)
DEF HCYC(N,H,T)=((N-1)*COS(T)+H*COS(T*(N-1)))/N
DEF HCYS(N,H,T)=((N-1)*SIN(T)-H*SIN(T*(N-1)))/N
DEF HC3X(N,H,U,V)=HCYS(N,H,U)*HCYC(N,H,V)
DEF HC3Y(N,H,U,V)=HCYS(N,H,U)*HCYS(N,H,V)
DEF HC3Z(N,H,U)=HCYC(N,H,U)
INPUT PROMPT "何角形=":NN
IF NN<3 THEN LET NN=3
LET H=1
FOR J=0 TO N
FOR I=0 TO N
LET ALPHA=J*180/N
LET BETA=I*360/N
LET X(I,J)=HC3X(NN,H,ALPHA,BETA)
LET Y(I,J)=HC3Y(NN,H,ALPHA,BETA)
LET Z(I,J)=HC3Z(NN,H,ALPHA)
NEXT I
NEXT J
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"trochoid"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";4*N*N;"float"
FOR J=0 TO N-1
FOR I=0 TO N-1
PRINT #1:X(I+1,J+1);Y(I+1,J+1);Z(I+1,J+1)
PRINT #1:X(I+1,J);Y(I+1,J);Z(I+1,J)
PRINT #1:X(I,J);Y(I,J);Z(I,J)
PRINT #1:X(I,J+1);Y(I,J+1);Z(I,J+1)
NEXT I
NEXT J
PRINT #1:"POLYGONS";N*N;5*N*N
FOR I=0 TO 4*N*N-1 STEP 4
PRINT #1:4;I;I+1;I+2;I+3
NEXT I
PRINT #1:"POINT_DATA";4*N*N
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
FOR J=0 TO N-1
FOR I=0 TO N-1
PRINT #1:Z(I+1,J+1)
PRINT #1:Z(I+1,J)
PRINT #1:Z(I,J)
PRINT #1:Z(I,J+1)
NEXT I
NEXT J
CLOSE #1
END
LET N=40 !'分割数
OPTION ANGLE DEGREES
DIM XX(N*(N-1)+2),YY(N*(N-1)+2),ZZ(N*(N-1)+2)
DEF FF(X)=.5*(IP(X)-IP(-X)-1)
DEF S2(X)=X+IP(-X)+1
DEF A(N)=360/N
DEF K(A,B,X)=FF((X+A)/(A+B))-FF(X/(A+B))
DEF KK(A,B,X)=2*(K(A,B,X)-.5)
DEF S(A,X)=2*ABS(S2(X/(A*2))-.5)*KK(A*2,A*2,X+A)
!'DEF ACC(X)=-.5*PI*(S(.5*PI,X)+1)
DEF ACC(X)=ACOS(COS(X))
DEF CNS(N,T)=COS(A(N))/COS(A(N)-ACC(N*T)/N)
DEF PC(N,T)=COS(T)*CNS(N,T)
DEF PS(N,T)=SIN(T)*CNS(N,T)
DEF P3X(N,U,V)=PS(N,U)*PC(N,V)
DEF P3Y(N,U,V)=PS(N,U)*PS(N,V)
DEF P3Z(N,U)=PC(N,U)
INPUT PROMPT "何角形 =":NN !'NN>=5
IF NN<5 THEN LET NN=5
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"star poly"
PRINT #1:"ASCII"
PRINT #1:"DATASET POLYDATA"
PRINT #1:"POINTS";N*(N-1)+2;"float"
LET ALPHA=0
LET BETA=0
LET X=P3X(NN,ALPHA,BETA)
LET Y=P3Y(NN,ALPHA,BETA)
LET Z=P3Z(NN,ALPHA)
PRINT #1:X;Y;Z
LET L=L+1
LET XX(L)=X
LET YY(L)=Y
LET ZZ(L)=Z
FOR ALPHA=180/N TO 179 STEP 180/N
FOR BETA=0 TO 359 STEP 360/N
LET X=P3X(NN,ALPHA,BETA)
LET Y=P3Y(NN,ALPHA,BETA)
LET Z=P3Z(NN,ALPHA)
PRINT #1:X;Y;Z
LET L=L+1
LET XX(L)=X
LET YY(L)=Y
LET ZZ(L)=Z
NEXT BETA
NEXT ALPHA
LET ALPHA=180
LET BETA=0
LET X=P3X(NN,ALPHA,BETA)
LET Y=P3Y(NN,ALPHA,BETA)
LET Z=P3Z(NN,ALPHA)
PRINT #1:X;Y;Z
LET L=L+1
LET XX(L)=X
LET YY(L)=Y
LET ZZ(L)=Z
PRINT #1:"POLYGONS";N*N;8*N+N*(N-2)*5
FOR I=1 TO N
IF I=N THEN
PRINT #1:3;1;0;N
ELSE
PRINT #1:3;0;I;I+1
END IF
NEXT I
FOR I=1 TO N*(N-2)
IF MOD(I,N)=0 THEN
PRINT #1:4;I;I+N;I+1;I-N+1
ELSE
PRINT #1:4;I;I+N;I+N+1;I+1
END IF
NEXT I
FOR I=N*(N-2)+1 TO N*(N-1)
IF I=N*(N-1) THEN
PRINT #1:3;N*(N-1);N*(N-1)+1;N*(N-2)+1
ELSE
PRINT #1:3;I;N*(N-1)+1;I+1
END IF
NEXT I
PRINT #1:"POINT_DATA";N*(N-1)+2
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
FOR I=1 TO L
PRINT #1:ZZ(I)
NEXT I
CLOSE #1
END
RANDOMIZE
LET XSIZE=100 !'各格子の大きさ
LET YSIZE=100
LET ZSIZE=100
LET A=INT(RND*20)-10
LET B=INT(RND*20)-10
LET C=INT(RND*20)-10
LET D=INT(RND*20)-10
LET E=INT(RND*20)-10
LET F=INT(RND*20)-10
LET G=INT(RND*20)-10
LET XS=-5 !'探索範囲
LET XE=5
LET YS=-5
LET YE=5
LET ZS=-5
LET ZE=5
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"inequality"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING";(XE-XS)/XSIZE;(YE-YS)/YSIZE;(ZE-ZS)/ZSIZE
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=XS+XX*(XE-XS)/XSIZE
LET Y=YS+YY*(YE-YS)/YSIZE
LET Z=ZS+ZZ*(ZE-ZS)/ZSIZE
IF X*X+Y*Y+Z*Z+A*X*Y+B*X*Z+C*Y*Z+D*X+E*Y+F*Z+G<0 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
LET XSIZE=100 !'各格子の大きさ
LET YSIZE=100
LET ZSIZE=100
INPUT PROMPT "MODE(1 - 28)=":MODE
SELECT CASE MODE
CASE 1
LET R=1
LET N=4
LET M=1.2
LET O=.7
CASE 2
LET R=2
LET A=1
LET B=1
LET C=1
LET D=-.5
LET E=.3
LET F=.7
LET G=-.05
LET H=.8
LET I=1
LET J=-1
CASE 3
LET R=1
LET A=1
LET B=.5
LET C=.8
CASE 4
LET R=4
LET A=1
LET B=.5
LET C=.8
CASE 5
LET R=4
LET A=1
LET B=.5
LET C=.8
CASE 6
LET R=4
LET A=1
LET B=.5
LET C=.8
CASE 7
LET R=2
LET A=1
LET B=.5
CASE 8
LET R=4
LET A=1
LET B=.5
CASE 9
LET R=3
LET A=1
LET B=1
CASE 10
LET R=4
LET A=1
LET B=.5
CASE 11
LET R=4
LET A=.3
CASE 12
LET R=2
LET A=1
LET B=.7
LET C=.4
LET D=1
LET R2=1
LET R1=3
LET R=5
CASE 13
LET R=2
LET A=1
LET B=2
LET C=1.5
LET N=.5
LET O=1.2
CASE 14
LET R=4
LET A=1
LET B=2
LET C=1.5
LET N=.5
LET O=1.2
CASE 15
LET R=4
LET A=1
LET B=2
LET C=1.5
LET N=.5
LET O=1.2
CASE 16
LET R=2
LET A=1
LET B=2
LET C=1.5
LET N=.5
LET O=1.2
CASE 17
LET R=2
LET A=1.8
CASE 18
LET R=2
CASE 19
LET R=3
LET C=1
LET B=1.5
CASE 20
LET R=3
CASE 21
LET R=4
CASE 22
LET R=20
CASE 23
LET R=20
CASE 24
LET R=100
CASE 25
LET R=5
CASE 26
LET R=6
CASE 27
LET R=2
LET N=2
LET E=3
CASE 28
LET R=5
END SELECT
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"inequality"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR Z=0 TO ZSIZE-1
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
IF FUNC(-R+X*2*R/XSIZE,-R+Y*2*R/YSIZE,-R+Z*2*R/ZSIZE)=1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT X
NEXT Y
NEXT Z
CLOSE #1
FUNCTION FUNC(X,Y,Z)
LET FL=0
SELECT CASE MODE
CASE 1
!'立方体
IF ABS(X)^N+ABS(Y)^M+ABS(Z)^O<1 THEN LET FL=1
CASE 2
!'一般形
IF A*X^2+B*Y^2+C*Z^2+D*X*Y+E*Y*Z+F*X*Z+G*X+H*Y+Z*I+J<0 THEN LET FL=1
CASE 3
!'楕円面
IF X^2/A^2+Y^2/B^2+Z^2/C^2<1 THEN LET FL=1
CASE 4
!'１葉双曲面
IF X^2/A^2+Y^2/B^2-Z^2/C^2<1 THEN LET FL=1
CASE 5
!'２葉双曲面
IF X^2/A^2+Y^2/B^2-Z^2/C^2<-1 THEN LET FL=1
CASE 6
!'楕円錐面
IF X^2/A^2+Y^2/B^2-Z^2/C^2<0 THEN LET FL=1
CASE 7
!'楕円放物面
IF X^2/A^2+Y^2/B^2<Z THEN LET FL=1
CASE 8
!'双曲放物面
IF X^2/A^2-Y^2/B^2<Z THEN LET FL=1
CASE 9
!'楕円柱面
IF(X/A)^2+(Z/B)^2<1 THEN LET FL=1
CASE 10
!'双曲柱面
IF X^2/A^2-Y^2/B^2<1 THEN LET FL=1
CASE 11
!'放物柱面
IF X-1/4/A*Y^2<0 THEN LET FL=1
CASE 12
!'トーラス面
IF X^2+Y^2+Z^2-2*R1*SQR(X^2+Y^2)+R1^2-R2^2<0 THEN LET FL=1
CASE 13
!'超楕円面
IF(ABS(X/A)^(2/N)+ABS(Y/B)^(2/O))^(N/O)+ABS(Z/C)^(2/O)<1 THEN LET FL=1
CASE 14
!'超１葉双曲面
IF(ABS(X/A)^(2/N)+ABS(Y/B)^(2/O))^(N/O)-ABS(Z/C)^(2/O)<1 THEN LET FL=1
CASE 15
!'超２葉双曲面
IF-(ABS(X/A)^(2/N)+ABS(Y/B)^(2/O))^(N/O)+ABS(Z/C)^(2/O)<1 THEN LET FL=1
CASE 16
!'超トーラス面
IF ABS((ABS(X/A)^(2/N)+ABS(Y/B)^(2/N))^(N/2)-D)^(2/O)+ABS(Z/C)^(2/O)<1 THEN LET FL=1
CASE 17
!'レムニスケート
IF(X^2+Y^2+Z^2)^2-A^2*(Z^2-X^2-Y^2)<0 THEN LET FL=1
CASE 18
!'ハート
IF(2*X^2+Y^2+Z^2-1)^3-(1/10)*X^2*Z^3-Y^2*Z^3<0 THEN LET FL=1
CASE 19
!'円錐
IF X^2+Z^2-C^2*(1-(Y/B))^2<1 THEN LET FL=1
CASE 20
IF X^2+Z^2<1 OR Y^2+Z^2<1 OR X^2+Y^2<1 THEN LET FL=1
CASE 21
IF Y^2+(Z+2)^2<1 OR X^2+(Z+2)^2<1 OR Z<6-4*SQR(X^2+Y^2) THEN LET FL=1
CASE 22
IF(4*X^2+Y^2+Z^2-14*SQR(4*X^2+Y^2)+48)*(X^2+4*Y^2+Z^2-14*SQR(Z^2+4*Y^2)+48)*(X^2+Y^2+4*Z^2-14*SQR(X^2+4*Z^2)+48)<0 THEN LET FL=1
CASE 23
IF(X^2+Y^2+Z^2-17*SQR(X^2+Y^2)+69.5)*((X+8.5)^2+Y^2+Z^2-10*SQR((X+8.5)^2+Y^2)+22.5)*((X-8.5)^2+Y^2+Z^2-10*SQR((X-8.5)^2+Y^2)+22.5)*((Y+8.5)^2+X^2+Z^2-10*SQR((Y+8.5)^2+X^2)+22.5)*((Y-8.5)^2+X^2+Z^2-10*SQR((Y-8.5)^2+X^2)+22.5)<0 THEN LET FL=1
CASE 24
IF((X/4)^2+Y^2+Z^2-1)*((Y/4)^2+X^2+Z^2-1)*((Z/4)^2+Y^2+X^2-1)*(X^2+Y^2+Z^2-10*SQR(X^2+Y^2)+24)<0 THEN LET FL=1
CASE 25
IF (TAN(3*X)^2+TAN(3*Y)^2-.1)<0 OR (TAN(3*Y)^2+TAN(3*Z)^2-.1)<0 OR (TAN(3*Z)^2+TAN(3*X)^2-.1)<0 THEN LET FL=1
CASE 26
IF(X^2+Y^2+Z^2-1)*(X^2+Y^2+16*Z^2-6*SQR(X^2+Y^2)+8)<0 THEN LET FL=1
CASE 27
IF(ABS(X)^(2/E)+ABS(Y)^(2/E))^(E/N)+ABS(Z)^(2/N)-1<0 THEN LET FL=1
CASE 28
IF SIN(X)+2*SIN(Y)+3*SIN(Z)+4*SIN(X)+5*SIN(Y)+6*SIN(Z)<0 THEN LET FL=1
END SELECT
LET FUNC=FL
END FUNCTION
END
LET XSIZE=100 !'各格子の大きさ
LET YSIZE=100
LET ZSIZE=100
OPTION BASE 0
DIM CC(3),ZZ(3)
READ XS,XE,YS,YE,ZS,ZE,MAXITER
DATA -2.2,0.5,-1.35,1.35,-1.35,1.35,50
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"mandel"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR Z=0 TO ZSIZE-1
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET CC(0)=XS+X*(XE-XS)/XSIZE
LET CC(1)=YS+Y*(YE-YS)/YSIZE
LET CC(2)=ZS+Z*(ZE-ZS)/ZSIZE
LET CC(3)=0
MAT ZZ=ZER
FOR I=1 TO MAXITER
CALL QMUL(ZZ,ZZ,ZZ) !' CALL HMUL(ZZ,ZZ,ZZ)
CALL ADD(ZZ,ZZ,CC)
IF ZZ(0)^2+ZZ(1)^2+ZZ(2)^2>4 THEN EXIT FOR
NEXT I
IF I>=MAXITER THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT X
NEXT Y
NEXT Z
CLOSE #1
END
EXTERNAL SUB QMUL(S(),A(),B()) !'QUATERNION 掛け算 S=A*B
OPTION BASE 0
DIM SS(3)
LET SS(0)=A(0)*B(0)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
LET SS(1)=A(0)*B(1)+A(1)*B(0)+A(2)*B(3)-A(3)*B(2)
LET SS(2)=A(0)*B(2)-A(1)*B(3)+A(2)*B(0)+A(3)*B(1)
LET SS(3)=A(0)*B(3)+A(1)*B(2)-A(2)*B(1)+A(3)*B(0)
MAT S=SS
END SUB
EXTERNAL SUB HMUL(S(),A(),B()) !'HYPER COMPLEX 掛け算 S=A*B
OPTION BASE 0
DIM SS(3)
LET P1=SQR(A(0)^2+A(1)^2)
LET P2=SQR(B(0)^2+B(1)^2)
IF P1<>0 AND P2<>0 THEN
LET AA=1-A(2)*B(2)/(P1*P2)
LET SS(0)=AA*(A(0)*B(0)-A(1)*B(1))
LET SS(1)=AA*(B(0)*A(1)+A(0)*B(1))
END IF
LET SS(2)=P1*B(2)+P2*A(2)
MAT S=SS
END SUB
EXTERNAL SUB ADD(S(),A(),B()) !'足し算 S=A+B
OPTION BASE 0
DIM SS(3)
MAT SS=A+B
MAT S=SS
END SUB
OPTION ANGLE DEGREES
DIM M(4,4),POINT(4),ROTXY(4,4),ROTXZ(4,4),ROTYU(4,4),ROTYZ(4,4),ROTXU(4,4),ROTZU(4,4)
LET L=100
LET X=0
LET Y=0
LET Z=0
LET U=0
LET ST=5 !'回転角
FILE GETSAVENAME F$,"vtkファイル|*.vtk" !'BASE名のみ(拡張子なし)
IF F$="" THEN STOP
FOR J=1 TO 360/ST
LET FF$=F$&RIGHT$("000"&STR$(J),3)
IF POS(UCASE$(FF$),".VTK")=0 THEN LET FF$=FF$&".vtk"
OPEN #1:NAME FF$
ERASE #1
LET YU=YU+ST
LET XZ=XZ+ST
MAT ROTXY=IDN !'XY平面上の回転
LET ROTXY(1,1)=COS(XY)
LET ROTXY(1,2)=SIN(XY)
LET ROTXY(2,1)=-SIN(XY)
LET ROTXY(2,2)=COS(XY)
MAT ROTXZ=IDN !'XZ平面上の回転
LET ROTXZ(1,1)=COS(XZ)
LET ROTXZ(1,3)=-SIN(XZ)
LET ROTXZ(3,1)=SIN(XZ)
LET ROTXZ(3,3)=COS(XZ)
MAT ROTYU=IDN !'YU平面上の回転
LET ROTYU(2,2)=COS(YU)
LET ROTYU(2,4)=-SIN(YU)
LET ROTYU(4,2)=SIN(YU)
LET ROTYU(4,4)=COS(YU)
MAT ROTYZ=IDN !'YZ平面上の回転
LET ROTYZ(2,2)=COS(YZ)
LET ROTYZ(2,3)=SIN(YZ)
LET ROTYZ(3,2)=-SIN(YZ)
LET ROTYZ(3,3)=COS(YZ)
MAT ROTXU=IDN !'XU平面上の回転
LET ROTXU(1,1)=COS(XU)
LET ROTXU(1,4)=SIN(XU)
LET ROTXU(4,1)=-SIN(XU)
LET ROTXU(4,4)=COS(XU)
MAT ROTZU=IDN !'ZU平面上の回転
LET ROTZU(3,3)=COS(ZU)
LET ROTZU(3,4)=-SIN(ZU)
LET ROTZU(4,3)=SIN(ZU)
LET ROTZU(4,4)=COS(ZU)
MAT M=ROTXY*ROTXZ*ROTYU*ROTYZ*ROTXU*ROTZU !'4次元回転
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"cube"
PRINT #1:"ASCII"
PRINT #1:"DATASET UNSTRUCTURED_GRID"
PRINT #1:"POINTS 8 float"
LET FLG=0
CALL PLOT(X-L/2,Y-L/2,Z-L/2,U) !'座標
CALL PLOT(X+L/2,Y-L/2,Z-L/2,U)
CALL PLOT(X+L/2,Y+L/2,Z-L/2,U)
CALL PLOT(X-L/2,Y+L/2,Z-L/2,U)
CALL PLOT(X-L/2,Y-L/2,Z+L/2,U)
CALL PLOT(X+L/2,Y-L/2,Z+L/2,U)
CALL PLOT(X+L/2,Y+L/2,Z+L/2,U)
CALL PLOT(X-L/2,Y+L/2,Z+L/2,U)
PRINT #1:"CELLS 1 9"
PRINT #1:"8 0 1 2 3 4 5 6 7" !'meshデータ
PRINT #1:"CELL_TYPES 1"
PRINT #1:12 !'立方体を表す
PRINT #1:"POINT_DATA 8"
PRINT #1:"SCALARS height float"
PRINT #1:"LOOKUP_TABLE default"
LET FLG=1
CALL PLOT(X-L/2,Y-L/2,Z-L/2,U) !'スカラー値
CALL PLOT(X+L/2,Y-L/2,Z-L/2,U)
CALL PLOT(X+L/2,Y+L/2,Z-L/2,U)
CALL PLOT(X-L/2,Y+L/2,Z-L/2,U)
CALL PLOT(X-L/2,Y-L/2,Z+L/2,U)
CALL PLOT(X+L/2,Y-L/2,Z+L/2,U)
CALL PLOT(X+L/2,Y+L/2,Z+L/2,U)
CALL PLOT(X-L/2,Y+L/2,Z+L/2,U)
CLOSE #1
NEXT J
SUB PLOT(X,Y,Z,U)
LET LU=100
LET POINT(1)=X
LET POINT(2)=Y
LET POINT(3)=Z
LET POINT(4)=U
MAT POINT=POINT*M
FOR I=1 TO 4
LET POINT(I)=POINT(I)/(LU-POINT(4))
NEXT I
IF FLG=0 THEN
PRINT #1:POINT(1);POINT(2);POINT(3) !'座標
ELSE
PRINT #1:POINT(2) !'スカラー値
END IF
END SUB
END
LET XSIZE=100 !'各格子の大きさ
LET YSIZE=100
LET ZSIZE=100
DIM P(3),B(3)
CALL VEC3(B,.7,.7,.7)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"round box"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-1.5+3/XSIZE*XX !'-1.5 ～ 1.5 探索範囲
LET Y=-1.5+3/YSIZE*YY !'-1.5 ～ 1.5
LET Z=-1.5+3/ZSIZE*ZZ !'-1.5 ～ 1.5
CALL VEC3(P,X,Y,Z)
IF ROUNDBOX(P,B,.4)<.1 THEN LET DA=255 ELSE LET DA=0 !'距離関数による判定
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION ROUNDBOX(P(),B(),R) !'float udRoundBox( vec3 p, vec3 b, float r )
DIM V(3),A(3)
CALL VABS(V,P)
MAT V=V-B
CALL NMAX(A,V,0)
LET ROUNDBOX=LENGTH(A)-R !' { return length(max(abs(p)-b,0.0))-r;}
END FUNCTION
EXTERNAL SUB VABS(A(),B())
FOR I=1 TO 3
LET A(I)=ABS(B(I))
NEXT I
END SUB
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2+A(3)^2)
END FUNCTION
EXTERNAL SUB NMAX(A(),B(),N)
FOR I=1 TO 3
LET A(I)=MAX(B(I),N)
NEXT I
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
LET XSIZE=100 !'各格子の大きさ
LET YSIZE=100
LET ZSIZE=100
DIM P(3),R(3)
CALL VEC3(R,.2,.3,.4)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"ellipsoid"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-1+2/XSIZE*XX !'-1 ～ 1 探索範囲
LET Y=-1+2/YSIZE*YY !'-1 ～ 1
LET Z=-1+2/ZSIZE*ZZ !'-1 ～ 1
CALL VEC3(P,X,Y,Z)
IF ELLIPSOID(P,R)<.1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION ELLIPSOID(P(),R()) !'float sdEllipsoid( in vec3 p, in vec3 r ){
LET ELLIPSOID=(LENGTH2(P(1)/R(1),P(2)/R(2),P(3)/R(3))-1)*MIN(MIN(R(1),R(2)),R(3)) !'return (length( p/r ) - 1.0) * min(min(r.x,r.y),r.z);}
END FUNCTION
EXTERNAL FUNCTION LENGTH2(A,B,C)
LET LENGTH2=SQR(A^2+B^2+C^2)
END FUNCTION
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
LET XSIZE=100
LET YSIZE=100
LET ZSIZE=100
DIM P(3),T(3)
CALL VEC2(T,.7,.1)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"torus"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-1+2/XSIZE*XX
LET Y=-1+2/YSIZE*YY
LET Z=-1+2/ZSIZE*ZZ
CALL VEC3(P,X,Y,Z)
IF TORUS(P,T)<.1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION TORUS(P(),T()) !'float sdTorus( vec3 p, vec2 t ){
DIM Q(3)
CALL VEC2(Q,LENGTH2(P(1),P(3),0)-T(1),P(2)) !' vec2 q = vec2(length(p.xz)-t.x,p.y);
LET TORUS=LENGTH(Q)-T(2) !' return length(q)-t.y;}
END FUNCTION
EXTERNAL FUNCTION LENGTH2(A,B,C)
LET LENGTH2=SQR(A^2+B^2+C^2)
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2+A(3)^2)
END FUNCTION
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
LET XSIZE=100
LET YSIZE=100
LET ZSIZE=100
DIM H(3),P(3)
CALL VEC2(H,1,.5)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"Hex Prism"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-2+4/XSIZE*XX
LET Y=-2+4/YSIZE*YY
LET Z=-2+4/ZSIZE*ZZ
CALL VEC3(P,X,Y,Z)
IF HEXPRISM(P,H)<.1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION HEXPRISM(P(),H()) !'float sdHexPrism( vec3 p, vec2 h ){
DIM Q(3)
CALL VABS(Q,P) !' vec3 q = abs(p);
LET HEXPRISM=MAX(Q(3)-H(2),MAX((Q(1)*SQR(3)/2+Q(2)*.5),Q(2))-H(1)) !' return max(q.z-h.y,max((q.x*0.866025+q.y*0.5),q.y)-h.x);}
END FUNCTION
EXTERNAL SUB VABS(A(),B())
FOR I=1 TO 3
LET A(I)=ABS(B(I))
NEXT I
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
LET XSIZE=100
LET YSIZE=100
LET ZSIZE=100
DIM P(3),H(3)
CALL VEC2(H,.8,.5)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"cylinder"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-1+2/XSIZE*XX
LET Y=-1+2/YSIZE*YY
LET Z=-1+2/ZSIZE*ZZ
CALL VEC3(P,X,Y,Z)
IF CAPPEDCYLINDER(P,H)<.1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION CAPPEDCYLINDER(P(),H()) !'float sdCappedCylinder( vec3 p, vec2 h ){
DIM V(3),S(3),DD(3),D(3)
LET L=LENGTH2(P(1),P(3),0)
CALL VEC2(V,L,P(2))
CALL VABS(S,V)
MAT D=S-H !'vec2 d = abs(vec2(length(p.xz),p.y)) - h;
CALL NMAX(DD,D,0)
LET CAPPEDCYLINDER=MIN(MAX(D(1),D(2)) ,0)+LENGTH(DD) !' return min(max(d.x,d.y),0.0) + length(max(d,0.0));}
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2+A(3)^2)
END FUNCTION
EXTERNAL FUNCTION LENGTH2(A,B,C)
LET LENGTH2=SQR(A^2+B^2+C^2)
END FUNCTION
EXTERNAL SUB NMAX(A(),B(),N)
FOR I=1 TO 3
LET A(I)=MAX(B(I),N)
NEXT I
END SUB
EXTERNAL SUB VABS(A(),B())
FOR I=1 TO 3
LET A(I)=ABS(B(I))
NEXT I
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
LET XSIZE=100
LET YSIZE=100
LET ZSIZE=100
DIM P(3),C(3)
CALL VEC3(C,.5,.7,.5)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"cone"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-1+2/XSIZE*XX
LET Y=-1+2/YSIZE*YY
LET Z=-1+2/ZSIZE*ZZ
CALL VEC3(P,X,Y,Z)
IF CAPPEDCONE(P,C)<.1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION CAPPEDCONE(P(),C()) !'float sdCappedCone( in vec3 p, in vec3 c ){
DIM Q(3),V(3),W(3),VV(3),QV(3),D(3),K(3)
CALL VEC2(Q,LENGTH2(P(1),P(3),0),P(2)) !'vec2 q = vec2( length(p.xz), p.y );
CALL VEC2(V,C(3)*C(2)/C(1),-C(3)) !'vec2 v = vec2( c.z*c.y/c.x, -c.z );
MAT W=V-Q !'vec2 w = v - q;
CALL VEC2(VV,DOT(V,V),V(1)^2) !'vec2 vv = vec2( dot(v,v), v.x*v.x );
CALL VEC2(QV,DOT(V,W),V(1)*W(1)) !'vec2 qv = vec2( dot(v,w), v.x*w.x );
CALL NMAX(K,QV,0) !'vec2 d = max(qv,0.0)*qv/vv;
LET D(1)=K(1)*QV(1)/VV(1)
LET D(2)=K(2)*QV(2)/VV(2)
WHEN EXCEPTION IN
LET CAPPEDCONE=SQR(DOT(W,W)-MAX(D(1),D(2)))*SGN(MAX(Q(2)*V(1)-Q(1)*V(2),W(2))) !'return sqrt( dot(w,w) - max(d.x,d.y) ) * sign(max(q.y*v.x-q.x*v.y,w.y));}
USE
LET CAPPEDCONE=100000
END WHEN
END FUNCTION
EXTERNAL FUNCTION LENGTH2(A,B,C)
LET LENGTH2=SQR(A^2+B^2+C^2)
END FUNCTION
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
EXTERNAL SUB NMAX(A(),B(),N)
FOR I=1 TO 3
LET A(I)=MAX(B(I),N)
NEXT I
END SUB
LET XSIZE=100
LET YSIZE=100
LET ZSIZE=100
DIM A(3),B(3),P(3)
CALL VEC3(A,.75,0,1)
CALL VEC3(B,-.75,0,1)
FILE GETSAVENAME F$,"vtkファイル|*.vtk"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".VTK")=0 THEN LET F$=F$&".vtk"
OPEN #1:NAME F$
ERASE #1
PRINT #1:"# vtk DataFile Version 2.0"
PRINT #1:"capsule"
PRINT #1:"ASCII"
PRINT #1:"DATASET STRUCTURED_POINTS"
PRINT #1:"DIMENSIONS";XSIZE;YSIZE;ZSIZE
PRINT #1:"ORIGIN 0 0 0"
PRINT #1:"SPACING 1 1 1"
PRINT #1:"POINT_DATA";XSIZE*YSIZE*ZSIZE
PRINT #1:"SCALARS scalar float"
PRINT #1:"LOOKUP_TABLE default"
FOR ZZ=0 TO ZSIZE-1
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=-2.5+5/XSIZE*XX
LET Y=-2.5+5/YSIZE*YY
LET Z=-2.5+5/ZSIZE*ZZ
CALL VEC3(P,X,Y,Z)
IF CAPSULE(P,A,B,1)<.1 THEN LET DA=255 ELSE LET DA=0
PRINT #1:DA
NEXT XX
NEXT YY
NEXT ZZ
CLOSE #1
END
EXTERNAL FUNCTION CAPSULE(P(),A(),B(),R) !'float sdCapsule( vec3 p, vec3 a, vec3 b, float r ){
DIM PA(3),BA(3),D(3)
MAT PA=P-A !'vec3 pa = p - a, ba = b - a;
MAT BA=B-A
LET H=CLAMP(DOT(PA,BA)/DOT(BA,BA),0,1) !'float h = clamp( dot(pa,ba)/dot(ba,ba), 0.0, 1.0 );
MAT D=H*BA
MAT PA=PA-D
LET CAPSULE=LENGTH(PA)-R !'return length( pa - ba*h ) - r;}
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2+A(3)^2)
END FUNCTION
EXTERNAL SUB VABS(A(),B())
FOR I=1 TO 3
LET A(I)=ABS(B(I))
NEXT I
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B) !' A<=X<=B
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
OPTION ARITHMETIC NATIVE ! [表示桁数を多く]にチェックを入れる
LET a0=1.6E10
FOR i=0 TO 5 ! 1.6E10, 3.2E10, 6.4E10, 1.28E11, 2.56E11, 5.12E11
LET a1=2^i*a0
LET d=CEIL(LOG10(a1))
LET u$=USING$("#.##^^^^",a1)
PRINT u$;"(=2^";STR$(i);"*1.6E10) 整数部";STR$(d);"桁"
FOR a=a1-50 TO a1+100
LET a$=USING$(REPEAT$("#",d)&".###########",a)
LET f=VAL(a$(d+1:d+12)) ! 小数部分 VAL(".###########")
IF f=0 THEN
PRINT a ! 問題なし
ELSE
IF POS(STR$(a),".")=0 THEN
PRINT " ";a$ ! 書式指定による誤表示
ELSE
PRINT " ";a$ ; a ! 書式指定と[表示桁数を多く]による誤表示
END IF
END IF
NEXT a
PRINT
NEXT i
END
> 2進モードで書式指定を利用して整数を表示すると、一部の整数が実数で表示されます。
> 十進BASICのバージョンは7.8.2
>
>
> 調査しましたが、誤表示される最小の整数はおそらく16000000001(=1.6E10+1)です。
>
> OPTION ARITHMETIC NATIVE
> FOR a=1.6E10 TO 1.6E10+10
> PRINT USING " ###########.###########" : a
> NEXT a
> END
>
>
> 上記の方法で誤表示される整数の一部は、書式指定を利用しなくとも[オプション][数値][表示桁数を多く]にチェックを入れると、やはり実数で表示されます。
> これで誤表示される最小の整数はおそらく64000000001(=6.4E10+1)です。
>
> OPTION ARITHMETIC NATIVE ! [表示桁数を多く]にチェックを入れる
> FOR a=6.4E10 TO 6.4E10+20
> PRINT USING " ###########.###########" : a
> PRINT a
> NEXT a
> END
>
>
> 誤表示される数値の出現には規則性があり、1.6E10を元にして倍々するごとに出現パターンが変化します。
> 1.6E10を2の累乗倍し、それより小さな値を50個、大きな値を100個出力させました。
>
> OPTION ARITHMETIC NATIVE ! [表示桁数を多く]にチェックを入れる
> LET a0=1.6E10
> FOR i=0 TO 5 ! 1.6E10, 3.2E10, 6.4E10, 1.28E11, 2.56E11, 5.12E11
> LET a1=2^i*a0
> LET d=CEIL(LOG10(a1))
> LET u$=USING$("#.##^^^^",a1)
> PRINT u$;"(=2^";STR$(i);"*1.6E10) 整数部";STR$(d);"桁"
> FOR a=a1-50 TO a1+100
> LET a$=USING$(REPEAT$("#",d)&".###########",a)
> LET f=VAL(a$(d+1:d+12)) ! 小数部分 VAL(".###########")
> IF f=0 THEN
> PRINT a ! 問題なし
> ELSE
> IF POS(STR$(a),".")=0 THEN
> PRINT " ";a$ ! 書式指定による誤表示
> ELSE
> PRINT " ";a$ ; a ! 書式指定と[表示桁数を多く]による誤表示
> END IF
> END IF
> NEXT a
> PRINT
> NEXT i
> END
OPTION ARITHMETIC NATIVE ! [表示桁数を多く]にチェックを入れる
LET z$="."&REPEAT$("0",19)
LET s$=REPEAT$("#",16)&"."&REPEAT$("#",19)
DIM ex(11 TO 16)
FOR i=11 TO 16
LET ex(i)=10^i
NEXT i
RANDOMIZE
PRINT TIME$
LET t=TIME
FOR k=1 TO 3E8
FOR d=11 TO 16
LET a=INT(RND*ex(d))
LET a$=USING$(s$,a)
IF a$(17:36)<>z$ THEN
PRINT a$
PRINT a
END IF
NEXT d
NEXT k
PRINT TIME-t;"sec" ! 約5時間55分
END
DIM P(2)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE) !'範囲を-1～1に正規化(描画領域が正方形の時)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
CALL VEC2(P,X,Y)
LET L=LENGTH(P)
IF L<>0 THEN LET C=.1/L ELSE LET C=1
CALL SETCOLOR(C,C,C)
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2)
END FUNCTION
----------------------------------------------------------------------------------------------------------------
このプログラムでも光の玉(オーブ)を描画しています。 https://qiita.com/doxas/items/00567758621bb506e584
DIM P(2),COL(3),PP(2),Q(2)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
MAT COL=ZER
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
CALL VEC2(P,X,Y)
FOR I=0 TO 5
LET J=I+1
CALL VEC2(PP,COS(J)*.5,SIN(J)*.5)
MAT Q=P+PP
LET L=LENGTH(Q)
FOR K=1 TO 3
IF L<>0 THEN LET COL(K)=COL(K)+.05/L ELSE LET COL(K)=1
NEXT K
NEXT I
CALL SETCOLOR(COL)
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB SETCOLOR(A())
SET COLOR COLORINDEX(CLAMP(A(1),0,1),CLAMP(A(2),0,1),CLAMP(A(3),0,1))
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2)
END FUNCTION
DIM P(2),COL(3),PP(2),Q(2),D(2)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
IF X*Y=0 THEN
LET F=1
ELSE
LET F=.001/ABS(X*Y)
END IF
CALL SETCOLOR(F,F,F)
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
DIM P(2),COL(3),PP(2),Q(2),D(2)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
LET T=INT(TIME)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
CALL VEC2(P,X,Y)
CALL VEC3(COL,1,.3,.7)
LET F=0
FOR I=0 TO 9
LET S=SIN(T+I*PI/5)*.5
LET C=COS(T+I*PI/5)*.5
CALL VEC2(PP,C,S)
MAT D=P+PP
LET LL=ABS(LENGTH(D)-.5)
IF LL<>0 THEN LET F=F+.0025/LL ELSE F=F+1
NEXT I
MAT COL=F*COL
CALL SETCOLOR(COL)
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB SETCOLOR(A())
SET COLOR COLORINDEX(CLAMP(A(1),0,1),CLAMP(A(2),0,1),CLAMP(A(3),0,1))
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2)
END FUNCTION
DIM Q(2),M(2,2)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
LET T=INT(TIME)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
LET Q(1)=MOD(X,.2)-.1
LET Q(2)=MOD(Y,.2)-.1
LET S=SIN(T)
LET C=COS(T)
CALL MAT2(M,C,S,-S,C)
MAT Q=Q*M
IF Q(1)*Q(2)=0 THEN
LET V=1
ELSE
LET V=.1/ABS(Q(2))*ABS(Q(1))
END IF
LET R=V*ABS(SIN(T*6)+1.5)
LET G=V*ABS(SIN(T*4.5)+1.5)
LET B=V*ABS(SIN(T*3)+1.5)
CALL SETCOLOR(R,G,B)
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL SUB MAT2(X(,),A,B,C,D)
LET X(1,1)=A
LET X(1,2)=B
LET X(2,1)=C
LET X(2,2)=D
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
PUBLIC NUMERIC LIGHTCOLOR(3),BACKCOLOR(3),FACECOLOR(3),NOSECOLOR(3),CHEEKCOLOR(3),EYESCOLOR(3),HIGHLIGHT(3),LINECOLOR(3),T
DIM P(2),M(2,2),V(2),W(2),Q(2),QQ(2),DESTCOLOR(3)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
CALL VEC3(LIGHTCOLOR,0.95, 0.95, 0.5)!' // 背景の後光の色
CALL VEC3(BACKCOLOR,0.95, 0.25, 0.25)!' // 背景の下地の色
CALL VEC3(FACECOLOR,0.95, 0.75, 0.5)!' // 顔の色
CALL VEC3(NOSECOLOR,0.95, 0.25, 0.25)!' // 鼻の色
CALL VEC3(CHEEKCOLOR,1.0, 0.55, 0.25)!' // 頬の色
CALL VEC3(EYESCOLOR,0.15, 0.05, 0.05)!' // 目の色
CALL VEC3(HIGHLIGHT,0.95, 0.95, 0.95)!' // ハイライトの色
CALL VEC3(LINECOLOR,0.3, 0.2, 0.2)!' // ラインの色
LET T=INT(TIME)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
CALL VEC2(P,X,Y)
CALL SUNRISE(P,DESTCOLOR)
LET S=SIN(SIN(T*2)*.75)
LET C=COS(SIN(T*2))
CALL MAT2(M,C,-S,S,C)
MAT Q=P*M
! circle(q, vec2(0.0), 0.5, faceColor, destColor);
CALL VEC2(V,0,0)
CALL CIRCLE(Q,V,.5,FACECOLOR,DESTCOLOR)
! circle(q, vec2(0.0, -0.05), 0.15, noseColor, destColor);
CALL VEC2(V,0,-.05)
CALL CIRCLE(Q,V,.15,NOSECOLOR,DESTCOLOR)
! circle(q, vec2(0.325, -0.05), 0.15, cheekColor, destColor);
CALL VEC2(V,.325,-.05)
CALL CIRCLE(Q,V,.15,CHEEKCOLOR,DESTCOLOR)
! circle(q, vec2(-0.325, -0.05), 0.15, cheekColor, destColor);
CALL VEC2(V,-.325,-.05)
CALL CIRCLE(Q,V,.15,CHEEKCOLOR,DESTCOLOR)
! ellipse(q, vec2(0.15, 0.135), vec2(0.75, 1.0), 0.075, eyesColor, destColor);
CALL VEC2(V,.15,.135)
CALL VEC2(W,.75,1)
CALL ELLIPSE(Q,V,W,.075,EYESCOLOR,DESTCOLOR)
! ellipse(q, vec2(-0.15, 0.135), vec2(0.75, 1.0), 0.075, eyesColor, destColor);
CALL VEC2(V,-.15,.135)
CALL ELLIPSE(Q,V,W,.075,EYESCOLOR,DESTCOLOR)
! circleLine(q, vec2(0.0), 0.5, 0.525, lineColor, destColor);
CALL VEC2(V,0,0)
CALL CIRCLELINE(Q,V,.5,.525,LINECOLOR,DESTCOLOR)
! circleLine(q, vec2(0.0, -0.05), 0.15, 0.17, lineColor, destColor);
CALL VEC2(V,0,-.05)
CALL CIRCLELINE(Q,V,.15,.17,LINECOLOR,DESTCOLOR)
! arcLine(q, vec2(0.325, -0.05), 0.15, 0.17, PI * 1.5, 0.0, lineColor, destColor);
CALL VEC2(V,.325,-.05)
CALL ARCLINE(Q,V,.15,.17,PI*.5,0,LINECOLOR,DESTCOLOR)
! arcLine(q, vec2(-0.325, -0.05), 0.15, 0.17, PI * 0.5, 0.0, lineColor, destColor);
CALL VEC2(V,-.325,-.05)
CALL ARCLINE(Q,V,.15,.17,PI*1.5,0,LINECOLOR,DESTCOLOR)
! arcLine(q * vec2(1.2, 1.0), vec2(0.19, 0.2), 0.125, 0.145, 0.0, 0.02, lineColor, destColor);
CALL VEC2(V,1.2,1)
CALL VEC2(W,.19,.2)
FOR I=1 TO 2
LET QQ(I)=Q(I)*V(I)
NEXT I
CALL ARCLINE(QQ,W,.125,.145,0,.02,LINECOLOR,DESTCOLOR)
! arcLine(q * vec2(1.2, 1.0), vec2(-0.19, 0.2), 0.125, 0.145, 0.0, 0.02, lineColor, destColor);
CALL VEC2(V,1.2,1)
CALL VEC2(W,-.19,.2)
FOR I=1 TO 2
LET QQ(I)=Q(I)*V(I)
NEXT I
CALL ARCLINE(QQ,W,.125,.145,0,.02,LINECOLOR,DESTCOLOR)
! arcLine(q * vec2(0.9, 1.0), vec2(0.0, -0.15), 0.2, 0.22, PI, 0.055, lineColor, destColor);
CALL VEC2(V,.9,1)
CALL VEC2(W,0,-.15)
FOR I=1 TO 2
LET QQ(I)=Q(I)*V(I)
NEXT I
CALL ARCLINE(QQ,W,0.2, 0.22, PI, 0.055,LINECOLOR,DESTCOLOR)
! rect(q, vec2(-0.025, 0.0), 0.035, highlight, destColor);
CALL VEC2(V,-.025,0)
CALL RECT(Q,V,.035,HIGHLIGHT,DESTCOLOR)
! rect(q, vec2(-0.35, 0.0), 0.035, highlight, destColor);
CALL VEC2(V,-.35,0)
CALL RECT(Q,V,.035,HIGHLIGHT,DESTCOLOR)
! rect(q, vec2(0.3, 0.0), 0.035, highlight, destColor);
CALL VEC2(V,.3,0)
CALL RECT(Q,V,.035,HIGHLIGHT,DESTCOLOR)
CALL SETCOLOR(DESTCOLOR)
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB CIRCLE(P(),OFFSET(),SIZE,COL(),I())
DIM PP(2)
MAT PP=P-OFFSET
LET L=LENGTH(PP)
IF L<SIZE THEN MAT I=COL
END SUB
EXTERNAL SUB ELLIPSE(P(),OFFSET(),PROP(),SIZE,COL(),I())
DIM PP(2),Q(2)
MAT PP=P-OFFSET
FOR J=1 TO 2
LET Q(J)=PP(J)/PROP(J)
NEXT J
IF LENGTH(Q)<SIZE THEN MAT I=COL
END SUB
EXTERNAL SUB CIRCLELINE(P(),OFFSET(),ISIZE,OSIZE,COL(),I())
DIM Q(2)
MAT Q=P-OFFSET
LET L=LENGTH(Q)
IF L>ISIZE AND L<OSIZE THEN MAT I=COL
END SUB
EXTERNAL SUB ARCLINE(P(),OFFSET(),ISIZE,OSIZE,RAD,HEIGHT,COL(),I())
DIM ROT(2,2),Q(2)
LET S=SIN(RAD)
LET C=COS(RAD)
CALL MAT2(ROT,C,-S,S,C)
MAT Q=P-OFFSET
MAT Q=Q*ROT
LET L=LENGTH(Q)
IF L>ISIZE AND L<OSIZE AND Q(2)>HEIGHT THEN MAT I=COL
END SUB
EXTERNAL SUB RECT(P(),OFFSET(),SIZE,COL(),I())
DIM Q(2)
MAT Q=P-OFFSET
MAT Q=(1/SIZE)*Q
IF ABS(Q(1))<1 AND ABS(Q(2))<1 THEN MAT I=COL
END SUB
EXTERNAL SUB SUNRISE(P(),I())
LET F=ATAN(P(1),P(2))+T
LET FS=SIN(F*10)
FOR J=1 TO 2
LET I(J)=MIX(LIGHTCOLOR(J),BACKCOLOR(J),FS)
NEXT J
END SUB
EXTERNAL SUB SETCOLOR(A())
SET COLOR COLORINDEX(CLAMP(A(1),0,1),CLAMP(A(2),0,1),CLAMP(A(3),0,1))
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL SUB VEC3(A(),X,Y,Z)
LET A(1)=X
LET A(2)=Y
LET A(3)=Z
END SUB
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2)
END FUNCTION
EXTERNAL FUNCTION MIX(X,Y,A)
LET MIX=X*(1-A)+Y*A
END FUNCTION
EXTERNAL SUB MAT2(X(,),A,B,C,D)
LET X(1,1)=A
LET X(1,2)=B
LET X(2,1)=C
LET X(2,2)=D
END SUB
EXTERNAL FUNCTION ATAN(X,Y)
IF ABS(X)>1E-4 THEN
LET TH=ATN(Y/X)
IF Y<>0 THEN
IF X>0 AND Y<0 THEN LET TH=TH+PI*2
IF X<0 THEN LET TH=TH+PI
ELSE !' Y=0
IF X<0 THEN LET TH=PI ELSE LET TH=0
END IF
ELSE !' X=0
LET TH=PI/2
IF Y<0 THEN LET TH=TH+PI
END IF
LET ATAN=TH
END FUNCTION
DIM P(2),V(2),CPOS(3),CDIR(3),CUP(3),CSIDE(3),RAY(3),R1(3),R2(3),R3(3),LIGHTDIR(3),RPOS(3)
DIM NORMAL(3)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
CALL VEC3(CPOS,0,0,2)
CALL VEC3(LIGHTDIR,-.577,.577,.577)
LET ANG=60 !'視野角
LET FOV=ANG*.5*PI/180
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
CALL VEC3(RAY,SIN(FOV)*X,SIN(FOV)*Y,-COS(FOV))
CALL NORMALIZE(RAY)
LET DISTANCE=0
LET RLEN=0
MAT RPOS=CPOS
FOR I=0 TO 127
LET DISTANCE=DISTANCEFUNC(RPOS)
LET RLEN=RLEN+DISTANCE
MAT RPOS=RLEN*RAY
MAT RPOS=RPOS+CPOS
IF ABS(DISTANCE)<.001 THEN EXIT FOR
NEXT I
IF ABS(DISTANCE)<.001 THEN
CALL GETNORMAL(RPOS,NORMAL)
LET DIFF=CLAMP(DOT(LIGHTDIR,NORMAL),.1,1)
CALL SETCOLOR(DIFF,DIFF,DIFF)
ELSE
CALL SETCOLOR(0,0,0)
END IF
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB TRANS(P())
FOR I=1 TO 3
LET P(I)=MOD(P(I),4)-2
NEXT I
END SUB
EXTERNAL FUNCTION DISTANCEFUNC(PP())
DIM V(3),A(3),B(3),P(3)
CALL VEC3(B,.5,.5,.5)
MAT P=PP
CALL TRANS(P)
CALL VABS(V,P)
MAT V=V-B
CALL NMAX(A,V,0)
LET DISTANCEFUNC=LENGTH(A)-.5
END FUNCTION
EXTERNAL SUB GETNORMAL(P(),N())
DIM X1(3),X2(3),Y1(3),Y2(3),Z1(3),Z2(3),PX1(3),PX2(3),PY1(3),PY2(3),PZ1(3),PZ2(3)
LET D=.0001
CALL VEC3(X1,D,0,0)
CALL VEC3(X2,-D,0,0)
MAT PX1=P+X1
MAT PX2=P+X2
CALL VEC3(Y1,0,D,0)
CALL VEC3(Y2,0,-D,0)
MAT PY1=P+Y1
MAT PY2=P+Y2
CALL VEC3(Z1,0,0,D)
CALL VEC3(Z2,0,0,-D)
MAT PZ1=P+Z1
MAT PZ2=P+Z2
CALL VEC3(N,DISTANCEFUNC(PX1)-DISTANCEFUNC(PX2),DISTANCEFUNC(PY1)-DISTANCEFUNC(PY2),DISTANCEFUNC(PZ1)-DISTANCEFUNC(PZ2))
CALL NORMALIZE(N)
END SUB
EXTERNAL SUB NORMALIZE(RAY())
LET S=LENGTH(RAY)
IF S<>0 THEN
MAT RAY=(1/S)*RAY
ELSE
MAT RAY=ZER
END IF
END SUB
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL SUB VEC3(V(),X,Y,Z)
LET V(1)=X
LET V(2)=Y
LET V(3)=Z
END SUB
EXTERNAL FUNCTION LENGTH(A())
LET LENGTH=SQR(A(1)^2+A(2)^2+A(3)^2)
END FUNCTION
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL SUB VABS(A(),B())
FOR I=1 TO 3
LET A(I)=ABS(B(I))
NEXT I
END SUB
EXTERNAL SUB NMAX(A(),B(),N)
FOR I=1 TO 3
LET A(I)=MAX(B(I),N)
NEXT I
END SUB
DIM CPOS(3),CDIR(3),CUP(3),CSIDE(3),RAY(3),R1(3),R2(3),R3(3),LIGHTDIR(3),RPOS(3),HALF(3)
DIM NORMAL(3),DPOS(3),COL(3)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
CALL VEC3(CPOS,0,5,5) !'カメラ
CALL VEC3(CDIR,0,-.707,-.707) !'カメラの向き(視線)
CALL VEC3(CUP,0,.707,-.707) !'カメラの上方向
CALL VEC3(LIGHTDIR,-.577,.577,.577)
MAT CSIDE=CROSS(CDIR,CUP) !'横方向
LET TARGETDEPTH=1 !'フォーカス深度
CALL NORMALIZE(LIGHTDIR)
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
MAT R1=X*CSIDE
MAT R2=Y*CUP
MAT R3=TARGETDEPTH*CDIR
MAT RAY=R1
MAT RAY=RAY+R2
MAT RAY=RAY+R3
CALL NORMALIZE(RAY) !'レイの定義
LET DIST=0
LET RLEN=0
MAT RPOS=CPOS
LET SHADOW=1
FOR I=0 TO 255 !'マーチングループ(marching loop)
CALL DISTANCE(RPOS,DIST,COL)
LET RLEN=RLEN+DIST
MAT RPOS=RLEN*RAY
MAT RPOS=RPOS+CPOS
IF DIST<.001 THEN EXIT FOR
NEXT I
IF ABS(DIST)<.001 THEN !'レイとの距離
CALL GETNORMAL(RPOS,NORMAL)
MAT HALF=LIGHTDIR-RAY
CALL NORMALIZE(HALF)
LET DIFF=CLAMP(DOT(LIGHTDIR,NORMAL),.1,1)
LET SPEC=CLAMP(DOT(HALF,NORMAL),0,1)^50
MAT DPOS=(1/1000)*NORMAL
MAT DPOS=DPOS+RPOS
LET SHADOW=GENSHADOW(DPOS,LIGHTDIR) !'シャドウ
FOR I=1 TO 3
LET COL(I)=COL(I)*DIFF+SPEC
NEXT I
ELSE
CALL VEC3(COL,0,0,0)
END IF
FOR I=1 TO 3
LET COL(I)=COL(I)*MAX(.5,SHADOW)
NEXT I
CALL SETCOLOR(COL(1),COL(2),COL(3))
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL FUNCTION TORUS(P()) !'距離関数(トーラス)
DIM T(3),R(3)
CALL VEC2(T,3,1)
CALL VEC2(R,LENGTH2(P(1),P(3),0)-T(1),P(2))
LET TORUS=LENGTH(R)-T(2)
END FUNCTION
EXTERNAL FUNCTION FLOOR(P()) !'距離関数(床)
DIM V(3)
CALL VEC3(V,0,1,0)
LET FLOOR=DOT(P,V)+1
END FUNCTION
EXTERNAL SUB DISTANCE(P(),DIST,COL())
LET D1=TORUS(P)
LET D2=FLOOR(P)
IF D1<D2 THEN
LET DIST=D1
CALL VEC3(COL,1,1,.25) !'色
ELSE
LET DIST=D2
LET U=1-IP(MOD(P(1),2))
LET V=1-IP(MOD(P(3),2))
IF U+V=1 THEN CALL VEC3(COL,.7,.7,.7) ELSE CALL VEC3(COL,1,1,1) !'色(市松模様)
END IF
END SUB
EXTERNAL SUB NMAX(A(),B(),N)
FOR I=1 TO 3
LET A(I)=MAX(B(I),N)
NEXT I
END SUB
EXTERNAL SUB GETNORMAL(P(),N()) !'法線ベクトル
DIM X1(3),X2(3),Y1(3),Y2(3),Z1(3),Z2(3),PX1(3),PX2(3),PY1(3),PY2(3),PZ1(3),PZ2(3),DMY(3)
LET D=.0001
CALL VEC3(X1,D,0,0)
CALL VEC3(X2,-D,0,0)
MAT PX1=P+X1
MAT PX2=P+X2
CALL VEC3(Y1,0,D,0)
CALL VEC3(Y2,0,-D,0)
MAT PY1=P+Y1
MAT PY2=P+Y2
CALL VEC3(Z1,0,0,D)
CALL VEC3(Z2,0,0,-D)
MAT PZ1=P+Z1
MAT PZ2=P+Z2
CALL DISTANCE(PX1,XS,DMY)
CALL DISTANCE(PX2,XE,DMY)
CALL DISTANCE(PY1,YS,DMY)
CALL DISTANCE(PY2,YE,DMY)
CALL DISTANCE(PZ1,ZS,DMY)
CALL DISTANCE(PZ2,ZE,DMY)
CALL VEC3(N,XS-XE,YS-YE,ZS-ZE)
CALL NORMALIZE(N)
END SUB
EXTERNAL SUB NORMALIZE(RAY()) !'正規化
LET S=LENGTH(RAY)
IF S<>0 THEN
MAT RAY=(1/S)*RAY
ELSE
MAT RAY=ZER
END IF
END SUB
EXTERNAL SUB VABS(A(),B())
FOR I=1 TO 3
LET A(I)=ABS(B(I))
NEXT I
END SUB
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL SUB VEC3(V(),X,Y,Z)
LET V(1)=X
LET V(2)=Y
LET V(3)=Z
END SUB
EXTERNAL SUB VEC2(A(),X,Y)
LET A(1)=X
LET A(2)=Y
END SUB
EXTERNAL FUNCTION LENGTH(A()) !'長さ
LET LENGTH=SQR(A(1)^2+A(2)^2+A(3)^2)
END FUNCTION
EXTERNAL FUNCTION LENGTH2(X,Y,Z)
LET LENGTH2=SQR(X^2+Y^2+Z^2)
END FUNCTION
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL FUNCTION GENSHADOW(RO(),RD()) !'シャドウ
DIM RAY(3),DMY(3)
LET R=1
LET C=.001
LET SHADOWCOEF=.5
FOR T=0 TO 49
MAT RAY=C*RD
MAT RAY=RAY+RO
CALL DISTANCE(RAY,H,DMY)
IF H<.001 THEN
LET GENSHADOW=SHADOWCOEF
EXIT FUNCTION
END IF
LET R=MIN(R,H*32/C)
LET C=C+H
NEXT T
LET GENSHADOW=1-SHADOWCOEF+R*SHADOWCOEF
END FUNCTION
DIM P(2),V(2),CPOS(3),CDIR(3),CUP(3),CSIDE(3),RAY(3),R1(3),R2(3),R3(3),LIGHTDIR(3),DPOS(3)
DIM NORMAL(3),COL(3)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
CALL VEC3(CPOS,5,5,.5)
CALL VEC3(CUP,.1,.4,0)
CALL NORMALIZE(CUP)
CALL VEC3(CDIR,-1,0,0)
MAT CDIR=CROSS(CUP,CDIR)
CALL VEC3(LIGHTDIR,1,1,-2)
CALL NORMALIZE(LIGHTDIR)
MAT CSIDE=CROSS(CDIR,CUP)
LET TARGETDEPTH=1
LET EPS=.001
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
MAT R1=X*CSIDE
MAT R2=Y*CUP
MAT R3=TARGETDEPTH*CDIR
MAT RAY=R1
MAT RAY=RAY+R2
MAT RAY=RAY+R3
CALL NORMALIZE(RAY)
LET DEPTH=0
MAT DPOS=CPOS
FOR I=0 TO 63
LET DIST=DISTANCEFUNC(DPOS)
LET DEPTH=DEPTH+DIST
MAT DPOS=DEPTH*RAY
MAT DPOS=DPOS+CPOS
IF ABS(DIST)<EPS THEN EXIT FOR
NEXT I
IF ABS(DIST)<EPS THEN
CALL GETNORMAL(DPOS,NORMAL)
LET DIFFUSE=CLAMP(DOT(LIGHTDIR,NORMAL),.1,1)
CALL VEC3(COL,1,.1,.1)
MAT COL=DIFFUSE*COL
CALL SETCOLOR(COL(1)+.05*DEPTH,COL(2)+.05*DEPTH,COL(3)+.05*DEPTH)
ELSE
CALL SETCOLOR(.05*DEPTH,.05*DEPTH,.05*DEPTH)
END IF
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB ONREP(P(), INTERVAL,PP())
FOR I=1 TO UBOUND(P,1)
LET PP(I)=MOD(P(I),INTERVAL)- INTERVAL * 0.5
NEXT I
END SUB
EXTERNAL FUNCTION BARDIST(X,Y,INTERVAL,WIDTH)
DIM PP(2),P(2)
CALL VEC2(P,X,Y)
CALL ONREP(P, INTERVAL,PP)
CALL VABS(PP)
FOR I=1 TO 2
LET PP(I)=PP(I)-WIDTH
NEXT I
CALL VMAX(PP,0)
LET BARDIST=LENGTH(PP)
END FUNCTION
EXTERNAL FUNCTION TUBEDIST(X,Y, INTERVAL, WIDTH)
DIM PP(2),P(2)
CALL VEC2(P,X,Y)
CALL ONREP(P, INTERVAL,PP)
LET TUBEDIST=LENGTH(PP) - WIDTH
END FUNCTION
EXTERNAL FUNCTION DISTANCEFUNC(P())
LET BARX=BARDIST(P(2),P(3),1,.1)
LET BARY=BARDIST(P(1),P(3),1,.1)
LET BARZ=BARDIST(P(1),P(2),1,.1)
LET TUBEX=TUBEDIST(P(2),P(3),.1,.025)
LET TUBEY=TUBEDIST(P(1),P(3),.1,.025)
LET TUBEZ=TUBEDIST(P(1),P(2),.1,.025)
LET DISTANCEFUNC=MAX(MAX(MAX(MIN(MIN(BARX, BARY),BARZ), -TUBEX), -TUBEY), -TUBEZ)
END FUNCTION
EXTERNAL SUB GETNORMAL(P(),N())
DIM X1(3),X2(3),Y1(3),Y2(3),Z1(3),Z2(3),PX1(3),PX2(3),PY1(3),PY2(3),PZ1(3),PZ2(3)
LET D=.001
CALL VEC3(X1,D,0,0)
CALL VEC3(X2,-D,0,0)
MAT PX1=P+X1
MAT PX2=P+X2
CALL VEC3(Y1,0,D,0)
CALL VEC3(Y2,0,-D,0)
MAT PY1=P+Y1
MAT PY2=P+Y2
CALL VEC3(Z1,0,0,D)
CALL VEC3(Z2,0,0,-D)
MAT PZ1=P+Z1
MAT PZ2=P+Z2
CALL VEC3(N,DISTANCEFUNC(PX1)-DISTANCEFUNC(PX2),DISTANCEFUNC(PY1)-DISTANCEFUNC(PY2),DISTANCEFUNC(PZ1)-DISTANCEFUNC(PZ2))
CALL NORMALIZE(N)
END SUB
EXTERNAL SUB NORMALIZE(RAY())
LET S=LENGTH(RAY)
IF S<>0 THEN
MAT RAY=(1/S)*RAY
ELSE
MAT RAY=ZER
END IF
END SUB
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL SUB VEC2(V(),X,Y)
LET V(1)=X
LET V(2)=Y
END SUB
EXTERNAL SUB VEC3(V(),X,Y,Z)
LET V(1)=X
LET V(2)=Y
LET V(3)=Z
END SUB
EXTERNAL FUNCTION LENGTH(A())
FOR I=1 TO UBOUND(A,1)
LET S=S+A(I)^2
NEXT I
LET LENGTH=SQR(S)
END FUNCTION
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL SUB VABS(A())
FOR I=1 TO UBOUND(A,1)
LET A(I)=ABS(A(I))
NEXT I
END SUB
EXTERNAL SUB VMAX(A(),N)
FOR I=1 TO UBOUND(A,1)
LET A(I)=MAX(A(I),N)
NEXT I
END SUB
PUBLIC NUMERIC EPS,OFFSET
DIM POS(3),CPOS(3),CDIR(3),CUP(3),CSIDE(3),RAY(3),R1(3),R2(3),R3(3),LIGHTDIR(3)
DIM NORMAL(3),COL(3),C(3),V(3),R(3),CC(3),CAMERA(3)
ASK BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW -XSIZE/MIN(XSIZE,YSIZE),XSIZE/MIN(XSIZE,YSIZE),-YSIZE/MIN(XSIZE,YSIZE),YSIZE/MIN(XSIZE,YSIZE)
CALL VEC3(CDIR,0,0,1)
CALL VEC3(CUP,0,1,0)
CALL VEC3(CAMERA,0,1,0)
MAT CSIDE=CROSS(CDIR,CUP)
LET EPS=.01
LET TARGETDEPTH=1.3
LET OFFSET = EPS * 100
FOR YY=0 TO YSIZE-1
FOR XX=0 TO XSIZE-1
LET X=(XX*2-XSIZE)/MIN(XSIZE,YSIZE)
LET Y=(YY*2-YSIZE)/MIN(XSIZE,YSIZE)
MAT R1=X*CSIDE
MAT R2=Y*CUP
MAT R3=TARGETDEPTH*CDIR
MAT RAY=R1
MAT RAY=RAY+R2
MAT RAY=RAY+R3
MAT CPOS=CAMERA
CALL NORMALIZE(RAY)
LET ALPHA=1
MAT COL=ZER
FOR I=0 TO 2
CALL GETRAYCOLOR(CPOS, RAY, POS, NORMAL, HIT,CC)
MAT C=ALPHA*CC
MAT COL=COL+C
LET ALPHA=ALPHA*.3
CALL REFLECT(RAY, NORMAL ,R)
CALL NORMALIZE(R)
MAT RAY=R
MAT CPOS=OFFSET*NORMAL
MAT CPOS=CPOS+POS
IF HIT=0 THEN EXIT FOR
NEXT I
CALL SETCOLOR(COL(1),COL(2),COL(3))
PLOT POINTS:X,Y
NEXT XX
NEXT YY
END
EXTERNAL SUB ONREP(P(), INTERVAL,PP())
DIM Q(2)
LET Q(1)=MOD(P(1),INTERVAL)- INTERVAL * 0.5
LET Q(2)=MOD(P(3),INTERVAL)- INTERVAL * 0.5
CALL VEC3(PP,Q(1),P(2),Q(2))
END SUB
EXTERNAL FUNCTION SPHEREDIST(P(),R)
DIM PP(3)
CALL ONREP(P,3,PP)
LET SPHEREDIST=LENGTH(PP)-R
END FUNCTION
EXTERNAL FUNCTION FLOORDIST(P())
DIM V(3)
CALL VEC3(V,0,1,0)
LET FLOORDIST=DOT(P,V)+1
END FUNCTION
EXTERNAL SUB MINVEC4(A(),B(),C())
IF A(4)<B(4) THEN MAT C=A ELSE MAT C=B
END SUB
EXTERNAL FUNCTION CHECKEREDPATTERN(P())
LET U=1-IP(MOD(P(1),2))
LET V=1-IP(MOD(P(3),2))
IF U=1 AND V<1 OR U<1 AND V=1 THEN LET CHECKEREDPATTERN=.2 ELSE LET CHECKEREDPATTERN=1
END FUNCTION
EXTERNAL SUB HSV2RGB(C(),RGB())
DIM K(4),P(3)
CALL VEC4(K,1.0, 2.0 / 3.0, 1.0 / 3.0, 3.0)
FOR I=1 TO 3
LET P(I)=ABS(FRACT(C(1)+K(I))*6-K(4))
NEXT I
FOR I=1 TO 3
LET RGB(I)=C(3)*MIX(K(1),CLAMP(P(I)-K(1),0,1),C(2))
NEXT I
END SUB
EXTERNAL FUNCTION SCENEDIST(P())
LET SCENEDIST=MIN(SPHEREDIST(P,1),FLOORDIST(P))
END FUNCTION
EXTERNAL SUB SCENECOLOR(P(),PP())
DIM A(4),B(4),C(3),COL(3)
CALL VEC3(C,(P(3) + P(1)) / 9.0, 1.0, 1.0 )
CALL HSV2RGB(C,COL)
CALL VEC4(A,COL(1),COL(2),COL(3), SPHEREDIST(P,1.0))
LET L=CHECKEREDPATTERN(P)
CALL VEC4(B,.5*L,.5*L,.5*L,FLOORDIST(P))
CALL MINVEC4(A,B,PP)
END SUB
EXTERNAL SUB GETNORMAL(P(),N())
DIM X1(3),X2(3),Y1(3),Y2(3),Z1(3),Z2(3),PX1(3),PX2(3),PY1(3),PY2(3),PZ1(3),PZ2(3)
CALL VEC3(X1,EPS,0,0)
CALL VEC3(X2,-EPS,0,0)
MAT PX1=P+X1
MAT PX2=P+X2
CALL VEC3(Y1,0,EPS,0)
CALL VEC3(Y2,0,-EPS,0)
MAT PY1=P+Y1
MAT PY2=P+Y2
CALL VEC3(Z1,0,0,EPS)
CALL VEC3(Z2,0,0,-EPS)
MAT PZ1=P+Z1
MAT PZ2=P+Z2
CALL VEC3(N,SCENEDIST(PX1)-SCENEDIST(PX2),SCENEDIST(PY1)-SCENEDIST(PY2),SCENEDIST(PZ1)-SCENEDIST(PZ2))
CALL NORMALIZE(N)
END SUB
EXTERNAL FUNCTION GETSHADOW(RO(),RD())
DIM RAY(3),DMY(3)
LET R=1
LET SHADOWCOEF=.5
FOR T=0 TO 49
MAT RAY=C*RD
MAT RAY=RAY+RO
LET H=SCENEDIST(RAY)
IF H<EPS THEN
LET GETSHADOW=SHADOWCOEF
EXIT FUNCTION
END IF
IF C<>0 THEN LET R=MIN(R,H*16/C)
LET C=C+H
NEXT T
LET GETSHADOW=1-SHADOWCOEF+R*SHADOWCOEF
END FUNCTION
EXTERNAL SUB GETRAYCOLOR(ORIGIN(),RAY(),POS(),NORMAL(),HIT,COL())
DIM P(3),S(3),V(3),LIGHTDIR(3),CL(4)
MAT POS=ORIGIN
CALL VEC3(LIGHTDIR,-0.48666426339228763, 0.8111071056538127, -0.3244428422615251)
FOR I=0 TO 63
LET DIST = SCENEDIST(POS)
LET DEPTH =DEPTH+ DIST
MAT POS=DEPTH*RAY
MAT POS=POS+ORIGIN
IF ABS(DIST)<EPS THEN EXIT FOR
NEXT I
IF ABS(DIST)<EPS THEN
CALL GETNORMAL(POS,NORMAL)
LET DIFFUSE = CLAMP(DOT(LIGHTDIR, NORMAL), 0.1, 1.0 )
CALL REFLECT(LIGHTDIR, NORMAL,V)
LET SPECULAR = CLAMP(DOT(V,RAY),0, 1)^10
CALL VEC3(S,SPECULAR*.8,SPECULAR*.8,SPECULAR*.8)
MAT P=OFFSET*NORMAL
MAT P=P+POS
LET SHADOW = GETSHADOW(P, LIGHTDIR)
CALL SCENECOLOR(POS ,CL)
FOR I=1 TO 3
LET COL(I)=CL(I)
NEXT I
MAT COL=DIFFUSE*COL
MAT COL=COL+S
MAT COL=(MAX(0.5,SHADOW))*COL
LET HIT = 1
ELSE
MAT COL=ZER
LET HIT=0
END IF
LET K= CLAMP(.05 * DEPTH, 0, .6)^2
FOR I=1 TO 3
LET COL(I)=COL(I)-K
NEXT I
END SUB
EXTERNAL SUB REFLECT(I(),N(),V())
DIM C(3),VV(3)
LET K=2*DOT(N,I)
MAT C=K*N
MAT VV=I-C
MAT V=VV
END SUB
EXTERNAL SUB NORMALIZE(RAY())
LET S=LENGTH(RAY)
IF S<>0 THEN
MAT RAY=(1/S)*RAY
ELSE
MAT RAY=ZER
END IF
END SUB
EXTERNAL SUB SETCOLOR(R,G,B)
SET COLOR COLORINDEX(CLAMP(R,0,1),CLAMP(G,0,1),CLAMP(B,0,1))
END SUB
EXTERNAL SUB VEC2(V(),X,Y)
LET V(1)=X
LET V(2)=Y
END SUB
EXTERNAL SUB VEC3(V(),X,Y,Z)
LET V(1)=X
LET V(2)=Y
LET V(3)=Z
END SUB
EXTERNAL SUB VEC4(V(),X,Y,Z,W)
LET V(1)=X
LET V(2)=Y
LET V(3)=Z
LET V(4)=W
END SUB
EXTERNAL FUNCTION LENGTH(A())
FOR I=1 TO UBOUND(A,1)
LET S=S+A(I)^2
NEXT I
LET LENGTH=SQR(S)
END FUNCTION
EXTERNAL FUNCTION CLAMP(X,A,B)
LET CLAMP=MIN(B,MAX(X,A))
END FUNCTION
EXTERNAL FUNCTION FRACT(X)
LET FRACT=FP(X)
END FUNCTION
EXTERNAL FUNCTION MIX(X,Y,A)
LET MIX=X*(1-A)+Y*A
END FUNCTION
DO
LET contTemp = contTemp + ddTemp
IF contTemp>3000 THEN LET contTemp = 3000
IF contTemp<10 THEN LET contTemP = 10
IF pauseFlag=0 THEN CALL moveParticles(tempMode,contTemp) ELSE WAIT DELAY 0.05
CALL drawParticles(tempMode,contTemp,drawMode)
LET S$=INKEY$
IF S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" OR S$="6" OR S$="7" THEN
LET material = VAL(S$)
LET tempMode = 0
LET contTemp = 300
CALL setInitialCondition(material,12.0,contTemp)
ELSEIF S$="T" OR S$="t" THEN
LET tempMode = MOD(tempMode+1,2)
IF tempMode=0 THEN LET ddTemp = 0
ELSEIF S$="K" OR S$="k" THEN
LET tempMode = 1
IF ddtemp=0 THEN LET ddTemp = 1 ELSE LET ddTemp = 0
ELSEIF S$="J" OR S$="j" THEN
LET tempMode = 1
IF ddTemp=0 THEN LET ddTemp = -1 ELSE LET ddTemp = 0
ELSEIF S$="D" OR S$="d" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$=" " THEN
LET pauseFlag = MOD(pauseFlag+1,2)
END IF
LOOP UNTIL S$=CHR$(27)
END
EXTERNAL FUNCTION INKEY$ !--- from decimal BASIC library inkey$.bas
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- molecular dynamics 2D - ion ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
!
! force: ion f(r) = fc + fr + fa
! fc = eForceConst*zi*zj*(EXP(-r/6.5e-10)/r)*(1.0/r+1.0/6.5e-10) !Debye-screened Coulomb force
! fr = 6.9742e-11*EXP((a-r)/b) !repulsive force
! fa = -6.9742e-21*(c/r^6) !attractive force
!
MODULE imd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC ionKind1,ionKind2, sysTime, dt, nMolec, xMax, yMax, Nsx,Nsy, rCutoff, hh
SHARE NUMERIC xx(5000),yy(5000) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(5000),vy(5000) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(5000),ffy(5000) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC kind(5000),mas(5000) ! kind(i),mas(i) : molec kind, mass of i-th particle
SHARE NUMERIC reg(5000,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC section(0 TO 101,0 TO 101,0 TO 20) !use pre-registration
SHARE NUMERIC ion_m(0 TO 17),ion_z(0 TO 17) ! ion mass,ion charge
SHARE NUMERIC ion_a(0 TO 17),ion_b(0 TO 17) ! ion force param a,ion force param b
SHARE NUMERIC ion_c(0 TO 17),ion_r(0 TO 17) ! ion force param c, ion radius
SHARE NUMERIC ion_col(0 TO 17) ! ion draw color
SHARE STRING ion_str$(0 TO 17) ! ion string
SHARE NUMERIC forceTable(0 TO 17, 0 TO 17,0 TO 1001) ! force table
LET ionKind1 = 3 ! ion kind1 - 3:Na+
LET ionKind2 = 7 ! ion kind2 - 7:Cl-
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 2.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET Nsx = 100
LET Nsy = 100
LET rCutoff = 1.0e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET ion_z(0)=0.0 ! if ion_z(0)=0.0 then set ion data
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(material,boxSizeInNM,contTemp)
DECLARE EXTERNAL SUB setIonData,ajustVelocity,setForceTable
DECLARE EXTERNAL FUNCTION setNaClTypeBlock
RANDOMIZE
LET sysTime = 0.0
CALL setIonData
CALL setForceTable
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
IF material=1 THEN !NaCl
LET ionKind1 = 3 !Na+
LET ionKind2 = 7 !Cl-
LET lattice = 5.6407e-10
ELSEIF material=2 THEN !MgO
LET ionKind1 = 4 !Mg++
LET ionKind2 = 1 !O--
LET lattice = 4.212e-10*0.94 !0.94: correction factor
ELSEIF material=3 THEN !CaO
LET ionKind1 = 9 !Ca++
LET ionKind2 = 1 !O--
LET lattice = 4.80e-10*0.94 !0.94: correction factor
ELSEIF material=4 THEN !BaO
LET ionKind1 = 12 !Ba++
LET ionKind2 = 1 !O--
LET lattice = 5.536e-10
ELSEIF material=5 THEN !NaF
LET ionKind1 = 3 !Na+
LET ionKind2 = 2 !F-
LET lattice = 4.62e-10
ELSEIF material=6 THEN !KF
LET ionKind1 = 8 !K+
LET ionKind2 = 2 !F-
LET lattice = 5.34e-10
ELSEIF material=7 THEN !KCl
LET ionKind1 = 8 !K+
LET ionKind2 = 7 !Cl-
LET lattice = 6.29e-10
END IF
LET nL = int(0.8*xMax/lattice)
LET s = 0.5*(xMax - lattice*nL)
! setNaClTypeBlock(ii, knd1, knd2, nx, ny, lattice, xPos, yPos)
LET nMolec = setNaClTypeBlock(1, ionKind1, ionKind2, nL, nL, lattice, s, s)
CALL ajustVelocity(contTemp)
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setIonData
! ion potential data
! 0 mass,1 charge, 2 a , 3 b , 4 c , 5 r-ion, 6 color 7 str$
DATA 10.81, 3.0, 0.720e-10, 0.080e-10, 0.0, 0.23e-10, 13 , "B+++" !0
DATA 16.00, -2.0, 1.626e-10, 0.085e-10, 20.0, 1.40e-10, 2 , "O--" !1
DATA 19.00, -1.0, 1.565e-10, 0.085e-10, 20.0, 1.33e-10, 2 , "F-" !2
DATA 22.99, 1.0, 1.260e-10, 0.080e-10, 20.0, 1.02e-10, 4 , "Na+" !3
DATA 24.31, 2.0, 1.161e-10, 0.080e-10, 10.0, 0.72e-10, 4 , "Mg++" !4
DATA 26.98, 3.0, 1.064e-10, 0.080e-10, 2.0, 0.53e-10, 13 , "Al+++" !5
DATA 28.09, 4.0, 1.012e-10, 0.080e-10, 0.0, 0.40e-10, 7 , "Si++++" !6
DATA 35.45, -1.0, 1.950e-10, 0.090e-10, 30.0, 1.81e-10, 2 , "Cl-" !7
DATA 39.10, 1.0, 1.595e-10, 0.080e-10, 15.0, 1.38e-10, 4 , "K+" !8
DATA 40.08, 2.0, 1.414e-10, 0.080e-10, 10.0, 1.00e-10, 4 , "Ca++" !9
DATA 47.88, 4.0, 1.235e-10, 0.080e-10, 0.0, 0.61e-10, 7 , "Ti++++" !10
DATA 87.62, 2.0, 1.632e-10, 0.080e-10, 15.0, 1.16e-10, 4 , "Sr++" !11
DATA 137.3, 2.0, 1.820e-10, 0.080e-10, 20.0, 1.36e-10, 4 , "Ba++" !12
DATA 4.003, 0.0, 1.200e-10, 0.110e-10, 4.76, 1.28e-10, 3 , "He" !13
DATA 20.18, 0.0, 1.415e-10, 0.112e-10,11.03, 1.37e-10, 3 , "Ne" !14
DATA 39.95, 0.0, 1.878e-10, 0.117e-10,38.53, 1.70e-10, 3 , "Ar" !15
DATA 83.80, 0.0, 2.041e-10, 0.130e-10,55.33, 1.83e-10, 3 , "Kr" !16
DATA 131.3, 0.0, 2.258e-10, 0.145e-10,85.55, 1.99e-10, 3 , "Xe" !17
IF ion_z(0)=0.0 THEN
FOR i=0 TO 17
READ ion_m(i),ion_z(i),ion_a(i),ion_b(i),ion_c(i),ion_r(i),ion_col(i),ion_str$(i)
LET ion_m(i) = ion_m(i)*1.661e-27
LET ion_z(i) = ion_z(i)*1.602e-19
NEXT i
END IF
END SUB
EXTERNAL FUNCTION setNaClTypeBlock(ii, knd1, knd2, nx, ny, lattice, xPos, yPos)
DECLARE EXTERNAL SUB setParticle
LET ipp = ii
LET a = lattice/2.0
FOR i=0 TO 2*nx-1
FOR j=0 TO 2*ny-1
LET x = xPos + a*i
LET y = yPos + a*j
IF MOD(i+j,2)=0 THEN
LET knd = knd1
ELSE
LET knd = knd2
END IF
CALL setParticle(ipp, knd, x, y)
LET ipp = ipp + 1
NEXT j
NEXT i
LET setNaClTypeBlock = ipp - 1
END FUNCTION
EXTERNAL SUB setParticle(i, knd, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET mas(i) = ion_m(knd)
LET kind(i) = knd
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
LET eForceConst = 1.0/(4.0*PI*8.8542e-12) !epsilon0=8.8542e-12
FOR ki=0 TO 17
FOR kj=0 TO 17
LET a = ion_a(ki)+ion_a(kj)
LET b = ion_b(ki)+ion_b(kj)
LET c = ion_c(ki)*ion_c(kj)*1.0e-60
LET zi = ion_z(ki)
LET zj = ion_z(kj)
FOR ir=10 TO 1001
LET r = ir*hh
LET fc = eForceConst*zi*zj*(EXP(-r/6.5e-10)/r)*(1.0/r+1.0/6.5e-10) !Debye-screened Coulomb force
LET fr = 6.9742e-11*EXP((a-r)/b) !repulsive force
LET fa = -6.9742e-21*(c/(r*r*r*r*r*r)) !attractive force
LET forceTable(ki,kj,ir) = cutoff(r)*(fc + fr + fa)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ki,kj,ir) = forceTable(ki,kj,10)
NEXT ir
NEXT kj
NEXT ki
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity,registerNearMolec,registration
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registration
!CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
IF rij<rCutoff THEN
LET f = force(rij,kind(i),kind(j))
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
EXTERNAL FUNCTION force(r,ki,kj) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ki,kj,ir) + a*forceTable(ki,kj,ir+1))/hh
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (3.418e-10/r)^6
LET boundaryForce = (24.0*(0.5*1.711e-21)*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
EXTERNAL SUB registration !faster registration
DECLARE EXTERNAL SUB preRegistration
CALL preRegistration
LET rreg = rCutoff+20*2000*dt
LET rreg2 = rreg*rreg
FOR ipp=1 TO nMolec-1
LET kp = 1
LET i0 = INT(Nsx*(xx(ipp)-rreg)/xMax)
IF (i0<0) THEN LET i0 = 0
LET i1 = INT(Nsx*(xx(ipp)+rreg)/xMax )
IF (i1>=Nsx) THEN LET i1 = Nsx-1
LET j0 = INT(Nsy*(yy(ipp)-rreg)/yMax )
IF (j0<0) THEN LET j0 = 0
LET j1 = INT(Nsy*(yy(ipp)+rreg)/yMax )
IF (j1>=Nsy) THEN LET j1 = Nsy-1
FOR i=i0 TO i1
FOR j=j0 TO j1
FOR iq=1 TO section(i,j,0)
LET jp = section(i,j,iq)
IF (jp>ipp) THEN
LET r2=(xx(ipp)-xx(jp))*(xx(ipp)-xx(jp))+(yy(ipp)-yy(jp))*(yy(ipp)-yy(jp))
IF (r2<rreg2) THEN
LET reg(ipp,kp) = jp
LET kp = kp + 1
END IF
END IF
NEXT iq
NEXT j
NEXT i
LET reg(ipp,0) = kp
NEXT ipp
END SUB
EXTERNAL SUB preRegistration
FOR i=0 TO Nsx-1
FOR j=0 TO Nsy-1
LET section(i,j,0) = 0
NEXT j
NEXT i
FOR ipp=1 TO nMolec
LET i = INT(Nsx*xx(ipp)/xMax)
IF i>=Nsx THEN LET i = Nsx-1
LET j = INT(Nsy*yy(ipp)/yMax)
IF j>=Nsy THEN LET j = Nsy-1
LET iq = section(i,j,0) + 1
LET section(i,j,0) = iq
LET section(i,j,iq) = ipp
NEXT ipp
END SUB
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mas(i)*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:circle 1:circle+bond
call plotBond(drawMode)
ELSEIF drawMode=2 THEN
call velocitySpace
END IF
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 :ion_str$(ionKind1)&","&ion_str$(ionKind2)
PLOT TEXT, AT 100, 55 ,USING " N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional ion - molecular dynamics"
PLOT TEXT, AT 50,480 :"[esc] exit [space]pause/go [D]change draw mode"
PLOT TEXT, AT 50,460 :"[1]NaCl [2]MgO [3]CaO [4]BaO [5]NaF [6]KF [7]KCl"
PLOT TEXT, AT 50,440 :"[T] toggle 0:adiabatic/1:constant temperature"
PLOT TEXT, AT 50,420 :"temp control -> [J]coolDown/stop [k]heatUp/stop"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
SET LINE COLOR ion_col(kind(i))
DRAW circle WITH SCALE(ion_r(kind(i))*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
LET r0 = (ion_r(kind(i))+ion_r(kind(j)))
IF r<1.1*r0 AND kind(i)<>kind(j) THEN
SET LINE COLOR 8 !gray
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT k
NEXT i
END IF
END sub
EXTERNAL sub velocitySpace
LET boxSize = 300
LET xp = 100
LET yp = 100
SET LINE COLOR 1 !black : axis
PLOT LINES: xp,boxSize/2+yp; boxSize+xp,boxSize/2+yp !vx-axis
PLOT LINES: boxSize/2+xp,yp; boxSize/2+xp,boxSize+yp !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize+xp,boxSize/2+yp: "vx"
PLOT TEXT, AT boxSize+xp,boxSize/2-12+yp: "2000m/s"
PLOT TEXT, AT boxSize/2-12+xp,boxSize+yp: "vy 2000m/s"
PLOT TEXT, AT boxSize/2-8+xp,boxSize/2-10+yp: "0"
PLOT TEXT, AT xp,boxSize+8+yp: "velocity space (vx,vy)"
LET mag = boxSize/4000
FOR i=1 TO nMolec
IF kind(i)=ionKind1 THEN SET LINE COLOR 4 ELSE SET LINE COLOR 2 !4:red, 2:blue
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+boxSize/2+xp,vy(i)*mag+boxSize/2+yp)
NEXT i
END sub
You Tubeを見ているとオーディオスペクトラム動画なるものを見かけることがあります。
これらの動画は専用のソフトや市販ソフトを使って作られているようです。
専用のソフト等には到底及びませんが、十進BASICでオーディオスペクトラム画像を書出します。
ここではGIFアニメではなく動画ファイル(mp4形式)として作成します。(画像サンプルを参照)
OPTION ARITHMETIC NATIVE
OPTION BASE 0
OPTION CHARACTER BYTE
DIM A$(20)
LET XSIZE=800 !'画像サイズ
LET YSIZE=400
LET FRAMERATE=30 !'動画フレームレート 30fps
LET DISPLAYMODE=0
!'INPUT PROMPT "DISPLAY MODE (0 - 9)=":DISPLAYMODE
LET TEST=0 !'画像の書出し 0以外にすると画像書出し。
LET SCALE=YSIZE/XSIZE
SET TEXT BACKGROUND "OPAQUE"
FILE GETNAME F$,"WAVファイル|*.WAV"
IF F$="" THEN STOP
FILE SPLITNAME (F$) PATH$, NAME$, EXT$
OPEN #1:NAME F$,ACCESS INPUT !'wavファイル読み込み
FOR I=1 TO 12
CHARACTER INPUT #1:A$(I)
NEXT I
IF A$(1)&A$(2)&A$(3)&A$(4)<>"RIFF" THEN
PRINT "WAVファイルではありません"
CLOSE #1
STOP
END IF
LET WAVEFILESIZE=CVL(A$(5)&A$(6)&A$(7)&A$(8))
IF A$(9)&A$(10)&A$(11)&A$(12)<>"WAVE" THEN
PRINT "WAVファイルではありません"
CLOSE #1
STOP
END IF
DO
FOR I=1 TO 4
CHARACTER INPUT #1:A$(I)
NEXT I
SELECT CASE A$(1)&A$(2)&A$(3)&A$(4)
CASE "fmt "
FOR I=1 TO 4
CHARACTER INPUT #1:A$(I)
NEXT I
LET HEADERSIZE=CVL(A$(1)&A$(2)&A$(3)&A$(4))
FOR I=1 TO HEADERSIZE
CHARACTER INPUT #1:A$(I)
NEXT I
LET WAVETYPE=CVI(A$(1)&A$(2))
IF WAVETYPE<>1 THEN
PRINT "対応していません"
CLOSE #1
STOP
END IF
LET CHANNEL=CVI(A$(3)&A$(4))
LET SAMPLINGFREQ=CVL(A$(5)&A$(6)&A$(7)&A$(8))
LET DATARATE=CVL(A$(9)&A$(10)&A$(11)&A$(12))
LET SAMPLESIZE=CVI(A$(13)&A$(14))
LET SAMPLEBIT=CVI(A$(15)&A$(16))
CASE "data"
FOR I=1 TO 4
CHARACTER INPUT #1:A$(I)
NEXT I
LET PCMSIZE=CVL(A$(1)&A$(2)&A$(3)&A$(4))
LET SECOND=PCMSIZE/DATARATE
!' LET NUM=INT(SAMPLINGFREQ*SECOND)
LET NUM=PCMSIZE/SAMPLESIZE
EXIT DO
CASE "fact"
FOR I=1 TO 8
CHARACTER INPUT #1:A$(I)
NEXT I
!' LET SIZE=CVL(A$(1)&A$(2)&A$(3)&A$(4))
!' LET SAMPLE=CVL(A$(5)&A$(6)&A$(7)&A$(8))
CASE "LIST"
FOR I=1 TO 4
CHARACTER INPUT #1:A$(I)
NEXT I
LET SIZE=CVL(A$(1)&A$(2)&A$(3)&A$(4))
FOR I=1 TO SIZE
CHARACTER INPUT #1:DMY$ !'空読み
NEXT I
CASE ELSE
PRINT "対応していません"
CLOSE #1
STOP
END SELECT
LOOP
PRINT "ファイルサイズ ";WAVEFILESIZE;"Byte" !' データ表示
PRINT "ＷＡＶＥタイプ ";WAVETYPE
PRINT "チャンネル数 ";CHANNEL;"ch"
PRINT "サンプリング周波数 ";SAMPLINGFREQ;"Hz"
PRINT "データレート ";DATARATE;"Byte"
PRINT "ブロックサイズ ";SAMPLESIZE;"Byte"
PRINT "サンプリングビット ";SAMPLEBIT;"bit"
PRINT "ＰＣＭサイズ ";PCMSIZE;"Byte"
PRINT "データ数 ";PCMSIZE/SAMPLESIZE;INT(SAMPLINGFREQ*SECOND)
PRINT "時間 ";SECOND;"秒"
PRINT "描画モード ";DISPLAYMODE
PRINT "出力画像 ";INT(SECOND*FRAMERATE);"枚"
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 BITMAP SIZE XSIZE,YSIZE
LET N=INT(SAMPLINGFREQ/FRAMERATE) !'1フレームあたりのポイント数
LET NN=2^INT(LOG2(N)+1) !'FFTポイント数
DIM RMAX(NN),LR(NN),RR(NN),FR(NN),FI(NN)
LET B$=" "
FOR K=0 TO NUM-1
FOR CH=1 TO CHANNEL
FOR J=1 TO SAMPLEBIT/8
CHARACTER INPUT #1:B$(J:J)
NEXT J
IF SAMPLEBIT=8 THEN LET DAT=ORD(B$(1:1))-128
IF SAMPLEBIT=16 THEN LET DAT=CVI(B$)
LET J=MOD(K,N)
SELECT CASE CH
CASE 1
LET LR(J)=DAT
CASE 2
LET RR(J)=DAT
CASE ELSE
END SELECT
NEXT CH
IF CHANNEL=1 THEN MAT RR=LR !'モノラルならコピー
IF K>0 AND J=0 THEN !'1フレーム描画 30フレームで1秒分
LET COUNT=COUNT+1
SET DRAW MODE HIDDEN !'ちらつき防止
SELECT CASE DISPLAYMODE !'画面表示
CASE 0
CALL DISPLAY0
CASE 1
CALL DISPLAY1
CASE 2
CALL DISPLAY2
CASE 3
CALL DISPLAY3
CASE 4
CALL DISPLAY4
CASE 5
CALL DISPLAY5
CASE 6
CALL DISPLAY6
CASE 7
CALL DISPLAY7
CASE 8
CALL DISPLAY8
CASE 9
CALL DISPLAY9
END SELECT
SET DRAW MODE EXPLICIT
IF TEST<>0 THEN GSAVE PATH$&"image"&RIGHT$("00000"&STR$(COUNT),5)&".jpg" !'画像書出し
END IF
NEXT K
CLOSE #1
PRINT "ffmpeg -r";FRAMERATE;"-i ";CHR$(34);PATH$;"image%05d.jpg";CHR$(34);" -i ";CHR$(34);F$;CHR$(34);" -vcodec h264 -b:v 1000k -acodec aac -b:a 128k ";CHR$(34);PATH$;NAME$;".mp4";CHR$(34)
SUB DISPLAY1
CALL GCLEAR
CALL TIMER(.9,1,0,.05,2,12) !'タイマー
CALL WAVE(RR,.51,1,.05,.95,5) !'右チャンネル(右)
CALL WAVE(LR,0,.49,.05,.95,5) !'左チャンネル(左)
END SUB
SUB DISPLAY2
CALL GCLEAR
CALL TIMER(.9,1,0,.05,2,12) !'タイマー
CALL WAVE2(LR,0,1,.6,.9,4) !'左チャンネル(上)
CALL WAVE2(RR,0,1,.1,.4,4) !'右チャンネル(下)
END SUB
SUB DISPLAY3
CALL GCLEAR
CALL TIMER(.9,1,0,.05,2,12)
CALL FREQ(LR,0,1,.6,.9,5,2) !'左チャンネル(上)
CALL FREQ(RR,0,1,.1,.4,5,2) !'右チャンネル(下)
END SUB
SUB DISPLAY4
CALL GCLEAR
CALL POWER(LR,.05,.48,.05,.95,4,2,8,"MODE2","RIGHT") !'左チャンネル(左)
CALL POWER(RR,.52,.95,.05,.95,4,2,8,"MODE2","LEFT") !'右チャンネル(右)
END SUB
SUB DISPLAY5
CALL GCLEAR
CALL WAVE3(LR,0,1,.6,.9,6,2) !'左チャンネル(上)
CALL WAVE3(RR,0,1,.1,.4,6,2) !'右チャンネル(下)
END SUB
SUB DISPLAY6
CALL GCLEAR
CALL VOLUMEBAR(LR,.1,.9,.7,.8,4,2,"MODE2","LEFT") !'左チャンネル(上)
CALL VOLUMEBAR(RR,.1,.9,.2,.3,4,2,"MODE2","LEFT") !'右チャンネル(下)
END SUB
SUB DISPLAY7
CALL GCLEAR
CALL VOLUMECIRCLE(LR,.05,.45,.1,.9,4,2) !'左チャンネル(左)
CALL VOLUMECIRCLE(RR,.55,.95,.1,.9,4,2) !'右チャンネル(右)
END SUB
SUB DISPLAY8
CALL GCLEAR
CALL XYPLOT(RR,.51,1,.05,.95,7) !'右チャンネル(右)
CALL XYPLOT(LR,0,.49,.05,.95,7) !'左チャンネル(左)
END SUB
SUB DISPLAY9
CALL GCLEAR
CALL POWERDISK(RR,.51,1,.05,.95,5,2,8,"MODE2") !'右チャンネル(右)
CALL POWERDISK(LR,0,.49,.05,.95,5,2,8,"MODE2") !'左チャンネル(左)
END SUB
SUB DISPLAY0
CALL GCLEAR
CALL TIMER(.9,1,0,.04,2,10)
CALL TIMEBAR(.1,.8,0,.04,3)
CALL VOLUMEBAR(LR,.02,.49,.05,.08,1,2,"MODE2","LEFT")
CALL POWER(LR,.02,.49,.1,.5,4,2,8,"MODE2","BOTTOM")
CALL FREQ(LR,.02,.49,.52,.75,6,2)
CALL WAVE(LR,.02,.49,.76,.99,5)
CALL VOLUMEBAR(RR,.51,.98,.05,.08,1,2,"MODE2","LEFT")
CALL POWER(RR,.51,.98,.1,.5,4,2,8,"MODE2","BOTTOM")
CALL FREQ(RR,.51,.98,.52,.75,6,2)
CALL WAVE(RR,.51,.98,.76,.99,5)
END SUB
SUB GCLEAR
SET VIEWPORT 0,1,0,SCALE
SET WINDOW 0,1,0,SCALE
SET AREA COLOR 7
PLOT AREA:0,0;1,0;1,SCALE;0,SCALE
END SUB
SUB TIMER(XS,XE,YS,YE,COL,HEIGHT)
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE !'VIEWPORTの領域を長方形でも 左下(0,0) 右上(1,1)とする
SET WINDOW XS,XE,YS,YE
SET TEXT FONT "",HEIGHT
SET TEXT COLOR COL
PLOT TEXT ,AT XS,YS:RIGHT$("0"&STR$(INT(COUNT/FRAMERATE/60)),2)&":"&RIGHT$("0"&STR$(MOD(INT(COUNT/FRAMERATE),60)),2)&"."&RIGHT$("0"&STR$(MOD(COUNT,FRAMERATE)),2)
END SUB
SUB TIMEBAR(XS,XE,YS,YE,COL)
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET XS=0
LET XE=NUM-1
LET YS=0
LET YE=1
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
CALL BOXFULL(0,0,K,1,COL)
END SUB
SUB WAVE(RR(),XS,XE,YS,YE,COL) !'波形
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET XS=0
LET XE=N-1
LET YS=-2^(SAMPLEBIT-1)
LET YE=-YS
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
SET LINE COLOR COL
FOR I=0 TO N-1
PLOT LINES:I,RR(I);
NEXT I
END SUB
SUB WAVE2(RR(),XS,XE,YS,YE,COL)
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET XS=0
LET XE=N-1
LET YS=-2^(SAMPLEBIT-1)
LET YE=-YS
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
SET LINE COLOR COL
FOR I=0 TO N-1
PLOT LINES:I,-RR(I);I,RR(I)
NEXT I
END SUB
SUB WAVE3(RR(),XS,XE,YS,YE,COL,MAXCOL)
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET XS=0
LET XE=N-1
LET YE=2^(SAMPLEBIT-1)
LET YS=0
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
IF COUNT=1 OR MOD(COUNT,INT(FRAMERATE/2))=0 THEN !'フレームレートの半分で最大値クリア
MAT RMAX=ZER
END IF
SET LINE COLOR MAXCOL
FOR I=0 TO N-1
PLOT LINES:I,0;I,RMAX(I)
NEXT I
PLOT LINES
SET LINE COLOR COL
FOR I=0 TO N-1
LET R=ABS(RR(I))
LET RMAX(I)=MAX(RMAX(I),R)
PLOT LINES:I,0;I,R
NEXT I
END SUB
SUB FREQ(RR(),XS,XE,YS,YE,COL,MAXCOL) !'周波数
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET XS=0
LET XE=NN/2-1
LET YS=0
LET YE=20*LOG10(2^(SAMPLEBIT-1))
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
IF COUNT=1 OR MOD(COUNT,INT(FRAMERATE/2))=0 THEN
MAT RMAX=ZER
END IF
FOR I=0 TO NN-1
LET FR(I)=RR(I)*HANNING(I,NN) !'ハニング窓関数を掛ける
NEXT I
MAT FI=ZER
CALL CDFT(2*NN,COS(PI/NN),SIN(PI/NN),FR,FI) !'FFT
SET LINE COLOR COL
FOR I=0 TO NN/2-1
LET R=10*LOG10(FR(I)^2+FI(I)^2+1)
LET RMAX(I)=MAX(RMAX(I),R)
PLOT LINES:I,R;
NEXT I
PLOT LINES
SET LINE COLOR MAXCOL
FOR I=0 TO NN/2-1
PLOT LINES:I,RMAX(I); !'最大値描画
NEXT I
END SUB
SUB POWER(RR(),XS,XE,YS,YE,COL,MAXCOL,LEV,MODE$,DIRECTION$) !'スペクトル
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET P=10*LOG10(2^(SAMPLEBIT-1))
SELECT CASE DIRECTION$
CASE "BOTTOM"
LET YS=0
LET YE=P
LET XE=NN/2-1
LET XS=0
CASE "TOP"
LET YS=P
LET YE=0
LET XS=0
LET XE=NN/2-1
CASE "LEFT"
LET XS=0
LET XE=P
LET YS=0
LET YE=NN/2-1
CASE "RIGHT"
LET XS=P
LET XE=0
LET YS=0
LET YE=NN/2-1
END SELECT
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
FOR I=0 TO NN-1
LET FR(I)=RR(I)*HANNING(I,NN)
NEXT I
MAT FI=ZER
CALL CDFT(2*NN,COS(PI/NN),SIN(PI/NN),FR,FI)
LET T=NN/LEV/2
FOR I=0 TO NN/2-1 STEP T
LET R=0
FOR P=0 TO T-1
LET R=R+10*LOG10(FR(I+P)^2+FI(I+P)^2+1)
NEXT P
LET R=R/T !'平均値
SELECT CASE DIRECTION$
CASE "TOP","BOTTOM"
SELECT CASE MODE$
CASE "MODE1"
IF R>MAX(YS,YE)/32 THEN
FOR Y=0 TO R STEP MAX(YS,YE)/32
IF Y<MAX(YS,YE)*.8 THEN CALL BOXFULL(I,Y,T*3/4+I,Y+MAX(YS,YE)/32,COL) ELSE CALL BOXFULL(I,Y,T*3/4+I,Y+MAX(YS,YE)/32,MAXCOL)
NEXT Y
END IF
CASE "MODE2"
IF R>MAX(YS,YE)/16 THEN
FOR Y=0 TO R STEP MAX(YS,YE)/16
IF Y<MAX(YS,YE)*.8 THEN CALL BOXFULL(I,Y,T*3/4+I,Y+MAX(YS,YE)/16*.8,COL) ELSE CALL BOXFULL(I,Y,T*3/4+I,Y+MAX(YS,YE)/16*.8,MAXCOL)
NEXT Y
END IF
END SELECT
CASE "LEFT","RIGHT"
SELECT CASE MODE$
CASE "MODE1"
IF R>MAX(XS,XE)/32 THEN
FOR X=0 TO R STEP MAX(XS,XE)/32
IF X<MAX(XS,XE)*.8 THEN CALL BOXFULL(X,I,X+MAX(XS,XE)/32,T*3/4+I,COL) ELSE CALL BOXFULL(X,I,X+MAX(XS,XE)/32,T*3/4+I,MAXCOL)
NEXT X
END IF
CASE "MODE2"
IF R>MAX(XS,XE)/16 THEN
FOR X=0 TO R STEP MAX(XS,XE)/16
IF X<MAX(XS,XE)*.8 THEN CALL BOXFULL(X,I,X+MAX(XS,XE)/16*.8,T*3/4+I,COL) ELSE CALL BOXFULL(X,I,X+MAX(XS,XE)/16*.8,T*3/4+I,MAXCOL)
NEXT X
END IF
END SELECT
END SELECT
NEXT I
END SUB
SUB POWERDISK(RR(),XS,XE,YS,YE,COL,MAXCOL,LEV,MODE$)
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET P=10*LOG10(2^(SAMPLEBIT-1))
LET YS=-P
LET YE=P
LET XE=P
LET XS=-P
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
FOR I=0 TO NN-1
LET FR(I)=RR(I)*HANNING(I,NN) !'ハニング窓関数を掛ける
NEXT I
MAT FI=ZER
CALL CDFT(2*NN,COS(PI/NN),SIN(PI/NN),FR,FI) !'FFT
LET T=NN/LEV/2
FOR I=0 TO NN/2-1 STEP T
LET R=0
FOR P=0 TO T-1
LET R=R+10*LOG10(FR(I+P)^2+FI(I+P)^2+1) !'平均値
NEXT P
LET R=R/2/T
LET TH1=I/(NN/2-1)*360
LET TH2=TH1+(T-NN/2/32)/(NN/2)*360
SELECT CASE MODE$
CASE "MODE1"
FOR Y=R TO YE/16 STEP -YE/32
IF Y<MAX(YS,YE)/2 THEN CALL DISK(0,0,Y+YE/32,COL,TH1,TH2) ELSE CALL DISK(0,0,Y+YE/32,MAXCOL,TH1,TH2)
NEXT Y
CALL DISK(0,0,YE/16,7,0,360)
CASE "MODE2"
IF MOD(R,YE/8)<YE/16 THEN LET X=0 ELSE LET X=1
FOR Y=INT(R/(YE/16))*(YE/16) TO YE/16 STEP -YE/16
LET X=1-X
IF X=1 THEN
IF Y<MAX(YS,YE)/2 THEN CALL DISK(0,0,Y+YE/16,COL,TH1,TH2) ELSE CALL DISK(0,0,Y+YE/16,MAXCOL,TH1,TH2)
ELSE
CALL DISK(0,0,Y+YE/16,0,TH1,TH2)
END IF
NEXT Y
CALL DISK(0,0,YE/16,7,0,360)
END SELECT
NEXT I
END SUB
SUB VOLUMEBAR(RR(),XS,XE,YS,YE,COL,MAXCOL,MODE$,DIRECTION$) !'音量バー
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET P=10*LOG10(2^(SAMPLEBIT-1))
SELECT CASE DIRECTION$
CASE "BOTTOM"
LET YS=0
LET YE=P
LET XE=1
LET XS=0
CASE "TOP"
LET YS=P
LET YE=0
LET XS=0
LET XE=1
CASE "LEFT"
LET XS=0
LET XE=P
LET YS=0
LET YE=1
CASE "RIGHT"
LET XS=P
LET XE=0
LET YS=0
LET YE=1
END SELECT
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
FOR I=0 TO NN-1
LET FR(I)=RR(I)*HANNING(I,NN)
NEXT I
MAT FI=ZER
CALL CDFT(2*NN,COS(PI/NN),SIN(PI/NN),FR,FI)
LET R=0
FOR I=0 TO NN/2-1
LET R=R+10*LOG10(FR(I)^2+FI(I)^2+1) !'平均値
NEXT I
LET R=R/(NN/2)
SELECT CASE DIRECTION$
CASE "LEFT","RIGHT"
SELECT CASE MODE$
CASE "MODE1"
IF R>MAX(XS,XE)/32 THEN
FOR X=0 TO R STEP MAX(XS,XE)/32
IF X<MAX(XS,XE)*.8 THEN CALL BOXFULL(X,0,X+MAX(XS,XE)/32,1,COL) ELSE CALL BOXFULL(X,0,X+MAX(XS,XE)/32,1,MAXCOL)
NEXT X
END IF
CASE "MODE2"
IF R>MAX(YS,YE)/16 THEN
FOR X=0 TO R STEP MAX(XS,XE)/16
IF X<MAX(XS,XE)*.8 THEN CALL BOXFULL(X,0,X+MAX(XS,XE)/16*.8,1,COL) ELSE CALL BOXFULL(X,0,X+MAX(XS,XE)/16*.8,1,MAXCOL)
NEXT X
END IF
END SELECT
CASE "TOP","BOTTOM"
SELECT CASE MODE$
CASE "MODE1"
IF R>MAX(YS,YE)/32 THEN
FOR Y=0 TO R STEP MAX(YS,YE)/32
IF Y<MAX(YS,YE)*.8 THEN CALL BOXFULL(0,Y,1,Y+MAX(YS,YE)/32,COL) ELSE CALL BOXFULL(0,Y,1,Y+MAX(YS,YE)/32,MAXCOL)
NEXT Y
END IF
CASE "MODE2"
IF R>MAX(YS,YE)/16 THEN
FOR Y=0 TO R STEP MAX(YS,YE)/16
IF Y<MAX(YS,YE)*.8 THEN CALL BOXFULL(0,Y,1,Y+MAX(YS,YE)/16*.8,COL) ELSE CALL BOXFULL(0,Y,1,Y+MAX(YS,YE)/16*.8,MAXCOL)
NEXT Y
END IF
END SELECT
END SELECT
END SUB
SUB VOLUMECIRCLE(RR(),XS,XE,YS,YE,COL,MAXCOL) !'音量円形
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET YS=-10*LOG10(2^(SAMPLEBIT-1))
LET YE=-YS
LET XS=-10*LOG10(2^(SAMPLEBIT-1))
LET XE=-XS
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
FOR I=0 TO NN-1
LET FR(I)=RR(I)*HANNING(I,NN)
NEXT I
MAT FI=ZER
CALL CDFT(2*NN,COS(PI/NN),SIN(PI/NN),FR,FI)
LET R=0
FOR I=0 TO NN/2-1
LET R=R+10*LOG10(FR(I)^2+FI(I)^2+1) !'平均値
NEXT I
LET R=R/(NN/2)/2
IF COUNT=1 OR MOD(COUNT,INT(FRAMERATE/2))=0 THEN LET TMAX=0
LET TMAX=MAX(TMAX,R)
CALL CIRCLE(0,0,TMAX,MAXCOL)
IF MOD(R,XE/8)<XE/16 THEN LET Y=0 ELSE LET Y=1
FOR X=INT(R/(XE/16))*(XE/16) TO XE/16 STEP -XE/16
LET Y=1-Y
IF Y=1 THEN
CALL CIRCLEFULL(0,0,X,COL)
ELSE
CALL CIRCLEFULL(0,0,X,0)
END IF
NEXT X
CALL CIRCLEFULL(0,0,XE/16,7)
END SUB
SUB XYPLOT(RR(),XS,XE,YS,YE,COL) !'スペクトルと位相
SET VIEWPORT XS,XE,YS*SCALE,YE*SCALE
LET YS=-PI
LET YE=PI
LET XS=0
LET XE=10*LOG10(2^(SAMPLEBIT-1))
SET WINDOW XS,XE,YS,YE
CALL BOXFULL(XS,YS,XE,YE,0)
FOR I=0 TO NN-1
LET FR(I)=RR(I)*HANNING(I,NN)
NEXT I
MAT FI=ZER
CALL CDFT(2*NN,COS(PI/NN),SIN(PI/NN),FR,FI)
SET COLOR COL
FOR I=0 TO NN/2-1
IF FR(I)<>0 OR FI(I)<>0 THEN PLOT POINTS:10*LOG10(FR(I)^2+FI(I)^2+1),ANGLE(FR(I),FI(I))
NEXT I
END SUB
END
EXTERNAL SUB BOXFULL(X1,Y1,X2,Y2,C)
OPTION ARITHMETIC NATIVE
SET AREA COLOR C
PLOT AREA:X1,Y1;X2,Y1;X2,Y2;X1,Y2
END SUB
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL SUB CIRCLE(X,Y,R,C)
SET COLOR C
DRAW CIRCLE WITH SCALE(R)*SHIFT(X,Y)
END SUB
EXTERNAL SUB DISK(XX,YY,R,C,S,T)
OPTION ANGLE DEGREES
OPTION BASE 0
DIM X(361),Y(361)
MAT X=(XX)*CON
MAT Y=(YY)*CON
FOR TH=S TO T
LET X(TH)=XX+R*COS(TH)
LET Y(TH)=YY-R*SIN(TH)
NEXT TH
SET AREA COLOR C
MAT PLOT AREA : X,Y
END SUB
EXTERNAL FUNCTION CVI(A$)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
DECLARE NUMERIC A
LET A$=LEFT$(A$,2)
LET A=ORD(A$(1:1))+ORD(A$(2:2))*256
IF A>32767 THEN LET A=A-65536
LET CVI=A
END FUNCTION
EXTERNAL FUNCTION CVL(A$)
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
DECLARE NUMERIC A
LET A$=LEFT$(A$,4)
LET A=ORD(A$(1:1))+ORD(A$(2:2))*256+ORD(A$(3:3))*256^2+ORD(A$(4:4))*256^3
IF A>=2^31-1 THEN LET A=A-2^32
LET CVL=A
END FUNCTION
EXTERNAL SUB CDFT(N,WR,WI,AR(),AI())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM A(N)
FOR I=0 TO N/2-1
LET A(2*I)=AR(I)
LET A(2*I+1)=AI(I)
NEXT I
LET WMR=WR
LET WMI=WI
LET M=N
DO WHILE M>4
LET L=M/2
LET WKR=1
LET WKI=0
LET WDR=1-2*WMI*WMI
LET WDI=2*WMI*WMR
LET SS=2*WDI
LET WMR=WDR
LET WMI=WDI
FOR J=0 TO N-M STEP M
LET I=J+L
LET XR=A(J)-A(I)
LET XI=A(J+1)-A(I+1)
LET A(J)=A(J)+A(I)
LET A(J+1)=A(J+1)+A(I+1)
LET A(I)=XR
LET A(I+1)=XI
LET XR=A(J+2)-A(I+2)
LET XI=A(J+3)-A(I+3)
LET A(J+2)=A(J+2)+A(I+2)
LET A(J+3)=A(J+3)+A(I+3)
LET A(I+2)=WDR*XR-WDI*XI
LET A(I+3)=WDR*XI+WDI*XR
NEXT J
FOR K=4 TO L-4 STEP 4
LET WKR=WKR-SS*WDI
LET WKI=WKI+SS*WDR
LET WDR=WDR-SS*WKI
LET WDI=WDI+SS*WKR
FOR J=K TO N-M+K STEP M
LET I=J+L
LET XR=A(J)-A(I)
LET XI=A(J+1)-A(I+1)
LET A(J)=A(J)+A(I)
LET A(J+1)=A(J+1)+A(I+1)
LET A(I)=WKR*XR-WKI*XI
LET A(I+1)=WKR*XI+WKI*XR
LET XR=A(J+2)-A(I+2)
LET XI=A(J+3)-A(I+3)
LET A(J+2)=A(J+2)+A(I+2)
LET A(J+3)=A(J+3)+A(I+3)
LET A(I+2)=WDR*XR-WDI*XI
LET A(I+3)=WDR*XI+WDI*XR
NEXT J
NEXT K
LET M=L
LOOP
IF M>2 THEN
FOR J=0 TO N-4 STEP 4
LET XR=A(J)-A(J+2)
LET XI=A(J+1)-A(J+3)
LET A(J)=A(J)+A(J+2)
LET A(J+1)=A(J+1)+A(J+3)
LET A(J+2)=XR
LET A(J+3)=XI
NEXT J
END IF
IF N>4 THEN CALL BITRV2(N,A)
FOR I=0 TO N/2-1
LET AR(I)=A(2*I)/SQR(N)
LET AI(I)=A(2*I+1)/SQR(N)
NEXT I
END SUB
EXTERNAL SUB BITRV2(N,A())
OPTION ARITHMETIC NATIVE
LET M=N/4
LET M2=2*M
LET N2=N-2
LET K=0
FOR J=0 TO M2-4 STEP 4
IF J<K THEN
LET XR=A(J)
LET XI=A(J+1)
LET A(J)=A(K)
LET A(J+1)=A(K+1)
LET A(K)=XR
LET A(K+1)=XI
ELSEIF J>K THEN
LET J1=N2-J
LET K1=N2-K
LET XR=A(J1)
LET XI=A(J1+1)
LET A(J1)=A(K1)
LET A(J1+1)=A(K1+1)
LET A(K1)=XR
LET A(K1+1)=XI
END IF
LET K1=M2+K
LET XR=A(J+2)
LET XI=A(J+3)
LET A(J+2)=A(K1)
LET A(J+3)=A(K1+1)
LET A(K1)=XR
LET A(K1+1)=XI
LET L=M
DO WHILE K>=L
LET K=K-L
LET L=L/2
LOOP
LET K=K+L
NEXT J
END SUB
EXTERNAL FUNCTION HANNING(X,N)
OPTION ARITHMETIC NATIVE
LET HANNING=.5-.5*COS(2*PI*X/N) !'ハニング窓関数
END FUNCTION
SAMPLE\Collatz.basにバグがあります。
---------------------------------
REM コラッツ予想
REM 任意の自然数に対し，
REM 偶数のとき，2で割り，
REM 奇数のとき，3倍して1を加える
REM という操作を繰り返すと，
REM 有限回で1に到達すると予想されている。
REM 証明はまだない。
OPTION ARITHMETIC RATIONAL
INPUT n
DO
IF MOD(n,2)=0 THEN
LET n=n/2
ELSE
LET n=3*n+1
PRINT n
END IF
LOOP UNTIL n=1
END
-------------------
PRINT n
END IF
この２行を入れ替えないと
1ではなく16で止まってしまいます。
例
100 DECLARE EXTERNAL FUNCTION m.f
110 FOR k=1 TO 10
120 PRINT f(k)
130 NEXT k
140 END
1000 MODULE m
1010 PUBLIC FUNCTION f
1020 DATA 10,20,30,40,50,60,70,80,90,100
1030 SHARE NUMERIC a(10)
1040 MAT READ a
1050 EXTERNAL FUNCTION f(x)
1060 LET f=a(x)
1070 END FUNCTION
1080 END MODULE
100 DECLARE EXTERNAL FUNCTION m.f
110 DECLARE EXTERNAL SUB m.s
120 CALL s
130 FOR k=1 TO 10
140 PRINT f(k)
150 NEXT k
160 END
1000 MODULE m
1010 PUBLIC FUNCTION f
1020 PUBLIC SUB s
1030 SHARE NUMERIC a(10)
1040 EXTERNAL SUB s
1050 DATA 10,20,30,40,50,60,70,80,90,100
1060 MAT READ a
1070 END SUB
1080 EXTERNAL FUNCTION f(x)
1090 LET f=a(x)
1100 END FUNCTION
1110 END MODULE
1000 DECLARE EXTERNAL SUB airpro ! 混合気体の物性値計算
1010 DIM pipe(19,4) ! 配管サイズの設定
1020 DIM ps(4) ! 配管サイズ番号
1030 DIM ins$(10) ! 保温材名称
1040 DIM insm(4,2) ! 1,2層目保温材番号
1050 DIM insth(4,3) ! 1,2層目保温厚さ、全厚
1060 DIM ins(10,3) ! 保温材番号順の熱伝導率データ
1070 DIM facek(4) ! 保温表面温度 K
1080 DIM airdat(4,8) ! 各保温表面温度 K と外気の平均温度に於ける気体物性値
1090 DIM midt(4,2)
1100 DIM t(4) ! 仮２層保温中間温度
1110 DIM kekka(4,14) ! 計算結果
1120 DIM Rth(4,4) ! 熱抵抗
1130 REM **********************************************************************
1140 MAT READ pipe(19,4) ! 配管サイズの設定
1150 MAT READ ins$(10) ! 保温材名称
1160 MAT READ ins(10,3) ! 保温材データの設定
1170 REM ******************************************
1180 REM LET q=0
1190 REM INPUT PROMPT "配管ライン名称 ":name$
1200 LET name$="pi"
1210 REM INPUT PROMPT "保 持 温 度 (C')":maint
1220 LET maint=200
1230 REM INPUT PROMPT "外 気 温 度 (C')":ambi
1240 LET ambi=0
1250 REM INPUT PROMPT "風 速 (m/s)":wv
1260 LET wv=10
1270 REM INPUT PROMPT "設 計 裕 度 ":df
1280 LET df=1.3
1290 REM INPUT PROMPT "効 率 ":eff
1300 LET eff=0.95
1310 PRINT " 番号 配管 (A) 番号 配管 (A) 番号 配管 (A)"
1320 PRINT " 1 15 7 65 14 200 "
1330 PRINT " 2 20 8 80 15 250 "
1340 PRINT " 3 25 9 90 16 300 "
1350 PRINT " 4 32 10 100 17 350 "
1360 PRINT " 5 40 11 125 18 400 "
1370 PRINT " 6 50 12 150 19 450 "
1380 LET pn=1
1390 REM INPUT PROMPT "配管 1 番号 ":ps(1)
1400 LET ps(1)=10 ! 仮の値
1410 REM INPUT PROMPT "配管 2 番号 無い場合は 0":ps(2)
1420 LET ps(2)=12 ! 仮の値
1430 LET pn=2
1440 IF ps(2)=0 THEN
1450 LET ps(2)=ps(1)
1460 LET ps(3)=ps(1)
1470 LET ps(4)=ps(1)
1480 LET pn=1
1490 END IF
1500 IF pn=2 THEN
1510 REM INPUT PROMPT "配管 3 番号 無い場合は 0":ps(3)
1520 LET ps(3)=14 ! 仮の値
1530 LET pn=3
1540 IF ps(3)=0 THEN
1550 LET ps(3)=ps(1)
1560 LET ps(4)=ps(1)
1570 LET pn=2
1580 END IF
1590 END IF
1600 IF pn=3 THEN
1610 REM INPUT PROMPT "配管 4 番号 無い場合は 0":ps(4)
1620 LET ps(4)=16 ! 仮の値 配管４種類にしています。
1630 LET pn=4 ! pn=4 の条件に設定
1640 IF ps(4)=0 THEN
1650 LET ps(4)=ps(1)
1660 LET pn=3
1670 END IF
1680 END IF
1690 PRINT " bangou kigou λ0 λ1 λ3 "
1700 PRINT " 1 clc13-300 0.04070 1.28E-04 0 "
1710 PRINT " 2 clc13-800 0.05550 2.05E-05 1.93E- 7 "
1720 PRINT " 3 clc22-300 0.05350 1.16E-04 0 "
1730 PRINT " 4 clc22-800 0.06120 3.38E-05 1.95E-07 "
1740 PRINT " 5 gwc 0.03330 1.21E-04 6.56E-07 "
1750 PRINT " 6 T#1260 0.11000 -1.40E-04 2.60E-07 "
1760 PRINT " 7 rwc100 0.03140 1.74E-04 0 "
1770 PRINT " 8 rwc600 0.04070 1.16E-04 7.67E-07 "
1780 PRINT " 9 T#5120 0.02470 1.014E-04 7.55E-08 "
1790 IF pn=1 THEN
1800 LET insmn=1
1810 INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
1820 INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は ”0,0”":insm(1,2),insth(1,2)
1830 IF insm(1,2)=0 THEN
1840 LET insmn=0
1850 LET insm(1,2)=insm(1,1)
1860 LET insth(1,2)=0
1870 END IF
1880 LET insm(2,1)=insm(1,1)
1890 LET insth(2,1)=insth(1,1)
1900 LET insm(2,2)=insm(1,2)
1910 LET insth(2,2)=insth(1,2)
1920 LET insm(3,1)=insm(1,1)
1930 LET insth(3,1)=insth(1,1)
1940 LET insm(3,2)=insm(1,2)
1950 LET insth(3,2)=insth(1,2)
1960 LET insm(4,1)=insm(1,1)
1970 LET insth(4,1)=insth(1,1)
1980 LET insm(4,2)=insm(1,2)
1990 LET insth(4,2)=insth(1,2)
2000 END IF
2010 IF pn=2 THEN
2020 LET insmn=1
2030 INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
2040 INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(1,2),insth(1,2)
2050 IF insm(1,2)=0 THEN
2060 LET insmn=0
2070 LET insm(1,2)=insm(1,1)
2080 LET insth(1,2)=0
2090 END IF
2100 LET insmn=1
2110 INPUT PROMPT "配管 2 1層目 保温材番号,厚みmm":insm(2,1),insth(2,1)
2120 INPUT PROMPT "配管 2 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(2,2),insth(2,2)
2130 IF insm(2,2)=0 THEN
2140 LET insmn=0
2150 LET insm(2,2)=insm(2,1)
2160 LET insth(2,2)=0
2170 END IF
2180 LET insm(3,1)=insm(1,1)
2190 LET insth(3,1)=insth(1,1)
2200 LET insm(3,2)=insm(1,2)
2210 LET insth(3,2)=insth(1,2)
2220 LET insm(4,1)=insm(1,1)
2230 LET insth(4,1)=insth(1,1)
2240 LET insm(4,2)=insm(1,2)
2250 LET insth(4,2)=insth(1,2)
2260 END IF
2270 IF pn=3 THEN
2280 LET insmn=1
2290 INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
2300 INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(1,2),insth(1,2)
2310 IF insm(1,2)=0 THEN
2320 LET insmn=0
2330 LET insm(1,2)=insm(1,1)
2340 LET insth(1,2)=0
2350 END IF
2360 LET insmn=1
2370 INPUT PROMPT "配管 2 1層目 保温材番号,厚みmm":insm(2,1),insth(2,1)
2380 INPUT PROMPT "配管 2 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(2,2),insth(2,2)
2390 IF insm(2,2)=0 THEN
2400 LET insmn=0
2410 LET insm(2,2)=insm(2,1)
2420 LET insth(2,2)=0
2430 END IF
2440 LET insmn=1
2450 INPUT PROMPT "配管 3 1層目 保温材番号,厚みmm":insm(3,1),insth(3,1)
2460 INPUT PROMPT "配管 3 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(3,2),insth(3,2)
2470 IF insm(3,2)=0 THEN
2480 LET insmn=0
2490 LET insm(3,2)=insm(3,1)
2500 LET insth(3,2)=0
2510 END IF
2520 LET insm(4,1)=insm(1,1)
2530 LET insth(4,1)=insth(1,1)
2540 LET insm(4,2)=insm(1,2)
2550 LET insth(4,2)=insth(1,2)
2560 END IF
2570 IF pn=4 THEN
2580 LET insmn=1
2590 REM INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
2600 LET insm(1,1)=1
2610 LET insth(1,1)=65
2620 REM INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(1,2),insth(1,2)
2630 LET insm(1,2)=0
2640 LET insth(1,2)=0
2650 IF insm(1,2)=0 THEN
2660 LET insmn=0
2670 LET insm(1,2)=insm(1,1)
2680 LET insth(1,2)=0
2690 END IF
2700 LET insmn=1
2710 REM INPUT PROMPT "配管 2 1層目 保温材番号,厚みmm":insm(2,1),insth(2,1)
2720 LET insm(2,1)=1
2730 LET insth(2,1)=75
2740 REM INPUT PROMPT "配管 2 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(2,2),insth(2,2)
2750 LET insm(2,2)=0
2760 LET insth(2,2)=0
2770 IF insm(2,2)=0 THEN
2780 LET insmn=0
2790 LET insm(2,2)=insm(2,1)
2800 LET insth(2,2)=0
2810 END IF
2820 LET insmn=1
2830 REM INPUT PROMPT "配管 3 1層目 保温材番号,厚みmm":insm(3,1),insth(3,1)
2840 LET insm(3,1)=1
2850 LET insth(3,1)=75
2860 REM INPUT PROMPT "配管 3 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(3,2),insth(3,2)
2870 LET insm(3,2)=1
2880 LET insth(3,2)=15
2890 IF insm(3,2)=0 THEN
2900 LET insmn=0
2910 LET insm(3,2)=insm(3,1)
2920 LET insth(3,2)=0
2930 END IF
2940 LET insmn=1
2950 REM INPUT PROMPT "配管 4 1層目 保温材番号,厚みmm":insm(4,1),insth(4,1)
2960 LET insm(4,1)=1
2970 LET insth(4,1)=75
2980 REM INPUT PROMPT "配管 4 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(4,2),insth(4,2)
2990 LET insm(4,2)=1
3000 LET insth(4,2)=25
3010 IF insm(4,2)=0 THEN
3020 LET insmn=0
3030 LET insm(4,2)=insm(4,1)
3040 LET insth(4,2)=0
3050 END IF
3060 END IF
3070 REM ********** 初期温度の設定 **********
3080 LET face1 = ambi+273+0.1
3090 FOR i=1 TO 4
3100 LET facek(i)=face1 ! 仮保温表面温度
3110 LET t(i)=(maint+(facek(i)-273))/2 ! 仮２層保温中間温度
3120 NEXT i
3130 REM ********** 保温材熱伝導率の計算 **************************
3140 FOR i=1 TO 4
3150 LET t1=(maint+t(i))/2
3160 LET t2=(t(i)+(facek(i)-273))/2
3170 LET x=1
3180 DO
3190 REM ********** 空気物性値の計算 ****************************
3200 CALL airpro(facek(i)-273,k2,k3,k4,k5,k6,k7,k8)
3210 LET airdat(i,2)=k2 ! 比重 kg/m^3
3220 LET airdat(i,3)=k3 ! 比熱 kJ/kgK
3230 LET airdat(i,4)=k4 ! 粘性係数 μPa・S
3240 LET airdat(i,5)=k5 ! 動粘性係数 mm^2/S
3250 LET airdat(i,6)=k6 ! 熱伝導率 mW/mK
3260 LET airdat(i,7)=k7 ! 温度伝導率 mm^2/S
3270 LET airdat(i,8)=k8 ! ﾌﾟﾗﾝﾄﾙ数
3280 LET d0=pipe(ps(i),4) ! 保温材内径
3290 LET d1=pipe(ps(i),4)+2*insth(i,1)/1000 ! 1層目保温材外径
3300 LET d2=pipe(ps(i),4)+2*insth(i,1)/1000+2*insth(i,2)/1000 ! 2層目保温材外径
3310 LET t1=(maint+t(i))/2 ! 1層目保温平均温度
3320 LET c1=(maint^2+maint*t(i)+t(i)^2)/3 ! 熱伝導率計算係数
3330 LET r1=(ins(insm(i,1),1)+ins(insm(i,1),2)*t1+ins(insm(i,1),3)*c1 ) ! 保温材熱伝導率
3340 LET Rth(i,1)=1/(2*PI*r1)*LOG(d1/d0) ! 1層目保温層熱抵抗
3350 LET t2=(t(i)+(facek(i)-273))/2 ! 2層目保温平均温度
3360 LET c2=(t(i)^2+t(i)*(facek(i)-273)+(facek(i)-273)^2)/3 ! 熱伝導率計算係数
3370 LET r2=(ins(insm(i,2),1)+ins(insm(i,2),2)*t2+ins(insm(i,2),3)*c2 ) ! 保温材熱伝導率
3380 LET Rth(i,2)=1/(2*PI*r2)*LOG(d2/d1)
3390 LET re=wv*3600*d2/(airdat(i,5)*3600/1000000)
3400 LET ac=1.12*(0.373*re^0.5+0.057*re^(2/3))*airdat(i,8)^(1/3)*airdat(i,6)/1000/d2
3410 LET ar=0.8*5.67E-8*(faceK(i)^4-(ambi+273)^4)/(facek(i)-(ambi+273))
3420 LET Rth(i,3)=1/(PI*d2*(ac+ar))
3430 LET Rth(i,4)=Rth(i,1)+Rth(i,2)+Rth(i,3)
3440 LET hloss=(maint-ambi)/Rth(i,4)
3450 LET fk=hloss*Rth(i,3)+ambi+273
3460 LET faceK(i) = fk
3470 LET t(i)=hloss*(Rth(i,2)+Rth(i,3))+ambi
3480 LET x=x+1
3490 LOOP WHILE X<=20
3500 LET kekka(i,1)=t1
3510 LET kekka(i,2)=c1
3520 LET kekka(i,3)=r1
3530 LET kekka(i,4)=t2
3540 LET kekka(i,5)=c2
3550 LET kekka(i,6)=r2
3560 LET kekka(i,7)=re
3570 LET kekka(i,8)=ac
3580 LET kekka(i,9)=ar
3590 LET kekka(i,10)=fk
3600 LET kekka(i,11)=t(i)
3610 LET kekka(i,12)=d0
3620 LET kekka(i,13)=d1
3630 LET kekka(i,14)=d2
3640 NEXT i
3650 REM *********************** 計算結果の表示 ***********************
3660 PLOT TEXT ,AT 0.1,0.95:"配管ライン名称 "
3670 PLOT TEXT ,AT 0.35,0.95: name$
3680 PLOT TEXT ,AT 0.1,0.92:"保 持 温 度 (C')"
3690 PLOT TEXT ,AT 0.35,0.92: STR$(maint)
3700 PLOT TEXT ,AT 0.1,0.89:"外 気 温 度 (C')"
3710 PLOT TEXT ,AT 0.35,0.89: STR$(ambi)
3720 PLOT TEXT ,AT 0.5,0.95:"風 速 (m/s)"
3730 PLOT TEXT ,AT 0.75,0.95: STR$(wv)
3740 PLOT TEXT ,AT 0.5,0.92:"設 計 裕 度 "
3750 PLOT TEXT ,AT 0.75,0.92: STR$(df)
3760 PLOT TEXT ,AT 0.5,0.89:"効 率 "
3770 PLOT TEXT ,AT 0.75,0.89: STR$(eff)
3780 PLOT TEXT ,AT 0.25,0.85:"配管サイズ"
3790 PLOT TEXT ,AT 0.40,0.85:"保温層"
3800 PLOT TEXT ,AT 0.50,0.85:"保温材"
3810 PLOT TEXT ,AT 0.60,0.85:"保温厚さ"
3820 PLOT TEXT ,AT 0.15,0.82:"配管 １"
3830 PLOT TEXT ,AT 0.28,0.82,USING"###": pipe(ps(1),1)
3840 PLOT TEXT ,AT 0.40,0.82:"１層目"
3850 PLOT TEXT ,AT 0.49,0.82:ins$(insm(1,1))
3860 PLOT TEXT ,AT 0.62,0.82,USING"###":insth(1,1)
3870 LET ygyou =0.82
3880 IF insth(1,2)<>0 THEN LET ygyou=ygyou-0.02
3890 IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou :"２層目"
3900 IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou :ins$(insm(1,2))
3910 IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou ,USING"###":insth(1,2)
3920 IF pn => 2 THEN LET ygyou=ygyou-0.02
3930 IF pn => 2 THEN PLOT TEXT ,AT 0.15,ygyou :"配管 ２"
3940 IF pn => 2 THEN PLOT TEXT ,AT 0.28,ygyou ,USING"###": pipe(ps(2),1)
3950 IF pn => 2 THEN PLOT TEXT ,AT 0.40,ygyou :"１層目"
3960 IF pn => 2 THEN PLOT TEXT ,AT 0.49,ygyou :ins$(insm(2,1))
3970 IF pn => 2 THEN PLOT TEXT ,AT 0.62,ygyou ,USING"###":insth(2,1)
3980 IF pn => 2 AND insth(2,2)<>0 THEN LET ygyou =ygyou-0.02
3990 IF pn => 2 AND insth(2,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou :"２層目"
4000 IF pn => 2 AND insth(2,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou :ins$(insm(2,2))
4010 IF pn => 2 AND insth(2,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou ,USING"###":insth(2,2)
4020 IF pn => 3 THEN LET ygyou=ygyou-0.02
4030 IF pn => 3 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ３"
4040 IF pn => 3 THEN PLOT TEXT ,AT 0.28,ygyou,USING"###": pipe(ps(3),1)
4050 IF pn => 3 THEN PLOT TEXT ,AT 0.40,ygyou:"１層目"
4060 IF pn => 3 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(3,1))
4070 IF pn => 3 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(3,1)
4080 IF pn => 3 AND insth(3,2)<>0 THEN LET ygyou=ygyou-0.02
4090 IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou:"２層目"
4100 IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(3,2))
4110 IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(3,2)
4120 IF pn = 4 THEN LET ygyou=ygyou-0.02
4130 IF pn = 4 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ４"
4140 IF pn = 4 THEN PLOT TEXT ,AT 0.28,ygyou,USING"###": pipe(ps(4),1)
4150 IF pn = 4 THEN PLOT TEXT ,AT 0.40,ygyou:"１層目"
4160 IF pn = 4 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(4,1))
4170 IF pn = 4 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(4,1)
4180 IF pn = 4 AND insth(4,2)<>0 THEN LET ygyou=ygyou-0.02
4190 IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou:"２層目"
4200 IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(4,2))
4210 IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(4,2)
4220 LET ygyou=ygyou-0.02*2
4230 PLOT TEXT ,AT 0.25,ygyou:"保温筒内径 保温筒外径 Re αｃ αｒ α "
4240 LET ygyou=ygyou-0.02
4250 PLOT TEXT ,AT 0.15,ygyou:"配管 １"
4260 PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(1,12),kekka(1,13),kekka(1,7),kekka(1,8),kekka(1,9),kekka(1,8)+kekka(1,9)
4270 IF insth(1,2)<>0 THEN LET ygyou=ygyou-0.02
4280 IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(1,13),kekka(1,14)
4290 IF pn => 2 THEN LET ygyou=ygyou-0.02
4300 IF pn => 2 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ２"
4310 IF pn => 2 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(2,12),kekka(2,13),kekka(2,7),kekka(2,8),kekka(2,9),kekka(2,8)+kekka(2,9)
4320 IF pn => 2 AND insth(2,2)<> 0 THEN LET ygyou=ygyou-0.02
4330 IF pn => 2 AND insth(2,2)<> 0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(2,13),kekka(2,14)
4340 IF pn => 3 THEN LET ygyou=ygyou-0.02
4350 IF pn => 3 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ３"
4360 IF pn => 3 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(3,12),kekka(3,13),kekka(3,7),kekka(3,8),kekka(3,9),kekka(3,8)+kekka(3,9)
4370 IF pn => 3 AND insth(3,2)<>0 THEN LET ygyou=ygyou-0.02
4380 IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(3,13),kekka(3,14)
4390 IF pn = 4 THEN LET ygyou=ygyou-0.02
4400 IF pn = 4 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ４"
4410 IF pn = 4 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(4,12),kekka(4,13),kekka(4,7),kekka(4,8),kekka(4,9),kekka(4,8)+kekka(4,9)
4420 IF pn = 4 AND insth(4,2)<>0 THEN LET ygyou=ygyou-0.02
4430 IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(4,13),kekka(4,14)
4440 LET ygyou=ygyou-0.02*3
4450 PLOT TEXT ,AT 0.25,ygyou:" Rth1 Rth2 Rth3 Rth hloss Pr θmid θf"
4460 LET ygyou=ygyou-0.02
4470 PLOT TEXT ,AT 0.25,ygyou:" C'm/W W/m W/m C' C' "
4480 LET ygyou=ygyou-0.02
4490 PLOT TEXT ,AT 0.15,ygyou:"配管 １"
4500 PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(1,1),Rth(1,2),Rth(1,3),Rth(1,4),(maint-ambi)/Rth(1,4),(maint-ambi)/Rth(1,4)*df/eff,kekka(1,11),kekka(1,10)-273
4510 LET ygyou=ygyou-0.02
4520 IF pn => 2 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ２"
4530 IF pn => 2 THEN PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(2,1),Rth(2,2),Rth(2,3),Rth(2,4),(maint-ambi)/Rth(2,4),(maint-ambi)/Rth(2,4)*df/eff,kekka(2,11),kekka(2,10)-273
4540 LET ygyou=ygyou-0.02
4550 IF pn => 3 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ３"
4560 IF pn => 3 THEN PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(3,1),Rth(3,2),Rth(3,3),Rth(3,4),(maint-ambi)/Rth(3,4),(maint-ambi)/Rth(3,4)*df/eff,kekka(3,11),kekka(3,10)-273
4570 LET ygyou=ygyou-0.02
4580 IF pn = 4 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ４"
4590 IF pn = 4 THEN PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(4,1),Rth(4,2),Rth(4,3),Rth(4,4),(maint-ambi)/Rth(4,4),(maint-ambi)/Rth(4,4)*df/eff,kekka(4,11),kekka(4,10)-273
4600 REM ********** 配管データ **********
4610 REM si d2 t di
4620 DATA 15 , 0.0217 , 0.0028 , 0.034
4630 DATA 20 , 0.0272 , 0.0029 , 0.034
4640 DATA 25 , 0.034 , 0.0034 , 0.0427
4650 DATA 32 , 0.0427 , 0.0036 , 0.0486
4660 DATA 40 , 0.0486 , 0.0037 , 0.0605
4670 DATA 50 , 0.0605 , 0.0039 , 0.0763
4680 DATA 65 , 0.0763 , 0.0052 , 0.0891
4690 DATA 80 , 0.0891 , 0.0055 , 0.1016
4700 DATA 90 , 0.1016 , 0.0057 , 0.1143
4710 DATA 100, 0.1143 , 0.0060 , 0.1398
4720 DATA 125, 0.1398 , 0.0066 , 0.1652
4730 DATA 150, 0.1652 , 0.0071 , 0.1910
4740 DATA 200, 0.2163 , 0.0082 , 0.2419
4750 DATA 250, 0.2674 , 0.0093 , 0.2930
4760 DATA 300, 0.3185 , 0.0103 , 0.3370
4770 DATA 350, 0.3556 , 0.0111 , 0.3810
4780 DATA 400, 0.4064 , 0.0127 , 0.4320
4790 DATA 450, 0.4572 , 0.0143 , 0.4830
4800 DATA 500, 0.5080 , 0.0151 , 0.5330
4810 REM *********************************
4820 REM ********** 保温材データ **********
4830 DATA clc13-300 , clc13-800 , clc22-300 , clc22-800 , gwc
4840 DATA Ts1260 , rwc100 , rwc600 , Ts5120 , daipa
4850 REM ********** 保温材熱伝導率 **********
4860 REM r1 r2 r3
4870 DATA 0.04070 , 1.28E-04 , 0
4880 DATA 0.05550 , 2.05E-05 , 1.93E-07
4890 DATA 0.05350 , 1.16E-04 , 0
4900 DATA 0.06120 , 3.38E-05 , 1.95E-07
4910 DATA 0.03330 , 1.21E-04 , 6.56E-07
4920 DATA 0.11000 , -1.40E-04, 2.60E-07
4930 DATA 0.03140 , 1.74E-04 , 0
4940 DATA 0.04070 , 1.16E-04 , 7.67E-07
4950 DATA 0.02470 , 1.14E-04 , 7.55E-08
4960 DATA 0.05550 , 2.05E-05 , 1.93E-07
4970 REM ***********************************
4980 END
4990 REM *****************************************************************
5000 EXTERNAL SUB airpro(k,rho7,cp7,mu7,nu7,lambda7,alpha7,pr7)
5010 REM SET WINDOW 0,1.0,0,1.0
5020 LET n=6 !対象気体数 ６種類 N2,O2,CO2,CO,He,Air
5030 REM TK !絶対温度 K
5040 REM Pa !圧力 パスカル
5050 DIM rho(n+1) !各気体の密度
5060 DIM CP(n+1) ! 〃 定圧比熱
5070 DIM CVv(n+1) ! 〃 定容比熱
5080 DIM CPO(n+1) ! 〃 定圧分子熱
5090 DIM n$(n) !気体名称 N2 , O2 , CO2 , CO , He , Air
5100 DIM mwp(n) !質量分率 重量％
5110 DIM mw(n) !分子量 molecular weight
5120 REM Mave !平均モル質量
5130 DIM Xmol(n+1) !モル数
5140 DIM Xmolb(n) !モル分率（体積分率）
5150 DIM mu(n+1) !粘性係数
5160 DIM phi(n,n) !粘性係数計算係数
5170 DIM phix(n,n)
5180 DIM nu(n+1) !動粘性係数
5190 DIM alpha(n+1) !温度伝導率
5200 DIM Pr(n+1) !ﾌﾟﾗﾝﾄﾙ数
5210 DIM kk(n)
5220 DIM lambda(n+1) !熱伝導率
5230 DIM Tc(n) !臨界温度 critical temperature
5240 DIM Pc(n) !臨界圧力 critical pressure
5250 DIM zeta(n) !偏心因子
5260 DIM Ac0(n) !Ac0 定圧分子熱の推算式に於ける係数
5270 DIM Bc0(n) !Bc0 〃 〃
5280 DIM Cc0(n) !Cc0 〃 〃
5290 DIM Dc0(n) !Dc0 〃 〃
5300 DIM Ac1(n) !Ac1 定圧比熱の推算式に於ける係数
5310 DIM Bc1(n) !Bc1 〃 〃
5320 DIM Cc1(n) !Cc1 〃 〃
5330 DIM Dc1(n) !Dc1 〃 〃
5340 DIM Ac2(n) !Ac2 定容比熱の推算式に於ける係数
5350 DIM Bc2(n) !Bc2 〃 〃
5360 DIM Cc2(n) !Cc2 〃 〃
5370 DIM Dc2(n) !Dc2 〃 〃
5380 DIM shiguma (n) !σ 各成分気体の特性直径
5390 DIM epsilonk(n) !ε/k 各成分気体の特性エネルギー
5400 DIM ohmv(6) !Ωv 粘性の衝突積分
5410 DIM ohmd(8) !Ωd 拡散の衝突積分
5420 REM *******************************************************************
5430 REM * 定数の読み込み *
5440 REM *******************************************************************
5450 FOR i=1 TO n
5460 READ n$(i)
5470 NEXT i
5480 FOR i=1 TO n
5490 READ mw(i)
5500 NEXT i
5510 FOR i=1 TO n
5520 READ Tc(i)
5530 NEXT i
5540 FOR i=1 TO n
5550 READ Pc(i)
5560 NEXT i
5570 FOR i=1 TO n
5580 READ zeta(i)
5590 NEXT i
5600 FOR i=1 TO n
5610 READ Ac0(i)
5620 NEXT i
5630 FOR i=1 TO n
5640 READ Bc0(i)
5650 LET Bc0(i)=Bc0(i)*1E-2
5660 NEXT i
5670 FOR i=1 TO n
5680 READ Cc0(i)
5690 LET Cc0(i)=Cc0(i)*1E-6
5700 NEXT i
5710 FOR i=1 TO n
5720 READ Dc0(n)
5730 LET Dc0(i)=Dc0(i)*1E-9
5740 NEXT i
5750 FOR i=1 TO n
5760 READ Ac1(i)
5770 NEXT i
5780 FOR i=1 TO n
5790 READ Bc1(i)
5800 LET Bc1(i)=Bc1(i)*1E-4
5810 NEXT i
5820 FOR i=1 TO n
5830 READ Cc1(i)
5840 LET Cc1(i)=Cc1(i)*1E-8
5850 NEXT i
5860 FOR i=1 TO n
5870 READ Dc1(i)
5880 LET Dc1(i)=Dc1(i)*1E-12
5890 NEXT i
5900 FOR i=1 TO n
5910 READ Ac2(i)
5920 NEXT i
5930 FOR i=1 TO n
5940 READ Bc2(i)
5950 LET Bc2(i)=Bc2(i)*1E-4
5960 NEXT I
5970 FOR i=1 TO n
5980 READ Cc2(i)
5990 LET Cc2(i)=Cc2(i)*1E-8
6000 NEXT i
6010 FOR i=1 TO n
6020 READ Dc2(i)
6030 LET Dc2(i)=Dc2(i)*1E-12
6040 NEXT i
6050 FOR i=1 TO n
6060 READ shiguma(i)
6070 NEXT i
6080 FOR i=1 TO n
6090 READ epsilonk(i)
6100 NEXT i
6110 READ Av
6120 READ Bv
6130 READ Cv
6140 READ Dv
6150 READ Ev
6160 READ Fv
6170 READ Ad
6180 READ Bd
6190 READ Cd
6200 READ Dd
6210 READ Ed
6220 READ Fd
6230 READ Gd
6240 READ Hd
6250 REM *****************************************************
6260 REM * 各気体の質量分率＝重量％を入力 *
6270 REM *****************************************************
6280 REM PRINT"各気体の重量％を入力してください"
6290 REM DO WHILE mwp(1)+mwp(2)+mwp(3)+mwp(4)+mwp(5)+mwp(6)<>100
6300 REM INPUT PROMPT"N2 , O2 , CO2 , CO , He , Air":mwp(1),mwp(2),mwp(3),mwp(4),mwp(5),mwp(6)
6310 REM LOOP
6320 LET mwp(1)=0
6330 LET mwp(2)=0
6340 LET mwp(3)=0
6350 LET mwp(4)=0
6360 LET mwp(5)=0
6370 LET mwp(6)=100
6380 LET Mkongou=0
6390 FOR i=1 TO n
6400 IF mwp(i)<>0 THEN
6410 LET Mkongou=(mwp(i)/100/mw(i))+Mkongou
6420 END IF
6430 NEXT i
6440 LET Mkongou=1/Mkongou ! 混合気体の分子量
6450 FOR i = 1 TO n
6460 IF mwp(i)<>0 THEN
6470 LET Xmolb(i)=Mkongou/mw(i)*mwp(i) ! 体積分率の計算
6480 END IF
6490 NEXT i
6500 FOR i=1 TO n
6510 LET Xmol(i)=mwp(i)/mw(i)
6520 NEXT i
6530 REM *****************************************************
6540 REM * 圧力、温度の設定 *
6550 REM *****************************************************
6560 REM PRINT"計算条件 温度(℃) , 圧力を指示してください。"
6570 REM INPUT PROMPT" T C' , P atm ":T,Patm !T C' ： T ℃ P atm : P 気圧
6580 LET T=k
6590 LET Patm=1.0
6600 LET TK=T+273.15 !TK : 絶対温度 K
6610 LET Pa=Patm*101325 !Pa : パスカル
6620 REM PRINT TK ;"K " ; TK-273.15;"C' ";Pa;"Pa "
6630 REM *****************************************************
6640 REM * 密度の計算 kg/m^3 *
6650 REM *****************************************************
6660 LET rho(n+1)=0
6670 FOR i=1 TO n
6680 LET rho(i)=Pa*mw(i)/8.314/TK/1000
6690 LET rho(n+1)=rho(i)*Xmolb(i)/100+rho(n+1)
6700 NEXT i
6710 LET rho7=rho(n+1)
6720 REM *****************************************************
6730 REM * 定圧比熱の計算 KJ/kgK *
6740 REM *****************************************************
6750 LET CP(n+1)=0
6760 FOR i=1 TO n
6770 IF i=5 THEN
6780 LET CP(i)=5193/1000
6790 ELSE
6800 LET CP(i)=Ac1(i)+Bc1(i)*TK+Cc1(i)*TK^2+Dc1(i)*TK^3
6810 END IF
6820 LET CP0=CP(i)*Xmolb(i)/100+CP0
6830 NEXT i
6840 REM PRINT CP0
6850 REM LET Mmix=0
6860 REM FOR i=1 TO n
6870 REM LET Mmix=mw(i)*Xmolb(i)/100+Mmix
6880 REM NEXT i
6890 REM PRINT Mmix
6900 LET CP(n+1)=CP0
6910 LET cp7=cp(n+1)
6920 REM ****************************************************
6930 REM * 粘性率の計算 Pa・s *
6940 REM ****************************************************
6950 FOR i=1 TO n
6960 LET tdot=TK/epsilonk(i)
6970 IF i=5 THEN
6980 IF TK>1100 THEN
6990 LET visc =Av/tdot^Bv
7000 ELSE
7010 LET visc=Av/tdot^Bv+Cv/EXP(Dv*tdot)
7020 END IF
7030 LET mu(i)=26.69*SQR(mw(i)*TK)/shiguma(i)^2/visc*1E-7*1E6
7040 ELSE
7050 LET ohmv(i)=(Av/tdot^Bv+Cv/EXP(Dv*tdot)+Ev/EXP(Fv*tdot))
7060 LET mu(i)=26.69*SQR(mw(i)*TK)/shiguma(i)^2/ohmv(I)*1E-7*1E6
7070 END IF
7080 NEXT i
7090 LET mu(n+1)=0
7100 FOR i=1 TO n
7110 FOR j=1 TO n
7120 IF mwp(j)<>0 THEN
7130 IF mwp(i)<>0 THEN
7140 LET phi(i,j)=(1+(mu(i)/mu(j))^0.5*(mw(j)/mw(i))^0.25)^2/(8*(1+mw(i)/mw(j)))^0.5
7150 END IF
7160 END IF
7170 NEXT j
7180 NEXT i
7190 LET ZZ=0
7200 FOR i=1 TO n
7210 IF mwp(i)<>0 THEN
7220 LET Z=0
7230 FOR j= 1 TO n
7240 IF mwp(j)<>0 THEN
7250 LET Z=Z+xmolb(j)*phi(i,j)
7260 END IF
7270 NEXT j
7280 LET ZZ=ZZ+Xmolb(i)*mu(i)/Z
7290 END IF
7300 NEXT i
7310 LET mu(n+1)=ZZ
7320 LET mu7=mu(n+1)
7330 REM ***************************************************
7340 REM * 熱伝導率の計算 mW/mK *
7350 REM ***************************************************
7360 FOR i=1 TO n
7370 LET CVv(i)=Ac2(i)+Bc2(i)*TK+Cc2(i)*TK^2+Dc2(i)*TK^3
7380 LET tdot=TK/epsilonk(i)
7390 IF i=5 THEN
7400 LET CVv(i)=3114
7410 IF TK > 1100 THEN
7420 LET Ohmvh=Av/tdot^Bv
7430 ELSE
7440 LET ohmvh=Av/tdot^Bv+Cv/EXP(Dv*tdot)
7450 END IF
7460 LET lambdahe=2.669*SQR(mw(i)*TK)/shiguma(i)^2/ohmvh*1E-7*1E6
7470 LET lambda(i)=(1.32*CVv(i)*mw(i)*0.001/4.186+3.52)*lambdahe/mw(i)*4.186*10
7480 ELSE
7490 LET lambda(i)=(1.32*CVv(i)*mw(i)/4.186+3.52)*mu(i)/mw(i)*4.186
7500 END IF
7510 NEXT i
7520 LET lambda(n+1)=0
7530 FOR i=1 TO n
7540 FOR j=1 TO n
7550 IF mwp(j)<>0 THEN
7560 IF mwp(i)<>0 THEN
7570 LET phi(i,j)=(1+(lambda(i)/lambda(j))^0.5*(mw(j)/mw(i))^0.25)^2/(8*(1+mw(i)/mw(j)))^0.5
7580 END IF
7590 END IF
7600 NEXT j
7610 NEXT i
7620 LET ZZ=0
7630 FOR i=1 TO n
7640 IF mwp(i)<>0 THEN
7650 LET Z=0
7660 FOR j= 1 TO n
7670 IF mwp(j)<>0 THEN
7680 LET Z=Z+xmolb(j)*phi(i,j)
7690 END IF
7700 NEXT j
7710 LET ZZ=ZZ+Xmolb(i)*lambda(i)/Z
7720 END IF
7730 NEXT i
7740 LET lambda(n+1)=ZZ
7750 LET lambda7=lambda(n+1)
7760 REM *************************************************
7770 REM * 動粘性係数 mm^2/s *
7780 REM *************************************************
7790 FOR i= 1TO n+1
7800 IF rho(i)<>0 THEN
7810 LET nu(i)=mu(i)/rho(i)
7820 END IF
7830 NEXT i
7840 LET nu7=nu(n+1)
7850 REM *************************************************
7860 REM * 温度伝導率 mm^2/s *
7870 REM *************************************************
7880 FOR i=1 TO n+1
7890 IF Rho(i)<> 0 THEN
7900 LET alpha(i)=lambda(i)/rho(i)/CP(I)
7910 END IF
7920 NEXT i
7930 LET alpha7=alpha(n+1)
7940 REM *************************************************
7950 REM * ﾌﾟﾗﾝﾄﾙ数 *
7960 REM *************************************************
7970 FOR i=1TO n+1
7980 IF alpha(i)<>0 THEN
7990 LET Pr(i)=nu(i)/alpha(i)
8000 END IF
8010 NEXT i
8020 LET pr7=pr(n+1)
8030 REM *************************************************
8040 REM * 計算結果 打ち出し *
8050 REM *************************************************
8060 REM PLOT TEXT ,AT 0.05,0.95 ,USING "温度、圧力 絶対温度 ---%.# K 摂氏 ---%.# ℃ 圧力 -%.##MPa ":TK,T,Pa/1000000
8070 REM PLOT TEXT ,AT 0.05,0.90:" N2 O2 CO2 CO He Air "
8080 REM PLOT TEXT ,AT 0.05,0.88 ,USING "質量分率 ## ---%.# ---%.# ---%.# ---%.# ---%.# ---%.# ":"%",mwp(1),mwp(2),mwp(3),mwp(4),mwp(5),mwp(6)
8090 REM PLOT TEXT ,AT 0.05,0.86 ,USING "モル数 n mol ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":Xmol(1),Xmol(2),Xmol(3),Xmol(4),Xmol(5),Xmol(6)
8100 REM PLOT TEXT ,AT 0.05,0.84 ,USING "体積分率 ## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"%",Xmolb(1),Xmolb(2),Xmolb(3),Xmolb(4),Xmolb(5),Xmolb(6)
8110 REM PLOT TEXT ,AT 0.05,0.80 ,USING "混合気体分子量 ---%.##":Mkongou
8120 REM PLOT TEXT ,AT 0.05,0.76: " N2 O2 CO2 CO He Air Mix"
8130 REM PLOT TEXT ,AT 0.05,0.74 ,USING "密度 ###### -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":"kg/m^3",rho(1),rho(2),rho(3),rho(4),rho(5),rho(6),rho(n+1)
8140 REM PLOT TEXT ,AT 0.05,0.72 ,USING "定圧比熱 ###### -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":"KJ/kgK",CP(1),CP(2),CP(3),CP(4),CP(5),CP(6),CP(n+1)
8150 REM PLOT TEXT ,AT 0.05,0.70 ,USING "粘性率の計算 ###### --%.## --%.## --%.## --%.## --%.## --%.## --%.##":"uPa.s",mu(1),mu(2),mu(3),mu(4),mu(5),mu(6),mu(n+1)
8160 REM PLOT TEXT ,AT 0.05,0.68 ,USING "動粘性係数 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mm2/s",nu(1),nu(2),nu(3),nu(4),nu(5),nu(6),nu(n+1)
8170 REM PLOT TEXT ,AT 0.05,0.66 ,USING "熱伝導率 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mW/mK",lambda(1),lambda(2),lambda(3),lambda(4),lambda(5),lambda(6),lambda(n+1)
8180 REM PLOT TEXT ,AT 0.05,0.64 ,USING "温度伝導率 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mm2/s",alpha(1),alpha(2),alpha(3),alpha(4),alpha(5),alpha(6),alpha(n+1)
8190 REM PLOT TEXT ,AT 0.05,0.62 ,USING "ﾌﾟﾗﾝﾄﾙ数 -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":Pr(1),Pr(2),Pr(3),Pr(4),Pr(5),Pr(6),Pr(n+1)
8200 REM N2 O2 CO2 CO He Air
8210 DATA N2 , O2 , CO2 , CO , He , Air
8220 DATA 28.0134 ,31.999 ,44.010 ,28.010 ,4.0026 ,28.964 !molecular weight 分子量
8230 DATA 126.2 ,154.6 ,304.2 ,132.9 ,5.19 ,132.5 !Tc 臨界温度 K
8240 DATA 33.5 ,50.1 ,72.8 ,34.5 ,2.24 ,37.2 !Pc 臨界圧力 atm 760mmhg 101325Pa
8250 DATA 0.040 ,0.021 ,0.225 ,0.049 ,-0.387 ,0 !ζ zeta 偏心因子
8260 DATA 7.440 ,6.713 ,4.728 ,7.373 ,0 ,0 !Ac0 定圧分子熱の推算式に於ける係数
8270 DATA -0.324 ,-8.79E-5 ,1.754 ,-0.307 ,0 ,0 !Bc0(×10^-2) 〃 〃
8280 DATA 6.400 ,4.170 ,-13.38 ,6.662 ,0 ,0 !Cc0(×10^-6) 〃 〃
8290 DATA -2.790 ,-2.544 ,4.097 ,-3.037 ,0 ,0 !Dc0(×10^-9) 〃 〃
8300 DATA 0.938314 ,0.817026 ,0.618542 ,0.929207 ,0 ,0.905673 !Ac1 定圧比熱の推算式に於ける係数
8310 DATA 2.95732 ,3.87124 ,9.43157 ,3.43656 ,0 ,3.10391 !Bc1(×10^-4) 〃 〃
8320 DATA -7.31507 ,-14.1476 ,-39.2290 ,-10.0711 ,0 ,-8.59483 !Cc1(×10^-8) 〃 〃
8330 DATA 5.81796 ,19.9678 ,54.4078 ,10.1493 ,0 ,8.56212 !Dc1(×10^-12) 〃 〃
8340 DATA 0.656848 ,0.547045 ,0.396046 ,0.641668 ,0 ,0.625027 !Ac2 定容比熱の推算式に於ける係数
8350 DATA 2.46015 ,4.12982 ,10.5300 ,3.13564 ,0 ,2.89050 !Bc2(×10^-4) 〃 〃
8360 DATA -3.16796 ,-16.1964 ,-48.3891 ,-7.57080 ,0 ,-6.76530 !Cc2(×10^-8) 〃 〃
8370 DATA -3.91928 ,24.6892 ,75.8699 ,4.29183 ,0 ,4.17504 !Dc2(×10^-12) 〃 〃
8380 DATA 3.798 ,3.467 ,3.941 ,3.690 ,2.551 ,3.711 !σ 各成分気体の特性直径
8390 DATA 71.4 ,106.7 ,195.2 ,91.7 ,10.22 ,78.6 !ε/k と特性エネルギー
8400 REM Av Bv Cv Dv Ev Fv Ωv 粘性の衝突積分
8410 DATA 1.16145 ,0.14874 ,0.52487 ,0.77320 ,2.16178 ,2.43787 !
8420 REM Ad Bd Cd Dd Ed Fd Gd Hd !Ωd 拡散の衝突積分
8430 DATA 1.06036 ,0.15610 ,0.19300 ,0.47635 ,1.03587 ,1.52996 ,1.76474 ,3.89411 !
8440 END sub
LET N=5
OPTION BASE 0
DIM X(N),Y(N)
SET WINDOW -1,1,-1,1
FOR I=0 TO N
LET X(I)=COS(I/N*2*PI)
LET Y(I)=SIN(I/N*2*PI)
NEXT I
FOR I=0 TO N
PLOT POINTS:X(I),Y(I) !'<--これを注釈にするとラインが描かれる
PLOT LINES:X(I),Y(I);
NEXT I
END
> SET LINE STYLE 2
> SET AREA COLOR 1
> PLOT AREA:0,0;1,0;1,1;0,1 !'淵にラインスタイルが見える
> SET LINE STYLE 3
> SET AREA COLOR 2
> PLOT AREA:0,0;.5,.5;1,0
> END
>
バグです（修正容易）。
> LET N=5
> OPTION BASE 0
> DIM X(N),Y(N)
> SET WINDOW -1,1,-1,1
> FOR I=0 TO N
> LET X(I)=COS(I/N*2*PI)
> LET Y(I)=SIN(I/N*2*PI)
> NEXT I
> FOR I=0 TO N
> PLOT POINTS:X(I),Y(I) !'<--これを注釈にするとラインが描かれる
> PLOT LINES:X(I),Y(I);
> NEXT I
> END
>
JISに厳格に適合させた結果で正しい動作です。
JISの規定を無視させたいときは，
SET BEAM MODE "IMMORTAL"
を実行してください。
詳細は http://hp.vector.co.jp/authors/VA008683/QA-plot.htm
を参照してください。
> FOR I=1 TO 10
> PRINT I !' <--- 先にテキストウィンドゥに文字が表示されるはず
> NEXT I
> EXECUTE "cmd.exe"
> END
>
PRINT文出力高速化の弊害です。
十進BASIC 8.0やBASICAccと異なる機構で動かしているので対応が個別的になってしまいます（EXECUTE文を実行するとき……など）。
同様の問題があればお知らせください。
まとめて修正します。
REM ********************************************************************
REM 多成分混合気体の熱物性値
REM 元になっているのは 旧日本原子力研究所のレポートです。
REM JAERI-M 92-131 多成分混合気体の熱物性値 1992年9月
REM 武田 哲明・Bing HAN ・小川 益郎
REM ********************************************************************
REM
REM N2,O2,CO2,CO,He,Air ６種類の気体からなる多成分混合気体の熱物性値を
REM 計算、表示します。
REM
REM 指示に従って各組成気体の百分率を入力してください。
REM 混合気体の温度、気圧を入力してください。
REM その温度に於ける、N2,O2,CO2,CO,He,Air の熱物性値と混合気体の
REM 熱物性値を表示します。
REM
SET WINDOW 0,1.0,0,1.0
LET n=6 !対象気体数 ６種類 N2,O2,CO2,CO,He,Air
DIM rho(n+1) !各気体の密度
DIM CP(n+1) ! 〃 定圧比熱
DIM CVv(n+1) ! 〃 定容比熱
DIM CPO(n+1) ! 〃 定圧分子熱
DIM n$(n) !気体名称 N2 , O2 , CO2 , CO , He , Air
DIM mwp(n) !質量分率 重量％
DIM mw(n) !分子量 molecular weight
DIM Xmol(n+1) !モル数
DIM Xmolb(n) !モル分率（体積分率）
DIM mu(n+1) !粘性係数
DIM phi(n,n) !粘性係数計算係数
DIM phix(n,n)
DIM nu(n+1) !動粘性係数
DIM alpha(n+1) !温度伝導率
DIM Pr(n+1) !ﾌﾟﾗﾝﾄﾙ数
DIM kk(n)
DIM lambda(n+1) !熱伝導率
DIM Tc(n) !臨界温度 critical temperature
DIM Pc(n) !臨界圧力 critical pressure
DIM zeta(n) !偏心因子
DIM Ac0(n) !Ac0 定圧分子熱の推算式に於ける係数
DIM Bc0(n) !Bc0 〃 〃
DIM Cc0(n) !Cc0 〃 〃
DIM Dc0(n) !Dc0 〃 〃
DIM Ac1(n) !Ac1 定圧比熱の推算式に於ける係数
DIM Bc1(n) !Bc1 〃 〃
DIM Cc1(n) !Cc1 〃 〃
DIM Dc1(n) !Dc1 〃 〃
DIM Ac2(n) !Ac2 定容比熱の推算式に於ける係数
DIM Bc2(n) !Bc2 〃 〃
DIM Cc2(n) !Cc2 〃 〃
DIM Dc2(n) !Dc2 〃 〃
DIM shiguma (n) !σ 各成分気体の特性直径
DIM epsilonk(n) !ε/k 各成分気体の特性エネルギー
DIM ohmv(6) !Ωv 粘性の衝突積分
DIM ohmd(8) !Ωd 拡散の衝突積分
REM *******************************************************************
REM * 定数の読み込み *
REM *******************************************************************
FOR i=1 TO n
READ n$(i)
NEXT i
FOR i=1 TO n
READ mw(i)
NEXT i
FOR i=1 TO n
READ Tc(i)
NEXT i
FOR i=1 TO n
READ Pc(i)
NEXT i
FOR i=1 TO n
READ zeta(i)
NEXT i
FOR i=1 TO n
READ Ac0(i)
NEXT i
FOR i=1 TO n
READ Bc0(i)
LET Bc0(i)=Bc0(i)*1E-2
NEXT i
FOR i=1 TO n
READ Cc0(i)
LET Cc0(i)=Cc0(i)*1E-6
NEXT i
FOR i=1 TO n
READ Dc0(n)
LET Dc0(i)=Dc0(i)*1E-9
NEXT i
FOR i=1 TO n
READ Ac1(i)
NEXT i
FOR i=1 TO n
READ Bc1(i)
LET Bc1(i)=Bc1(i)*1E-4
NEXT i
FOR i=1 TO n
READ Cc1(i)
LET Cc1(i)=Cc1(i)*1E-8
NEXT i
FOR i=1 TO n
READ Dc1(i)
LET Dc1(i)=Dc1(i)*1E-12
NEXT i
FOR i=1 TO n
READ Ac2(i)
NEXT i
FOR i=1 TO n
READ Bc2(i)
LET Bc2(i)=Bc2(i)*1E-4
NEXT I
FOR i=1 TO n
READ Cc2(i)
LET Cc2(i)=Cc2(i)*1E-8
NEXT i
FOR i=1 TO n
READ Dc2(i)
LET Dc2(i)=Dc2(i)*1E-12
NEXT i
FOR i=1 TO n
READ shiguma(i)
NEXT i
FOR i=1 TO n
READ epsilonk(i)
NEXT i
READ Av
READ Bv
READ Cv
READ Dv
READ Ev
READ Fv
READ Ad
READ Bd
READ Cd
READ Dd
READ Ed
READ Fd
READ Gd
READ Hd
REM *****************************************************
REM * 各気体の質量分率＝重量％を入力 *
REM *****************************************************
REM 百分率の合計が１００にならなければ再入力となります。
DO WHILE mwp(1)+mwp(2)+mwp(3)+mwp(4)+mwp(5)+mwp(6)<>100
INPUT PROMPT"各気体の重量％を入力してください。 N2 , O2 , CO2 , CO , He , Air":mwp(1),mwp(2),mwp(3),mwp(4),mwp(5),mwp(6)
LOOP
FOR i=1 TO n
IF mwp(i)<>0 THEN
LET Mkongou=(mwp(i)/100/mw(i))+Mkongou
END IF
NEXT i
LET Mkongou=1/Mkongou ! 混合気体の分子量
FOR i = 1 TO n
IF mwp(i)<>0 THEN
LET Xmolb(i)=Mkongou/mw(i)*mwp(i) ! 体積分率の計算
END IF
NEXT i
FOR i=1 TO n
LET Xmol(i)=mwp(i)/mw(i)
NEXT i
REM *****************************************************
REM * 圧力、温度の設定 *
REM *****************************************************
INPUT PROMPT"計算条件 温度(℃) , 圧力を指示してください。 T C', P atm ":T,Patm !T C' ： T ℃ P atm : P 気圧
LET TK=T+273.15 !TK : 絶対温度 K
LET Pa=Patm*101325 !Pa : パスカル
REM *****************************************************
REM * 密度の計算 kg/m^3 *
REM *****************************************************
LET rho(n+1)=0
FOR i=1 TO n
LET rho(i)=Pa*mw(i)/8.314/TK/1000
LET rho(n+1)=rho(i)*Xmolb(i)/100+rho(n+1)
NEXT i
REM *****************************************************
REM * 定圧比熱の計算 KJ/kgK *
REM *****************************************************
LET CP(n+1)=0
FOR i=1 TO n
IF i=5 THEN
LET CP(i)=5193/1000
ELSE
LET CP(i)=Ac1(i)+Bc1(i)*TK+Cc1(i)*TK^2+Dc1(i)*TK^3
END IF
LET CP0=CP(i)*Xmolb(i)/100+CP0
NEXT i
LET CP(n+1)=CP0
REM ****************************************************
REM * 粘性率の計算 Pa・s *
REM ****************************************************
FOR i=1 TO n
LET tdot=TK/epsilonk(i)
IF i=5 THEN
IF TK>1100 THEN
LET visc =Av/tdot^Bv
ELSE
LET visc=Av/tdot^Bv+Cv/EXP(Dv*tdot)
END IF
LET mu(i)=26.69*SQR(mw(i)*TK)/shiguma(i)^2/visc*1E-7*1E6
ELSE
LET ohmv(i)=(Av/tdot^Bv+Cv/EXP(Dv*tdot)+Ev/EXP(Fv*tdot))
LET mu(i)=26.69*SQR(mw(i)*TK)/shiguma(i)^2/ohmv(I)*1E-7*1E6
END IF
NEXT i
LET mu(n+1)=0
FOR i=1 TO n
FOR j=1 TO n
IF mwp(j)<>0 THEN
IF mwp(i)<>0 THEN
LET phi(i,j)=(1+(mu(i)/mu(j))^0.5*(mw(j)/mw(i))^0.25)^2/(8*(1+mw(i)/mw(j)))^0.5
END IF
END IF
NEXT j
NEXT i
LET ZZ=0
FOR i=1 TO n
IF mwp(i)<>0 THEN
LET Z=0
FOR j= 1 TO n
IF mwp(j)<>0 THEN
LET Z=Z+xmolb(j)*phi(i,j)
END IF
NEXT j
LET ZZ=ZZ+Xmolb(i)*mu(i)/Z
END IF
NEXT i
LET mu(n+1)=ZZ
REM ***************************************************
REM * 熱伝導率の計算 mW/mK *
REM ***************************************************
FOR i=1 TO n
LET CVv(i)=Ac2(i)+Bc2(i)*TK+Cc2(i)*TK^2+Dc2(i)*TK^3
LET tdot=TK/epsilonk(i)
IF i=5 THEN
LET CVv(i)=3114
IF TK > 1100 THEN
LET Ohmvh=Av/tdot^Bv
ELSE
LET ohmvh=Av/tdot^Bv+Cv/EXP(Dv*tdot)
END IF
LET lambdahe=2.669*SQR(mw(i)*TK)/shiguma(i)^2/ohmvh*1E-7*1E6
LET lambda(i)=(1.32*CVv(i)*mw(i)*0.001/4.186+3.52)*lambdahe/mw(i)*4.186*10
ELSE
LET lambda(i)=(1.32*CVv(i)*mw(i)/4.186+3.52)*mu(i)/mw(i)*4.186
END IF
NEXT i
LET lambda(n+1)=0
FOR i=1 TO n
FOR j=1 TO n
IF mwp(j)<>0 THEN
IF mwp(i)<>0 THEN
LET phi(i,j)=(1+(lambda(i)/lambda(j))^0.5*(mw(j)/mw(i))^0.25)^2/(8*(1+mw(i)/mw(j)))^0.5
END IF
END IF
NEXT j
NEXT i
LET ZZ=0
FOR i=1 TO n
IF mwp(i)<>0 THEN
LET Z=0
FOR j= 1 TO n
IF mwp(j)<>0 THEN
LET Z=Z+xmolb(j)*phi(i,j)
END IF
NEXT j
LET ZZ=ZZ+Xmolb(i)*lambda(i)/Z
END IF
NEXT i
LET lambda(n+1)=ZZ
REM *************************************************
REM * 動粘性係数 mm^2/s *
REM *************************************************
FOR i= 1TO n+1
IF rho(i)<>0 THEN
LET nu(i)=mu(i)/rho(i)
END IF
NEXT i
REM *************************************************
REM * 温度伝導率 mm^2/s *
REM *************************************************
FOR i=1 TO n+1
IF Rho(i)<> 0 THEN
LET alpha(i)=lambda(i)/rho(i)/CP(I)
END IF
NEXT i
REM *************************************************
REM * ﾌﾟﾗﾝﾄﾙ数 *
REM *************************************************
FOR i=1TO n+1
IF alpha(i)<>0 THEN
LET Pr(i)=nu(i)/alpha(i)
END IF
NEXT i
REM *************************************************
REM * 計算結果 打ち出し *
REM *************************************************
PLOT TEXT ,AT 0.05,0.95 ,USING "温度、圧力 絶対温度 ---%.# K 摂氏 ---%.# ℃ 圧力 -%.##MPa ":TK,T,Pa/1000000
PLOT TEXT ,AT 0.05,0.90:" N2 O2 CO2 CO He Air "
PLOT TEXT ,AT 0.05,0.88 ,USING "質量分率 ## ---%.# ---%.# ---%.# ---%.# ---%.# ---%.# ":"%",mwp(1),mwp(2),mwp(3),mwp(4),mwp(5),mwp(6)
PLOT TEXT ,AT 0.05,0.86 ,USING "モル数 n mol ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":Xmol(1),Xmol(2),Xmol(3),Xmol(4),Xmol(5),Xmol(6)
PLOT TEXT ,AT 0.05,0.84 ,USING "体積分率 ## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"%",Xmolb(1),Xmolb(2),Xmolb(3),Xmolb(4),Xmolb(5),Xmolb(6)
PLOT TEXT ,AT 0.05,0.80 ,USING "混合気体分子量 ---%.##":Mkongou
PLOT TEXT ,AT 0.05,0.76: " N2 O2 CO2 CO He Air Mix"
PLOT TEXT ,AT 0.05,0.74 ,USING "密度 ###### -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":"kg/m^3",rho(1),rho(2),rho(3),rho(4),rho(5),rho(6),rho(n+1)
PLOT TEXT ,AT 0.05,0.72 ,USING "定圧比熱 ###### -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":"KJ/kgK",CP(1),CP(2),CP(3),CP(4),CP(5),CP(6),CP(n+1)
PLOT TEXT ,AT 0.05,0.70 ,USING "粘性率の計算 ###### --%.## --%.## --%.## --%.## --%.## --%.## --%.##":"uPa.s",mu(1),mu(2),mu(3),mu(4),mu(5),mu(6),mu(n+1)
PLOT TEXT ,AT 0.05,0.68 ,USING "動粘性係数 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mm2/s",nu(1),nu(2),nu(3),nu(4),nu(5),nu(6),nu(n+1)
PLOT TEXT ,AT 0.05,0.66 ,USING "熱伝導率 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mW/mK",lambda(1),lambda(2),lambda(3),lambda(4),lambda(5),lambda(6),lambda(n+1)
PLOT TEXT ,AT 0.05,0.64 ,USING "温度伝導率 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mm2/s",alpha(1),alpha(2),alpha(3),alpha(4),alpha(5),alpha(6),alpha(n+1)
PLOT TEXT ,AT 0.05,0.62 ,USING "ﾌﾟﾗﾝﾄﾙ数 -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":Pr(1),Pr(2),Pr(3),Pr(4),Pr(5),Pr(6),Pr(n+1)
REM N2 O2 CO2 CO He Air
DATA N2 , O2 , CO2 , CO , He , Air
DATA 28.0134 ,31.999 ,44.010 ,28.010 ,4.0026 ,28.964 !molecular weight 分子量
DATA 126.2 ,154.6 ,304.2 ,132.9 ,5.19 ,132.5 !Tc 臨界温度 K
DATA 33.5 ,50.1 ,72.8 ,34.5 ,2.24 ,37.2 !Pc 臨界圧力 atm 760mmhg 101325Pa
DATA 0.040 ,0.021 ,0.225 ,0.049 ,-0.387 ,0 !ζ zeta 偏心因子
DATA 7.440 ,6.713 ,4.728 ,7.373 ,0 ,0 !Ac0 定圧分子熱の推算式に於ける係数
DATA -0.324 ,-8.79E-5 ,1.754 ,-0.307 ,0 ,0 !Bc0(×10^-2) 〃 〃
DATA 6.400 ,4.170 ,-13.38 ,6.662 ,0 ,0 !Cc0(×10^-6) 〃 〃
DATA -2.790 ,-2.544 ,4.097 ,-3.037 ,0 ,0 !Dc0(×10^-9) 〃 〃
DATA 0.938314 ,0.817026 ,0.618542 ,0.929207 ,0 ,0.905673 !Ac1 定圧比熱の推算式に於ける係数
DATA 2.95732 ,3.87124 ,9.43157 ,3.43656 ,0 ,3.10391 !Bc1(×10^-4) 〃 〃
DATA -7.31507 ,-14.1476 ,-39.2290 ,-10.0711 ,0 ,-8.59483 !Cc1(×10^-8) 〃 〃
DATA 5.81796 ,19.9678 ,54.4078 ,10.1493 ,0 ,8.56212 !Dc1(×10^-12) 〃 〃
DATA 0.656848 ,0.547045 ,0.396046 ,0.641668 ,0 ,0.625027 !Ac2 定容比熱の推算式に於ける係数
DATA 2.46015 ,4.12982 ,10.5300 ,3.13564 ,0 ,2.89050 !Bc2(×10^-4) 〃 〃
DATA -3.16796 ,-16.1964 ,-48.3891 ,-7.57080 ,0 ,-6.76530 !Cc2(×10^-8) 〃 〃
DATA -3.91928 ,24.6892 ,75.8699 ,4.29183 ,0 ,4.17504 !Dc2(×10^-12) 〃 〃
DATA 3.798 ,3.467 ,3.941 ,3.690 ,2.551 ,3.711 !σ 各成分気体の特性直径
DATA 71.4 ,106.7 ,195.2 ,91.7 ,10.22 ,78.6 !ε/k と特性エネルギー
REM Av Bv Cv Dv Ev Fv Ωv 粘性の衝突積分
DATA 1.16145 ,0.14874 ,0.52487 ,0.77320 ,2.16178 ,2.43787 !
REM Ad Bd Cd Dd Ed Fd Gd Hd !Ωd 拡散の衝突積分
DATA 1.06036 ,0.15610 ,0.19300 ,0.47635 ,1.03587 ,1.52996 ,1.76474 ,3.89411 !
その１
REM **********************************************************************
REM 配管保温計算
REM 4種類の配管の保温計算を行います。保温材は２層保温までとします。
REM 配管サイズ、保温材種類に不足がある場合は該当するデータを書き換えて
REM 使用してください。
REM *********************************************************************
DECLARE EXTERNAL SUB aa.airpro ! 混合気体の物性値計算
DIM pipe(19,4) ! 配管サイズの設定
DIM ps(4) ! 配管サイズ番号
DIM ins$(10) ! 保温材名称
DIM insm(4,2) ! 1,2層目保温材番号
DIM insth(4,3) ! 1,2層目保温厚さ、全厚
DIM ins(10,3) ! 保温材番号順の熱伝導率データ
DIM facek(4) ! 保温表面温度 K
DIM airdat(4,8) ! 各保温表面温度 K と外気の平均温度に於ける気体物性値
DIM midt(4,2)
DIM t(4) ! 仮２層保温中間温度
DIM kekka(4,14) ! 計算結果
DIM Rth(4,4) ! 熱抵抗
REM **********************************************************************
MAT READ pipe(19,4) ! 配管サイズの設定
MAT READ ins$(10) ! 保温材名称
MAT READ ins(10,3) ! 保温材データの設定
REM ******************************************
INPUT PROMPT "配管ライン名称 ":name$
INPUT PROMPT "保 持 温 度 (C')":maint
INPUT PROMPT "外 気 温 度 (C')":ambi
INPUT PROMPT "風 速 (m/s)":wv
INPUT PROMPT "設 計 裕 度 ":df
INPUT PROMPT "効 率 ":eff
LET pn=1
INPUT PROMPT "配管 1 番号 ":ps(1)
INPUT PROMPT "配管 2 番号 無い場合は 0":ps(2)
LET pn=2
IF ps(2)=0 THEN
LET ps(2)=ps(1)
LET ps(3)=ps(1)
LET ps(4)=ps(1)
LET pn=1
END IF
IF pn=2 THEN
INPUT PROMPT "配管 3 番号 無い場合は 0":ps(3)
LET pn=3
IF ps(3)=0 THEN
LET ps(3)=ps(1)
LET ps(4)=ps(1)
LET pn=2
END IF
END IF
IF pn=3 THEN
INPUT PROMPT "配管 4 番号 無い場合は 0":ps(4)
LET pn=4
IF ps(4)=0 THEN
LET ps(4)=ps(1)
LET pn=3
END IF
END IF
PRINT " bangou kigou λ0 λ1 λ3 "
PRINT " 1 clc13-300 0.04070 1.28E-04 0 "
PRINT " 2 clc13-800 0.05550 2.05E-05 1.93E- 7 "
PRINT " 3 clc22-300 0.05350 1.16E-04 0 "
PRINT " 4 clc22-800 0.06120 3.38E-05 1.95E-07 "
PRINT " 5 gwc 0.03330 1.21E-04 6.56E-07 "
PRINT " 6 T#1260 0.11000 -1.40E-04 2.60E-07 "
PRINT " 7 rwc100 0.03140 1.74E-04 0 "
PRINT " 8 rwc600 0.04070 1.16E-04 7.67E-07 "
PRINT " 9 T#5120 0.02470 1.014E-04 7.55E-08 "
IF pn=1 THEN
LET insmn=1
INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は ”0,0”":insm(1,2),insth(1,2)
IF insm(1,2)=0 THEN
LET insmn=0
LET insm(1,2)=insm(1,1)
LET insth(1,2)=0
END IF
LET insm(2,1)=insm(1,1)
LET insth(2,1)=insth(1,1)
LET insm(2,2)=insm(1,2)
LET insth(2,2)=insth(1,2)
LET insm(3,1)=insm(1,1)
LET insth(3,1)=insth(1,1)
LET insm(3,2)=insm(1,2)
LET insth(3,2)=insth(1,2)
LET insm(4,1)=insm(1,1)
LET insth(4,1)=insth(1,1)
LET insm(4,2)=insm(1,2)
LET insth(4,2)=insth(1,2)
END IF
IF pn=2 THEN
LET insmn=1
INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(1,2),insth(1,2)
IF insm(1,2)=0 THEN
LET insmn=0
LET insm(1,2)=insm(1,1)
LET insth(1,2)=0
END IF
LET insmn=1
INPUT PROMPT "配管 2 1層目 保温材番号,厚みmm":insm(2,1),insth(2,1)
INPUT PROMPT "配管 2 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(2,2),insth(2,2)
IF insm(2,2)=0 THEN
LET insmn=0
LET insm(2,2)=insm(2,1)
LET insth(2,2)=0
END IF
LET insm(3,1)=insm(1,1)
LET insth(3,1)=insth(1,1)
LET insm(3,2)=insm(1,2)
LET insth(3,2)=insth(1,2)
LET insm(4,1)=insm(1,1)
LET insth(4,1)=insth(1,1)
LET insm(4,2)=insm(1,2)
LET insth(4,2)=insth(1,2)
END IF
IF pn=3 THEN
LET insmn=1
INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(1,2),insth(1,2)
IF insm(1,2)=0 THEN
LET insmn=0
LET insm(1,2)=insm(1,1)
LET insth(1,2)=0
END IF
LET insmn=1
INPUT PROMPT "配管 2 1層目 保温材番号,厚みmm":insm(2,1),insth(2,1)
INPUT PROMPT "配管 2 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(2,2),insth(2,2)
IF insm(2,2)=0 THEN
LET insmn=0
LET insm(2,2)=insm(2,1)
LET insth(2,2)=0
END IF
LET insmn=1
INPUT PROMPT "配管 3 1層目 保温材番号,厚みmm":insm(3,1),insth(3,1)
INPUT PROMPT "配管 3 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(3,2),insth(3,2)
IF insm(3,2)=0 THEN
LET insmn=0
LET insm(3,2)=insm(3,1)
LET insth(3,2)=0
END IF
LET insm(4,1)=insm(1,1)
LET insth(4,1)=insth(1,1)
LET insm(4,2)=insm(1,2)
LET insth(4,2)=insth(1,2)
END IF
IF pn=4 THEN
LET insmn=1
INPUT PROMPT "配管１ 1層目 保温材番号,厚みmm":insm(1,1),insth(1,1)
INPUT PROMPT "配管 1 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(1,2),insth(1,2)
LET insm(1,2)=0
LET insth(1,2)=0
IF insm(1,2)=0 THEN
LET insmn=0
LET insm(1,2)=insm(1,1)
LET insth(1,2)=0
END IF
LET insmn=1
iNPUT PROMPT "配管 2 1層目 保温材番号,厚みmm":insm(2,1),insth(2,1)
INPUT PROMPT "配管 2 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(2,2),insth(2,2)
IF insm(2,2)=0 THEN
LET insmn=0
LET insm(2,2)=insm(2,1)
LET insth(2,2)=0
END IF
LET insmn=1
INPUT PROMPT "配管 3 1層目 保温材番号,厚みmm":insm(3,1),insth(3,1)
INPUT PROMPT "配管 3 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(3,2),insth(3,2)
IF insm(3,2)=0 THEN
LET insmn=0
LET insm(3,2)=insm(3,1)
LET insth(3,2)=0
END IF
LET insmn=1
INPUT PROMPT "配管 4 1層目 保温材番号,厚みmm":insm(4,1),insth(4,1)
INPUT PROMPT "配管 4 2層目 保温材番号,厚みmm 無い場合は”0,0”":insm(4,2),insth(4,2)
IF insm(4,2)=0 THEN
LET insmn=0
LET insm(4,2)=insm(4,1)
LET insth(4,2)=0
END IF
END IF
REM ********** 初期温度の設定 **********
LET face1 = ambi+273+0.1
FOR i=1 TO 4
LET facek(i)=face1 ! 仮保温表面温度
LET t(i)=(maint+(facek(i)-273))/2 ! 仮２層保温中間温度
NEXT i
REM ********** 保温材熱伝導率の計算 **************************
FOR i=1 TO 4
LET t1=(maint+t(i))/2
LET t2=(t(i)+(facek(i)-273))/2
LET x=1
DO
REM ********** 空気物性値の計算 ****************************
CALL airpro(facek(i)-273,k2,k3,k4,k5,k6,k7,k8)
LET airdat(i,2)=k2 ! 比重 kg/m^3
LET airdat(i,3)=k3 ! 比熱 kJ/kgK
LET airdat(i,4)=k4 ! 粘性係数 μPa・S
LET airdat(i,5)=k5 ! 動粘性係数 mm^2/S
LET airdat(i,6)=k6 ! 熱伝導率 mW/mK
LET airdat(i,7)=k7 ! 温度伝導率 mm^2/S
LET airdat(i,8)=k8 ! ﾌﾟﾗﾝﾄﾙ数
LET d0=pipe(ps(i),4) ! 保温材内径
LET d1=pipe(ps(i),4)+2*insth(i,1)/1000 ! 1層目保温材外径
LET d2=pipe(ps(i),4)+2*insth(i,1)/1000+2*insth(i,2)/1000 ! 2層目保温材外径
LET t1=(maint+t(i))/2 ! 1層目保温平均温度
LET c1=(maint^2+maint*t(i)+t(i)^2)/3 ! 熱伝導率計算係数
LET r1=(ins(insm(i,1),1)+ins(insm(i,1),2)*t1+ins(insm(i,1),3)*c1 ) ! 保温材熱伝導率
LET Rth(i,1)=1/(2*PI*r1)*LOG(d1/d0) ! 1層目保温層熱抵抗
LET t2=(t(i)+(facek(i)-273))/2 ! 2層目保温平均温度
LET c2=(t(i)^2+t(i)*(facek(i)-273)+(facek(i)-273)^2)/3 ! 熱伝導率計算係数
LET r2=(ins(insm(i,2),1)+ins(insm(i,2),2)*t2+ins(insm(i,2),3)*c2 ) ! 保温材熱伝導率
LET Rth(i,2)=1/(2*PI*r2)*LOG(d2/d1)
LET re=wv*3600*d2/(airdat(i,5)*3600/1000000)
LET ac=1.12*(0.373*re^0.5+0.057*re^(2/3))*airdat(i,8)^(1/3)*airdat(i,6)/1000/d2
LET ar=0.8*5.67E-8*(faceK(i)^4-(ambi+273)^4)/(facek(i)-(ambi+273))
LET Rth(i,3)=1/(PI*d2*(ac+ar))
LET Rth(i,4)=Rth(i,1)+Rth(i,2)+Rth(i,3)
LET hloss=(maint-ambi)/Rth(i,4)
LET fk=hloss*Rth(i,3)+ambi+273
LET faceK(i) = fk
LET t(i)=hloss*(Rth(i,2)+Rth(i,3))+ambi
LET x=x+1
LOOP WHILE X<=20
LET kekka(i,1)=t1
LET kekka(i,2)=c1
LET kekka(i,3)=r1
LET kekka(i,4)=t2
LET kekka(i,5)=c2
LET kekka(i,6)=r2
LET kekka(i,7)=re
LET kekka(i,8)=ac
LET kekka(i,9)=ar
LET kekka(i,10)=fk
LET kekka(i,11)=t(i)
LET kekka(i,12)=d0
LET kekka(i,13)=d1
LET kekka(i,14)=d2
NEXT i
REM *********************** 計算結果の表示 ***********************
PLOT TEXT ,AT 0.1,0.95:"配管ライン名称 "
PLOT TEXT ,AT 0.35,0.95: name$
PLOT TEXT ,AT 0.1,0.92:"保 持 温 度 (C')"
PLOT TEXT ,AT 0.35,0.92: STR$(maint)
PLOT TEXT ,AT 0.1,0.89:"外 気 温 度 (C')"
PLOT TEXT ,AT 0.35,0.89: STR$(ambi)
PLOT TEXT ,AT 0.5,0.95:"風 速 (m/s)"
PLOT TEXT ,AT 0.75,0.95: STR$(wv)
PLOT TEXT ,AT 0.5,0.92:"設 計 裕 度 "
PLOT TEXT ,AT 0.75,0.92: STR$(df)
PLOT TEXT ,AT 0.5,0.89:"効 率 "
PLOT TEXT ,AT 0.75,0.89: STR$(eff)
PLOT TEXT ,AT 0.25,0.85:"配管サイズ"
PLOT TEXT ,AT 0.40,0.85:"保温層"
PLOT TEXT ,AT 0.50,0.85:"保温材"
PLOT TEXT ,AT 0.60,0.85:"保温厚さ"
PLOT TEXT ,AT 0.15,0.82:"配管 １"
PLOT TEXT ,AT 0.28,0.82,USING"###": pipe(ps(1),1)
PLOT TEXT ,AT 0.40,0.82:"１層目"
PLOT TEXT ,AT 0.49,0.82:ins$(insm(1,1))
PLOT TEXT ,AT 0.62,0.82,USING"###":insth(1,1)
LET ygyou =0.82
IF insth(1,2)<>0 THEN LET ygyou=ygyou-0.02
IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou :"２層目"
IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou :ins$(insm(1,2))
IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou ,USING"###":insth(1,2)
IF pn => 2 THEN LET ygyou=ygyou-0.02
IF pn => 2 THEN PLOT TEXT ,AT 0.15,ygyou :"配管 ２"
IF pn => 2 THEN PLOT TEXT ,AT 0.28,ygyou ,USING"###": pipe(ps(2),1)
IF pn => 2 THEN PLOT TEXT ,AT 0.40,ygyou :"１層目"
IF pn => 2 THEN PLOT TEXT ,AT 0.49,ygyou :ins$(insm(2,1))
IF pn => 2 THEN PLOT TEXT ,AT 0.62,ygyou ,USING"###":insth(2,1)
IF pn => 2 AND insth(2,2)<>0 THEN LET ygyou =ygyou-0.02
IF pn => 2 AND insth(2,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou :"２層目"
IF pn => 2 AND insth(2,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou :ins$(insm(2,2))
IF pn => 2 AND insth(2,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou ,USING"###":insth(2,2)
IF pn => 3 THEN LET ygyou=ygyou-0.02
IF pn => 3 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ３"
IF pn => 3 THEN PLOT TEXT ,AT 0.28,ygyou,USING"###": pipe(ps(3),1)
IF pn => 3 THEN PLOT TEXT ,AT 0.40,ygyou:"１層目"
IF pn => 3 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(3,1))
IF pn => 3 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(3,1)
IF pn => 3 AND insth(3,2)<>0 THEN LET ygyou=ygyou-0.02
IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou:"２層目"
IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(3,2))
IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(3,2)
IF pn = 4 THEN LET ygyou=ygyou-0.02
IF pn = 4 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ４"
IF pn = 4 THEN PLOT TEXT ,AT 0.28,ygyou,USING"###": pipe(ps(4),1)
IF pn = 4 THEN PLOT TEXT ,AT 0.40,ygyou:"１層目"
IF pn = 4 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(4,1))
IF pn = 4 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(4,1)
IF pn = 4 AND insth(4,2)<>0 THEN LET ygyou=ygyou-0.02
IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.40,ygyou:"２層目"
IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.49,ygyou:ins$(insm(4,2))
IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.62,ygyou,USING"###":insth(4,2)
LET ygyou=ygyou-0.02*2
PLOT TEXT ,AT 0.25,ygyou:"保温筒内径 保温筒外径 Re αｃ αｒ α "
LET ygyou=ygyou-0.02
PLOT TEXT ,AT 0.15,ygyou:"配管 １"
PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(1,12),kekka(1,13),kekka(1,7),kekka(1,8),kekka(1,9),kekka(1,8)+kekka(1,9)
IF insth(1,2)<>0 THEN LET ygyou=ygyou-0.02
IF insth(1,2)<>0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(1,13),kekka(1,14)
IF pn => 2 THEN LET ygyou=ygyou-0.02
IF pn => 2 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ２"
IF pn => 2 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(2,12),kekka(2,13),kekka(2,7),kekka(2,8),kekka(2,9),kekka(2,8)+kekka(2,9)
IF pn => 2 AND insth(2,2)<> 0 THEN LET ygyou=ygyou-0.02
IF pn => 2 AND insth(2,2)<> 0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(2,13),kekka(2,14)
IF pn => 3 THEN LET ygyou=ygyou-0.02
IF pn => 3 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ３"
IF pn => 3 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(3,12),kekka(3,13),kekka(3,7),kekka(3,8),kekka(3,9),kekka(3,8)+kekka(3,9)
IF pn => 3 AND insth(3,2)<>0 THEN LET ygyou=ygyou-0.02
IF pn => 3 AND insth(3,2)<>0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(3,13),kekka(3,14)
IF pn = 4 THEN LET ygyou=ygyou-0.02
IF pn = 4 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ４"
IF pn = 4 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.### ###### ###.# ##.# ###.# ":kekka(4,12),kekka(4,13),kekka(4,7),kekka(4,8),kekka(4,9),kekka(4,8)+kekka(4,9)
IF pn = 4 AND insth(4,2)<>0 THEN LET ygyou=ygyou-0.02
IF pn = 4 AND insth(4,2)<>0 THEN PLOT TEXT ,AT 0.27,ygyou,USING"%.### %.###":kekka(4,13),kekka(4,14)
LET ygyou=ygyou-0.02*3
PLOT TEXT ,AT 0.25,ygyou:" Rth1 Rth2 Rth3 Rth hloss Pr θmid θf"
LET ygyou=ygyou-0.02
PLOT TEXT ,AT 0.25,ygyou:" C'm/W W/m W/m C' C' "
LET ygyou=ygyou-0.02
PLOT TEXT ,AT 0.15,ygyou:"配管 １"
PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(1,1),Rth(1,2),Rth(1,3),Rth(1,4),(maint-ambi)/Rth(1,4),(maint-ambi)/Rth(1,4)*df/eff,kekka(1,11),kekka(1,10)-273
LET ygyou=ygyou-0.02
IF pn => 2 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ２"
IF pn => 2 THEN PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(2,1),Rth(2,2),Rth(2,3),Rth(2,4),(maint-ambi)/Rth(2,4),(maint-ambi)/Rth(2,4)*df/eff,kekka(2,11),kekka(2,10)-273
LET ygyou=ygyou-0.02
IF pn => 3 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ３"
IF pn => 3 THEN PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(3,1),Rth(3,2),Rth(3,3),Rth(3,4),(maint-ambi)/Rth(3,4),(maint-ambi)/Rth(3,4)*df/eff,kekka(3,11),kekka(3,10)-273
LET ygyou=ygyou-0.02
IF pn = 4 THEN PLOT TEXT ,AT 0.15,ygyou:"配管 ４"
IF pn = 4 THEN PLOT TEXT ,AT 0.26,ygyou,USING"##.## ##.## %.## ##.## ###.# ###.# ###.# ###.# ##.##":Rth(4,1),Rth(4,2),Rth(4,3),Rth(4,4),(maint-ambi)/Rth(4,4),(maint-ambi)/Rth(4,4)*df/eff,kekka(4,11),kekka(4,10)-273
REM ********** 配管データ **********
REM si d2 t di
DATA 15 , 0.0217 , 0.0028 , 0.034
DATA 20 , 0.0272 , 0.0029 , 0.034
DATA 25 , 0.034 , 0.0034 , 0.0427
DATA 32 , 0.0427 , 0.0036 , 0.0486
DATA 40 , 0.0486 , 0.0037 , 0.0605
DATA 50 , 0.0605 , 0.0039 , 0.0763
DATA 65 , 0.0763 , 0.0052 , 0.0891
DATA 80 , 0.0891 , 0.0055 , 0.1016
DATA 90 , 0.1016 , 0.0057 , 0.1143
DATA 100, 0.1143 , 0.0060 , 0.1398
DATA 125, 0.1398 , 0.0066 , 0.1652
DATA 150, 0.1652 , 0.0071 , 0.1910
DATA 200, 0.2163 , 0.0082 , 0.2419
DATA 250, 0.2674 , 0.0093 , 0.2930
DATA 300, 0.3185 , 0.0103 , 0.3370
DATA 350, 0.3556 , 0.0111 , 0.3810
DATA 400, 0.4064 , 0.0127 , 0.4320
DATA 450, 0.4572 , 0.0143 , 0.4830
DATA 500, 0.5080 , 0.0151 , 0.5330
REM *********************************
REM ********** 保温材データ **********
DATA clc13-300 , clc13-800 , clc22-300 , clc22-800 , gwc
DATA Ts1260 , rwc100 , rwc600 , Ts5120 , daipa
REM ********** 保温材熱伝導率 **********
REM r1 r2 r3
DATA 0.04070 , 1.28E-04 , 0
DATA 0.05550 , 2.05E-05 , 1.93E-07
DATA 0.05350 , 1.16E-04 , 0
DATA 0.06120 , 3.38E-05 , 1.95E-07
DATA 0.03330 , 1.21E-04 , 6.56E-07
DATA 0.11000 , -1.40E-04, 2.60E-07
DATA 0.03140 , 1.74E-04 , 0
DATA 0.04070 , 1.16E-04 , 7.67E-07
DATA 0.02470 , 1.14E-04 , 7.55E-08
DATA 0.05550 , 2.05E-05 , 1.93E-07
REM ***********************************
END
REM *****************************************************************
MODULE aa ! モジュール名 aa
REM SET WINDOW 0,1.0,0,1.0
SHARE NUMERIC n
LET n=6 !対象気体数 ６種類 N2,O2,CO2,CO,He,Air
REM TK !絶対温度 K
REM Pa !圧力 パスカル
SHARE NUMERIC rho(7) !各気体の密度
SHARE NUMERIC CP(7) ! 〃 定圧比熱
SHARE NUMERIC CVv(7) ! 〃 定容比熱
SHARE NUMERIC CPO(7) ! 〃 定圧分子熱
SHARE STRING n$(6) !気体名称 N2 , O2 , CO2 , CO , He , Air
SHARE NUMERIC mwp(6) !質量分率 重量％
SHARE NUMERIC mw(6) !分子量 molecular weight
REM Mave !平均モル質量
SHARE NUMERIC Xmol(7) !モル数
SHARE NUMERIC Xmolb(6) !モル分率（体積分率）
SHARE NUMERIC mu(7) !粘性係数
SHARE NUMERIC phi(6,6) !粘性係数計算係数
SHARE NUMERIC phix(6,6)
SHARE NUMERIC nu(7) !動粘性係数
SHARE NUMERIC alpha(7) !温度伝導率
SHARE NUMERIC Pr(7) !ﾌﾟﾗﾝﾄﾙ数
SHARE NUMERIC kk(6)
SHARE NUMERIC lambda(7) !熱伝導率
SHARE NUMERIC Tc(6) !臨界温度 critical temperature
SHARE NUMERIC Pc(6) !臨界圧力 critical pressure
SHARE NUMERIC zeta(6) !偏心因子
SHARE NUMERIC Ac0(6) !Ac0 定圧分子熱の推算式に於ける係数
SHARE NUMERIC Bc0(6) !Bc0 〃 〃
SHARE NUMERIC Cc0(6) !Cc0 〃 〃
SHARE NUMERIC Dc0(6) !Dc0 〃 〃
SHARE NUMERIC Ac1(6) !Ac1 定圧比熱の推算式に於ける係数
SHARE NUMERIC Bc1(6) !Bc1 〃 〃
SHARE NUMERIC Cc1(6) !Cc1 〃 〃
SHARE NUMERIC Dc1(6) !Dc1 〃 〃
SHARE NUMERIC Ac2(6) !Ac2 定容比熱の推算式に於ける係数
SHARE NUMERIC Bc2(6) !Bc2 〃 〃
SHARE NUMERIC Cc2(6) !Cc2 〃 〃
SHARE NUMERIC Dc2(6) !Dc2 〃 〃
SHARE NUMERIC shiguma (6) ! σ 各成分気体の特性直径
SHARE NUMERIC epsilonk(6) ! ε/k 各成分気体の特性エネルギー
SHARE NUMERIC ohmv(6) ! Ωv 粘性の衝突積分
SHARE NUMERIC ohmd(8) ! Ωd 拡散の衝突積分
SHARE NUMERIC Av,Bv,Cv,Dv,Ev,Fv,Ad,Bd,Cd,Dd,Ed,Fd,Gd,Hd
REM N2 O2 CO2 CO He Air
DATA N2 , O2 , CO2 , CO , He , Air
DATA 28.0134 ,31.999 ,44.010 ,28.010 ,4.0026 ,28.964 !molecular weight 分子量
DATA 126.2 ,154.6 ,304.2 ,132.9 ,5.19 ,132.5 !Tc 臨界温度 K
DATA 33.5 ,50.1 ,72.8 ,34.5 ,2.24 ,37.2 !Pc 臨界圧力 atm 760mmhg 101325Pa
DATA 0.040 ,0.021 ,0.225 ,0.049 ,-0.387 ,0 !ζ zeta 偏心因子
DATA 7.440 ,6.713 ,4.728 ,7.373 ,0 ,0 !Ac0 定圧分子熱の推算式に於ける係数
DATA -0.324 ,-8.79E-5 ,1.754 ,-0.307 ,0 ,0 !Bc0(×10^-2) 〃 〃
DATA 6.400 ,4.170 ,-13.38 ,6.662 ,0 ,0 !Cc0(×10^-6) 〃 〃
DATA -2.790 ,-2.544 ,4.097 ,-3.037 ,0 ,0 !Dc0(×10^-9) 〃 〃
DATA 0.938314 ,0.817026 ,0.618542 ,0.929207 ,0 ,0.905673 !Ac1 定圧比熱の推算式に於ける係数
DATA 2.95732 ,3.87124 ,9.43157 ,3.43656 ,0 ,3.10391 !Bc1(×10^-4) 〃 〃
DATA -7.31507 ,-14.1476 ,-39.2290 ,-10.0711 ,0 ,-8.59483 !Cc1(×10^-8) 〃 〃
DATA 5.81796 ,19.9678 ,54.4078 ,10.1493 ,0 ,8.56212 !Dc1(×10^-12) 〃 〃
DATA 0.656848 ,0.547045 ,0.396046 ,0.641668 ,0 ,0.625027 !Ac2 定容比熱の推算式に於ける係数
DATA 2.46015 ,4.12982 ,10.5300 ,3.13564 ,0 ,2.89050 !Bc2(×10^-4) 〃 〃
DATA -3.16796 ,-16.1964 ,-48.3891 ,-7.57080 ,0 ,-6.76530 !Cc2(×10^-8) 〃 〃
DATA -3.91928 ,24.6892 ,75.8699 ,4.29183 ,0 ,4.17504 !Dc2(×10^-12) 〃 〃
DATA 3.798 ,3.467 ,3.941 ,3.690 ,2.551 ,3.711 !σ 各成分気体の特性直径
DATA 71.4 ,106.7 ,195.2 ,91.7 ,10.22 ,78.6 !ε/k と特性エネルギー
REM Av Bv Cv Dv Ev Fv Ωv 粘性の衝突積分
DATA 1.16145 ,0.14874 ,0.52487 ,0.77320 ,2.16178 ,2.43787 !
REM Ad Bd Cd Dd Ed Fd Gd Hd !Ωd 拡散の衝突積分
DATA 1.06036 ,0.15610 ,0.19300 ,0.47635 ,1.03587 ,1.52996 ,1.76474 ,3.89411 !
REM *******************************************************************
REM * 定数の読み込み *
REM *******************************************************************
FOR i=1 TO n
READ n$(i)
NEXT i
FOR i=1 TO n
READ mw(i)
NEXT i
FOR i=1 TO n
READ Tc(i)
NEXT i
FOR i=1 TO n
READ Pc(i)
NEXT i
FOR i=1 TO n
READ zeta(i)
NEXT i
FOR i=1 TO n
READ Ac0(i)
NEXT i
FOR i=1 TO n
READ Bc0(i)
LET Bc0(i)=Bc0(i)*1E-2
NEXT i
FOR i=1 TO n
READ Cc0(i)
LET Cc0(i)=Cc0(i)*1E-6
NEXT i
FOR i=1 TO n
READ Dc0(n)
LET Dc0(i)=Dc0(i)*1E-9
NEXT i
FOR i=1 TO n
READ Ac1(i)
NEXT i
FOR i=1 TO n
READ Bc1(i)
LET Bc1(i)=Bc1(i)*1E-4
NEXT i
FOR i=1 TO n
READ Cc1(i)
LET Cc1(i)=Cc1(i)*1E-8
NEXT i
FOR i=1 TO n
READ Dc1(i)
LET Dc1(i)=Dc1(i)*1E-12
NEXT i
FOR i=1 TO n
READ Ac2(i)
NEXT i
FOR i=1 TO n
READ Bc2(i)
LET Bc2(i)=Bc2(i)*1E-4
NEXT I
FOR i=1 TO n
READ Cc2(i)
LET Cc2(i)=Cc2(i)*1E-8
NEXT i
FOR i=1 TO n
READ Dc2(i)
LET Dc2(i)=Dc2(i)*1E-12
NEXT i
FOR i=1 TO n
READ shiguma(i)
NEXT i
FOR i=1 TO n
READ epsilonk(i)
NEXT i
READ Av
READ Bv
READ Cv
READ Dv
READ Ev
READ Fv
READ Ad
READ Bd
READ Cd
READ Dd
READ Ed
READ Fd
READ Gd
READ Hd
EXTERNAL SUB airpro(k,rho7,cp7,mu7,nu7,lambda7,alpha7,pr7)
REM *****************************************************
REM * 各気体の質量分率＝重量％を入力 *
REM *****************************************************
REM PRINT"各気体の重量％を入力してください"
REM DO WHILE mwp(1)+mwp(2)+mwp(3)+mwp(4)+mwp(5)+mwp(6)<>100
REM INPUT PROMPT"N2 , O2 , CO2 , CO , He , Air":mwp(1),mwp(2),mwp(3),mwp(4),mwp(5),mwp(6)
REM LOOP
LET mwp(1)=0
LET mwp(2)=0
LET mwp(3)=0
LET mwp(4)=0
LET mwp(5)=0
LET mwp(6)=100
LET Mkongou=0
FOR i=1 TO n
IF mwp(i)<>0 THEN
LET Mkongou=(mwp(i)/100/mw(i))+Mkongou
END IF
NEXT i
LET Mkongou=1/Mkongou ! 混合気体の分子量
FOR i = 1 TO n
IF mwp(i)<>0 THEN
LET Xmolb(i)=Mkongou/mw(i)*mwp(i) ! 体積分率の計算
END IF
NEXT i
FOR i=1 TO n
LET Xmol(i)=mwp(i)/mw(i)
NEXT i
REM *****************************************************
REM * 圧力、温度の設定 *
REM *****************************************************
REM PRINT"計算条件 温度(℃) , 圧力を指示してください。"
REM INPUT PROMPT" T C' , P atm ":T,Patm !T C' ： T ℃ P atm : P 気圧
LET T=k
LET Patm=1.0
LET TK=T+273.15 !TK : 絶対温度 K
LET Pa=Patm*101325 !Pa : パスカル
REM PRINT TK ;"K " ; TK-273.15;"C' ";Pa;"Pa "
REM *****************************************************
REM * 密度の計算 kg/m^3 *
REM *****************************************************
LET rho(7)=0
FOR i=1 TO n
LET rho(i)=Pa*mw(i)/8.314/TK/1000
LET rho(7)=rho(i)*Xmolb(i)/100+rho(7)
NEXT i
LET rho7=rho(7)
REM *****************************************************
REM * 定圧比熱の計算 KJ/kgK *
REM *****************************************************
LET CP(7)=0
FOR i=1 TO n
IF i=5 THEN
LET CP(i)=5193/1000
ELSE
LET CP(i)=Ac1(i)+Bc1(i)*TK+Cc1(i)*TK^2+Dc1(i)*TK^3
END IF
LET CP0=CP(i)*Xmolb(i)/100+CP0
NEXT i
REM PRINT CP0
REM LET Mmix=0
REM FOR i=1 TO n
REM LET Mmix=mw(i)*Xmolb(i)/100+Mmix
REM NEXT i
REM PRINT Mmix
LET CP(7)=CP0
LET cp7=cp(7)
REM ****************************************************
REM * 粘性率の計算 Pa・s *
REM ****************************************************
FOR i=1 TO n
LET tdot=TK/epsilonk(i)
IF i=5 THEN
IF TK>1100 THEN
LET visc =Av/tdot^Bv
ELSE
LET visc=Av/tdot^Bv+Cv/EXP(Dv*tdot)
END IF
LET mu(i)=26.69*SQR(mw(i)*TK)/shiguma(i)^2/visc*1E-7*1E6
ELSE
LET ohmv(i)=(Av/tdot^Bv+Cv/EXP(Dv*tdot)+Ev/EXP(Fv*tdot))
LET mu(i)=26.69*SQR(mw(i)*TK)/shiguma(i)^2/ohmv(I)*1E-7*1E6
END IF
NEXT i
LET mu(7)=0
FOR i=1 TO n
FOR j=1 TO n
IF mwp(j)<>0 THEN
IF mwp(i)<>0 THEN
LET phi(i,j)=(1+(mu(i)/mu(j))^0.5*(mw(j)/mw(i))^0.25)^2/(8*(1+mw(i)/mw(j)))^0.5
END IF
END IF
NEXT j
NEXT i
LET ZZ=0
FOR i=1 TO n
IF mwp(i)<>0 THEN
LET Z=0
FOR j= 1 TO n
IF mwp(j)<>0 THEN
LET Z=Z+xmolb(j)*phi(i,j)
END IF
NEXT j
LET ZZ=ZZ+Xmolb(i)*mu(i)/Z
END IF
NEXT i
LET mu(7)=ZZ
LET mu7=mu(7)
REM ***************************************************
REM * 熱伝導率の計算 mW/mK *
REM ***************************************************
FOR i=1 TO n
LET CVv(i)=Ac2(i)+Bc2(i)*TK+Cc2(i)*TK^2+Dc2(i)*TK^3
LET tdot=TK/epsilonk(i)
IF i=5 THEN
LET CVv(i)=3114
IF TK > 1100 THEN
LET Ohmvh=Av/tdot^Bv
ELSE
LET ohmvh=Av/tdot^Bv+Cv/EXP(Dv*tdot)
END IF
LET lambdahe=2.669*SQR(mw(i)*TK)/shiguma(i)^2/ohmvh*1E-7*1E6
LET lambda(i)=(1.32*CVv(i)*mw(i)*0.001/4.186+3.52)*lambdahe/mw(i)*4.186*10
ELSE
LET lambda(i)=(1.32*CVv(i)*mw(i)/4.186+3.52)*mu(i)/mw(i)*4.186
END IF
NEXT i
LET lambda(7)=0
FOR i=1 TO n
FOR j=1 TO n
IF mwp(j)<>0 THEN
IF mwp(i)<>0 THEN
LET phi(i,j)=(1+(lambda(i)/lambda(j))^0.5*(mw(j)/mw(i))^0.25)^2/(8*(1+mw(i)/mw(j)))^0.5
END IF
END IF
NEXT j
NEXT i
LET ZZ=0
FOR i=1 TO n
IF mwp(i)<>0 THEN
LET Z=0
FOR j= 1 TO n
IF mwp(j)<>0 THEN
LET Z=Z+xmolb(j)*phi(i,j)
END IF
NEXT j
LET ZZ=ZZ+Xmolb(i)*lambda(i)/Z
END IF
NEXT i
LET lambda(7)=ZZ
LET lambda7=lambda(7)
REM *************************************************
REM * 動粘性係数 mm^2/s *
REM *************************************************
FOR i= 1TO 7
IF rho(i)<>0 THEN
LET nu(i)=mu(i)/rho(i)
END IF
NEXT i
LET nu7=nu(7)
REM *************************************************
REM * 温度伝導率 mm^2/s *
REM *************************************************
FOR i=1 TO 7
IF Rho(i)<> 0 THEN
LET alpha(i)=lambda(i)/rho(i)/CP(I)
END IF
NEXT i
LET alpha7=alpha(7)
REM *************************************************
REM * ﾌﾟﾗﾝﾄﾙ数 *
REM *************************************************
FOR i=1TO 7
IF alpha(i)<>0 THEN
LET Pr(i)=nu(i)/alpha(i)
END IF
NEXT i
LET pr7=pr(7)
REM *************************************************
REM * 計算結果 打ち出し *
REM *************************************************
REM PLOT TEXT ,AT 0.05,0.95 ,USING "温度、圧力 絶対温度 ---%.# K 摂氏 ---%.# ℃ 圧力 -%.##MPa ":TK,T,Pa/1000000
REM PLOT TEXT ,AT 0.05,0.90:" N2 O2 CO2 CO He Air "
REM PLOT TEXT ,AT 0.05,0.88 ,USING "質量分率 ## ---%.# ---%.# ---%.# ---%.# ---%.# ---%.# ":"%",mwp(1),mwp(2),mwp(3),mwp(4),mwp(5),mwp(6)
REM PLOT TEXT ,AT 0.05,0.86 ,USING "モル数 n mol ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":Xmol(1),Xmol(2),Xmol(3),Xmol(4),Xmol(5),Xmol(6)
REM PLOT TEXT ,AT 0.05,0.84 ,USING "体積分率 ## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"%",Xmolb(1),Xmolb(2),Xmolb(3),Xmolb(4),Xmolb(5),Xmolb(6)
REM PLOT TEXT ,AT 0.05,0.80 ,USING "混合気体分子量 ---%.##":Mkongou
REM PLOT TEXT ,AT 0.05,0.76: " N2 O2 CO2 CO He Air Mix"
REM PLOT TEXT ,AT 0.05,0.74 ,USING "密度 ###### -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":"kg/m^3",rho(1),rho(2),rho(3),rho(4),rho(5),rho(6),rho(n+1)
REM PLOT TEXT ,AT 0.05,0.72 ,USING "定圧比熱 ###### -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":"KJ/kgK",CP(1),CP(2),CP(3),CP(4),CP(5),CP(6),CP(n+1)
REM PLOT TEXT ,AT 0.05,0.70 ,USING "粘性率の計算 ###### --%.## --%.## --%.## --%.## --%.## --%.## --%.##":"uPa.s",mu(1),mu(2),mu(3),mu(4),mu(5),mu(6),mu(n+1)
REM PLOT TEXT ,AT 0.05,0.68 ,USING "動粘性係数 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mm2/s",nu(1),nu(2),nu(3),nu(4),nu(5),nu(6),nu(n+1)
REM PLOT TEXT ,AT 0.05,0.66 ,USING "熱伝導率 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mW/mK",lambda(1),lambda(2),lambda(3),lambda(4),lambda(5),lambda(6),lambda(n+1)
REM PLOT TEXT ,AT 0.05,0.64 ,USING "温度伝導率 ##### ---%.## ---%.## ---%.## ---%.## ---%.## ---%.## ---%.##":"mm2/s",alpha(1),alpha(2),alpha(3),alpha(4),alpha(5),alpha(6),alpha(n+1)
REM PLOT TEXT ,AT 0.05,0.62 ,USING "ﾌﾟﾗﾝﾄﾙ数 -%.#### -%.#### -%.#### -%.#### -%.#### -%.#### -%.####":Pr(1),Pr(2),Pr(3),Pr(4),Pr(5),Pr(6),Pr(n+1)
DIM A(2)
LOCATE VALUE (1):A(1) !'変数名が表示されない
LOCATE VALUE (2):B12345 !'変数名が表示される
LOCATE VALUE (3):A(2) !'変数名が表示されない
LOCATE VALUE (4):A12345 !'変数名が表示される
END
LOCATE VALUE (1),RANGE 0 TO 360,AT 0,PROMPT "角度":THETA
LOCATE VALUE (2),RANGE 0 TO 100,AT 0,PROMPT "X-移動":XMOVE
LOCATE VALUE (3),RANGE 0 TO 100,AT 0,PROMPT "Y-移動":YMOVE
OPTION ANGLE DEGREES
OPTION BASE 0
CALL GINIT(800,800)
LET MODE=0
LET SAVE=0
DO
CLEAR
LET XMAX=0
LET YMAX=0
LET XMIN=0
LET YMIN=0
SELECT CASE MODE
CASE 0
RANDOMIZE
LET A1=INT(RND*5)+1
LET B1=INT(RND*10)+1
LET A2=INT(RND*5)+1
LET B2=INT(RND*10)+1
LET R1=INT(RND*5)+1
LET R2=INT(RND*5)+1
LET RR1=INT(RND*5)+1
LET RR2=INT(RND*5)+1
LET NN1=INT(RND*20)+1
LET NN2=INT(RND*20)+1
LET MM1=INT(RND*5)+1
LET MM2=INT(RND*5)+1
PRINT "DATA ";A1;",";A2;",";B1;",";B2;",";MM1;",";MM2;",";R1;",";R2;",";RR1;",";RR2;",";NN1;",";NN2 !'気に入ったものはREAD文の下にコピペしておく
CASE 1
READ A1,A2,B1,B2,MM1,MM2,R1,R2,RR1,RR2,NN1,NN2
END SELECT
DIM X1(360),X2(360),Y1(360),Y2(360),C(360)
FOR I=0 TO 360
LET X1(I)=F(A1,MM1,R1,RR1,NN1,I)
LET Y1(I)=G(B1,MM1,R1,RR1,NN1,I)
LET X2(I)=F(A2,MM2,R2,RR2,NN2,I)
LET Y2(I)=G(B2,MM2,R2,RR2,NN2,I)
IF MOD(I,5)=0 AND I<=360-4 THEN
LET CC=INT(RND*255+1)
FOR J=0 TO 4
LET C(I+J)=CC
NEXT J
END IF
LET XMAX=MAX(XMAX,X1(I))
LET XMAX=MAX(XMAX,X2(I))
LET YMAX=MAX(YMAX,Y1(I))
LET YMAX=MAX(YMAX,Y2(I))
LET XMIN=MIN(XMIN,X1(I))
LET XMIN=MIN(XMIN,X2(I))
LET YMIN=MIN(YMIN,Y1(I))
LET YMIN=MIN(YMIN,Y2(I))
NEXT I
SET WINDOW XMIN,XMAX,YMIN,YMAX
FOR I=1 TO 360
SET LINE COLOR 1
PLOT LINES: X1(I-1),Y1(I-1);X1(I),Y1(I)
SET LINE COLOR 2
PLOT LINES: X2(I-1),Y2(I-1);X2(I),Y2(I)
NEXT I
LET A$=CONFIRM$("よろしいですか?")
LOOP WHILE A$="NO"
CLEAR
DO
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
END IF
FOR TH=0 TO 359 STEP 2
IF SAVE=0 AND (GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0) THEN STOP
FOR I=TH-15 TO TH
SET LINE COLOR C(MOD(I+360,360))
PLOT LINES:X1(MOD(I+360,360)),Y1(MOD(I+360,360));X2(MOD(I+360,360)),Y2(MOD(I+360,360))
NEXT I
SET DRAW MODE EXPLICIT
WAIT DELAY .05
IF SAVE=1 THEN
LET K=K+1
GSAVE "image" & RIGHT$("00000" & STR$(K),5) & ".png" !'gifアニメ用
PRINT "No.";K
END IF
SET DRAW MODE HIDDEN
CLEAR
NEXT TH
LOOP WHILE SAVE=0
END
EXTERNAL FUNCTION F(A,MM,R1,RR1,NN,TH)
OPTION ANGLE DEGREES
LET F=A*COS(TH*MM)*(R1+RR1*COS(NN*TH))
END FUNCTION
EXTERNAL FUNCTION G(A,MM,R1,RR1,NN,TH)
OPTION ANGLE DEGREES
LET G=A*SIN(TH*MM)*(R1+RR1*SIN(NN*TH))
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 MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
SET WINDOW -1,1,-1,1
DIM X(10),Y(10),XX(10),YY(10)
LOCATE VALUE NOWAIT(1),RANGE 3 TO 10,AT 3:POLYGON
LOCATE VALUE NOWAIT(2),RANGE .01 TO .99,AT .1:RATIO
LOCATE VALUE NOWAIT(3),RANGE 1 TO 30,AT 6.01:SPEED
DO
IF SAVE=0 AND (GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0) THEN STOP
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
LET TH=0
END IF
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1):POLYGON
LOCATE VALUE NOWAIT(2):RATIO
LOCATE VALUE NOWAIT(3):SPEED
END IF
LET POLYGON=INT(POLYGON)
LET SPEED=INT(SPEED)
LET RATIO=ROUND(RATIO,3)
LET K=0
LET TH=MOD(TH+SPEED,360)
FOR I=0 TO 359 STEP 360/POLYGON
LET K=K+1
LET X(K)=SIN(RAD(I-TH))*2
LET Y(K)=COS(RAD(I-TH))*2
NEXT I
LET C=0
SET AREA COLOR C
MAT PLOT AREA:X,Y
DO
FOR I=1 TO POLYGON
LET XX(I)=(1-RATIO)*X(I)+RATIO*X(MOD(I,POLYGON)+1)
LET YY(I)=(1-RATIO)*Y(I)+RATIO*Y(MOD(I,POLYGON)+1)
NEXT I
LET C=MOD(C+1,2)
SET AREA COLOR C
MAT PLOT AREA,LIMIT POLYGON:XX,YY
MAT X=XX
MAT Y=YY
LOOP UNTIL SQR((X(2)-X(1))^2+(Y(2)-Y(1))^2)<.03
SET DRAW MODE EXPLICIT
WAIT DELAY .1
IF SAVE=1 THEN
LET KK=KK+1
GSAVE "image"&USING$("%%%%%",KK)&".png" !'gifアニメ用
PRINT "No.";KK
END IF
SET DRAW MODE HIDDEN
CLEAR
LOOP UNTIL SAVE=1 AND TH>=360/POLYGON
END
OPTION ANGLE DEGREES
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LOCATE VALUE NOWAIT(1),RANGE .01 TO 1,AT .1: INTERVAL
LOCATE VALUE NOWAIT(2),RANGE .01 TO .5,AT .1 : RADIUS
LOCATE VALUE NOWAIT(3),RANGE 1 TO 1000,AT 500 : POWER
LOCATE VALUE NOWAIT(4),RANGE .001 TO .1,AT .01: SIZE
LOCATE VALUE NOWAIT(5),RANGE 1 TO 30,AT 10 : SPEED
LOCATE VALUE NOWAIT(6),RANGE 1 TO 11,AT 1 : MODE
LOCATE VALUE NOWAIT(7),RANGE 0 TO 1,AT .4 : COL
LOCATE VALUE NOWAIT(8),RANGE -1 TO 0,AT -.5 : XS
LOCATE VALUE NOWAIT(9),RANGE -1 TO 0,AT -.5 : YS
DO
IF SAVE=0 AND GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
END IF
FOR T=0 TO 359 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1): INTERVAL
LOCATE VALUE NOWAIT(2): RADIUS
LOCATE VALUE NOWAIT(3): POWER
LOCATE VALUE NOWAIT(4): SIZE
LOCATE VALUE NOWAIT(5): SPEED
LOCATE VALUE NOWAIT(6): MODE
LOCATE VALUE NOWAIT(7): COL
LOCATE VALUE NOWAIT(8): XS
LOCATE VALUE NOWAIT(9): YS
END IF
LET MODE=INT(MODE)
LET SPEED=INT(SPEED)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
SET COLOR MIX(8) COL,COL,COL
SET WINDOW XS,XS+1,YS,YS+1
IF COL>0 THEN
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
CALL CIRCLE(X,Y,RADIUS,8)
NEXT X
NEXT Y
END IF
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
IF GETKEYSTATE(32)<0 AND SAVE=0 THEN STOP
SELECT CASE MODE
CASE 1
LET L=X+Y
CASE 2
LET L=X-Y
CASE 3
IF Y=0 THEN LET L=100 ELSE LET L=X/Y
CASE 4
LET L=ABS(X)+ABS(Y)
CASE 5
LET L=SQR(X*X+Y*Y)
CASE 6
LET L=X*Y
CASE 7
LET L=MAX(X,Y)
CASE 8
LET L=MIN(X,Y)
CASE 9
LET L=X^3+Y^3
CASE 10
IF X+Y=0 THEN LET L=100 ELSE LET L=1/(X+Y)
CASE 11
IF X=0 AND Y=0 THEN LET L=0 ELSE LET L=ANGLE(X,Y)
END SELECT
LET L=L*POWER
LET XX=X+RADIUS*COS(L+T)
LET YY=Y+RADIUS*SIN(L+T)
CALL CIRCLEFULL(XX,YY,SIZE,7)
NEXT X
NEXT Y
SET DRAW MODE EXPLICIT
WAIT DELAY .05
IF SAVE<>0 THEN
LET KK=KK+1
GSAVE "IMAGE"&USING$("%%%%%",KK)&".png" !'gifアニメ用コマ
PRINT "No.";KK
END IF
SET DRAW MODE HIDDEN
CLEAR
NEXT T
LOOP UNTIL SAVE=1
END
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL SUB CIRCLE(X,Y,R,C)
SET COLOR C
DRAW CIRCLE WITH SCALE(R)*SHIFT(X,Y)
END SUB
OPTION ANGLE DEGREES
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LOCATE VALUE NOWAIT(1),RANGE .01 TO 1,AT .1: INTERVAL
LOCATE VALUE NOWAIT(2),RANGE .01 TO .5,AT .1 : RADIUS
LOCATE VALUE NOWAIT(3),RANGE 1 TO 1000,AT 500 : POWER
LOCATE VALUE NOWAIT(4),RANGE .001 TO .1,AT .01 : SIZE
LOCATE VALUE NOWAIT(5),RANGE 1 TO 30,AT 10 : SPEED
LOCATE VALUE NOWAIT(6),RANGE 0 TO 360,AT 0 : ROT
LOCATE VALUE NOWAIT(7),RANGE 3 TO 15,AT 3 : POLYGON
LOCATE VALUE NOWAIT(8),RANGE 1 TO 11,AT 1 : MODE
LOCATE VALUE NOWAIT(9),RANGE 0 TO 1,AT .4 : COL
LOCATE VALUE NOWAIT(10),RANGE -1 TO 0,AT -.5 : XS
LOCATE VALUE NOWAIT(11),RANGE -1 TO 0,AT -.5 : YS
DO
IF SAVE=0 AND GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
END IF
FOR T=0 TO 359 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1): INTERVAL
LOCATE VALUE NOWAIT(2): RADIUS
LOCATE VALUE NOWAIT(3): POWER
LOCATE VALUE NOWAIT(4): SIZE
LOCATE VALUE NOWAIT(5): SPEED
LOCATE VALUE NOWAIT(6): ROT
LOCATE VALUE NOWAIT(7): POLYGON
LOCATE VALUE NOWAIT(8): MODE
LOCATE VALUE NOWAIT(9): COL
LOCATE VALUE NOWAIT(10): XS
LOCATE VALUE NOWAIT(11): YS
END IF
LET POLYGON=INT(POLYGON)
LET ROT=INT(ROT)
LET SPEED=INT(SPEED)
LET MODE=INT(MODE)
LET A=360/POLYGON
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
SET COLOR MIX(8) COL,COL,COL
SET WINDOW XS,XS+1,YS,YS+1
IF COL>0 THEN
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
CALL POLY(X,Y,RADIUS,8,-ROT,360-ROT,A)
NEXT X
NEXT Y
END IF
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
IF GETKEYSTATE(32)<0 AND SAVE=0 THEN STOP
SELECT CASE MODE
CASE 1
LET L=X+Y
CASE 2
LET L=X-Y
CASE 3
IF Y=0 THEN LET L=100 ELSE LET L=X/Y
CASE 4
LET L=ABS(X)+ABS(Y)
CASE 5
LET L=SQR(X*X+Y*Y)
CASE 6
LET L=X*Y
CASE 7
LET L=MAX(X,Y)
CASE 8
LET L=MIN(X,Y)
CASE 9
LET L=X^3+Y^3
CASE 10
IF X+Y=0 THEN LET L=100 ELSE LET L=1/(X+Y)
CASE 11
IF X=0 AND Y=0 THEN LET L=0 ELSE LET L=ANGLE(X,Y)
END SELECT
LET L=L*POWER
DO WHILE L<0
LET L=L+360
LOOP
LET XX=X+RADIUS*COS(T+ROT+L)*COS(A/2)/COS(A*((T+L)/A-IP((T+L)/A))-A/2)
LET YY=Y+RADIUS*SIN(T+ROT+L)*COS(A/2)/COS(A*((T+L)/A-IP((T+L)/A))-A/2)
CALL CIRCLEFULL(XX,YY,SIZE,7)
NEXT X
NEXT Y
SET DRAW MODE EXPLICIT
WAIT DELAY .05
IF SAVE<>0 THEN
LET KK=KK+1
GSAVE "IMAGE"&USING$("%%%%%",KK)&".png" !'gifアニメ用コマ
PRINT "No.";KK
END IF
SET DRAW MODE HIDDEN
CLEAR
NEXT T
LOOP UNTIL SAVE=1
END
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL SUB POLY(X,Y,R,C,S,E,ST)
OPTION ANGLE DEGREES
SET LINE COLOR C
FOR TH=S TO E+ST/2 STEP ST
LET X1=X+R*COS(TH)
LET Y1=Y-R*SIN(TH)
PLOT LINES:X1,Y1;
LET X0=X1
LET Y0=Y1
NEXT TH
PLOT LINES
END SUB
OPTION ANGLE DEGREES
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LOCATE VALUE NOWAIT(1),RANGE .01 TO 1,AT .1: INTERVAL
LOCATE VALUE NOWAIT(2),RANGE .01 TO .5,AT .1 : RADIUS
LOCATE VALUE NOWAIT(3),RANGE 1 TO 1000,AT 500 : POWER
LOCATE VALUE NOWAIT(4),RANGE .001 TO .1,AT .01 : SIZE
LOCATE VALUE NOWAIT(5),RANGE 1 TO 30,AT 10 : SPEED
LOCATE VALUE NOWAIT(6),RANGE 0 TO 360,AT 0 : ROT
LOCATE VALUE NOWAIT(7),RANGE 5 TO 10,AT 5 : POLYGON
LOCATE VALUE NOWAIT(8),RANGE 1 TO 11,AT 1 : MODE
LOCATE VALUE NOWAIT(9),RANGE 0 TO 1,AT .4 : COL
LOCATE VALUE NOWAIT(10),RANGE -1 TO 0,AT -.5 : XS
LOCATE VALUE NOWAIT(11),RANGE -1 TO 0,AT -.5 : YS
DO
IF SAVE=0 AND GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
END IF
FOR T=0 TO 359 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1): INTERVAL
LOCATE VALUE NOWAIT(2): RADIUS
LOCATE VALUE NOWAIT(3): POWER
LOCATE VALUE NOWAIT(4): SIZE
LOCATE VALUE NOWAIT(5): SPEED
LOCATE VALUE NOWAIT(6): ROT
LOCATE VALUE NOWAIT(7): POLYGON
LOCATE VALUE NOWAIT(8): MODE
LOCATE VALUE NOWAIT(9): COL
LOCATE VALUE NOWAIT(10): XS
LOCATE VALUE NOWAIT(11): YS
END IF
LET POLYGON=INT(POLYGON)
LET ROT=INT(ROT)
LET SPEED=INT(SPEED)
LET MODE=INT(MODE)
LET A=360/POLYGON
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
SET COLOR MIX(8) COL,COL,COL
SET WINDOW XS,XS+1,YS,YS+1
IF COL>0 THEN
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
CALL POLY(X,Y,RADIUS,8,POLYGON,ROT)
NEXT X
NEXT Y
END IF
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
IF GETKEYSTATE(32)<0 AND SAVE=0 THEN STOP
SELECT CASE MODE
CASE 1
LET L=X+Y
CASE 2
LET L=X-Y
CASE 3
IF Y=0 THEN LET L=100 ELSE LET L=X/Y
CASE 4
LET L=ABS(X)+ABS(Y)
CASE 5
LET L=SQR(X*X+Y*Y)
CASE 6
LET L=X*Y
CASE 7
LET L=MAX(X,Y)
CASE 8
LET L=MIN(X,Y)
CASE 9
LET L=X^3+Y^3
CASE 10
IF X+Y=0 THEN LET L=100 ELSE LET L=1/(X+Y)
CASE 11
IF X=0 AND Y=0 THEN LET L=0 ELSE LET L=ANGLE(X,Y)
END SELECT
LET L=L*POWER
LET XX=X+RADIUS*COS(T+ROT+L)*COS(A)/COS(A-1/POLYGON*ACOS(COS(POLYGON*(L+T))))
LET YY=Y+RADIUS*SIN(T+ROT+L)*COS(A)/COS(A-1/POLYGON*ACOS(COS(POLYGON*(L+T))))
CALL CIRCLEFULL(XX,YY,SIZE,7)
NEXT X
NEXT Y
SET DRAW MODE EXPLICIT
WAIT DELAY .05
IF SAVE<>0 THEN
LET KK=KK+1
GSAVE "IMAGE"&USING$("%%%%%",KK)&".png" !'gifアニメ用コマ
PRINT "No.";KK
END IF
SET DRAW MODE HIDDEN
CLEAR
NEXT T
LOOP UNTIL SAVE=1
END
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL SUB POLY(X,Y,R,C,N,TT)
OPTION ANGLE DEGREES
SET LINE COLOR C
LET A=360/N
FOR T=0 TO 360
LET XX=X+R*COS(T+TT)*COS(A)/COS(A-1/N*ACOS(COS(N*T)))
LET YY=Y+R*SIN(T+TT)*COS(A)/COS(A-1/N*ACOS(COS(N*T)))
PLOT LINES:XX,YY;
NEXT T
PLOT LINES
END SUB
OPTION ANGLE DEGREES
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LOCATE VALUE NOWAIT(1),RANGE .01 TO 1,AT .1: INTERVAL
LOCATE VALUE NOWAIT(2),RANGE .01 TO .5,AT .05 : RADIUS
LOCATE VALUE NOWAIT(3),RANGE 1 TO 1000,AT 500 : POWER
LOCATE VALUE NOWAIT(4),RANGE .001 TO .1,AT .01 : SIZE
LOCATE VALUE NOWAIT(5),RANGE 0 TO 359,AT 0 : ROT
LOCATE VALUE NOWAIT(6),RANGE 1 TO 30,AT 10 : SPEED
LOCATE VALUE NOWAIT(7),RANGE 1 TO 10,AT 1 : N
LOCATE VALUE NOWAIT(8),RANGE 1 TO 10,AT 2 : M
LOCATE VALUE NOWAIT(9),RANGE 1 TO 11,AT 1 : MODE
LOCATE VALUE NOWAIT(10),RANGE 0 TO 1,AT .4 : COL
LOCATE VALUE NOWAIT(11),RANGE -1 TO 0,AT -.5 : XS
LOCATE VALUE NOWAIT(12),RANGE -1 TO 0,AT -.5 : YS
DO
IF SAVE=0 AND GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
END IF
FOR T=0 TO 359 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1): INTERVAL
LOCATE VALUE NOWAIT(2): RADIUS
LOCATE VALUE NOWAIT(3): POWER
LOCATE VALUE NOWAIT(4): SIZE
LOCATE VALUE NOWAIT(5): ROT
LOCATE VALUE NOWAIT(6): SPEED
LOCATE VALUE NOWAIT(7): N
LOCATE VALUE NOWAIT(8): M
LOCATE VALUE NOWAIT(9): MODE
LOCATE VALUE NOWAIT(10): COL
LOCATE VALUE NOWAIT(11): XS
LOCATE VALUE NOWAIT(12): YS
END IF
LET ROT=INT(ROT)
LET SPEED=INT(SPEED)
LET N=INT(N)
LET M=INT(M)
LET MODE=INT(MODE)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
SET COLOR MIX(8) COL,COL,COL
SET WINDOW XS,XS+1,YS,YS+1
IF COL>0 THEN
SET LINE COLOR 8
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
PLOT LINES
FOR THETA=0 TO 360
LET XX=X+RADIUS*COS(N*THETA+ROT)
LET YY=Y+RADIUS*SIN(M*THETA+ROT)
PLOT LINES:XX,YY;
NEXT THETA
NEXT X
NEXT Y
END IF
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
IF GETKEYSTATE(32)<0 AND SAVE=0 THEN STOP
SELECT CASE MODE
CASE 1
LET L=X+Y
CASE 2
LET L=X-Y
CASE 3
IF Y=0 THEN LET L=100 ELSE LET L=X/Y
CASE 4
LET L=ABS(X)+ABS(Y)
CASE 5
LET L=SQR(X*X+Y*Y)
CASE 6
LET L=X*Y
CASE 7
LET L=MAX(X,Y)
CASE 8
LET L=MIN(X,Y)
CASE 9
LET L=X^3+Y^3
CASE 10
IF X+Y=0 THEN LET L=100 ELSE LET L=1/(X+Y)
CASE 11
IF X=0 AND Y=0 THEN LET L=0 ELSE LET L=ANGLE(X,Y)
END SELECT
LET L=L*POWER
LET XX=X+RADIUS*COS(N*(T+L)+ROT)
LET YY=Y+RADIUS*SIN(M*(T+L)+ROT)
CALL CIRCLEFULL(XX,YY,SIZE,7)
NEXT X
NEXT Y
SET DRAW MODE EXPLICIT
WAIT DELAY .05
IF SAVE<>0 THEN
LET KK=KK+1
GSAVE "IMAGE"&USING$("%%%%%",KK)&".png" !'gifアニメ用コマ
PRINT "No.";KK
END IF
SET DRAW MODE HIDDEN
CLEAR
NEXT T
LOOP UNTIL SAVE=1
END
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
OPTION ANGLE DEGREES
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
LOCATE VALUE NOWAIT(1),RANGE .01 TO 1,AT .1: INTERVAL
LOCATE VALUE NOWAIT(2),RANGE .01 TO .5,AT .1 : RADIUS
LOCATE VALUE NOWAIT(3),RANGE .01 TO .5,AT .01 : RADIUS2
LOCATE VALUE NOWAIT(4),RANGE 1 TO 20,AT 5 : CYCLE
LOCATE VALUE NOWAIT(5),RANGE 1 TO 1000,AT 500 : POWER
LOCATE VALUE NOWAIT(6),RANGE .001 TO .1,AT .01: SIZE
LOCATE VALUE NOWAIT(7),RANGE 1 TO 30,AT 10 : SPEED
LOCATE VALUE NOWAIT(8),RANGE 0 TO 360,AT 0 : ROT
LOCATE VALUE NOWAIT(9),RANGE 1 TO 11,AT 1 : MODE
LOCATE VALUE NOWAIT(10),RANGE 0 TO 1,AT .4 : COL
LOCATE VALUE NOWAIT(11),RANGE -1 TO 0,AT -.5 : XS
LOCATE VALUE NOWAIT(12),RANGE -1 TO 0,AT -.5 : YS
DO
IF SAVE=0 AND GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
END IF
FOR T=0 TO 359 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1): INTERVAL
LOCATE VALUE NOWAIT(2): RADIUS
LOCATE VALUE NOWAIT(3): RADIUS2
LOCATE VALUE NOWAIT(4): CYCLE
LOCATE VALUE NOWAIT(5): POWER
LOCATE VALUE NOWAIT(6): SIZE
LOCATE VALUE NOWAIT(7): SPEED
LOCATE VALUE NOWAIT(8): ROT
LOCATE VALUE NOWAIT(9): MODE
LOCATE VALUE NOWAIT(10): COL
LOCATE VALUE NOWAIT(11): XS
LOCATE VALUE NOWAIT(12): YS
END IF
LET MODE=INT(MODE)
LET SPEED=INT(SPEED)
LET CYCLE=INT(CYCLE)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
SET COLOR MIX(8) COL,COL,COL
SET WINDOW XS,XS+1,YS,YS+1
IF COL>0 THEN
SET LINE COLOR 8
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
PLOT LINES
FOR THETA=0 TO 360
LET XX=X+(RADIUS+RADIUS2*SIN(CYCLE*THETA))*COS(THETA+ROT)
LET YY=Y+(RADIUS+RADIUS2*SIN(CYCLE*THETA))*SIN(THETA+ROT)
PLOT LINES:XX,YY;
NEXT THETA
NEXT X
NEXT Y
END IF
FOR Y=YS TO YS+1 STEP INTERVAL
FOR X=XS TO XS+1 STEP INTERVAL
IF GETKEYSTATE(32)<0 AND SAVE=0 THEN STOP
SELECT CASE MODE
CASE 1
LET L=X+Y
CASE 2
LET L=X-Y
CASE 3
IF Y=0 THEN LET L=100 ELSE LET L=X/Y
CASE 4
LET L=ABS(X)+ABS(Y)
CASE 5
LET L=SQR(X*X+Y*Y)
CASE 6
LET L=X*Y
CASE 7
LET L=MAX(X,Y)
CASE 8
LET L=MIN(X,Y)
CASE 9
LET L=X^3+Y^3
CASE 10
IF X+Y=0 THEN LET L=100 ELSE LET L=1/(X+Y)
CASE 11
IF X=0 AND Y=0 THEN LET L=0 ELSE LET L=ANGLE(X,Y)
END SELECT
LET L=L*POWER
LET XX=X+(RADIUS+RADIUS2*SIN(CYCLE*(L+T)))*COS(L+T+ROT)
LET YY=Y+(RADIUS+RADIUS2*SIN(CYCLE*(L+T)))*SIN(L+T+ROT)
CALL CIRCLEFULL(XX,YY,SIZE,7)
NEXT X
NEXT Y
SET DRAW MODE EXPLICIT
WAIT DELAY .05
IF SAVE<>0 THEN
LET KK=KK+1
GSAVE "IMAGE"&USING$("%%%%%",KK)&".png" !'gifアニメ用コマ
PRINT "No.";KK
END IF
SET DRAW MODE HIDDEN
CLEAR
NEXT T
LOOP UNTIL SAVE=1
END
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
SET WINDOW -1,1,-1,1
LOCATE VALUE NOWAIT(1),RANGE 1 TO 7,AT 2:V
LOCATE VALUE NOWAIT(2),RANGE 1 TO 20,AT 3.01:ST
LOCATE VALUE NOWAIT(3),RANGE 1 TO 10,AT 2.01:SPEED
LOCATE VALUE NOWAIT(4),RANGE 1 TO 20,AT 4:ST2
DO
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "画像セーブ中..."
END IF
FOR TTT=0 TO 360/INT(ST)-1 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1):V
LOCATE VALUE NOWAIT(2):ST
LOCATE VALUE NOWAIT(3):SPEED
LOCATE VALUE NOWAIT(4):ST2
IF GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0 THEN STOP
LET V=INT(V)
LET ST=INT(ST)
LET ST2=INT(ST2)
LET SPEED=INT(SPEED)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
END IF
SET DRAW MODE HIDDEN
CLEAR
FOR TT=TTT TO TTT+359 STEP 360/ST
FOR T=0 TO 359 STEP ST2
CALL LINE(COS(T),SIN(T),COS(TT+V*T),SIN(TT+V*T),7)
NEXT T
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET K=K+1
PRINT "image";USING$("%%%%%",K);".png"
GSAVE "image" & USING$("%%%%%",K) & ".png" !'gifアニメ用コマ(最大360コマ)
END IF
WAIT DELAY .05
NEXT TTT
LOOP UNTIL SAVE=1
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET LINE COLOR C
PLOT LINES:XS,YS;XE,YE
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
SET WINDOW -1,1,-1,1
LOCATE VALUE NOWAIT(1),RANGE 1 TO 7,AT 2:V
LOCATE VALUE NOWAIT(2),RANGE 1 TO 20,AT 3.01:ST
LOCATE VALUE NOWAIT(3),RANGE 1 TO 10,AT 2.01:SPEED
LOCATE VALUE NOWAIT(4),RANGE 1 TO 20,AT 3.01:ST2
LOCATE VALUE NOWAIT(5),RANGE 3 TO 10,AT 3:POLYGON
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT .201:ROT
LOCATE VALUE NOWAIT(7),RANGE 0 TO 359,AT 0:ROT2
DO
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "画像セーブ中..."
END IF
FOR TTT=0 TO 360/INT(ST)-1 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1):V
LOCATE VALUE NOWAIT(2):ST
LOCATE VALUE NOWAIT(3):SPEED
LOCATE VALUE NOWAIT(4):ST2
LOCATE VALUE NOWAIT(5):POLYGON
LOCATE VALUE NOWAIT(6):ROT
LOCATE VALUE NOWAIT(7):ROT2
IF GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0 THEN STOP
LET V=INT(V)
LET ST=INT(ST)
LET ST2=INT(ST2)
LET SPEED=INT(SPEED)
LET ROT2=INT(ROT2)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
LET POLYGON=INT(POLYGON)
LET ROT=ROUND(ROT,2)
LET A=360/POLYGON
END IF
SET DRAW MODE HIDDEN
CLEAR
FOR TT=TTT TO TTT+359 STEP 360/ST
LET TH=MOD(TH+ROT+360,360)
FOR T=0 TO 359 STEP ST2
LET X1=COS(T+TH+ROT2)*COS(A/2)/COS(A*(T/A-IP(T/A))-A/2)
LET Y1=SIN(T+TH+ROT2)*COS(A/2)/COS(A*(T/A-IP(T/A))-A/2)
LET X2=COS(TT+V*T+TH+ROT2)*COS(A/2)/COS(A*((TT+V*T)/A-IP((TT+V*T)/A))-A/2)
LET Y2=SIN(TT+V*T+TH+ROT2)*COS(A/2)/COS(A*((TT+V*T)/A-IP((TT+V*T)/A))-A/2)
CALL LINE(X1,Y1,X2,Y2,7)
NEXT T
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET K=K+1
PRINT "image";USING$("%%%%%",K);".png"
GSAVE "image" & USING$("%%%%%",K) & ".png" !'gifアニメ用コマ
END IF
WAIT DELAY .05
NEXT TTT
LOOP UNTIL SAVE=1
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET LINE COLOR C
PLOT LINES:XS,YS;XE,YE
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
SET WINDOW -1,1,-1,1
LOCATE VALUE NOWAIT(1),RANGE 1 TO 7,AT 1:V
LOCATE VALUE NOWAIT(2),RANGE 1 TO 20,AT 1:ST
LOCATE VALUE NOWAIT(3),RANGE 1 TO 10,AT 2.01:SPEED
LOCATE VALUE NOWAIT(4),RANGE 1 TO 20,AT 1:ST2
LOCATE VALUE NOWAIT(5),RANGE 5 TO 10,AT 5:POLYGON
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT .2:ROT
LOCATE VALUE NOWAIT(7),RANGE 0 TO 359,AT 0:ROT2
DO
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "画像セーブ中..."
END IF
FOR TTT=0 TO 360/INT(ST)-1 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1):V
LOCATE VALUE NOWAIT(2):ST
LOCATE VALUE NOWAIT(3):SPEED
LOCATE VALUE NOWAIT(4):ST2
LOCATE VALUE NOWAIT(5):POLYGON
LOCATE VALUE NOWAIT(6):ROT
LOCATE VALUE NOWAIT(7):ROT2
IF GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0 THEN STOP
LET V=INT(V)
LET ST=INT(ST)
LET ST2=INT(ST2)
LET SPEED=INT(SPEED)
LET ROT2=INT(ROT2)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
LET POLYGON=INT(POLYGON)
LET ROT=ROUND(ROT,2)
LET A=360/POLYGON
END IF
SET DRAW MODE HIDDEN
CLEAR
FOR TT=TTT TO TTT+359 STEP 360/ST
LET TH=MOD(TH+ROT+360,360)
FOR T=0 TO 359 STEP ST2
LET X1=COS(T+TH+ROT2)*COS(A)/COS(A-1/POLYGON*ACOS(COS(POLYGON*T)))
LET Y1=SIN(T+TH+ROT2)*COS(A)/COS(A-1/POLYGON*ACOS(COS(POLYGON*T)))
LET X2=COS(TT+V*T+TH+ROT2)*COS(A)/COS(A-1/POLYGON*ACOS(COS(POLYGON*(TT+V*T))))
LET Y2=SIN(TT+V*T+TH+ROT2)*COS(A)/COS(A-1/POLYGON*ACOS(COS(POLYGON*(TT+V*T))))
CALL LINE(X1,Y1,X2,Y2,7)
NEXT T
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET K=K+1
PRINT "image";USING$("%%%%%",K);".png"
GSAVE "image" & USING$("%%%%%",K) & ".png" !'gifアニメ用コマ
END IF
WAIT DELAY .05
NEXT TTT
LOOP UNTIL SAVE=1
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET LINE COLOR C
PLOT LINES:XS,YS;XE,YE
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
SET WINDOW -1,1,-1,1
LOCATE VALUE NOWAIT(1),RANGE 1 TO 7,AT 2:V
LOCATE VALUE NOWAIT(2),RANGE 1 TO 20,AT 3.01:ST
LOCATE VALUE NOWAIT(3),RANGE 1 TO 10,AT 2.01:SPEED
LOCATE VALUE NOWAIT(4),RANGE 1 TO 20,AT 4:ST2
LOCATE VALUE NOWAIT(5),RANGE .1 TO 1,AT .8:R
LOCATE VALUE NOWAIT(6),RANGE 0 TO 1,AT .2:R1
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT 3:N
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT .2:ROT
LOCATE VALUE NOWAIT(9),RANGE 0 TO 359,AT 0:ROT2
DO
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "画像セーブ中..."
END IF
FOR TTT=0 TO 360/INT(ST)-1 STEP SPEED
IF SAVE=0 THEN
LOCATE VALUE NOWAIT(1):V
LOCATE VALUE NOWAIT(2):ST
LOCATE VALUE NOWAIT(3):SPEED
LOCATE VALUE NOWAIT(4):ST2
LOCATE VALUE NOWAIT(5):R
LOCATE VALUE NOWAIT(6):R1
LOCATE VALUE NOWAIT(7):N
LOCATE VALUE NOWAIT(8):ROT
LOCATE VALUE NOWAIT(9):ROT2
IF GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0 THEN STOP
LET V=INT(V)
LET ST=INT(ST)
LET ST2=INT(ST2)
LET SPEED=INT(SPEED)
LET ROT2=INT(ROT2)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
LET N=INT(N)
LET ROT=ROUND(ROT,2)
END IF
SET DRAW MODE HIDDEN
CLEAR
FOR TT=TTT TO TTT+359 STEP 360/ST
LET TH=MOD(TH+ROT+360,360)
FOR T=0 TO 359 STEP ST2
LET X1=(R+R1*SIN(N*T+TH+ROT2))*COS(T+TH+ROT2)
LET Y1=(R+R1*SIN(N*T+TH+ROT2))*SIN(T+TH+ROT2)
LET X2=(R+R1*SIN(N*(TT+V*T)+TH+ROT2))*COS(TT+V*T+TH+ROT2)
LET Y2=(R+R1*SIN(N*(TT+V*T)+TH+ROT2))*SIN(TT+V*T+TH+ROT2)
CALL LINE(X1,Y1,X2,Y2,7)
NEXT T
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET K=K+1
PRINT "image";USING$("%%%%%",K);".png"
GSAVE "image" & USING$("%%%%%",K) & ".png" !'gifアニメ用コマ
END IF
WAIT DELAY .05
NEXT TTT
LOOP UNTIL SAVE=1
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET LINE COLOR C
PLOT LINES:XS,YS;XE,YE
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
DIM C(8),T(8),R(8),CL(10),M(8),S(8),L(10)
MAT READ C
READ CYCLE1,CYCLE2,CYCLE3,CYCLE4,CYCLE5,CYCLE6,CYCLE7,CYCLE8 !'周期初期値
DATA 1,2,3,4,5,6,7,8
DATA 1,2,3,4,5,6,7,8
MAT READ R
READ RADIUS1,RADIUS2,RADIUS3,RADIUS4,RADIUS5,RADIUS6,RADIUS7,RADIUS8 !'半径初期値
DATA 1,.5,0,0,0,0,0,0
DATA 1,.5,0,0,0,0,0,0
MAT READ CL
READ COL1,COL2,COL3,COL4,COL5,COL6,COL7,COL8,COL9,COL10 !'色初期値
DATA 1,2,3,4,8,9,10,11,5.5,7.5
DATA 1,2,3,4,8,9,10,11,5.5,7.5
MAT READ S
READ SIGN1,SIGN2,SIGN3,SIGN4,SIGN5,SIGN6,SIGN7,SIGN8 !'回転向き初期値
DATA 1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1
MAT READ L
READ WID1,WID2,WID3,WID4,WID5,WID6,WID7,WID8,WID9,WID10 !'ラインの太さ初期値
DATA 1,1,1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1,1,1
LET SP=3.01
LET SPEED=SP !'速度初期値
LET SC=4.01
LET SCALE=SC !'ウィンドウ初期値
LET KEY$="CRTKMXW"
DO
FOR TH=0 TO 359 STEP SPEED
IF SAVE=0 THEN
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
EXIT FOR
END IF
FOR I=1 TO LEN(KEY$)
IF GETKEYSTATE(ORD(KEY$(I:I)))<0 THEN
LET PAGE=I-1
LET FLG=0
EXIT FOR
END IF
NEXT I
IF GETKEYSTATE(27)<0 THEN STOP
IF GETKEYSTATE(32)<0 THEN
DO
LOOP WHILE GETKEYSTATE(32)<0
LET PAGE=MOD(PAGE+1,LEN(KEY$))
LET FLG=0
END IF
SELECT CASE PAGE
CASE 0 !'周期
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 20,AT C(1):CYCLE1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 20,AT C(2):CYCLE2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT C(3):CYCLE3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT C(4):CYCLE4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT C(5):CYCLE5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT C(6):CYCLE6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT C(7):CYCLE7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 20,AT C(8):CYCLE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):CYCLE1
LOCATE VALUE NOWAIT(2):CYCLE2
LOCATE VALUE NOWAIT(3):CYCLE3
LOCATE VALUE NOWAIT(4):CYCLE4
LOCATE VALUE NOWAIT(5):CYCLE5
LOCATE VALUE NOWAIT(6):CYCLE6
LOCATE VALUE NOWAIT(7):CYCLE7
LOCATE VALUE NOWAIT(8):CYCLE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET C(1)=CYCLE1
LET C(2)=CYCLE2
LET C(3)=CYCLE3
LET C(4)=CYCLE4
LET C(5)=CYCLE5
LET C(6)=CYCLE6
LET C(7)=CYCLE7
LET C(8)=CYCLE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 1 !'半径
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 1,AT R(1):RADIUS1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 1,AT R(2):RADIUS2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 1,AT R(3):RADIUS3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 1,AT R(4):RADIUS4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 1,AT R(5):RADIUS5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 1,AT R(6):RADIUS6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 1,AT R(7):RADIUS7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 1,AT R(8):RADIUS8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):RADIUS1
LOCATE VALUE NOWAIT(2):RADIUS2
LOCATE VALUE NOWAIT(3):RADIUS3
LOCATE VALUE NOWAIT(4):RADIUS4
LOCATE VALUE NOWAIT(5):RADIUS5
LOCATE VALUE NOWAIT(6):RADIUS6
LOCATE VALUE NOWAIT(7):RADIUS7
LOCATE VALUE NOWAIT(8):RADIUS8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET R(1)=RADIUS1
LET R(2)=RADIUS2
LET R(3)=RADIUS3
LET R(4)=RADIUS4
LET R(5)=RADIUS5
LET R(6)=RADIUS6
LET R(7)=RADIUS7
LET R(8)=RADIUS8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 2 !'開始角度
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 359,AT T(1):ROT1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 359,AT T(2):ROT2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 359,AT T(3):ROT3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 359,AT T(4):ROT4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 359,AT T(5):ROT5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 359,AT T(6):ROT6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 359,AT T(7):ROT7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 359,AT T(8):ROT8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):ROT1
LOCATE VALUE NOWAIT(2):ROT2
LOCATE VALUE NOWAIT(3):ROT3
LOCATE VALUE NOWAIT(4):ROT4
LOCATE VALUE NOWAIT(5):ROT5
LOCATE VALUE NOWAIT(6):ROT6
LOCATE VALUE NOWAIT(7):ROT7
LOCATE VALUE NOWAIT(8):ROT8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET T(1)=ROT1
LET T(2)=ROT2
LET T(3)=ROT3
LET T(4)=ROT4
LET T(5)=ROT5
LET T(6)=ROT6
LET T(7)=ROT7
LET T(8)=ROT8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 3 !'色
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 255,AT CL(1):COL1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT CL(2):COL2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 255,AT CL(3):COL3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 255,AT CL(4):COL4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 255,AT CL(5):COL5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 255,AT CL(6):COL6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 255,AT CL(7):COL7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 255,AT CL(8):COL8
LOCATE VALUE NOWAIT(9),RANGE 0 TO 255,AT CL(9):COL9
LOCATE VALUE NOWAIT(10),RANGE 0 TO 255,AT CL(10):COL10
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):COL1
LOCATE VALUE NOWAIT(2):COL2
LOCATE VALUE NOWAIT(3):COL3
LOCATE VALUE NOWAIT(4):COL4
LOCATE VALUE NOWAIT(5):COL5
LOCATE VALUE NOWAIT(6):COL6
LOCATE VALUE NOWAIT(7):COL7
LOCATE VALUE NOWAIT(8):COL8
LOCATE VALUE NOWAIT(9):COL9
LOCATE VALUE NOWAIT(10):COL10
LET CL(1)=COL1
LET CL(2)=COL2
LET CL(3)=COL3
LET CL(4)=COL4
LET CL(5)=COL5
LET CL(6)=COL6
LET CL(7)=COL7
LET CL(8)=COL8
LET CL(9)=COL9
LET CL(10)=COL10
END IF
CASE 4 !'平行移動
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT M(1):MOVE1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT M(2):MOVE2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT M(3):MOVE3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT M(4):MOVE4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT M(5):MOVE5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT M(6):MOVE6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT M(7):MOVE7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT M(8):MOVE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):MOVE1
LOCATE VALUE NOWAIT(2):MOVE2
LOCATE VALUE NOWAIT(3):MOVE3
LOCATE VALUE NOWAIT(4):MOVE4
LOCATE VALUE NOWAIT(5):MOVE5
LOCATE VALUE NOWAIT(6):MOVE6
LOCATE VALUE NOWAIT(7):MOVE7
LOCATE VALUE NOWAIT(8):MOVE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET M(1)=MOVE1
LET M(2)=MOVE2
LET M(3)=MOVE3
LET M(4)=MOVE4
LET M(5)=MOVE5
LET M(6)=MOVE6
LET M(7)=MOVE7
LET M(8)=MOVE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 5 !'回転の向き
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT S(1):SIGN1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT S(2):SIGN2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT S(3):SIGN3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT S(4):SIGN4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT S(5):SIGN5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT S(6):SIGN6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT S(7):SIGN7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT S(8):SIGN8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):SIGN1
LOCATE VALUE NOWAIT(2):SIGN2
LOCATE VALUE NOWAIT(3):SIGN3
LOCATE VALUE NOWAIT(4):SIGN4
LOCATE VALUE NOWAIT(5):SIGN5
LOCATE VALUE NOWAIT(6):SIGN6
LOCATE VALUE NOWAIT(7):SIGN7
LOCATE VALUE NOWAIT(8):SIGN8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET S(1)=SIGN1
LET S(2)=SIGN2
LET S(3)=SIGN3
LET S(4)=SIGN4
LET S(5)=SIGN5
LET S(6)=SIGN6
LET S(7)=SIGN7
LET S(8)=SIGN8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 6 !'ラインの太さ
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT L(1):WID1
LOCATE VALUE NOWAIT(2),RANGE 1 TO 10,AT L(2):WID2
LOCATE VALUE NOWAIT(3),RANGE 1 TO 10,AT L(3):WID3
LOCATE VALUE NOWAIT(4),RANGE 1 TO 10,AT L(4):WID4
LOCATE VALUE NOWAIT(5),RANGE 1 TO 10,AT L(5):WID5
LOCATE VALUE NOWAIT(6),RANGE 1 TO 10,AT L(6):WID6
LOCATE VALUE NOWAIT(7),RANGE 1 TO 10,AT L(7):WID7
LOCATE VALUE NOWAIT(8),RANGE 1 TO 10,AT L(8):WID8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 10,AT L(9):WID9
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT L(10):WID10
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):WID1
LOCATE VALUE NOWAIT(2):WID2
LOCATE VALUE NOWAIT(3):WID3
LOCATE VALUE NOWAIT(4):WID4
LOCATE VALUE NOWAIT(5):WID5
LOCATE VALUE NOWAIT(6):WID6
LOCATE VALUE NOWAIT(7):WID7
LOCATE VALUE NOWAIT(8):WID8
LOCATE VALUE NOWAIT(9):WID9
LOCATE VALUE NOWAIT(10):WID10
LET L(1)=WID1
LET L(2)=WID2
LET L(3)=WID3
LET L(4)=WID4
LET L(5)=WID5
LET L(6)=WID6
LET L(7)=WID7
LET L(8)=WID8
LET L(9)=WID9
LET L(10)=WID10
END IF
END SELECT
END IF
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET CYCLE1=INT(CYCLE1)
LET CYCLE2=INT(CYCLE2)
LET CYCLE3=INT(CYCLE3)
LET CYCLE4=INT(CYCLE4)
LET CYCLE5=INT(CYCLE5)
LET CYCLE6=INT(CYCLE6)
LET CYCLE7=INT(CYCLE7)
LET CYCLE8=INT(CYCLE8)
LET COL1=INT(COL1)
LET COL2=INT(COL2)
LET COL3=INT(COL3)
LET COL4=INT(COL4)
LET COL5=INT(COL5)
LET COL6=INT(COL6)
LET COL7=INT(COL7)
LET COL8=INT(COL8)
LET COL9=INT(COL9)
LET COL10=INT(COL10)
LET WID1=INT(WID1)
LET WID2=INT(WID2)
LET WID3=INT(WID3)
LET WID4=INT(WID4)
LET WID5=INT(WID5)
LET WID6=INT(WID6)
LET WID7=INT(WID7)
LET WID8=INT(WID8)
LET WID9=INT(WID9)
LET WID10=INT(WID10)
IF SIGN1>=0 THEN LET SIGN1=1 ELSE LET SIGN1=-1
IF SIGN2>=0 THEN LET SIGN2=1 ELSE LET SIGN2=-1
IF SIGN3>=0 THEN LET SIGN3=1 ELSE LET SIGN3=-1
IF SIGN4>=0 THEN LET SIGN4=1 ELSE LET SIGN4=-1
IF SIGN5>=0 THEN LET SIGN5=1 ELSE LET SIGN5=-1
IF SIGN6>=0 THEN LET SIGN6=1 ELSE LET SIGN6=-1
IF SIGN7>=0 THEN LET SIGN7=1 ELSE LET SIGN7=-1
IF SIGN8>=0 THEN LET SIGN8=1 ELSE LET SIGN8=-1
LET SPEED=INT(SPEED)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
CLEAR
SET LINE WIDTH 1
DRAW GRID
LET X1=0
LET Y1=0
LET X2=FX(RADIUS1+MOVE1,TH*SIGN1,CYCLE1,ROT1)
LET Y2=FY(RADIUS1+MOVE1,TH*SIGN1,CYCLE1,ROT1)
LET X3=X2+FX(RADIUS2+MOVE2,TH*SIGN2,CYCLE2,ROT2)
LET Y3=Y2+FY(RADIUS2+MOVE2,TH*SIGN2,CYCLE2,ROT2)
LET X4=X3+FX(RADIUS3+MOVE3,TH*SIGN3,CYCLE3,ROT3)
LET Y4=Y3+FY(RADIUS3+MOVE3,TH*SIGN3,CYCLE3,ROT3)
LET X5=X4+FX(RADIUS4+MOVE4,TH*SIGN4,CYCLE4,ROT4)
LET Y5=Y4+FY(RADIUS4+MOVE4,TH*SIGN4,CYCLE4,ROT4)
LET X6=X5+FX(RADIUS5+MOVE5,TH*SIGN5,CYCLE5,ROT5)
LET Y6=Y5+FY(RADIUS5+MOVE5,TH*SIGN5,CYCLE5,ROT5)
LET X7=X6+FX(RADIUS6+MOVE6,TH*SIGN6,CYCLE6,ROT6)
LET Y7=Y6+FY(RADIUS6+MOVE6,TH*SIGN6,CYCLE6,ROT6)
LET X8=X7+FX(RADIUS7+MOVE7,TH*SIGN7,CYCLE7,ROT7)
LET Y8=Y7+FY(RADIUS7+MOVE7,TH*SIGN7,CYCLE7,ROT7)
LET X9=X8+FX(RADIUS8+MOVE8,TH*SIGN8,CYCLE8,ROT8)
LET Y9=Y8+FY(RADIUS8+MOVE8,TH*SIGN8,CYCLE8,ROT8)
SET LINE WIDTH WID1
CALL CIRCLE(X1,Y1,RADIUS1,COL1)
SET LINE WIDTH WID2
CALL CIRCLE(X2,Y2,RADIUS2,COL2)
SET LINE WIDTH WID3
CALL CIRCLE(X3,Y3,RADIUS3,COL3)
SET LINE WIDTH WID4
CALL CIRCLE(X4,Y4,RADIUS4,COL4)
SET LINE WIDTH WID5
CALL CIRCLE(X5,Y5,RADIUS5,COL5)
SET LINE WIDTH WID6
CALL CIRCLE(X6,Y6,RADIUS6,COL6)
SET LINE WIDTH WID7
CALL CIRCLE(X7,Y7,RADIUS7,COL7)
SET LINE WIDTH WID8
CALL CIRCLE(X8,Y8,RADIUS8,COL8)
SET LINE WIDTH WID9
SET LINE COLOR COL9
PLOT LINES:X1,Y1;X2,Y2;X3,Y3;X4,Y4;X5,Y5;X6,Y6;X7,Y7;X8,Y8;X9,Y9
SET LINE COLOR COL10
PLOT LINES
SET LINE WIDTH WID10
FOR TT=0 TO TH
LET X= FX(RADIUS1+MOVE1,TT*SIGN1,CYCLE1,ROT1)+FX(RADIUS2+MOVE2,TT*SIGN2,CYCLE2,ROT2)+FX(RADIUS3+MOVE3,TT*SIGN3,CYCLE3,ROT3)+FX(RADIUS4+MOVE4,TT*SIGN4,CYCLE4,ROT4)
LET Y= FY(RADIUS1+MOVE1,TT*SIGN1,CYCLE1,ROT1)+FY(RADIUS2+MOVE2,TT*SIGN2,CYCLE2,ROT2)+FY(RADIUS3+MOVE3,TT*SIGN3,CYCLE3,ROT3)+FY(RADIUS4+MOVE4,TT*SIGN4,CYCLE4,ROT4)
LET X=X+FX(RADIUS5+MOVE5,TT*SIGN5,CYCLE5,ROT5)+FX(RADIUS6+MOVE6,TT*SIGN6,CYCLE6,ROT6)+FX(RADIUS7+MOVE7,TT*SIGN7,CYCLE7,ROT7)+FX(RADIUS8+MOVE8,TT*SIGN8,CYCLE8,ROT8)
LET Y=Y+FY(RADIUS5+MOVE5,TT*SIGN5,CYCLE5,ROT5)+FY(RADIUS6+MOVE6,TT*SIGN6,CYCLE6,ROT6)+FY(RADIUS7+MOVE7,TT*SIGN7,CYCLE7,ROT1)+FY(RADIUS8+MOVE8,TT*SIGN8,CYCLE8,ROT8)
PLOT LINES:X,Y;
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET KK=KK+1
GSAVE "image"&USING$("%%%%%",KK)&".png"
PRINT "No.";KK
END IF
WAIT DELAY .1
SET DRAW MODE HIDDEN
NEXT TH
LOOP UNTIL SAVE=1 AND TH=>359
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL SUB CIRCLE(X,Y,R,C)
SET COLOR C
DRAW CIRCLE WITH SCALE(R)*SHIFT(X,Y)
END SUB
EXTERNAL FUNCTION FX(R,T,N,ROT)
OPTION ANGLE DEGREES
LET FX=R*COS(T*N+ROT)
END FUNCTION
EXTERNAL FUNCTION FY(R,T,N,ROT)
OPTION ANGLE DEGREES
LET FY=R*SIN(T*N+ROT)
END FUNCTION
CALL GINIT(800,800)
OPTION ANGLE DEGREES
DIM C(8),T(8),R(8),P(8),CL(10),M(8),S(8)
MAT READ C
READ CYCLE1,CYCLE2,CYCLE3,CYCLE4,CYCLE5,CYCLE6,CYCLE7,CYCLE8
DATA 1,2,3,4,5,6,7,8
DATA 1,2,3,4,5,6,7,8
MAT READ R
READ RADIUS1,RADIUS2,RADIUS3,RADIUS4,RADIUS5,RADIUS6,RADIUS7,RADIUS8
DATA 1,.5,0,0,0,0,0,0
DATA 1,.5,0,0,0,0,0,0
MAT READ P
READ POLY1,POLY2,POLY3,POLY4,POLY5,POLY6,POLY7,POLY8
DATA 3,3,3,3,3,3,3,3
DATA 3,3,3,3,3,3,3,3
MAT READ CL
READ COL1,COL2,COL3,COL4,COL5,COL6,COL7,COL8,COL9,COL10
DATA 1,2,3,4,8,9,10,11,5.5,7.5
DATA 1,2,3,4,8,9,10,11,5.5,7.5
LET SP=3.01
LET SPEED=SP
LET SC=4.01
LET SCALE=SC
LET KEY$="PCRTKMX"
DO
FOR TH=0 TO 359 STEP SPEED
IF SAVE=0 THEN
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
EXIT FOR
END IF
FOR I=1 TO LEN(KEY$)
IF GETKEYSTATE(ORD(KEY$(I:I)))<0 THEN
LET PAGE=I-1
LET FLG=0
EXIT FOR
END IF
NEXT I
IF GETKEYSTATE(27)<0 THEN STOP
IF GETKEYSTATE(32)<0 THEN
DO
LOOP WHILE GETKEYSTATE(32)<0
LET PAGE=MOD(PAGE+1,7)
LET FLG=0
END IF
SELECT CASE PAGE
CASE 0 !'角数
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 2 TO 10,AT P(1):POLY1
LOCATE VALUE NOWAIT(2),RANGE 2 TO 10,AT P(2):POLY2
LOCATE VALUE NOWAIT(3),RANGE 2 TO 10,AT P(3):POLY3
LOCATE VALUE NOWAIT(4),RANGE 2 TO 10,AT P(4):POLY4
LOCATE VALUE NOWAIT(5),RANGE 2 TO 10,AT P(5):POLY5
LOCATE VALUE NOWAIT(6),RANGE 2 TO 10,AT P(6):POLY6
LOCATE VALUE NOWAIT(7),RANGE 2 TO 10,AT P(7):POLY7
LOCATE VALUE NOWAIT(8),RANGE 2 TO 10,AT P(8):POLY8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):POLY1
LOCATE VALUE NOWAIT(2):POLY2
LOCATE VALUE NOWAIT(3):POLY3
LOCATE VALUE NOWAIT(4):POLY4
LOCATE VALUE NOWAIT(5):POLY5
LOCATE VALUE NOWAIT(6):POLY6
LOCATE VALUE NOWAIT(7):POLY7
LOCATE VALUE NOWAIT(8):POLY8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET P(1)=POLY1
LET P(2)=POLY2
LET P(3)=POLY3
LET P(4)=POLY4
LET P(5)=POLY5
LET P(6)=POLY6
LET P(7)=POLY7
LET P(8)=POLY8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 1 !'周期
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 20,AT C(1):CYCLE1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 20,AT C(2):CYCLE2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT C(3):CYCLE3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT C(4):CYCLE4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT C(5):CYCLE5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT C(6):CYCLE6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT C(7):CYCLE7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 20,AT C(8):CYCLE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):CYCLE1
LOCATE VALUE NOWAIT(2):CYCLE2
LOCATE VALUE NOWAIT(3):CYCLE3
LOCATE VALUE NOWAIT(4):CYCLE4
LOCATE VALUE NOWAIT(5):CYCLE5
LOCATE VALUE NOWAIT(6):CYCLE6
LOCATE VALUE NOWAIT(7):CYCLE7
LOCATE VALUE NOWAIT(8):CYCLE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET C(1)=CYCLE1
LET C(2)=CYCLE2
LET C(3)=CYCLE3
LET C(4)=CYCLE4
LET C(5)=CYCLE5
LET C(6)=CYCLE6
LET C(7)=CYCLE7
LET C(8)=CYCLE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 2 !'半径
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 1,AT R(1):RADIUS1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 1,AT R(2):RADIUS2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 1,AT R(3):RADIUS3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 1,AT R(4):RADIUS4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 1,AT R(5):RADIUS5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 1,AT R(6):RADIUS6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 1,AT R(7):RADIUS7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 1,AT R(8):RADIUS8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):RADIUS1
LOCATE VALUE NOWAIT(2):RADIUS2
LOCATE VALUE NOWAIT(3):RADIUS3
LOCATE VALUE NOWAIT(4):RADIUS4
LOCATE VALUE NOWAIT(5):RADIUS5
LOCATE VALUE NOWAIT(6):RADIUS6
LOCATE VALUE NOWAIT(7):RADIUS7
LOCATE VALUE NOWAIT(8):RADIUS8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET R(1)=RADIUS1
LET R(2)=RADIUS2
LET R(3)=RADIUS3
LET R(4)=RADIUS4
LET R(5)=RADIUS5
LET R(6)=RADIUS6
LET R(7)=RADIUS7
LET R(8)=RADIUS8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 3 !'開始角度
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 359,AT T(1):ROT1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 359,AT T(2):ROT2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 359,AT T(3):ROT3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 359,AT T(4):ROT4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 359,AT T(5):ROT5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 359,AT T(6):ROT6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 359,AT T(7):ROT7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 359,AT T(8):ROT8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):ROT1
LOCATE VALUE NOWAIT(2):ROT2
LOCATE VALUE NOWAIT(3):ROT3
LOCATE VALUE NOWAIT(4):ROT4
LOCATE VALUE NOWAIT(5):ROT5
LOCATE VALUE NOWAIT(6):ROT6
LOCATE VALUE NOWAIT(7):ROT7
LOCATE VALUE NOWAIT(8):ROT8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET T(1)=ROT1
LET T(2)=ROT2
LET T(3)=ROT3
LET T(4)=ROT4
LET T(5)=ROT5
LET T(6)=ROT6
LET T(7)=ROT7
LET T(8)=ROT8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 4 !'色
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 255,AT CL(1):COL1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT CL(2):COL2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 255,AT CL(3):COL3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 255,AT CL(4):COL4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 255,AT CL(5):COL5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 255,AT CL(6):COL6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 255,AT CL(7):COL7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 255,AT CL(8):COL8
LOCATE VALUE NOWAIT(9),RANGE 0 TO 255,AT CL(9):COL9
LOCATE VALUE NOWAIT(10),RANGE 0 TO 255,AT CL(10):COL10
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):COL1
LOCATE VALUE NOWAIT(2):COL2
LOCATE VALUE NOWAIT(3):COL3
LOCATE VALUE NOWAIT(4):COL4
LOCATE VALUE NOWAIT(5):COL5
LOCATE VALUE NOWAIT(6):COL6
LOCATE VALUE NOWAIT(7):COL7
LOCATE VALUE NOWAIT(8):COL8
LOCATE VALUE NOWAIT(9):COL9
LOCATE VALUE NOWAIT(10):COL10
LET CL(1)=COL1
LET CL(2)=COL2
LET CL(3)=COL3
LET CL(4)=COL4
LET CL(5)=COL5
LET CL(6)=COL6
LET CL(7)=COL7
LET CL(8)=COL8
LET CL(9)=COL9
LET CL(10)=COL10
END IF
CASE 5 !'平行移動
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT M(1):MOVE1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT M(2):MOVE2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT M(3):MOVE3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT M(4):MOVE4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT M(5):MOVE5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT M(6):MOVE6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT M(7):MOVE7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT M(8):MOVE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):MOVE1
LOCATE VALUE NOWAIT(2):MOVE2
LOCATE VALUE NOWAIT(3):MOVE3
LOCATE VALUE NOWAIT(4):MOVE4
LOCATE VALUE NOWAIT(5):MOVE5
LOCATE VALUE NOWAIT(6):MOVE6
LOCATE VALUE NOWAIT(7):MOVE7
LOCATE VALUE NOWAIT(8):MOVE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET M(1)=MOVE1
LET M(2)=MOVE2
LET M(3)=MOVE3
LET M(4)=MOVE4
LET M(5)=MOVE5
LET M(6)=MOVE6
LET M(7)=MOVE7
LET M(8)=MOVE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 6 !'回転の向き
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT S(1):SIGN1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT S(2):SIGN2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT S(3):SIGN3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT S(4):SIGN4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT S(5):SIGN5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT S(6):SIGN6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT S(7):SIGN7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT S(8):SIGN8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):SIGN1
LOCATE VALUE NOWAIT(2):SIGN2
LOCATE VALUE NOWAIT(3):SIGN3
LOCATE VALUE NOWAIT(4):SIGN4
LOCATE VALUE NOWAIT(5):SIGN5
LOCATE VALUE NOWAIT(6):SIGN6
LOCATE VALUE NOWAIT(7):SIGN7
LOCATE VALUE NOWAIT(8):SIGN8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET S(1)=SIGN1
LET S(2)=SIGN2
LET S(3)=SIGN3
LET S(4)=SIGN4
LET S(5)=SIGN5
LET S(6)=SIGN6
LET S(7)=SIGN7
LET S(8)=SIGN8
LET SP=SPEED
LET SC=SCALE
END IF
END SELECT
END IF
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET POLY1=INT(POLY1)
LET POLY2=INT(POLY2)
LET POLY3=INT(POLY3)
LET POLY4=INT(POLY4)
LET POLY5=INT(POLY5)
LET POLY6=INT(POLY6)
LET POLY7=INT(POLY7)
LET POLY8=INT(POLY8)
LET CYCLE1=INT(CYCLE1)
LET CYCLE2=INT(CYCLE2)
LET CYCLE3=INT(CYCLE3)
LET CYCLE4=INT(CYCLE4)
LET CYCLE5=INT(CYCLE5)
LET CYCLE6=INT(CYCLE6)
LET CYCLE7=INT(CYCLE7)
LET CYCLE8=INT(CYCLE8)
LET COL1=INT(COL1)
LET COL2=INT(COL2)
LET COL3=INT(COL3)
LET COL4=INT(COL4)
LET COL5=INT(COL5)
LET COL6=INT(COL6)
LET COL7=INT(COL7)
LET COL8=INT(COL8)
LET COL9=INT(COL9)
LET COL10=INT(COL10)
IF SIGN1>=0 THEN LET SIGN1=1 ELSE LET SIGN1=-1
IF SIGN2>=0 THEN LET SIGN2=1 ELSE LET SIGN2=-1
IF SIGN3>=0 THEN LET SIGN3=1 ELSE LET SIGN3=-1
IF SIGN4>=0 THEN LET SIGN4=1 ELSE LET SIGN4=-1
IF SIGN5>=0 THEN LET SIGN5=1 ELSE LET SIGN5=-1
IF SIGN6>=0 THEN LET SIGN6=1 ELSE LET SIGN6=-1
IF SIGN7>=0 THEN LET SIGN7=1 ELSE LET SIGN7=-1
IF SIGN8>=0 THEN LET SIGN8=1 ELSE LET SIGN8=-1
LET SPEED=INT(SPEED)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
CLEAR
DRAW GRID
LET X1=0
LET Y1=0
LET X2=FX(POLY1,CYCLE1,RADIUS1+MOVE1,TH*SIGN1,ROT1)
LET Y2=FY(POLY1,CYCLE1,RADIUS1+MOVE1,TH*SIGN1,ROT1)
LET X3=X2+FX(POLY2,CYCLE2,RADIUS2+MOVE2,TH*SIGN2,ROT2)
LET Y3=Y2+FY(POLY2,CYCLE2,RADIUS2+MOVE2,TH*SIGN2,ROT2)
LET X4=X3+FX(POLY3,CYCLE3,RADIUS3+MOVE3,TH*SIGN3,ROT3)
LET Y4=Y3+FY(POLY3,CYCLE3,RADIUS3+MOVE3,TH*SIGN3,ROT3)
LET X5=X4+FX(POLY4,CYCLE4,RADIUS4+MOVE4,TH*SIGN4,ROT4)
LET Y5=Y4+FY(POLY4,CYCLE4,RADIUS4+MOVE4,TH*SIGN4,ROT4)
LET X6=X5+FX(POLY5,CYCLE5,RADIUS5+MOVE5,TH*SIGN5,ROT5)
LET Y6=Y5+FY(POLY5,CYCLE5,RADIUS5+MOVE5,TH*SIGN5,ROT5)
LET X7=X6+FX(POLY6,CYCLE6,RADIUS6+MOVE6,TH*SIGN6,ROT6)
LET Y7=Y6+FY(POLY6,CYCLE6,RADIUS6+MOVE6,TH*SIGN6,ROT6)
LET X8=X7+FX(POLY7,CYCLE7,RADIUS7+MOVE7,TH*SIGN7,ROT7)
LET Y8=Y7+FY(POLY7,CYCLE7,RADIUS7+MOVE7,TH*SIGN7,ROT7)
LET X9=X8+FX(POLY8,CYCLE8,RADIUS8+MOVE8,TH*SIGN8,ROT8)
LET Y9=Y8+FY(POLY8,CYCLE8,RADIUS8+MOVE8,TH*SIGN8,ROT8)
CALL POLY(X1,Y1,RADIUS1,COL1,POLY1,ROT1)
CALL POLY(X2,Y2,RADIUS2,COL2,POLY2,ROT2)
CALL POLY(X3,Y3,RADIUS3,COL3,POLY3,ROT3)
CALL POLY(X4,Y4,RADIUS4,COL4,POLY4,ROT4)
CALL POLY(X5,Y5,RADIUS5,COL5,POLY5,ROT5)
CALL POLY(X6,Y6,RADIUS6,COL6,POLY6,ROT6)
CALL POLY(X7,Y7,RADIUS7,COL7,POLY7,ROT7)
CALL POLY(X8,Y8,RADIUS8,COL8,POLY8,ROT8)
SET LINE COLOR COL9
PLOT LINES:X1,Y1;X2,Y2;X3,Y3;X4,Y4;X5,Y5;X6,Y6;X7,Y7;X8,Y8;X9,Y9
SET LINE COLOR COL10
PLOT LINES
FOR TT=0 TO TH
LET X= FX(POLY1,CYCLE1,RADIUS1+MOVE1,TT*SIGN1,ROT1)+FX(POLY2,CYCLE2,RADIUS2+MOVE2,TT*SIGN2,ROT2)+FX(POLY3,CYCLE3,RADIUS3+MOVE3,TT*SIGN3,ROT3)+FX(POLY4,CYCLE4,RADIUS4+MOVE4,TT*SIGN4,ROT4)
LET Y= FY(POLY1,CYCLE1,RADIUS1+MOVE1,TT*SIGN1,ROT1)+FY(POLY2,CYCLE2,RADIUS2+MOVE2,TT*SIGN2,ROT2)+FY(POLY3,CYCLE3,RADIUS3+MOVE3,TT*SIGN3,ROT3)+FY(POLY4,CYCLE4,RADIUS4+MOVE4,TT*SIGN4,ROT4)
LET X=X+FX(POLY5,CYCLE5,RADIUS5+MOVE5,TT*SIGN5,ROT5)+FX(POLY6,CYCLE6,RADIUS6+MOVE6,TT*SIGN6,ROT6)+FX(POLY7,CYCLE7,RADIUS7+MOVE7,TT*SIGN7,ROT7)+FX(POLY8,CYCLE8,RADIUS8+MOVE8,TT*SIGN8,ROT8)
LET Y=Y+FY(POLY5,CYCLE5,RADIUS5+MOVE5,TT*SIGN5,ROT5)+FY(POLY6,CYCLE6,RADIUS6+MOVE6,TT*SIGN6,ROT6)+FY(POLY7,CYCLE7,RADIUS7+MOVE7,TT*SIGN7,ROT7)+FY(POLY8,CYCLE8,RADIUS8+MOVE8,TT*SIGN8,ROT8)
PLOT LINES:X,Y;
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET KK=KK+1
GSAVE "image"&USING$("%%%%%",KK)&".png"
PRINT "No.";KK
END IF
WAIT DELAY .1
SET DRAW MODE HIDDEN
NEXT TH
LOOP UNTIL SAVE=1 AND TH=>359
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL FUNCTION FX(M,N,R,T,ROT)
OPTION ANGLE DEGREES
IF M>=3 THEN
LET A=360/M
LET FX=R*COS(T*N+ROT)*COS(A/2)/COS(A*(T*N/A-IP(T*N/A))-A/2)
ELSE
LET FX=R*COS(T*N+ROT)
END IF
END FUNCTION
EXTERNAL FUNCTION FY(M,N,R,T,ROT)
OPTION ANGLE DEGREES
IF M>=3 THEN
LET A=360/M
LET FY=R*SIN(T*N+ROT)*COS(A/2)/COS(A*(T*N/A-IP(T*N/A))-A/2)
ELSE
LET FY=R*SIN(T*N+ROT)
END IF
END FUNCTION
EXTERNAL SUB POLY(X,Y,R,C,M,ROT)
OPTION ANGLE DEGREES
SET LINE COLOR C
PLOT LINES
IF R>0 THEN
FOR T=0 TO 360
IF M>=3 THEN
LET A=360/M
LET XX=X+R*COS(T+ROT)*COS(A/2)/COS(A*(T/A-IP(T/A))-A/2)
LET YY=Y+R*SIN(T+ROT)*COS(A/2)/COS(A*(T/A-IP(T/A))-A/2)
ELSE
LET XX=X+R*COS(T)
LET YY=Y+R*SIN(T)
END IF
PLOT LINES:XX,YY;
NEXT T
END IF
PLOT LINES
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
DIM C(8),T(8),R(8),P(8),CL(10),M(8),S(8)
MAT READ C
READ CYCLE1,CYCLE2,CYCLE3,CYCLE4,CYCLE5,CYCLE6,CYCLE7,CYCLE8
DATA 1,2,3,4,5,6,7,8
DATA 1,2,3,4,5,6,7,8
MAT READ R
READ RADIUS1,RADIUS2,RADIUS3,RADIUS4,RADIUS5,RADIUS6,RADIUS7,RADIUS8
DATA 1,.5,0,0,0,0,0,0
DATA 1,.5,0,0,0,0,0,0
MAT READ P
READ POLY1,POLY2,POLY3,POLY4,POLY5,POLY6,POLY7,POLY8
DATA 5,5,5,5,5,5,5,5
DATA 5,5,5,5,5,5,5,5
MAT READ CL
READ COL1,COL2,COL3,COL4,COL5,COL6,COL7,COL8,COL9,COL10
DATA 1,2,3,4,8,9,10,11,5.5,7.5
DATA 1,2,3,4,8,9,10,11,5.5,7.5
MAT READ S
READ SIGN1,SIGN2,SIGN3,SIGN4,SIGN5,SIGN6,SIGN7,SIGN8
DATA 1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1
LET SP=3.01
LET SPEED=SP
LET SC=4.01
LET SCALE=SC
LET KEY$="PCRTKMX"
DO
FOR TH=0 TO 359 STEP SPEED
IF SAVE=0 THEN
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
EXIT FOR
END IF
FOR I=1 TO LEN(KEY$)
IF GETKEYSTATE(ORD(KEY$(I:I)))<0 THEN
LET PAGE=I-1
LET FLG=0
EXIT FOR
END IF
NEXT I
IF GETKEYSTATE(27)<0 THEN STOP
IF GETKEYSTATE(32)<0 THEN
DO
LOOP WHILE GETKEYSTATE(32)<0
LET PAGE=MOD(PAGE+1,7)
LET FLG=0
END IF
SELECT CASE PAGE
CASE 0 !'角数
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 4 TO 10,AT P(1):POLY1
LOCATE VALUE NOWAIT(2),RANGE 4 TO 10,AT P(2):POLY2
LOCATE VALUE NOWAIT(3),RANGE 4 TO 10,AT P(3):POLY3
LOCATE VALUE NOWAIT(4),RANGE 4 TO 10,AT P(4):POLY4
LOCATE VALUE NOWAIT(5),RANGE 4 TO 10,AT P(5):POLY5
LOCATE VALUE NOWAIT(6),RANGE 4 TO 10,AT P(6):POLY6
LOCATE VALUE NOWAIT(7),RANGE 4 TO 10,AT P(7):POLY7
LOCATE VALUE NOWAIT(8),RANGE 4 TO 10,AT P(8):POLY8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):POLY1
LOCATE VALUE NOWAIT(2):POLY2
LOCATE VALUE NOWAIT(3):POLY3
LOCATE VALUE NOWAIT(4):POLY4
LOCATE VALUE NOWAIT(5):POLY5
LOCATE VALUE NOWAIT(6):POLY6
LOCATE VALUE NOWAIT(7):POLY7
LOCATE VALUE NOWAIT(8):POLY8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET P(1)=POLY1
LET P(2)=POLY2
LET P(3)=POLY3
LET P(4)=POLY4
LET P(5)=POLY5
LET P(6)=POLY6
LET P(7)=POLY7
LET P(8)=POLY8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 1 !'周期
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 20,AT C(1):CYCLE1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 20,AT C(2):CYCLE2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT C(3):CYCLE3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT C(4):CYCLE4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT C(5):CYCLE5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT C(6):CYCLE6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT C(7):CYCLE7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 20,AT C(8):CYCLE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):CYCLE1
LOCATE VALUE NOWAIT(2):CYCLE2
LOCATE VALUE NOWAIT(3):CYCLE3
LOCATE VALUE NOWAIT(4):CYCLE4
LOCATE VALUE NOWAIT(5):CYCLE5
LOCATE VALUE NOWAIT(6):CYCLE6
LOCATE VALUE NOWAIT(7):CYCLE7
LOCATE VALUE NOWAIT(8):CYCLE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET C(1)=CYCLE1
LET C(2)=CYCLE2
LET C(3)=CYCLE3
LET C(4)=CYCLE4
LET C(5)=CYCLE5
LET C(6)=CYCLE6
LET C(7)=CYCLE7
LET C(8)=CYCLE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 2 !'半径
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 1,AT R(1):RADIUS1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 1,AT R(2):RADIUS2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 1,AT R(3):RADIUS3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 1,AT R(4):RADIUS4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 1,AT R(5):RADIUS5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 1,AT R(6):RADIUS6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 1,AT R(7):RADIUS7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 1,AT R(8):RADIUS8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):RADIUS1
LOCATE VALUE NOWAIT(2):RADIUS2
LOCATE VALUE NOWAIT(3):RADIUS3
LOCATE VALUE NOWAIT(4):RADIUS4
LOCATE VALUE NOWAIT(5):RADIUS5
LOCATE VALUE NOWAIT(6):RADIUS6
LOCATE VALUE NOWAIT(7):RADIUS7
LOCATE VALUE NOWAIT(8):RADIUS8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET R(1)=RADIUS1
LET R(2)=RADIUS2
LET R(3)=RADIUS3
LET R(4)=RADIUS4
LET R(5)=RADIUS5
LET R(6)=RADIUS6
LET R(7)=RADIUS7
LET R(8)=RADIUS8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 3 !'開始角度
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 359,AT T(1):ROT1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 359,AT T(2):ROT2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 359,AT T(3):ROT3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 359,AT T(4):ROT4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 359,AT T(5):ROT5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 359,AT T(6):ROT6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 359,AT T(7):ROT7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 359,AT T(8):ROT8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):ROT1
LOCATE VALUE NOWAIT(2):ROT2
LOCATE VALUE NOWAIT(3):ROT3
LOCATE VALUE NOWAIT(4):ROT4
LOCATE VALUE NOWAIT(5):ROT5
LOCATE VALUE NOWAIT(6):ROT6
LOCATE VALUE NOWAIT(7):ROT7
LOCATE VALUE NOWAIT(8):ROT8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET T(1)=ROT1
LET T(2)=ROT2
LET T(3)=ROT3
LET T(4)=ROT4
LET T(5)=ROT5
LET T(6)=ROT6
LET T(7)=ROT7
LET T(8)=ROT8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 4 !'色
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 255,AT CL(1):COL1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT CL(2):COL2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 255,AT CL(3):COL3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 255,AT CL(4):COL4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 255,AT CL(5):COL5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 255,AT CL(6):COL6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 255,AT CL(7):COL7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 255,AT CL(8):COL8
LOCATE VALUE NOWAIT(9),RANGE 0 TO 255,AT CL(9):COL9
LOCATE VALUE NOWAIT(10),RANGE 0 TO 255,AT CL(10):COL10
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):COL1
LOCATE VALUE NOWAIT(2):COL2
LOCATE VALUE NOWAIT(3):COL3
LOCATE VALUE NOWAIT(4):COL4
LOCATE VALUE NOWAIT(5):COL5
LOCATE VALUE NOWAIT(6):COL6
LOCATE VALUE NOWAIT(7):COL7
LOCATE VALUE NOWAIT(8):COL8
LOCATE VALUE NOWAIT(9):COL9
LOCATE VALUE NOWAIT(10):COL10
LET CL(1)=COL1
LET CL(2)=COL2
LET CL(3)=COL3
LET CL(4)=COL4
LET CL(5)=COL5
LET CL(6)=COL6
LET CL(7)=COL7
LET CL(8)=COL8
LET CL(9)=COL9
LET CL(10)=COL10
END IF
CASE 5 !'平行移動
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT M(1):MOVE1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT M(2):MOVE2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT M(3):MOVE3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT M(4):MOVE4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT M(5):MOVE5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT M(6):MOVE6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT M(7):MOVE7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT M(8):MOVE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):MOVE1
LOCATE VALUE NOWAIT(2):MOVE2
LOCATE VALUE NOWAIT(3):MOVE3
LOCATE VALUE NOWAIT(4):MOVE4
LOCATE VALUE NOWAIT(5):MOVE5
LOCATE VALUE NOWAIT(6):MOVE6
LOCATE VALUE NOWAIT(7):MOVE7
LOCATE VALUE NOWAIT(8):MOVE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET M(1)=MOVE1
LET M(2)=MOVE2
LET M(3)=MOVE3
LET M(4)=MOVE4
LET M(5)=MOVE5
LET M(6)=MOVE6
LET M(7)=MOVE7
LET M(8)=MOVE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 6 !'回転の向き
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT S(1):SIGN1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT S(2):SIGN2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT S(3):SIGN3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT S(4):SIGN4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT S(5):SIGN5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT S(6):SIGN6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT S(7):SIGN7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT S(8):SIGN8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):SIGN1
LOCATE VALUE NOWAIT(2):SIGN2
LOCATE VALUE NOWAIT(3):SIGN3
LOCATE VALUE NOWAIT(4):SIGN4
LOCATE VALUE NOWAIT(5):SIGN5
LOCATE VALUE NOWAIT(6):SIGN6
LOCATE VALUE NOWAIT(7):SIGN7
LOCATE VALUE NOWAIT(8):SIGN8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET S(1)=SIGN1
LET S(2)=SIGN2
LET S(3)=SIGN3
LET S(4)=SIGN4
LET S(5)=SIGN5
LET S(6)=SIGN6
LET S(7)=SIGN7
LET S(8)=SIGN8
LET SP=SPEED
LET SC=SCALE
END IF
END SELECT
END IF
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET POLY1=INT(POLY1)
LET POLY2=INT(POLY2)
LET POLY3=INT(POLY3)
LET POLY4=INT(POLY4)
LET POLY5=INT(POLY5)
LET POLY6=INT(POLY6)
LET POLY7=INT(POLY7)
LET POLY8=INT(POLY8)
LET CYCLE1=INT(CYCLE1)
LET CYCLE2=INT(CYCLE2)
LET CYCLE3=INT(CYCLE3)
LET CYCLE4=INT(CYCLE4)
LET CYCLE5=INT(CYCLE5)
LET CYCLE6=INT(CYCLE6)
LET CYCLE7=INT(CYCLE7)
LET CYCLE8=INT(CYCLE8)
LET COL1=INT(COL1)
LET COL2=INT(COL2)
LET COL3=INT(COL3)
LET COL4=INT(COL4)
LET COL5=INT(COL5)
LET COL6=INT(COL6)
LET COL7=INT(COL7)
LET COL8=INT(COL8)
LET COL9=INT(COL9)
LET COL10=INT(COL10)
IF SIGN1>=0 THEN LET SIGN1=1 ELSE LET SIGN1=-1
IF SIGN2>=0 THEN LET SIGN2=1 ELSE LET SIGN2=-1
IF SIGN3>=0 THEN LET SIGN3=1 ELSE LET SIGN3=-1
IF SIGN4>=0 THEN LET SIGN4=1 ELSE LET SIGN4=-1
IF SIGN5>=0 THEN LET SIGN5=1 ELSE LET SIGN5=-1
IF SIGN6>=0 THEN LET SIGN6=1 ELSE LET SIGN6=-1
IF SIGN7>=0 THEN LET SIGN7=1 ELSE LET SIGN7=-1
IF SIGN8>=0 THEN LET SIGN8=1 ELSE LET SIGN8=-1
LET SPEED=INT(SPEED)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
CLEAR
DRAW GRID
LET X1=0
LET Y1=0
LET X2=FX(POLY1,CYCLE1,RADIUS1+MOVE1,TH*SIGN1,ROT1)
LET Y2=FY(POLY1,CYCLE1,RADIUS1+MOVE1,TH*SIGN1,ROT1)
LET X3=X2+FX(POLY2,CYCLE2,RADIUS2+MOVE2,TH*SIGN2,ROT2)
LET Y3=Y2+FY(POLY2,CYCLE2,RADIUS2+MOVE2,TH*SIGN2,ROT2)
LET X4=X3+FX(POLY3,CYCLE3,RADIUS3+MOVE3,TH*SIGN3,ROT3)
LET Y4=Y3+FY(POLY3,CYCLE3,RADIUS3+MOVE3,TH*SIGN3,ROT3)
LET X5=X4+FX(POLY4,CYCLE4,RADIUS4+MOVE4,TH*SIGN4,ROT4)
LET Y5=Y4+FY(POLY4,CYCLE4,RADIUS4+MOVE4,TH*SIGN4,ROT4)
LET X6=X5+FX(POLY5,CYCLE5,RADIUS5+MOVE5,TH*SIGN5,ROT5)
LET Y6=Y5+FY(POLY5,CYCLE5,RADIUS5+MOVE5,TH*SIGN5,ROT5)
LET X7=X6+FX(POLY6,CYCLE6,RADIUS6+MOVE6,TH*SIGN6,ROT6)
LET Y7=Y6+FY(POLY6,CYCLE6,RADIUS6+MOVE6,TH*SIGN6,ROT6)
LET X8=X7+FX(POLY7,CYCLE7,RADIUS7+MOVE7,TH*SIGN7,ROT7)
LET Y8=Y7+FY(POLY7,CYCLE7,RADIUS7+MOVE7,TH*SIGN7,ROT7)
LET X9=X8+FX(POLY8,CYCLE8,RADIUS8+MOVE8,TH*SIGN8,ROT8)
LET Y9=Y8+FY(POLY8,CYCLE8,RADIUS8+MOVE8,TH*SIGN8,ROT8)
CALL POLY(X1,Y1,RADIUS1,COL1,POLY1,ROT1)
CALL POLY(X2,Y2,RADIUS2,COL2,POLY2,ROT2)
CALL POLY(X3,Y3,RADIUS3,COL3,POLY3,ROT3)
CALL POLY(X4,Y4,RADIUS4,COL4,POLY4,ROT4)
CALL POLY(X5,Y5,RADIUS5,COL5,POLY5,ROT5)
CALL POLY(X6,Y6,RADIUS6,COL6,POLY6,ROT6)
CALL POLY(X7,Y7,RADIUS7,COL7,POLY7,ROT7)
CALL POLY(X8,Y8,RADIUS8,COL8,POLY8,ROT8)
SET LINE COLOR COL9
PLOT LINES:X1,Y1;X2,Y2;X3,Y3;X4,Y4;X5,Y5;X6,Y6;X7,Y7;X8,Y8;X9,Y9
SET LINE COLOR COL10
PLOT LINES
FOR TT=0 TO TH
LET X= FX(POLY1,CYCLE1,RADIUS1+MOVE1,TT*SIGN1,ROT1)+FX(POLY2,CYCLE2,RADIUS2+MOVE2,TT*SIGN2,ROT2)+FX(POLY3,CYCLE3,RADIUS3+MOVE3,TT*SIGN3,ROT3)+FX(POLY4,CYCLE4,RADIUS4+MOVE4,TT*SIGN4,ROT4)
LET Y= FY(POLY1,CYCLE1,RADIUS1+MOVE1,TT*SIGN1,ROT1)+FY(POLY2,CYCLE2,RADIUS2+MOVE2,TT*SIGN2,ROT2)+FY(POLY3,CYCLE3,RADIUS3+MOVE3,TT*SIGN3,ROT3)+FY(POLY4,CYCLE4,RADIUS4+MOVE4,TT*SIGN4,ROT4)
LET X=X+FX(POLY5,CYCLE5,RADIUS5+MOVE5,TT*SIGN5,ROT5)+FX(POLY6,CYCLE6,RADIUS6+MOVE6,TT*SIGN6,ROT6)+FX(POLY7,CYCLE7,RADIUS7+MOVE7,TT*SIGN7,ROT7)+FX(POLY8,CYCLE8,RADIUS8+MOVE8,TT*SIGN8,ROT8)
LET Y=Y+FY(POLY5,CYCLE5,RADIUS5+MOVE5,TT*SIGN5,ROT5)+FY(POLY6,CYCLE6,RADIUS6+MOVE6,TT*SIGN6,ROT6)+FY(POLY7,CYCLE7,RADIUS7+MOVE7,TT*SIGN7,ROT7)+FY(POLY8,CYCLE8,RADIUS8+MOVE8,TT*SIGN8,ROT8)
PLOT LINES:X,Y;
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET KK=KK+1
GSAVE "image"&USING$("%%%%%",KK)&".png"
PRINT "No.";KK
END IF
WAIT DELAY .1
SET DRAW MODE HIDDEN
NEXT TH
LOOP UNTIL SAVE=1 AND TH=>359
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL FUNCTION FX(M,N,R,T,ROT)
OPTION ANGLE DEGREES
IF M>=5 THEN
LET A=360/M
LET FX=R*COS(T*N+ROT)*COS(A)/COS(A-1/M*ACOS(COS(N*M*T)))
ELSE
LET FX=R*COS(T*N+ROT)
END IF
END FUNCTION
EXTERNAL FUNCTION FY(M,N,R,T,ROT)
OPTION ANGLE DEGREES
IF M>=5 THEN
LET A=360/M
LET FY=R*SIN(T*N+ROT)*COS(A)/COS(A-1/M*ACOS(COS(N*M*T)))
ELSE
LET FY=R*SIN(T*N+ROT)
END IF
END FUNCTION
EXTERNAL SUB POLY(X,Y,R,C,M,ROT)
OPTION ANGLE DEGREES
SET LINE COLOR C
PLOT LINES
IF R>0 THEN
FOR T=0 TO 360
IF M>=5 THEN
LET A=360/M
LET XX=X+R*COS(T+ROT)*COS(A)/COS(A-1/M*ACOS(COS(M*T)))
LET YY=Y+R*SIN(T+ROT)*COS(A)/COS(A-1/M*ACOS(COS(M*T)))
ELSE
LET XX=X+R*COS(T)
LET YY=Y+R*SIN(T)
END IF
PLOT LINES:XX,YY;
NEXT T
END IF
PLOT LINES
END SUB
CALL GINIT(800,800)
OPTION ANGLE DEGREES
DIM C1(8),C2(8),T(8),R(8),CL(10),M(8),S(8)
MAT READ C1
READ XCYCLE1,YCYCLE1,XCYCLE2,YCYCLE2,XCYCLE3,YCYCLE3,XCYCLE4,YCYCLE4
DATA 1,2,1,3,1,4,1,5
DATA 1,2,1,3,1,4,1,5
MAT READ C2
READ XCYCLE5,YCYCLE5,XCYCLE6,YCYCLE6,XCYCLE7,YCYCLE7,XCYCLE8,YCYCLE8
DATA 1,6,1,7,1,8,1,9
DATA 1,6,1,7,1,8,1,9
MAT READ R
READ RADIUS1,RADIUS2,RADIUS3,RADIUS4,RADIUS5,RADIUS6,RADIUS7,RADIUS8
DATA 1,.5,0,0,0,0,0,0
DATA 1,.5,0,0,0,0,0,0
MAT READ CL
READ COL1,COL2,COL3,COL4,COL5,COL6,COL7,COL8,COL9,COL10
DATA 1.1,2.1,3.1,4.1,8.1,9.1,10.1,11.1,5.1,7.1
DATA 1.1,2.1,3.1,4.1,8.1,9.1,10.1,11.1,5.1,7.1
MAT READ S
READ SIGN1,SIGN2,SIGN3,SIGN4,SIGN5,SIGN6,SIGN7,SIGN8
DATA 1,1,1,1,1,1,1,1
DATA 1,1,1,1,1,1,1,1
LET SP=3.01
LET SPEED=SP
LET SC=4.01
LET SCALE=SC
LET KEY$="CVRTKMX"
DO
FOR TH=0 TO 359 STEP SPEED
IF SAVE=0 THEN
IF GETKEYSTATE(ORD("S"))<0 THEN
LET SAVE=1
PRINT "セーブ開始"
EXIT FOR
END IF
FOR I=1 TO LEN(KEY$)
IF GETKEYSTATE(ORD(KEY$(I:I)))<0 THEN
LET PAGE=I-1
LET FLG=0
EXIT FOR
END IF
NEXT I
IF GETKEYSTATE(27)<0 THEN STOP
IF GETKEYSTATE(32)<0 THEN
DO
LOOP WHILE GETKEYSTATE(32)<0
LET PAGE=MOD(PAGE+1,7)
LET FLG=0
END IF
SELECT CASE PAGE
CASE 0 !'周期
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 20,AT C1(1):XCYCLE1 !'バーの並びに注意(1～4)
LOCATE VALUE NOWAIT(2),RANGE 0 TO 20,AT C1(2):YCYCLE1
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT C1(3):XCYCLE2
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT C1(4):YCYCLE2
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT C1(5):XCYCLE3
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT C1(6):YCYCLE3
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT C1(7):XCYCLE4
LOCATE VALUE NOWAIT(8),RANGE 0 TO 20,AT C1(8):YCYCLE4
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):XCYCLE1
LOCATE VALUE NOWAIT(2):YCYCLE1
LOCATE VALUE NOWAIT(3):XCYCLE2
LOCATE VALUE NOWAIT(4):YCYCLE2
LOCATE VALUE NOWAIT(5):XCYCLE3
LOCATE VALUE NOWAIT(6):YCYCLE3
LOCATE VALUE NOWAIT(7):XCYCLE4
LOCATE VALUE NOWAIT(8):YCYCLE4
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET C1(1)=XCYCLE1
LET C1(2)=YCYCLE1
LET C1(3)=XCYCLE2
LET C1(4)=YCYCLE2
LET C1(5)=XCYCLE3
LET C1(6)=YCYCLE3
LET C1(7)=XCYCLE4
LET C1(8)=YCYCLE4
LET SP=SPEED
LET SC=SCALE
END IF
CASE 1 !'周期
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 20,AT C2(1):XCYCLE5 !'バーの並びに注意(5～8)
LOCATE VALUE NOWAIT(2),RANGE 0 TO 20,AT C2(2):YCYCLE5
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT C2(3):XCYCLE6
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT C2(4):YCYCLE6
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT C2(5):XCYCLE7
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT C2(6):YCYCLE7
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT C2(7):XCYCLE8
LOCATE VALUE NOWAIT(8),RANGE 0 TO 20,AT C2(8):YCYCLE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):XCYCLE5
LOCATE VALUE NOWAIT(2):YCYCLE5
LOCATE VALUE NOWAIT(3):XCYCLE6
LOCATE VALUE NOWAIT(4):YCYCLE6
LOCATE VALUE NOWAIT(5):XCYCLE7
LOCATE VALUE NOWAIT(6):YCYCLE7
LOCATE VALUE NOWAIT(7):XCYCLE8
LOCATE VALUE NOWAIT(8):YCYCLE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET C2(1)=XCYCLE5
LET C2(2)=YCYCLE5
LET C2(3)=XCYCLE6
LET C2(4)=YCYCLE6
LET C2(5)=XCYCLE7
LET C2(6)=YCYCLE7
LET C2(7)=XCYCLE8
LET C2(8)=YCYCLE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 2 !'半径
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 1,AT R(1):RADIUS1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 1,AT R(2):RADIUS2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 1,AT R(3):RADIUS3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 1,AT R(4):RADIUS4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 1,AT R(5):RADIUS5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 1,AT R(6):RADIUS6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 1,AT R(7):RADIUS7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 1,AT R(8):RADIUS8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):RADIUS1
LOCATE VALUE NOWAIT(2):RADIUS2
LOCATE VALUE NOWAIT(3):RADIUS3
LOCATE VALUE NOWAIT(4):RADIUS4
LOCATE VALUE NOWAIT(5):RADIUS5
LOCATE VALUE NOWAIT(6):RADIUS6
LOCATE VALUE NOWAIT(7):RADIUS7
LOCATE VALUE NOWAIT(8):RADIUS8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET R(1)=RADIUS1
LET R(2)=RADIUS2
LET R(3)=RADIUS3
LET R(4)=RADIUS4
LET R(5)=RADIUS5
LET R(6)=RADIUS6
LET R(7)=RADIUS7
LET R(8)=RADIUS8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 3 !'開始角度
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 359,AT T(1):ROT1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 359,AT T(2):ROT2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 359,AT T(3):ROT3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 359,AT T(4):ROT4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 359,AT T(5):ROT5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 359,AT T(6):ROT6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 359,AT T(7):ROT7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 359,AT T(8):ROT8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):ROT1
LOCATE VALUE NOWAIT(2):ROT2
LOCATE VALUE NOWAIT(3):ROT3
LOCATE VALUE NOWAIT(4):ROT4
LOCATE VALUE NOWAIT(5):ROT5
LOCATE VALUE NOWAIT(6):ROT6
LOCATE VALUE NOWAIT(7):ROT7
LOCATE VALUE NOWAIT(8):ROT8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET T(1)=ROT1
LET T(2)=ROT2
LET T(3)=ROT3
LET T(4)=ROT4
LET T(5)=ROT5
LET T(6)=ROT6
LET T(7)=ROT7
LET T(8)=ROT8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 4 !'色
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE 0 TO 255,AT CL(1):COL1
LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT CL(2):COL2
LOCATE VALUE NOWAIT(3),RANGE 0 TO 255,AT CL(3):COL3
LOCATE VALUE NOWAIT(4),RANGE 0 TO 255,AT CL(4):COL4
LOCATE VALUE NOWAIT(5),RANGE 0 TO 255,AT CL(5):COL5
LOCATE VALUE NOWAIT(6),RANGE 0 TO 255,AT CL(6):COL6
LOCATE VALUE NOWAIT(7),RANGE 0 TO 255,AT CL(7):COL7
LOCATE VALUE NOWAIT(8),RANGE 0 TO 255,AT CL(8):COL8
LOCATE VALUE NOWAIT(9),RANGE 0 TO 255,AT CL(9):COL9
LOCATE VALUE NOWAIT(10),RANGE 0 TO 255,AT CL(10):COL10
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):COL1
LOCATE VALUE NOWAIT(2):COL2
LOCATE VALUE NOWAIT(3):COL3
LOCATE VALUE NOWAIT(4):COL4
LOCATE VALUE NOWAIT(5):COL5
LOCATE VALUE NOWAIT(6):COL6
LOCATE VALUE NOWAIT(7):COL7
LOCATE VALUE NOWAIT(8):COL8
LOCATE VALUE NOWAIT(9):COL9
LOCATE VALUE NOWAIT(10):COL10
LET CL(1)=COL1
LET CL(2)=COL2
LET CL(3)=COL3
LET CL(4)=COL4
LET CL(5)=COL5
LET CL(6)=COL6
LET CL(7)=COL7
LET CL(8)=COL8
LET CL(9)=COL9
LET CL(10)=COL10
END IF
CASE 5 !'平行移動
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT M(1):MOVE1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT M(2):MOVE2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT M(3):MOVE3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT M(4):MOVE4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT M(5):MOVE5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT M(6):MOVE6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT M(7):MOVE7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT M(8):MOVE8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):MOVE1
LOCATE VALUE NOWAIT(2):MOVE2
LOCATE VALUE NOWAIT(3):MOVE3
LOCATE VALUE NOWAIT(4):MOVE4
LOCATE VALUE NOWAIT(5):MOVE5
LOCATE VALUE NOWAIT(6):MOVE6
LOCATE VALUE NOWAIT(7):MOVE7
LOCATE VALUE NOWAIT(8):MOVE8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET M(1)=MOVE1
LET M(2)=MOVE2
LET M(3)=MOVE3
LET M(4)=MOVE4
LET M(5)=MOVE5
LET M(6)=MOVE6
LET M(7)=MOVE7
LET M(8)=MOVE8
LET SP=SPEED
LET SC=SCALE
END IF
CASE 6 !'回転の向き
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT S(1):SIGN1
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT S(2):SIGN2
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT S(3):SIGN3
LOCATE VALUE NOWAIT(4),RANGE -1 TO 1,AT S(4):SIGN4
LOCATE VALUE NOWAIT(5),RANGE -1 TO 1,AT S(5):SIGN5
LOCATE VALUE NOWAIT(6),RANGE -1 TO 1,AT S(6):SIGN6
LOCATE VALUE NOWAIT(7),RANGE -1 TO 1,AT S(7):SIGN7
LOCATE VALUE NOWAIT(8),RANGE -1 TO 1,AT S(8):SIGN8
LOCATE VALUE NOWAIT(9),RANGE 1 TO 20,AT SP:SPEED
LOCATE VALUE NOWAIT(10),RANGE 1 TO 10,AT SC:SCALE
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):SIGN1
LOCATE VALUE NOWAIT(2):SIGN2
LOCATE VALUE NOWAIT(3):SIGN3
LOCATE VALUE NOWAIT(4):SIGN4
LOCATE VALUE NOWAIT(5):SIGN5
LOCATE VALUE NOWAIT(6):SIGN6
LOCATE VALUE NOWAIT(7):SIGN7
LOCATE VALUE NOWAIT(8):SIGN8
LOCATE VALUE NOWAIT(9):SPEED
LOCATE VALUE NOWAIT(10):SCALE
LET S(1)=SIGN1
LET S(2)=SIGN2
LET S(3)=SIGN3
LET S(4)=SIGN4
LET S(5)=SIGN5
LET S(6)=SIGN6
LET S(7)=SIGN7
LET S(8)=SIGN8
LET SP=SPEED
LET SC=SCALE
END IF
END SELECT
END IF
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET XCYCLE1=INT(XCYCLE1)
LET XCYCLE2=INT(XCYCLE2)
LET XCYCLE3=INT(XCYCLE3)
LET XCYCLE4=INT(XCYCLE4)
LET XCYCLE5=INT(XCYCLE5)
LET XCYCLE6=INT(XCYCLE6)
LET XCYCLE7=INT(XCYCLE7)
LET XCYCLE8=INT(XCYCLE8)
LET YCYCLE1=INT(YCYCLE1)
LET YCYCLE2=INT(YCYCLE2)
LET YCYCLE3=INT(YCYCLE3)
LET YCYCLE4=INT(YCYCLE4)
LET YCYCLE5=INT(YCYCLE5)
LET YCYCLE6=INT(YCYCLE6)
LET YCYCLE7=INT(YCYCLE7)
LET YCYCLE8=INT(YCYCLE8)
LET COL1=INT(COL1)
LET COL2=INT(COL2)
LET COL3=INT(COL3)
LET COL4=INT(COL4)
LET COL5=INT(COL5)
LET COL6=INT(COL6)
LET COL7=INT(COL7)
LET COL8=INT(COL8)
LET COL9=INT(COL9)
LET COL10=INT(COL10)
IF SIGN1>=0 THEN LET SIGN1=1 ELSE LET SIGN1=-1
IF SIGN2>=0 THEN LET SIGN2=1 ELSE LET SIGN2=-1
IF SIGN3>=0 THEN LET SIGN3=1 ELSE LET SIGN3=-1
IF SIGN4>=0 THEN LET SIGN4=1 ELSE LET SIGN4=-1
IF SIGN5>=0 THEN LET SIGN5=1 ELSE LET SIGN5=-1
IF SIGN6>=0 THEN LET SIGN6=1 ELSE LET SIGN6=-1
IF SIGN7>=0 THEN LET SIGN7=1 ELSE LET SIGN7=-1
IF SIGN8>=0 THEN LET SIGN8=1 ELSE LET SIGN8=-1
LET SPEED=INT(SPEED)
IF SPEED<>SPE THEN
LET SPE=SPEED
EXIT FOR
END IF
CLEAR
DRAW GRID
LET X1=0
LET Y1=0
LET X2=(RADIUS1+MOVE1)*COS(TH*XCYCLE1*SIGN1)
LET Y2=(RADIUS1+MOVE1)*SIN(TH*YCYCLE1*SIGN1+ROT1)
LET X3=X2+(RADIUS2+MOVE2)*COS(TH*XCYCLE2*SIGN2)
LET Y3=Y2+(RADIUS2+MOVE2)*SIN(TH*YCYCLE2*SIGN2+ROT2)
LET X4=X3+(RADIUS3+MOVE3)*COS(TH*XCYCLE3*SIGN3)
LET Y4=Y3+(RADIUS3+MOVE3)*SIN(TH*YCYCLE3*SIGN3+ROT3)
LET X5=X4+(RADIUS4+MOVE4)*COS(TH*XCYCLE4*SIGN4)
LET Y5=Y4+(RADIUS4+MOVE4)*SIN(TH*YCYCLE4*SIGN4+ROT4)
LET X6=X5+(RADIUS5+MOVE5)*COS(TH*XCYCLE5*SIGN5)
LET Y6=Y5+(RADIUS5+MOVE5)*SIN(TH*YCYCLE5*SIGN5+ROT5)
LET X7=X6+(RADIUS6+MOVE6)*COS(TH*XCYCLE6*SIGN6)
LET Y7=Y6+(RADIUS6+MOVE6)*SIN(TH*YCYCLE6*SIGN6+ROT6)
LET X8=X7+(RADIUS7+MOVE7)*COS(TH*XCYCLE7*SIGN7)
LET Y8=Y7+(RADIUS7+MOVE7)*SIN(TH*YCYCLE7*SIGN7+ROT7)
LET X9=X8+(RADIUS8+MOVE8)*COS(TH*XCYCLE8*SIGN8)
LET Y9=Y8+(RADIUS8+MOVE8)*SIN(TH*YCYCLE8*SIGN8+ROT8)
CALL LISSAJOUS(X1,Y1,RADIUS1,COL1,XCYCLE1,YCYCLE1,ROT1)
CALL LISSAJOUS(X2,Y2,RADIUS2,COL2,XCYCLE2,YCYCLE2,ROT2)
CALL LISSAJOUS(X3,Y3,RADIUS3,COL3,XCYCLE3,YCYCLE3,ROT3)
CALL LISSAJOUS(X4,Y4,RADIUS4,COL4,XCYCLE4,YCYCLE4,ROT4)
CALL LISSAJOUS(X5,Y5,RADIUS5,COL5,XCYCLE5,YCYCLE5,ROT5)
CALL LISSAJOUS(X6,Y6,RADIUS6,COL6,XCYCLE6,YCYCLE6,ROT6)
CALL LISSAJOUS(X7,Y7,RADIUS7,COL7,XCYCLE7,YCYCLE7,ROT7)
CALL LISSAJOUS(X8,Y8,RADIUS8,COL8,XCYCLE8,YCYCLE8,ROT8)
SET LINE COLOR COL9
PLOT LINES:X1,Y1;X2,Y2;X3,Y3;X4,Y4;X5,Y5;X6,Y6;X7,Y7;X8,Y8;X9,Y9
SET LINE COLOR COL10
PLOT LINES
FOR TT=0 TO TH
LET X= (RADIUS1+MOVE1)*COS(TT*XCYCLE1*SIGN1)+(RADIUS2+MOVE2)*COS(TT*XCYCLE2*SIGN2)+(RADIUS3+MOVE3)*COS(TT*XCYCLE3*SIGN3)+(RADIUS4+MOVE4)*COS(TT*XCYCLE4*SIGN4)
LET Y= (RADIUS1+MOVE1)*SIN(TT*YCYCLE1*SIGN1+ROT1)+(RADIUS2+MOVE2)*SIN(TT*YCYCLE2*SIGN2+ROT2)+(RADIUS3+MOVE3)*SIN(TT*YCYCLE3*SIGN3+ROT3)+(RADIUS4+MOVE4)*SIN(TT*YCYCLE4*SIGN4+ROT4)
LET X=X+(RADIUS5+MOVE5)*COS(TT*XCYCLE5*SIGN5)+(RADIUS6+MOVE6)*COS(TT*XCYCLE6*SIGN6)+(RADIUS7+MOVE7)*COS(TT*XCYCLE7*SIGN7)+(RADIUS8+MOVE8)*COS(TT*XCYCLE8*SIGN8)
LET Y=Y+(RADIUS5+MOVE5)*SIN(TT*YCYCLE5*SIGN5+ROT5)+(RADIUS6+MOVE6)*SIN(TT*YCYCLE6*SIGN6+ROT6)+(RADIUS7+MOVE7)*SIN(TT*YCYCLE7*SIGN7+ROT7)+(RADIUS8+MOVE8)*SIN(TT*YCYCLE8*SIGN8+ROT8)
PLOT LINES:X,Y;
NEXT TT
SET DRAW MODE EXPLICIT
IF SAVE=1 THEN
LET KK=KK+1
GSAVE "image"&USING$("%%%%%",KK)&".png"
PRINT "No.";KK
END IF
WAIT DELAY .1
SET DRAW MODE HIDDEN
NEXT TH
LOOP UNTIL SAVE=1 AND TH=>359
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
END SUB
EXTERNAL SUB LISSAJOUS(X,Y,R,C,N,M,ROT)
OPTION ANGLE DEGREES
SET LINE COLOR C
PLOT LINES
FOR T=0 TO 360
LET XX=X+R*COS(N*T)
LET YY=Y+R*SIN(M*T+ROT)
PLOT LINES:XX,YY;
NEXT T
PLOT LINES
END SUB
１０進basicに関しては今年の夏に始めたばかりの初心者です。
カラーチャートがないと不便なので作りました。
REM 十進BASIC カラーチャート
SET BITMAP SIZE 800, 800
LET LEFT = 0
LET RIGHT = 560
LET BOTTOM = -560
LET TOP = 0
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET TEXT HEIGHT 24
PLOT TEXT, AT 90, -35 : "DECIMAL BASIC COLOR CHART"
LET COL = 0
SET TEXT HEIGHT 8
FOR X = 0 TO 450 STEP 90
FOR Y = 0 TO -490 STEP -10
DRAW RECT(COL) WITH SHIFT(X, Y)
LET COL = COL + 1
IF MOD(COL, 50) = 0 THEN
EXIT FOR
END IF
IF COL = 256 THEN
GOTO 100
END IF
NEXT Y
NEXT X
PICTURE RECT(C) ! 80x10の色番号付き色Cの長方形
SET AREA COLOR C
PLOT AREA: 50,-50; 50,-40; 100,-40; 100,-50
PLOT LINES: 20,-50; 20,-40; 100,-40; 100,-50;20,-50
PLOT LINES: 50,-50;50,-40
PLOT TEXT, AT 27, -51, USING ">%%": STR$(C)
END PICTURE
100 GSAVE "decimal_basic_color_chart.png"
END
REM ペンタクン(アニメーション)
LET REDUCTION = (3-SQR(5))/2 ! 縮小率
PICTURE PENTAKUN(N)
IF N=0 THEN
SET AREA COLOR 49 ! 黄緑
PLOT AREA: 1,0; COS(72),SIN(72); COS(144),SIN(144);COS(216),SIN(216);COS(288),SIN(288)
ELSE
DRAW PENTAKUN(N-1) WITH SCALE(REDUCTION)*SHIFT(1-REDUCTION,0)
DRAW PENTAKUN(N-1) WITH SCALE(REDUCTION)*SHIFT(1-REDUCTION,0)*ROTATE( 72)
DRAW PENTAKUN(N-1) WITH SCALE(REDUCTION)*SHIFT(1-REDUCTION,0)*ROTATE(144)
DRAW PENTAKUN(N-1) WITH SCALE(REDUCTION)*SHIFT(1-REDUCTION,0)*ROTATE(216)
DRAW PENTAKUN(N-1) WITH SCALE(REDUCTION)*SHIFT(1-REDUCTION,0)*ROTATE(288)
END IF
END PICTURE
LET LEFT = -1.2
LET RIGHT = 1.2
LET BOTTOM = -1.2
LET TOP = 1.2
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
OPTION ANGLE DEGREES
SET TEXT COLOR 49 ! 黄緑
DO
FOR N = 0 TO 4
SET DRAW MODE HIDDEN ! 描画途中を画面に反映させない
SET AREA COLOR 1 ! 背景を黒で塗りつぶす
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
DRAW PENTAKUN(N)
PLOT TEXT ,AT -0.1, -1.15, USING "N = %":STR$(N)
SET DRAW MODE EXPLICIT ! 描画結果を画面に反映させる
WAIT DELAY 1 ! 処理を1秒停止
NEXT N
LOOP
END
OPTION ARITHMETIC NATIVE
FILE GETOPENNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
IF F$<>"" THEN GLOAD F$ !'下絵の読み込み
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE,YSIZE,0
ASK DIRECTORY PATH$ !'保存パス
LET EXT$=".png" !'保存形式
LOCATE VALUE NOWAIT(1),RANGE 1 TO 50,AT 10: WID
LOCATE VALUE NOWAIT(2),RANGE 0 TO 255,AT 1: COL
DO
DO
LOCATE VALUE NOWAIT(1): WID !'太さ
LOCATE VALUE NOWAIT(2): COL !'色
MOUSE POLL X,Y,LEFT,RIGHT
IF GETKEYSTATE(27)<0 THEN STOP !'ESC
IF GETKEYSTATE(32)<0 OR RIGHT=1 THEN !'スペースキー又は右クリック
IF KMAX=0 THEN
PRINT "画像ファイルがありません"
STOP
END IF
IF KKMAX>KMAX THEN !'表示画像以降の画像は削除
FOR I=KMAX+1 TO KKMAX
PRINT "削除中:";PATH$;"\image";USING$("%%%%%",I);EXT$
FILE DELETE PATH$ & "\image" & USING$("%%%%%",I) & EXT$
NEXT I
END IF
CALL PLAY
STOP !'ここでプログラム終了
END IF
IF GETKEYSTATE(107)<0 OR GETKEYSTATE(187)<0 THEN !' "+"キー
LET T=TIME
DO
LOOP WHILE (GETKEYSTATE(107)<0 OR GETKEYSTATE(187)<0) AND TIME-T<.2 !' 0.2秒以上でキーリピート
IF K<=KKMAX-1 THEN
LET K=K+1
CALL LOAD
END IF
END IF
IF GETKEYSTATE(109)<0 OR GETKEYSTATE(189)<0 THEN !' "-"キー
LET T=TIME
DO
LOOP WHILE (GETKEYSTATE(109)<0 OR GETKEYSTATE(189)<0) AND TIME-T<.2
IF K>0 THEN
LET K=K-1
CALL LOAD
END IF
END IF
LOOP UNTIL LEFT=1
LET XX=-1
LET YY=-1
LET WID=INT(WID)
LET COL=INT(COL)
SET LINE WIDTH WID
SET LINE COLOR COL
DO
MOUSE POLL X,Y,LEFT,RIGHT
IF (XX<>X OR YY<>Y) AND SQR((X-XX)^2+(Y-YY)^2)>8 THEN !'8ドット以上動かした時にライン描画
PLOT LINES:X,Y;
IF XX<>-1 OR YY<>-1 THEN !'始点でないなら保存する
LET K=K+1
GSAVE PATH$ & "\image" & USING$("%%%%%",K) & EXT$ !'コマの保存
LET KMAX=K
LET KKMAX=MAX(KKMAX,KMAX)
PRINT "保存中: ";PATH$;"\image";USING$("%%%%%",K);EXT$;"/";KKMAX
END IF
LET XX=X
LET YY=Y
END IF
LOOP WHILE LEFT=1
PLOT LINES
LOOP
SUB PLAY !'簡易再生
LET ID$=CONFIRM$("再生しますか?")
IF ID$="YES" THEN
FOR K=1 TO KMAX
IF GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0 THEN EXIT FOR
CALL LOAD
SET DRAW MODE EXPLICIT
WAIT DELAY .1
SET DRAW MODE HIDDEN
NEXT K
END IF
END SUB
SUB LOAD
GLOAD PATH$ & "\image" & USING$("%%%%%",K) & EXT$
PRINT "Load ";PATH$;"\image";USING$("%%%%%",K);EXT$;"/";KKMAX
END SUB
END
