PUBLIC NUMERIC N,KMAX
LET N=100
LET KMAX=100
DIM X(N)
SET WINDOW 1,N+1,0,KMAX
FOR MODE=1 TO 16
CALL DATASET(N,X)
SELECT CASE MODE
CASE 1
PRINT "バブルソート"
CALL BUBBLESORT(N,X)
CASE 2
PRINT "双方向バブルソート"
CALL BIDIRECTIONALBUBBLESORT(N,X)
CASE 3
PRINT "選択法"
CALL SELECTIONSORT(N,X)
CASE 4
PRINT "基数ソート"
CALL RADIXSORT(N,X)
CASE 5
PRINT "シェルソート"
CALL SHELLSORT(N,X)
CASE 6
PRINT "マージソート"
CALL MERGESORT(1,N,X)
CASE 7
PRINT "ヒープソート"
CALL HEAPSORT(N,X)
CASE 8
PRINT "選択ソート"
CALL SELECTSORT(N,X)
CASE 9
PRINT "挿入ソート"
CALL INSERTSORT(N,X)
CASE 10
PRINT "コムソート"
CALL COMBSORT(N,X)
CASE 11
PRINT "ストゥージソート"
CALL STOOGESORT(1,N,X)
CASE 12
PRINT "ノームソート"
CALL GNOMESORT(N,X)
CASE 13
PRINT "バケットソート"
CALL BUCKETSORT(N,X)
CASE 14
PRINT "分布数えソート"
CALL DISTRIBUTIONSORT(N,X)
CASE 15
PRINT "奇遇転置ソート"
CALL ODDEVEN(N,X)
CASE 16
PRINT "クイックソート"
CALL QUICKSORT(1,N,X)
END SELECT
IF MODE<16 THEN PAUSE
NEXT MODE
END
EXTERNAL SUB DATASET(N,X())
RANDOMIZE
FOR I=1 TO N
LET X(I)=INT(RND*KMAX)
CALL DRAWBAR(X)
NEXT I
END SUB
EXTERNAL SUB DRAWBAR(X())
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO N
PLOT AREA:I,0;I+.5,0;I+.5,X(I);I,X(I)
NEXT I
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB BUBBLESORT(N,X())
FOR I=1 TO N
FOR J=1 TO N-I
IF X(J)>X(J+1) THEN
SWAP X(J),X(J+1)
CALL DRAWBAR(X)
END IF
NEXT J
NEXT I
END SUB
EXTERNAL SUB BIDIRECTIONALBUBBLESORT(N,A())
LET ST=0
LET EN=N
DO WHILE ST<EN
LET ST=ST+1
LET EN=EN-1
FOR I=ST TO EN
IF A(I)>A(I+1) THEN
SWAP A(I),A(I+1)
CALL DRAWBAR(A)
LET FL=1
END IF
NEXT I
IF FL=0 THEN EXIT DO
LET FL=0
FOR I=EN TO ST STEP-1
IF A(I)>A(I+1) THEN
SWAP A(I),A(I+1)
CALL DRAWBAR(A)
LET FL=1
END IF
NEXT I
IF FL=0 THEN EXIT DO
LET FL=0
LOOP
END SUB
EXTERNAL SUB SELECTIONSORT(N,X())
FOR I=1 TO N-1
FOR J=I+1 TO N
IF X(I)>X(J) THEN
SWAP X(I),X(J)
CALL DRAWBAR(X)
END IF
NEXT J
NEXT I
END SUB
EXTERNAL SUB RADIXSORT(N,A())
DIM B(N)
FOR I=1 TO N
LET KETA=MAX(KETA,LOG10(A(I)+1))
NEXT I
FOR J=0 TO INT(KETA)
LET M=1
FOR K=0 TO 9
FOR I=1 TO N
IF MOD(INT(A(I)/10^J),10)=K THEN
LET B(M)=A(I)
CALL DRAWBAR(B)
LET M=M+1
END IF
NEXT I
NEXT K
MAT A=B
NEXT J
END SUB
EXTERNAL SUB SHELLSORT(N,A())
LET H=1
DO WHILE H<=N
LET H=H*3+1
LOOP
LET H=INT(H/9)
DO WHILE H>=1
FOR I=H TO N
LET X=A(I)
LET J=I-H
DO WHILE J>0 AND A(J)>X
LET A(J+H)=A(J)
LET J=J-H
IF J<1 THEN EXIT DO
LOOP
LET A(J+H)=X
CALL DRAWBAR(A)
NEXT I
LET H=INT(H/3)
LOOP
END SUB
EXTERNAL SUB MERGESORT(FI,LA,X())
IF FI>=LA THEN EXIT SUB
DIM W(LA-FI+1)
LET MI=INT((FI+LA)/2)
CALL MERGESORT(FI,MI,X)
CALL MERGESORT(MI+1,LA,X)
LET P=1
FOR I=FI TO MI
LET W(P)=X(I)
LET P=P+1
NEXT I
LET I=MI+1
LET J=1
LET K=FI
DO WHILE I <= LA AND J < P
IF W(J) <= X(I) THEN
LET X(K)=W(J)
LET K=K+1
LET J=J+1
CALL DRAWBAR(X)
ELSE
LET X(K)=X(I)
LET K=K+1
LET I=I+1
CALL DRAWBAR(X)
END IF
LOOP
DO WHILE J < P
LET X(K)=W(J)
CALL DRAWBAR(X)
LET K=K+1
LET J=J+1
LOOP
END SUB
EXTERNAL SUB SELECTSORT(N,A())
FOR I=1 TO N-1
LET MIN=A(I)
LET K=I
FOR J=I+1 TO N
IF A(J)<MIN THEN
LET MIN=A(J)
LET K=J
END IF
NEXT J
LET A(K)=A(I)
LET A(I)=MIN
CALL DRAWBAR(A)
NEXT I
END SUB
EXTERNAL SUB INSERTSORT(N,A())
FOR I=N TO 1 STEP-1
LET X=A(I)
LET J=I+1
DO WHILE J<=N AND A(J)<X
LET A(J-1)=A(J)
CALL DRAWBAR(A)
LET J=J+1
LOOP
LET A(J-1)=X
CALL DRAWBAR(A)
NEXT I
END SUB
EXTERNAL SUB COMBSORT(SIZE,ARRAY())
LET H = SIZE
DO WHILE H > 1 OR IS_SWAPPED=1
LET H = INT((H*10)/13)
IF H<1 THEN LET H=1
IF H=9 OR H=10 THEN LET H=11
LET IS_SWAPPED = 0
FOR I = 1 TO SIZE-H
IF ARRAY(I) > ARRAY(I+H) THEN
SWAP ARRAY(I),ARRAY(I+H)
LET IS_SWAPPED = 1
CALL DRAWBAR(ARRAY)
END IF
NEXT I
LOOP
END SUB
EXTERNAL SUB STOOGESORT(I,J,L())
IF L(J) < L(I) THEN
SWAP L(I) , L(J)
CALL DRAWBAR(L)
END IF
IF J - I + 1 >= 3 THEN
LET T = INT((J - I + 1) / 3)
CALL STOOGESORT(I , J-T,L)
CALL STOOGESORT(I+T, J ,L)
CALL STOOGESORT(I , J-T,L)
END IF
END SUB
EXTERNAL SUB GNOMESORT(SIZE,A())
LET I = 1
DO WHILE I < SIZE
IF A(I) <= A(I+1) THEN
LET I = I + 1
ELSE
SWAP A(I), A(I+1)
CALL DRAWBAR(A)
LET I = I - 1
IF I = 0 THEN
LET I = I + 1
END IF
END IF
LOOP
END SUB
EXTERNAL SUB BUCKETSORT(N,A())
LET MIN=999999999
LET MAX=-MIN
FOR I=1 TO N
IF MIN>A(I) THEN LET MIN=A(I)
IF MAX<A(I) THEN LET MAX=A(I)
NEXT I
DIM BUFF(MIN TO MAX)
FOR I=1 TO N
LET BUFF(A(I))=BUFF(A(I))+1
NEXT I
FOR I=MIN TO MAX
FOR J=1 TO BUFF(I)
LET COUNT=COUNT+1
LET A(COUNT)=I
CALL DRAWBAR(A)
NEXT J
NEXT I
END SUB
EXTERNAL SUB DISTRIBUTIONSORT(N,A())
LET MIN=999999999
LET MAX=-MIN
FOR I=1 TO N
IF MIN>A(I) THEN LET MIN=A(I)
IF MAX<A(I) THEN LET MAX=A(I)
NEXT I
DIM C(MIN TO MAX),B(N)
FOR I=1 TO N
LET C(A(I))=C(A(I))+1
NEXT I
FOR I=MIN TO MAX-1
LET C(I+1)=C(I+1)+C(I)
NEXT I
FOR I=N TO 1 STEP-1
LET X=A(I)
LET B(C(X))=X
CALL DRAWBAR(B)
LET C(X)=C(X)-1
NEXT I
MAT A=B
END SUB
EXTERNAL SUB ODDEVEN(N,D())
DO
LET FLAG = 0
FOR I = 2 TO N-1 STEP 2
IF D(I) > D(I+1) THEN
SWAP D(I), D(I+1)
CALL DRAWBAR(D)
LET FLAG = 1
END IF
NEXT I
FOR I = 1 TO N-1 STEP 2
IF D(I) > D(I+1) THEN
SWAP D(I), D(I+1)
CALL DRAWBAR(D)
LET FLAG = 1
END IF
NEXT I
LOOP WHILE FLAG=1
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A())
LET X=A((FI+LA)/2)
LET I=FI
LET J=LA
DO
DO WHILE A(I)<X
LET I=I+1
LOOP
DO WHILE X<A(J)
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP A(I),A(J)
CALL DRAWBAR(A)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A)
END SUB
REM グモウスキーとミラーの写像
LET LEFT = -20
LET RIGHT = 23
LET BOTTOM = -13
LET TOP = 12
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET POINT STYLE 1
SET POINT COLOR 3 ! 緑
SET AREA COLOR 1 ! 黒
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
LET N = 300000
LET X = 0.1
LET Y = 0
LET A = 0.008
LET B = 0.05
LET MU = -0.8
DEF G(X) = MU * X + 2*(1 - MU)*X^2/(1 + X^2)
FOR I = 1 TO N
DRAW GM(X,Y)
NEXT I
PICTURE GM(X,Y)
LET PX = X
LET X = Y + A*(1-B*Y^2)*Y + G(PX)
LET Y = -PX + G(X)
PLOT POINTS : X,Y
END PICTURE
END
REM ハート型
DEF F(X,Y) = (X^2 + Y^2 - 1)^3 - X^2 * Y^3
LET LEFT = -1.5
LET RIGHT = 1.5
LET BOTTOM = -1.5
LET TOP = 1.5
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET AREA COLOR 1 ! 黒
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
SET POINT STYLE 1
SET POINT COLOR 4 ! 赤
FOR I=0 TO PIXELX(RIGHT)
FOR J=0 TO PIXELY(TOP)
LET X=WORLDX(I)
LET Y=WORLDY(J)
IF F(X,Y) < 0 THEN
PLOT POINTS: X , Y
END IF
NEXT J
NEXT I
DRAW GRID
END
SET COLOR MODE "NATIVE"
RANDOMIZE
SET LINE WIDTH 30
DIM R(5),G(5),B(5)
FOR I=1 TO 19
FOR J=1 TO 5
LET R(J)=INT(RND*255)
LET G(J)=INT(RND*255)
LET B(J)=INT(RND*255)
NEXT J
LET XS=.1
LET XE=.9
LET YS=YS+1/20
LET YE=YS+1/20
CALL LINE(XS,YS,XE,YE,R,G,B)
NEXT I
END
EXTERNAL SUB LINE(XS,YS,XE,YE,R(),G(),B())
FOR T=0 TO 1 STEP 1/128
LET RR=Y3(T,R)
LET GG=Y3(T,G)
LET BB=Y3(T,B)
LET RR=MAX(0,MIN(INT(RR),255))
LET GG=MAX(0,MIN(INT(GG),255))
LET BB=MAX(0,MIN(INT(BB),255))
SET LINE COLOR 65536*BB+256*GG+RR
LET X=XE*T+(1-T)*XS
LET Y=YE*T+(1-T)*YS
PLOT LINES:X,Y;
NEXT T
PLOT LINES
END SUB
EXTERNAL FUNCTION Y1(T,X()) !'1次補間式
LET A=-X(1)+X(2) !'T=0...X(1)
LET B=X(1) !'T=1...X(2)
LET Y1=A*T+B
END FUNCTION
EXTERNAL FUNCTION Y2(T,X()) !'2次補間式
!' C=X(1)
!'1/4*A+1/2*B+C=X(2)
!' A+ B+C=X(3)
LET A=2*X(1)-4*X(2)+2*X(3) !'T=0/2...X(1)
LET B=-3*X(1)+4*X(2)-X(3) !'T=1/2...X(2)
LET C=X(1) !'T=2/2...X(3)
LET Y2=A*T^2+B*T+C
END FUNCTION
EXTERNAL FUNCTION Y3(T,X()) !'3次補間式
!' D=X(1)
!'1/27*A+1/9*B+1/3*C+D=X(2)
!'8/27*A+4/9*B+2/3*C+D=X(3)
!' A+ B+ C+D=X(4)
LET A=-9/2*X(1)+27/2*X(2)-27/2*X(3)+9/2*X(4) !'T=0/3...X(1)
LET B=9*X(1)-45/2*X(2)+18*X(3)-9/2*X(4) !'T=1/3...X(2)
LET C=-11/2*X(1)+9*X(2)-9/2*X(3)+X(4) !'T=2/3...X(3)
LET D=X(1) !'T=3/3...X(4)
LET Y3=A*T^3+B*T^2+C*T+D
END FUNCTION
EXTERNAL FUNCTION Y4(T,X()) !'4次補間式
!' E=X(1)
!' 1/256*A+ 1/64*B+1/16*C+1/4*D+E=X(2)
!'16/256*A+ 8/64*B+4/16*C+2/4*D+E=X(3)
!'81/256*A+27/64*B+9/16*C+3/4*D+E=X(4)
!' A+ B+ C+ D+E=X(5)
LET A=32/3*X(1)-128/3*X(2)+64*X(3)-128/3*X(4)+32/3*X(5) !'T=0/4...X(1)
LET B=-80/3*X(1)+96*X(2)-128*X(3)+224/3*X(4)-16*X(5) !'T=1/4...X(2)
LET C=70/3*X(1)-208/3*X(2)+76*X(3)-112/3*X(4)+22/3*X(5) !'T=2/4...X(3)
LET D=-25/3*X(1)+16*X(2)-12*X(3)+16/3*X(4)-X(5) !'T=3/4...X(4)
LET E=X(1) !'T=4/4...X(5)
LET Y4=A*T^4+B*T^3+C*T^2+D*T+E
END FUNCTION
SET COLOR MODE "NATIVE"
RANDOMIZE
SET LINE WIDTH 30
LET N=INT(RND*3)+3
DIM R(N),G(N),B(N),X(N),Y(N)
FOR J=1 TO N
LET R(J)=INT(RND*255)
LET G(J)=INT(RND*255)
LET B(J)=INT(RND*255)
LET X(J)=RND
LET Y(J)=RND
NEXT J
CALL LINE(N,X,Y,R,G,B)
END
EXTERNAL FUNCTION LARGRANGE(X(),Y(),N,T) !'ラグランジュ補間
FOR I=1 TO N
LET R=Y(I)
FOR J=1 TO N
IF J<>I THEN LET R=R*(T-X(J))/(X(I)-X(J))
NEXT J
LET S=S+R
NEXT I
LET LARGRANGE=S
END FUNCTION
EXTERNAL SUB LINE(N,X(),Y(),R(),G(),B())
DIM TT(N)
FOR I=1 TO N
LET TT(I)=(I-1)/(N-1)
NEXT I
FOR T=0 TO 1 STEP 1/128
LET RR=LARGRANGE(TT,R,N,T)
LET GG=LARGRANGE(TT,G,N,T)
LET BB=LARGRANGE(TT,B,N,T)
LET XX=LARGRANGE(TT,X,N,T)
LET YY=LARGRANGE(TT,Y,N,T)
LET RR=MAX(0,MIN(INT(RR),255))
LET GG=MAX(0,MIN(INT(GG),255))
LET BB=MAX(0,MIN(INT(BB),255))
SET LINE COLOR 65536*BB+256*GG+RR
PLOT LINES:XX,YY;
NEXT T
PLOT LINES
END SUB
SET COLOR MODE "NATIVE"
RANDOMIZE
SET LINE WIDTH 10
DIM R(10),G(10),B(10)
SET WINDOW -1,1,-1,1
FOR RR=.1 TO 1 STEP 1/10
LET N=INT(RND*4)+3
FOR J=1 TO N-1
LET R(J)=INT(RND*255)
LET G(J)=INT(RND*255)
LET B(J)=INT(RND*255)
NEXT J
LET R(N)=R(1)
LET G(N)=G(1)
LET B(N)=B(1)
CALL CIRCLE(N,0,0,RR,R,G,B)
NEXT RR
END
EXTERNAL FUNCTION LARGRANGE(X(),Y(),N,T)
FOR I=1 TO N
LET R=Y(I)
FOR J=1 TO N
IF J<>I THEN LET R=R*(T-X(J))/(X(I)-X(J))
NEXT J
LET S=S+R
NEXT I
LET LARGRANGE=S
END FUNCTION
EXTERNAL SUB CIRCLE(N,XX,YY,R0,R(),G(),B())
DIM TT(N)
FOR I=1 TO N
LET TT(I)=(I-1)/(N-1)
NEXT I
FOR T=0 TO 1 STEP 1/128
LET RR=LARGRANGE(TT,R,N,T)
LET GG=LARGRANGE(TT,G,N,T)
LET BB=LARGRANGE(TT,B,N,T)
LET RR=MAX(0,MIN(INT(RR),255))
LET GG=MAX(0,MIN(INT(GG),255))
LET BB=MAX(0,MIN(INT(BB),255))
SET LINE COLOR 65536*BB+256*GG+RR
PLOT LINES:XX+R0*COS(2*PI*T),YY+R0*SIN(2*PI*T);
NEXT T
PLOT LINES
END SUB
REM BARNSLEY FERN(バーンスレイのシダ)
LET LEFT = -4
LET RIGHT = 4
LET BOTTOM = 0
LET TOP = 11
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET POINT STYLE 1
SET POINT COLOR 3 ! 緑
SET AREA COLOR 1 ! 背景黒
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
LET N = 100000
LET X = 0
LET Y = 0
RANDOMIZE
FOR I = 1 TO N
DRAW FERN(X,Y,RND)
NEXT I
PICTURE FERN(X,Y,R)
IF R < 0.85 THEN
LET PX = X
LET X = 0.85 * PX + 0.04 * Y
LET Y = -0.04 * PX + 0.85 * Y + 1.6
ELSEIF R < 0.92 THEN
LET PX = X
LET X = 0.2 * PX - 0.26 * Y
LET Y = 0.23 * PX + 0.22 * Y + 1.6
ELSEIF R < 0.99 THEN
LET PX = X
LET X = -0.15 * PX + 0.28 * Y
LET Y = 0.26 * PX + 0.24 * Y + 0.44
ELSE
LET X = 0
LET Y = 0.16 * Y
END IF
PLOT POINTS : X,Y
END PICTURE
END
REM ヒルベルト曲線(アニメーション)
OPTION ANGLE DEGREES
LET LEFT = 0
LET RIGHT = 2
LET BOTTOM = 0
LET TOP = 2
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET LINE COLOR 6 ! 黄
DO
FOR N = 1 TO 6
SET DRAW MODE HIDDEN ! 描画途中を画面に反映させない
SET AREA COLOR 1 ! 背景を黒で塗りつぶす
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
LET DIRECTION = 0
LET CURX = 0.5
LET CURY = 0.5
LET L = 1
DRAW HIRBERT(N, L, 90) WITH SCALE(0.5^(N-1))
SET DRAW MODE EXPLICIT ! 描画結果を画面に反映させる
WAIT DELAY 1 ! 処理を1秒停止
NEXT N
LOOP
PICTURE FORWARD(R)
LET X0 = CURX
LET Y0 = CURY
LET CURX = CURX + R*COS(DIRECTION)
LET CURY = CURY + R*SIN(DIRECTION)
PLOT LINES: X0, Y0; CURX, CURY
END PICTURE
SUB TURN(T)
LET DIRECTION = DIRECTION + T
END SUB
PICTURE HIRBERT(N, L, A)
IF N <> 0 THEN
CALL TURN( A)
DRAW HIRBERT(N - 1, L, -A)
DRAW FORWARD(L)
CALL TURN(-A)
DRAW HIRBERT(N - 1, L, A)
DRAW FORWARD(L)
DRAW HIRBERT(N - 1, L, A)
CALL TURN(-A)
DRAW FORWARD(L)
DRAW HIRBERT(N - 1, L, -A)
CALL TURN( A)
END IF
END PICTURE
END
PUBLIC NUMERIC X,Y,ALPHA
LET XSIZE=650
LET YSIZE=650
CALL GINIT(XSIZE,YSIZE)
INPUT PROMPT "LEVEL(1-10)=":LEV
LET Y=YSIZE-10
IF MOD(LEV,2)=1 THEN
CALL LT(180)
LET X=XSIZE-5
ELSE
CALL LT(90)
LET X=5
END IF
LET L=10*SQR(2)^(9-LEV)
CALL KNUTH(LEV,-90,45,L)
END
EXTERNAL SUB KNUTH(N,A,T,H)
IF N=0 THEN
CALL RT(45+T)
CALL FD(H)
CALL LT(45+T)
ELSE
CALL RT(2*T+A)
CALL KNUTH(N-1,2*T,-T,H)
CALL RT(45-3*T-A)
CALL FD(H)
CALL LT(45-T+A)
CALL KNUTH(N-1,0,-T,H)
CALL RT(A)
END IF
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
SET COLOR 7
END SUB
EXTERNAL SUB FD(L)
PLOT LINES:X,Y;
LET X=X+L*COS(ALPHA*PI/180)
LET Y=Y-L*SIN(ALPHA*PI/180)
PLOT LINES:X,Y;
END SUB
EXTERNAL SUB LT(R)
LET ALPHA=MOD(ALPHA+R+360,360)
END SUB
EXTERNAL SUB RT(R)
LET ALPHA=MOD(ALPHA-R+360,360)
END SUB
PUBLIC NUMERIC X,Y,ALPHA
LET XSIZE=640
LET YSIZE=640
CALL GINIT(XSIZE,YSIZE)
CALL GRATE(4,90,XSIZE,YSIZE)
END
EXTERNAL SUB TWO(A,C,W)
IF C<=1 THEN EXIT SUB
CALL RT(A)
CALL FD(1)
CALL RT(A)
CALL FD(W)
CALL LT(A)
IF C>1 THEN CALL FD(1)
CALL LT(A)
CALL FD(W)
CALL TWO(A,C-2,W)
END SUB
EXTERNAL SUB SQUARE(A,H,W)
CALL FD(W)
CALL TWO(A,H-1,W)
END SUB
EXTERNAL SUB GRATE(N,A,W,H)
IF N<=0 THEN
CALL SQUARE(A,H,W)
EXIT SUB
END IF
CALL RT(A)
CALL GRATE(N-1,-A,H/4,W)
CALL FD(H/8)
CALL GRATE(N-1,A,H/4,W)
CALL FD(H/8)
CALL GRATE(N-1,-A,H/4,W)
CALL LT(A)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
SET COLOR 7
END SUB
EXTERNAL SUB FD(L)
PLOT LINES:X,Y;
LET X=X+L*COS(ALPHA*PI/180)
LET Y=Y-L*SIN(ALPHA*PI/180)
PLOT LINES:X,Y;
END SUB
EXTERNAL SUB LT(R)
LET ALPHA=MOD(ALPHA+R+360,360)
END SUB
EXTERNAL SUB RT(R)
LET ALPHA=MOD(ALPHA-R+360,360)
END SUB
PUBLIC NUMERIC X,Y,ALPHA,XYMAX
LET XSIZE=600
LET YSIZE=600
CALL GINIT(XSIZE,YSIZE)
INPUT PROMPT "LEVEL(1-8)=":N
LET X=5
LET Y=5
LET LENGTH=100
CALL PEANO(N,90,LENGTH)
IF XYMAX>XSIZE OR XYMAX>YSIZE THEN
CLEAR
SET WINDOW 0,XYMAX+5,0,XYMAX+5
LET X=5
LET Y=5
CALL PEANO(N,90,LENGTH)
END IF
END
EXTERNAL SUB PEANO(N,A,H)
IF N>0 THEN
CALL RT(A)
CALL PEANO(N-1,-A,H)
CALL FD(H)
CALL PEANO(N-1,A,H)
CALL FD(H)
CALL PEANO(N-1,-A,H)
CALL LT(A)
END IF
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,0,YSIZE-1
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
SET COLOR 7
END SUB
EXTERNAL SUB FD(L)
PLOT LINES:X,Y;
LET X=X+L*COS(ALPHA*PI/180)
LET Y=Y-L*SIN(ALPHA*PI/180)
PLOT LINES:X,Y;
LET XYMAX=MAX(XYMAX,MAX(X,Y))
END SUB
EXTERNAL SUB LT(R)
LET ALPHA=MOD(ALPHA+R+360,360)
END SUB
EXTERNAL SUB RT(R)
LET ALPHA=MOD(ALPHA-R+360,360)
END SUB
REM パスカルのリマソン
DEF F(X,Y,A) = (X^2 + Y^2 - X)^2 - A^2 * (X^2 + Y^2)
LET LEFT = -1.5
LET RIGHT = 3.5
LET BOTTOM = -2.5
LET TOP = 2.5
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET AREA COLOR 1 ! 背景黒
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
SET POINT STYLE 1
LET COL1 = 4 ! 赤
LET COL2 = 0 ! 白
FOR A = 2.2 TO 0.4 STEP -0.2
SET POINT COLOR COL1
FOR I = 0 TO PIXELX(RIGHT)
LET X = WORLDX(I)
FOR J = 0 TO PIXELY(TOP)
LET Y = WORLDY(J)
IF F(X,Y,A) < 0 THEN
PLOT POINTS: X, Y
END IF
NEXT J
NEXT I
SWAP COL1,COL2 ! 赤白交互
NEXT A
DRAW GRID
END
> PUBLIC NUMERIC N,KMAX
> LET N=100
> LET KMAX=100
> DIM X(N)
> SET WINDOW 1,N+1,0,KMAX
> FOR MODE=1 TO 16
> CALL DATASET(N,X)
> SELECT CASE MODE
> CASE 1
> PRINT "バブルソート"
> CALL BUBBLESORT(N,X)
> CASE 2
> PRINT "双方向バブルソート"
> CALL BIDIRECTIONALBUBBLESORT(N,X)
> CASE 3
> PRINT "選択法"
> CALL SELECTIONSORT(N,X)
> CASE 4
> PRINT "基数ソート"
> CALL RADIXSORT(N,X)
> CASE 5
> PRINT "シェルソート"
> CALL SHELLSORT(N,X)
> CASE 6
> PRINT "マージソート"
> CALL MERGESORT(1,N,X)
> CASE 7
> PRINT "ヒープソート"
> CALL HEAPSORT(N,X)
> CASE 8
> PRINT "選択ソート"
> CALL SELECTSORT(N,X)
> CASE 9
> PRINT "挿入ソート"
> CALL INSERTSORT(N,X)
> CASE 10
> PRINT "コムソート"
> CALL COMBSORT(N,X)
> CASE 11
> PRINT "ストゥージソート"
> CALL STOOGESORT(1,N,X)
> CASE 12
> PRINT "ノームソート"
> CALL GNOMESORT(N,X)
> CASE 13
> PRINT "バケットソート"
> CALL BUCKETSORT(N,X)
> CASE 14
> PRINT "分布数えソート"
> CALL DISTRIBUTIONSORT(N,X)
> CASE 15
> PRINT "奇遇転置ソート"
> CALL ODDEVEN(N,X)
> CASE 16
> PRINT "クイックソート"
> CALL QUICKSORT(1,N,X)
> END SELECT
> IF MODE<16 THEN PAUSE
> NEXT MODE
> END
>
> EXTERNAL SUB DATASET(N,X())
> RANDOMIZE
> FOR I=1 TO N
> LET X(I)=INT(RND*KMAX)
> CALL DRAWBAR(X)
> NEXT I
> END SUB
>
> EXTERNAL SUB DRAWBAR(X())
> SET DRAW MODE HIDDEN
> CLEAR
> FOR I=1 TO N
> PLOT AREA:I,0;I+.5,0;I+.5,X(I);I,X(I)
> NEXT I
> SET DRAW MODE EXPLICIT
> END SUB
>
> EXTERNAL SUB BUBBLESORT(N,X())
> FOR I=1 TO N
> FOR J=1 TO N-I
> IF X(J)>X(J+1) THEN
> SWAP X(J),X(J+1)
> CALL DRAWBAR(X)
> END IF
> NEXT J
> NEXT I
> END SUB
>
> EXTERNAL SUB BIDIRECTIONALBUBBLESORT(N,A())
> LET ST=0
> LET EN=N
> DO WHILE ST<EN
> LET ST=ST+1
> LET EN=EN-1
> FOR I=ST TO EN
> IF A(I)>A(I+1) THEN
> SWAP A(I),A(I+1)
> CALL DRAWBAR(A)
> LET FL=1
> END IF
> NEXT I
> IF FL=0 THEN EXIT DO
> LET FL=0
> FOR I=EN TO ST STEP-1
> IF A(I)>A(I+1) THEN
> SWAP A(I),A(I+1)
> CALL DRAWBAR(A)
> LET FL=1
> END IF
> NEXT I
> IF FL=0 THEN EXIT DO
> LET FL=0
> LOOP
> END SUB
>
> EXTERNAL SUB SELECTIONSORT(N,X())
> FOR I=1 TO N-1
> FOR J=I+1 TO N
> IF X(I)>X(J) THEN
> SWAP X(I),X(J)
> CALL DRAWBAR(X)
> END IF
> NEXT J
> NEXT I
> END SUB
>
> EXTERNAL SUB RADIXSORT(N,A())
> DIM B(N)
> FOR I=1 TO N
> LET KETA=MAX(KETA,LOG10(A(I)+1))
> NEXT I
> FOR J=0 TO INT(KETA)
> LET M=1
> FOR K=0 TO 9
> FOR I=1 TO N
> IF MOD(INT(A(I)/10^J),10)=K THEN
> LET B(M)=A(I)
> CALL DRAWBAR(B)
> LET M=M+1
> END IF
> NEXT I
> NEXT K
> MAT A=B
> NEXT J
> END SUB
>
> EXTERNAL SUB SHELLSORT(N,A())
> LET H=1
> DO WHILE H<=N
> LET H=H*3+1
> LOOP
> LET H=INT(H/9)
> DO WHILE H>=1
> FOR I=H TO N
> LET X=A(I)
> LET J=I-H
> DO WHILE J>0 AND A(J)>X
> LET A(J+H)=A(J)
> LET J=J-H
> IF J<1 THEN EXIT DO
> LOOP
> LET A(J+H)=X
> CALL DRAWBAR(A)
> NEXT I
> LET H=INT(H/3)
> LOOP
> END SUB
>
> EXTERNAL SUB MERGESORT(FI,LA,X())
> IF FI>=LA THEN EXIT SUB
> DIM W(LA-FI+1)
> LET MI=INT((FI+LA)/2)
> CALL MERGESORT(FI,MI,X)
> CALL MERGESORT(MI+1,LA,X)
> LET P=1
> FOR I=FI TO MI
> LET W(P)=X(I)
> LET P=P+1
> NEXT I
> LET I=MI+1
> LET J=1
> LET K=FI
> DO WHILE I <= LA AND J < P
> IF W(J) <= X(I) THEN
> LET X(K)=W(J)
> LET K=K+1
> LET J=J+1
> CALL DRAWBAR(X)
> ELSE
> LET X(K)=X(I)
> LET K=K+1
> LET I=I+1
> CALL DRAWBAR(X)
> END IF
> LOOP
> DO WHILE J < P
> LET X(K)=W(J)
> CALL DRAWBAR(X)
> LET K=K+1
> LET J=J+1
> LOOP
> END SUB
>
> EXTERNAL SUB SELECTSORT(N,A())
> FOR I=1 TO N-1
> LET MIN=A(I)
> LET K=I
> FOR J=I+1 TO N
> IF A(J)<MIN THEN
> LET MIN=A(J)
> LET K=J
> END IF
> NEXT J
> LET A(K)=A(I)
> LET A(I)=MIN
> CALL DRAWBAR(A)
> NEXT I
> END SUB
>
> EXTERNAL SUB INSERTSORT(N,A())
> FOR I=N TO 1 STEP-1
> LET X=A(I)
> LET J=I+1
> DO WHILE J<=N AND A(J)<X
> LET A(J-1)=A(J)
> CALL DRAWBAR(A)
> LET J=J+1
> LOOP
> LET A(J-1)=X
> CALL DRAWBAR(A)
> NEXT I
> END SUB
>
> EXTERNAL SUB COMBSORT(SIZE,ARRAY())
> LET H = SIZE
> DO WHILE H > 1 OR IS_SWAPPED=1
> LET H = INT((H*10)/13)
> IF H<1 THEN LET H=1
> IF H=9 OR H=10 THEN LET H=11
> LET IS_SWAPPED = 0
> FOR I = 1 TO SIZE-H
> IF ARRAY(I) > ARRAY(I+H) THEN
> SWAP ARRAY(I),ARRAY(I+H)
> LET IS_SWAPPED = 1
> CALL DRAWBAR(ARRAY)
> END IF
> NEXT I
> LOOP
> END SUB
>
> EXTERNAL SUB STOOGESORT(I,J,L())
> IF L(J) < L(I) THEN
> SWAP L(I) , L(J)
> CALL DRAWBAR(L)
> END IF
> IF J - I + 1 >= 3 THEN
> LET T = INT((J - I + 1) / 3)
> CALL STOOGESORT(I , J-T,L)
> CALL STOOGESORT(I+T, J ,L)
> CALL STOOGESORT(I , J-T,L)
> END IF
> END SUB
>
> EXTERNAL SUB GNOMESORT(SIZE,A())
> LET I = 1
> DO WHILE I < SIZE
> IF A(I) <= A(I+1) THEN
> LET I = I + 1
> ELSE
> SWAP A(I), A(I+1)
> CALL DRAWBAR(A)
> LET I = I - 1
> IF I = 0 THEN
> LET I = I + 1
> END IF
> END IF
> LOOP
> END SUB
>
> EXTERNAL SUB BUCKETSORT(N,A())
> LET MIN=999999999
> LET MAX=-MIN
> FOR I=1 TO N
> IF MIN>A(I) THEN LET MIN=A(I)
> IF MAX<A(I) THEN LET MAX=A(I)
> NEXT I
> DIM BUFF(MIN TO MAX)
> FOR I=1 TO N
> LET BUFF(A(I))=BUFF(A(I))+1
> NEXT I
> FOR I=MIN TO MAX
> FOR J=1 TO BUFF(I)
> LET COUNT=COUNT+1
> LET A(COUNT)=I
> CALL DRAWBAR(A)
> NEXT J
> NEXT I
> END SUB
>
> EXTERNAL SUB DISTRIBUTIONSORT(N,A())
> LET MIN=999999999
> LET MAX=-MIN
> FOR I=1 TO N
> IF MIN>A(I) THEN LET MIN=A(I)
> IF MAX<A(I) THEN LET MAX=A(I)
> NEXT I
> DIM C(MIN TO MAX),B(N)
> FOR I=1 TO N
> LET C(A(I))=C(A(I))+1
> NEXT I
> FOR I=MIN TO MAX-1
> LET C(I+1)=C(I+1)+C(I)
> NEXT I
> FOR I=N TO 1 STEP-1
> LET X=A(I)
> LET B(C(X))=X
> CALL DRAWBAR(B)
> LET C(X)=C(X)-1
> NEXT I
> MAT A=B
> END SUB
>
> EXTERNAL SUB ODDEVEN(N,D())
> DO
> LET FLAG = 0
> FOR I = 2 TO N-1 STEP 2
> IF D(I) > D(I+1) THEN
> SWAP D(I), D(I+1)
> CALL DRAWBAR(D)
> LET FLAG = 1
> END IF
> NEXT I
> FOR I = 1 TO N-1 STEP 2
> IF D(I) > D(I+1) THEN
> SWAP D(I), D(I+1)
> CALL DRAWBAR(D)
> LET FLAG = 1
> END IF
> NEXT I
> LOOP WHILE FLAG=1
> END SUB
>
> EXTERNAL SUB QUICKSORT(FI,LA,A())
> LET X=A((FI+LA)/2)
> LET I=FI
> LET J=LA
> DO
> DO WHILE A(I)<X
> LET I=I+1
> LOOP
> DO WHILE X<A(J)
> LET J=J-1
> LOOP
> IF I>=J THEN EXIT DO
> SWAP A(I),A(J)
> CALL DRAWBAR(A)
> LET I=I+1
> LET J=J-1
> LOOP
> IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A)
> IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A)
> END SUB
>
REM フーリエ級数展開(矩形波)アニメーション
OPTION ANGLE RADIANS
LET LEFT = -2*PI
LET RIGHT = 2*PI
LET BOTTOM = -2
LET TOP = 2
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
DATA 1, 2, 3, 5, 10, 50
DIM N(0 TO 5)
MAT READ N
DRAW GRID
DO
FOR J = 0 TO 5
SET DRAW MODE HIDDEN ! 描画途中を画面に反映させない
SET AREA COLOR 0 ! 背景を白で塗りつぶす
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
DRAW GRID
FOR T = LEFT TO RIGHT STEP 0.02
LET S = 0
FOR I = 1 TO N(J) ! 1から第N(J)項まで足す
LET S = S + 1/(2*I-1)*SIN((2*I-1)*T)
NEXT I
PLOT LINES:T,S;
NEXT T
PLOT TEXT ,AT -0.8, -1.5, USING "N = >%":STR$(N(J))
SET DRAW MODE EXPLICIT ! 描画結果を画面に反映させる
WAIT DELAY 1 ! 処理を1秒停止
NEXT J
LOOP
END
EXTERNAL SUB HEAPSORT(N,A())
LET NN=N
FOR K=INT(NN/2) TO 1 STEP -1
LET I=K
LET X=A(I)
DO WHILE 2*I<=NN
LET J=2*I
IF J<NN THEN
IF A(J)<A(J+1) THEN LET J=J+1
END IF
IF X>=A(J) THEN EXIT DO
LET A(I)=A(J)
CALL DRAWBAR(A)
LET I=J
LOOP
LET A(I)=X
CALL DRAWBAR(A)
NEXT K
DO WHILE NN>1
LET X=A(NN)
LET A(NN)=A(1)
CALL DRAWBAR(A)
LET NN=NN-1
LET I=1
DO WHILE 2*I<=NN
LET J=2*I
IF J<NN AND A(J)<A(J+1) THEN LET J=J+1
IF X>=A(J) THEN EXIT DO
LET A(I)=A(J)
CALL DRAWBAR(A)
LET I=J
LOOP
LET A(I)=X
CALL DRAWBAR(A)
LOOP
END SUB
REM 花模様
LET LEFT = -1
LET RIGHT = 1
LET BOTTOM = -1
LET TOP = 1
SET WINDOW LEFT, RIGHT, BOTTOM, TOP
SET AREA COLOR 1 ! 黒
PLOT AREA : LEFT,BOTTOM;RIGHT,BOTTOM;RIGHT,TOP;LEFT,TOP
SET LINE COLOR 7 ! ピンク
FOR T = 0 TO 2*PI STEP 0.01
LET R = SIN(4*T) + 0.25*SIN(12*T) + 0.12*SIN(20*T) + 0.07*SIN(28*T)
PLOT R * COS(T), R * SIN(T);
NEXT T
END
REM 8-QUEEN PROBLEM SOLVER
DECLARE EXTERNAL SUB SET_QUEEN
OPTION BASE 0
PUBLIC NUMERIC FLG0(7),FLG1(14),FLG2(14),QUEEN(7),COUNT_ANS
MAT FLG0 = ZER !列(|)方向に配置済みか
MAT FLG1 = ZER !右上左下方向に配置済みか
MAT FLG2 = ZER !左上右下方向に配置済みか
LET COUNT_ANS = 0 !答のカウント
CALL SET_QUEEN(0)
END
EXTERNAL SUB SET_QUEEN(I)
FOR J = 0 TO 7 !各行チェック
!3方向に未配置なら
IF(FLG0(J) = 0) AND (FLG1(I+J) = 0) AND (FLG2(I-J+7) = 0) THEN
LET QUEEN(I) = J !I行目のJ列目に配置
IF I = 7 THEN !全行配置完了なら
LET COUNT_ANS = COUNT_ANS + 1
PRINT COUNT_ANS !答の通し番号を表示
FOR K = 0 TO 7 !答を表示
PRINT REPEAT$("□",QUEEN(K)) & "■" & REPEAT$("□",7-QUEEN(K))
NEXT K
PRINT !一行空ける
ELSE
LET FLG0(J) = 1 !配置済み
LET FLG1(I+J) = 1
LET FLG2(I-J+7) = 1
CALL SET_QUEEN(I+1)
LET FLG0(J) = 0 !一つ下の行をチェック
LET FLG1(I+J) = 0 !するので未配置に戻す
LET FLG2(I-J+7) = 0
END IF
END IF
NEXT J
END SUB
DECLARE EXTERNAL FUNCTION GETKEY
OPTION BASE 0
LET XSIZE=600
LET YSIZE=600
DIM BACK(XSIZE,YSIZE)
CALL GINIT(XSIZE,YSIZE)
!'''SET DRAW MODE HIDDEN
DO !'キャラクター描画
READ IF MISSING THEN EXIT DO: A$
READ B$
LET A$=A$ & B$
LET X=0
FOR J=1 TO LEN(A$) STEP 6
LET R=BVAL(A$(J:J+1),16)
LET G=BVAL(A$(J+2:J+3),16)
LET B=BVAL(A$(J+4:J+5),16)
CALL PSET(X,Y,R,G,B)
LET X=X+1
NEXT J
LET Y=Y+1
LOOP
LET XX=X-1 !'キャラクターサイズ
LET YY=Y-1
DIM MASK(XX,YY),CHARA(XX,YY)
ASK PIXEL ARRAY (0,0) CHARA !'キャラクタービットマップデータ
FOR Y=0 TO YY-1 !'マスクデータ作成
FOR X=0 TO XX-1
CALL GETPOINT(X,Y,R,G,B)
IF R=0 AND G=0 AND B=0 THEN !'キャラクターの背景部分を白へ。それ以外は黒へ
LET R=255
LET G=255
LET B=255
ELSE
LET R=0
LET G=0
LET B=0
END IF
CALL PSET(X,Y,R,G,B)
NEXT X
NEXT Y
ASK PIXEL ARRAY (0,0) MASK !'マスクビットマップデータ
CLEAR
RANDOMIZE
FOR I=1 TO 150 !'背景描画(仮)
CALL CIRCLE(RND*800,RND*800,RND*200,RND*255,RND*255,RND*255)
NEXT I
ASK PIXEL ARRAY (0,0) BACK !'背景データ
LET X=0
LET Y=0
LET X0=-1
LET Y0=-1
LET SC=2 !'描画倍率
DO
LET DX=0
LET DY=0
LET S=GETKEY !'キー入力(矢印、テンキー)
IF GETKEYSTATE(32)<0 OR GETKEYSTATE(27)<0 THEN STOP
IF S<>-1 THEN !' X,Y 移動量
IF S=1 OR S=2 OR S=3 THEN LET DY=YY/2
IF S=7 OR S=8 OR S=9 THEN LET DY=-YY/2
IF S=1 OR S=4 OR S=7 THEN LET DX=-XX/2
IF S=3 OR S=6 OR S=9 THEN LET DX=XX/2
LET T=TIME
DO
LOOP WHILE GETKEY=S AND TIME-T<.1
END IF
LET X=X+DX
LET Y=Y+DY
IF X<0 THEN LET X=0 !'壁の処理
IF Y<0 THEN LET Y=0
IF X>XSIZE-XX*SC THEN LET X=XSIZE-XX*SC
IF Y>YSIZE-YY*SC THEN LET Y=YSIZE-YY*SC
IF X<>X0 OR Y<>Y0 THEN !'画面描画
SET DRAW MODE HIDDEN
SET DRAW MODE OVERWRITE
MAT PLOT CELLS,IN 0,0; XSIZE-1,YSIZE-1:BACK
DRAW DISP(XX,YY,CHARA,MASK) WITH SCALE(SC)*SHIFT(X,Y)
SET DRAW MODE EXPLICIT
LET X0=X
LET Y0=Y
END IF
LOOP
DATA "000000000000000000000000000000161019020202000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000010101885C8E4A334C000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000080705000000262121B783C4B064B4352C2900000027231B19130F000000000000000000000000000000000000000000000000000000000000000000000000000000000000010101010101000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000051412F13100C4D464FB88DD9BC6FD38766751714106659461A140F0000000000000000000000000000000000000000000000000000000000000000000404030908082723283F3842433A463731391C1A1C"
DATA "010101000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "0000000000004C3D2F8C795D82868E7A7ACD7A6DD56E619A886D597C644C0605030000000000000000000000000000000000000000000000000000000000000000003A352D3E3B363734352A262B2C262E2F2A313B373E"
DATA "302D32000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000241D16887261706D7C6B9FD05596D6516B80847888806E6A6659473B31250201010000000000000000000000000000000000000000000101012323238E7F747B67505047443430373B363E3A363E413C45"
DATA "4E4A541F1D20000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "00000040392D7D62527E67518B78656493A83698C772766681644B5F4B3A88747F92776017120E000000000000000000000000000000000000000000030303696464A2978F675D5929272A373339403C4438343A302D32"
DATA "2C292D323033090909000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "02020182705A6255550A0706453426243A3E3D7B8915151134271C2B201894837B8C71663A2C210000000000000000000000000000000000000000000E0D0D403C3C9894922C2B2C2B282A433D3E594D4B2E2C2E302E31"
DATA "2625261E1C1D2F2D2F151414050505000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "0000007E654C41332625221B00000016130F6C5A4609070513110F594B3E4C3B2CAA906D15100C0000000000000000000000000000000000000000000101012624243E3C3C343032554A49AEA2978C8179433D3E423A3A"
DATA "2E2B2B1A18191E1D1D2B292B201E1F141314131214181518151316100F11020101000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "06060589715635281D6B5B471715121D221F80887B1A1F1B5146375747370C090684684E201A130000000000000000000000000000000000000000000303031F1C1E2A2729413839684F577F666E82736E6A5A595F474B"
DATA "4E413F281C201C1A1C2120221E1D1E110F11151315100E11110F111E1B1E272327201D21232224232123282628292629282628181718060606000000000000000000000000000000000000000000000000000000000000"
DATA "13100D775D440906055747377C68525169693687C35F6061907357372B200403025947376855400101010000000000000000000000000000000000000A0A0A1E181C2A2427584846B9A8A1D7C7C0CBC3B4CEBFB6B598A6"
DATA "5F5251382127321F2428151A1F1C1E211F210605060101010504040605060303040C0B0C1B181B1412130B0A0A0F0D0E1C1A1B332F32322F32191819010101000000000000000000000000000000000000000000000000"
DATA "3B2E246957470100001D19136756454B493D6180916152455442301E18140505042C29237F736A0D0A070000000000000100001615154644434542403430302B1F232B20254B272CA79B90E2D9C9E2D9C8DFD7C7D6CBBB"
DATA "523B3F471F264321285F2A3441171E2B191D3E353D332D351F1B200D0B0D0807080404040403041714171B191C0908090000000101010B0A0A1F1D1E2C292B0E0D0E000000000000000000000000000000000000000000"
DATA "4C4133645A49040403241C150201011B140E89745954453702010114110E4841394A4538807159080504000000111011504F50BAB9B8DFDCD6E0DDD7D1CDC7A79F9C4F45475822298C6560DCD3C2DCD0C0DCD3C3956D6B"
DATA "59212865272F491F275A242D69232A581D24451A21481F264222292E1F251F1C20211E21262327312D31423D43302C30120F12010000000000000000050405141313110F11000000000000000000000000000000000000"
DATA "241B15765E47463C31110D0A010100392D2362443535261C020101000000231B15705E4B867155010000121212BAB8B6E1E0DDE1DFDDE1DFDAE1DFD9E2E2DCDDD9D3B6ADA9542C318B7574AA9089BEAEA188676463262D"
DATA "7431358147445B3C3A6F403D703C3473443A60212843171E451A1F64252D58212A391D2320181C1A181B242124413D43524C55363137181518050405000000000000050505090809000000000000000000000000000000"
DATA "2019139F917544362B000000271B155430256D28245A241F311A15000000060403715A42836D5001010166605CDBD4CDD9D4CED4CEC7D4CEC8D7D3CCDDDAD4E2E1DADCD5CF8B7E7A745E678B778A7F726D6B5B5D221013"
DATA "654E429A80648E776181604D703D308A3C35A3836E7D5D55542A2F3B161B63202B61212C541F28361B20201B1D221E212824282A262C262227241F240F0D0F000000000000040303030202000000000000000000000000"
DATA "15100C75735E251B140E0B0A4F382F391F1979352E5F252254464502020200000045473B6E634E3A3633C1B3AACCC3BACDC3BACBC0B5CABFB4CFC4BBD3CBC3DBD6D0E1E0D8D1C8C170635FAFA094917B648E7D6787796F"
DATA "513E3A79604AAD8F6C8E674E71585286664D67392B977E77CFCDCE886A6E67283064212A5C1F255C2028491C232E22262C21262F22282320242B262C29242A131114010101000000090707000000000000000000000000"
DATA "090705806E56281E163B2F2A251A172A1C167F3B356C413E7D6760424037000000745E46403429A39C95C7B8AEC6B5A8C9B8AAC7B4A5B9A192C1AD9FC6B5A9CEC2B9D7D0C8DEDAD193867F988F85D0C3B17D8D8ED2CEBF"
DATA "B6A6985E4D42AD906D9D8873D4D1CE8C736C6F3D2F987C66D1D0CEDCDBDBBAACAD81555968232B5F1E255E1F25511E254032384A363F3B252D433C442621271713161714170000000A0708000000000000000000000000"
DATA "0000004D41324E3F306149400605040C08064A18186A47466F4D3F815947462A227C6249322D28CEC2B8CCBBAFCDB8A9C3A996A186738656458953439D8377C1AA9CC8B7AAD1C4B9C8BCB3C2B8A9E0D8C6CBC1B3DACBB9"
DATA "E2D8C7C8C1B1A89886A6968CE1E1E1C8BFBB6F43388D7053988179E2E2E2E2E2E2DDDCDB81585B6A222A6820296321275A242A3B32383F2129331D232B262A2320250F0C0E0F0D0F0B080A000000000000000000000000"
DATA "0000000E0A07795E474939330000000000003513126533294F33246E463D8C5C4B85634D594E46A69184B39484B2907AA585707147388142338F5046792D258F7065B8A292C1AEA1B4857CA56C59B5A790D1CDBBD5C1AF"
DATA "DBD4C2BFB49F9B886FA85444C69F9CD6D0CD754842713C31A97864CEC6C2E2E2E1E2E2E2C7C0BF7F3E426B22296E242C69232A49242A2D252B461D24301C22201C21181518050404141113000000000000000000000000"
DATA "000000000000544436473F330000000000002D12114C1D1B140E0A654B3B7B5A4B744137954B418E4A3F9C6150865C4D7643347546347E3B2EA22C289D2C254E2A1E66514276362DBB2720B74B3B8A715A9C7C63967D6A"
DATA "AA9B88685162957C617D453CAB322EC2B0A98156526B39318E67509F655ED5CCC5E1DFDEE2E1E0AA8F8C78282D64202567212767262C261E223E262E48191F28191E19161A0F0D0F141114000000000000000000000000"
DATA "000000000000604F4366594B18181700000025171254342A010100362E24704F42602E2E574237893831A92A299A423B86322B984C3D7D38317B382E6A44365734287C664F733026971E1C9B28246E4D3E6F5A6472595A"
DATA "82675A4E3E6647344A3A29257E231EA8867D8756555D2F2D72473CA76755A98C7DCFC1B8E0DFDCCEC8C48234387524294C181B68212634232A251E254A1E24451C231815191F1B21100D0F030303000000000000000000"
DATA "0000000D0A095B473E0A07055E4E413E3933403529846D534A443A79675176644A6638356D3E3B5D43368039336C3730441A1B5E1A175D30316934335A322B644B4682654C6B3D318F2B2C8C29294627243C2B394A394B"
DATA "59595C3E29553D274E3826258A3B388A6D6278363E693432672D2D8E5747916350B19C8FDAD5D0E1DFDE945C5C601F227726293512133E262D1D171C3F242B4E1B2223191F19151A050405080608000000000000000000"
DATA "000000231A1932262338362C9F95758973587459428062487B66509C8463917B5C87725C704039642E2F6F4A405E44394A2D264B282344324B55415E5A40586F585F8A6D53694F3A6725259C3739482825483338483B42"
DATA "5B6E72503847432C3D351F2352373F453042631F2F7F373A75312F997B6094654EAC756AD6CDC6E2E2E2AD8F8D6E25286722243B15153322282D1B202F2128521D2426161A1D1A1E09080A080608000000000000000000"
DATA "0000004F3F35302822796C544C3A2A543E2D4F3C2C795A415A493731241A1F161074604C7B635266453F4C2A2855362F63302D563642473555564165634D736C575F856A507C6147774133892F2A44221C3928373B2957"
DATA "74525D503B6934243052282E3B2A4B372347311F335F3A3067292C5B2724603F3197564ECCBDB3E1DFDCC2B4B0782D2A411719672426251E25351B1F361D214A2329261115231F231210120B090A000000000000000000"
DATA "000000644E42261F192E241A01010022181135261B977C5D3F2F2217100C070707897C6FB4A2979D86806B48416C443B6A4F5250374A453153513A5E5E486D654F636F57497B655064372EA12F29782E26392A3242335E"
DATA "8062725A48684B3A4865343A3B284A3320422F1E3C341E2C6C2B2C911B29742A2A926256C6B2A7E0DCD7D8D4CE86463F240E0E7E3539221B213B1D204D2024371B20210D0F282327252125030303000000000000000000"
DATA "000000513D3740392B53463412100C0605040E0A078A6749211811151310332B229480659F866AA68F849E867BA58C825B495252363D422D4D483254583C64553D6159425E5D4B5B562A37973B2EB03B33604E4E5D4C77"
DATA "64516D5D4B74615262643F3F3B274A2F1E3D311E3D2A183525132A54232E932236966D5EC8B5A9E1E0DDDFDAD5945D554C19134E2D34301B1F412023642526311B2016090A2723260E0C0F000000000000000000000000"
DATA "000000523B3380654AB99B74917B5D1D1A150604037E6249110D0A29241D9D8667BAA485C1AFA1AA9185A2877BA68C84604C534E323E3F274A3E26464B30574D355A50385B4B375948304D86241FA95546634F47564669"
DATA "55457451407256495963453E34203E2F1E3C301E3C2B193621112D1F0F2B49313AB18F76CDBFB4E2E2E1E1DEDBA280786C261F211C21572A2E452225682729331C20161115252125030303000000000000000000000000"
DATA "00000058423719100E1B130E8E8266564F3F020201745A42110D0A473E31988E72958E81D6C5BAB8A194A99287AC9388654E55482E394025493A20423F284A442D4E472E51493054452F4B7C291EAA4C3C5D4B3F4D3D57"
DATA "4C3A6E49386B5242536444355434323320382D1B372C1B3820112B1E0F243B2934B3957ED5CBC2E2E2E2E2E2E2A796933A2729341E21703A3E48202465282B3F2125171316191619000000000000000000000000000000"
DATA "00000040312A291D190F0C094D3C2C584735372F246E56402D251D53433434281F8C8379D5C3B8C1AA9EB0988AAE9688745E5E422A324229493C23483F274B452E4B5D2D3B531C2C5E453F894935A160496D48394E3B4F"
DATA "462D65472D6645304E563E307947343F222626142D2A183322112B1D0F20453338BF9F8BD8D1CAE2E2E2DBDAD86A6367271F2269242453353B58262A56262A472328131013050405000000000000000000000000000000"
DATA "0000002017133B292300000000000000000041322568503B7058410F0A07000000615B55D6C3B7C5B0A4AE9789A99285866D67412B37462C49442A4D4A2E53663E467B1F1E88202076201B6D3C31966750947D64634E50"
DATA "50336C4E306A483058765A449781687B200E44111A21112B21112A1C0E203D2D33C1A592DCD5CED7D6D76E6A6E2E2629611B197221212D222760292E4E2226351C21090709000000000000000000000000000000000000"
DATA "0000000906055E42340000000000001E1D19322D25735A43584433564F441D1C1869625DDCCABECFBCB0B59C8FA68D81886C654C343F543947472C5050374F803F378C362F9B3A309F2A23812618795C4799866F7C614E"
DATA "543E5A5640614F3C4F654B396A523E78372387171249101B1E0F271E0F213E2E36C3AC9CC0BAB55B575C312B306637357B100F52282E2F1C20391A1D622C32180F11020102000000000000000000000000000000000000"
DATA "0000000000003C28200E09070000005046383E30256B503B5641304D3D2E4F443322211FD4C9BDD7C5BAC1AB9FAE9387987C745E465253384842294D52344684352EA05E4B954537A55242854B38524037755F483E2B3F"
DATA "48376856447744335F3A2A2C4B32264C39328C2A1E89191A350B191F0F224F3C41BBA6989B938FA19794AD9F9B7F38356C212326202653423751242C4A23290B080B000000000000000000000000000000000000000000"
DATA "0000000000002719131F110E000000221B146557475F4534522D255B4C3F18120D0101019A938BD6C2B6C6B4A7BDA59BA890887A6067573A4F4F344A50384EAA6C588B4736A26352A87C63503B367332294836304D3755"
DATA "5342736150824633635A484C5F2F27412D2A6E3B31931E1E5F0D13300A16584447C0A89ACBC0B9CCC4BFC7BCB878393A37282F3629297655446F4347170D100C080C000000000000000000000000000000000000000000"
DATA "0000000000000502025D43330B050500000002010122161240191800000000000000000069615CD2BEB2C5B5A6C3AFA4B19A959D85816549654D314A442B4C7A5D58945440A764575A49457E4E40AC342E503F3E563E65"
DATA "4A386A5C4A7D422C615C4F5973362E76372E463633812C277811144B03097B5C54C2AB9ED8D1CAE1E1DEBDB8B93F363C2521229E8B707C573E4F423C1D161E010101000000000000000000000000000000000000000000"
DATA "000000000000000000160D0B4D35290000000000001F1710493026000000000000060506605957D5C3B7C6B6A8C2AEA4B49F98A48D8A7B616E6140574C314E52354EA2765F8A675E4E3A35A63A30A641385547474F3763"
DATA "432F624B3A6D453065554A57753731871F2064453B4B3230851A1A4F0408977B70C5B0A6DCD6D1B9B6B94E494D2925276857489F775A7B261A6346380D0A0C000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000004C32241C110F00000016100B4C31260000000000001614165E5B5DDBCDC3C8B5AABFA9A1B19A95A087847F64695F3C61664554765965CB9F8C9B8B76855F4CB32D2984403969574E765E6A"
DATA "543E6E58446A6A546E6C5D556E3B34A2272785302C4C3C385A2D275A0C0AA18880BAA8A19089893E393E242023401818986E529B7F619D3C2C723727150F0C000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000805045A3C2C0B0605110C094C2A21000000000000191619454145CEC1B7C7B5A9C3AEA5B79E98A186829072736E5061553656624F4BD0B09DD2B09CB59981A967566D4A416C5343866D5F"
DATA "6C5360624B617D635A8068536136309F3E379C5F4F7358492218174F1E1B7061604B46483B3739766C6A7464636F15129367508B6E54976C5E873A2C21100D000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000F0A085333280F0A0859211F0000000000001C191C201C22B0A199C8B6A7C5B3A6BDA59EA789839674728160634E3941655447706660918579D9CAB7CFC1AEAE907A7759536B514F"
DATA "80645B8A6D6192715F836158A18978C1B19ED1BEAC67554B2D1F1F2C2022796A66908480BAAFABAEA19EB5A5A17719168C5541804A396F3C2D92352F3C201C000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000281812341D186A27250100000000001E1A1E1D161E917F7CD0BBB0C9B5A8C2ABA1A2867C7656478F6F5C7F67578D7158887D673D3132D0C4B29E8D81786357523934361E35"
DATA "3A203B432C2D6749427C5F57897D7590867BC8B5A55242373522232C1E1D998782C8BAB4CFC8C4D5D0CBBCABA67C2115863725926751982E2D903832492F26000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000003120175727230502020000001D191C1F171F7D6A6CD9C9BFCEB9B0C4AEA3AB8E84643029793B2EA582659A8368544438453639A994874639398B85764F3D32361F33"
DATA "4225451D141A1B14174A3A37756A62857D73A28A7D3E2C265A3C2B381812998B84CEC3BDDFDDD9E1E0DDC0AFA9832A178F241A81543F9C6F5A90363646161A000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000010000502A2123130F0000001D191E261D27513841D8D1C9D5C2B9C8B2A8BB9F958A5B556313116617148452407763513A2B2D45353634282B79624E5E46463D243F"
DATA "4C2D5439243243312A5B473A6E5C4A6354464D3C3B5F483954291F360B0E867370CABBB3E0DEDBE2E2E1C3B3AF892E1CA0291E882721825B438B453E77272E000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000005B24202A18130000001D191E2D252E2E1820AFA4A4D8C8BECCB6ACC2ABA1A6877E71221D70141186241E906A54443934251D20231A1E3222313E264A3D244A"
DATA "503560472E56261C201C1419281E2434282D372A2C775340480B0A3714248F7C7CCABCB3E1DFDDE2E2E2B59C97922D1AA0271EA828259326268C302D872F31080706000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000005C24221708080000001613173830391E10175E3F47CBB8B1C7B1A7C1A79DB3988F873A32801411A02722A45B4A6955451E171E1F161A38213F3D23493C204A"
DATA "462D5847335E3525381D131A22191D2F23295F5042783A2D4F0D0C3A1D34A4938DCEC1B9E1E1E0E2E2E2C1AFAA8F2D1E9044349A352C9F2B27954E488A64532B251E000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000602B271A07070000000302033F35411712163F202AA38B8BC8B0A7C0A69BB79D969248418C1717A25242964037775642261B1D2B1C2A3C22483E244B3C214B"
DATA "3D214C402D573B2B4920161C1E16194C3F39945A4778392B4D1615452D46B1A198CFC3BAE2E1E0E2E1E1C7B7B18E4236A0896A8755427E65527D6651604937534333000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000070404713731230C0C000000000000322A34221B231E0E13704C53C3ACA5BFA59BB69C968F4541951E1DA6483FAA5B4B794D3C2C211E51354A3F254C3E244C3D224C"
DATA "4626573C224C3F3155261C2121181C806A58B93F378D41374F2125543C56C4B1A9CFC2BAE1E1DEE2E0DED1C3BC824B406E4F3A57392A523B2C6648347F5D448F785C0E0D0B000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000D090766322A2D1111000000000000110E11362C380704063E1E258F6E70C7AFA6B99F978A4B42A25E4DBA6757B950457049374A312C65415E4F31573E244C3E244C"
DATA "49295C4525563D294B342A2B493E38977160A7615D903430511A1E6A5667CEBCB2D0C2B9E1DFDBE1DFDDD0C3BC9D4E44772C1D7347338662489A7455AE8B67A28866423E36000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000100004A2D212512100000000000000101012F263120141C090506542F35B89F9ABAA1949E6E53993C33A86855A6463E6132295B38385935657953633E244B40254E"
DATA "48295A4C2A60432550492B288150419D7C6ABF4541934E3F601A1A614C5ECEBDB2CABAB2DFDBD6DFDDD8C4B4AE93392E8B260E82432EAC8B69B2946FB3926D906F5326201A000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000160707593427030201000000000000100D1030233127151B0F080B5C4041A4816D996D5695574CB476618E3B335B332A765D5F5E405D5E376955385042274F"
DATA "48285A4C2C6349285A3F2D32A08566C09F81C15A5292463A691717695461D0C0B4CEC0B8E0DDD9E0DEDAC0AEA8942C228A2A0F7A3E2BA58C6A997B5C9F7E5E3D2F23020201000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000220D0C5D28210B06050000000000000000001C161D25182248232C4124287D4033BAA391ACA295B16A5C74372E674B3F8C74767458645934656E495E51344E"
DATA "4728574D2C644B2B61473041A38365AF937AB0A391986A5A662921574353C9B9AED2C7BEE1E0DDE1DFDCBAA5A19325198D2C1287392A875C467D342868201A000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000001A0C0B56211F0202010000000000000000000101011D161E130D113A24227E493CB39E92C29B8CAD957577543F613930947B7B876C716A4E5D543061543650"
DATA "53364A5A385C502E64482B4AAA7C64BB9481C8BF9C9D755967493958465ECCBDB0D0C4BCE1DDD8E2E0DDB1948F94291A982C18A2231A90281C922B20792523000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000000000000000000000029161158211F0000000000000000000000000000000202021F1820261B1A733C32874038BB9279AB856574463575564FA28A8A8E72757A5E645938574A2B55"
DATA "44284E4D2F5075506242253C714F3AA76D63A86E5E98684E593E3A635169C9BAAED0C2BAE0DCD7E1DFDBAD807B932614A52B1CB12824AA312CA02C28772626000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000004727205F262301010000000000000000000000000000000004030353372960392FAA9F82BF9A7A875B446B3F35A68F8CA8908E967A7B7B5E626B4C53684A54"
DATA "4E344642264F5535595F333964473090574D9E64538955414F38434E3C5FC6B6ADD0C1B8E0DCD7E1DDD9B38B84902915A834299F897AA18B77A7554A7D493E000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000003F291E632D280301010000000000000000000000000000002317106E3A2B68211EA98970CAAE857B5240AF9A91BCA5A1AE95929F838287696B75555B715159"
DATA "66474C573B494A30495B232B8F654B4F24207E5D497943344C394D544462CAB8B0D2C4BAE1DED8E2DED8B0857F962B19A4352A793D31761F1E9B7156775A44050302000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000130D0A5D3C2E050202000000000000000000000000000000512820894B3C8620217E55458F7055574039C0B1AAC9B3ACB89F9AAC928D98797782616276545A"
DATA "6D4C516A4B4D65474A6C29299E6B538A2121561C1972523C452D41705F72D5C2B7D3C6BCDEDBD3E0DAD4A477719B2D1DB02E27972425A5252B8C453B754E40000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000000000000000000000002010144221A1D110D0000000000000000000000000403026C2F28A35D4DA32E30772A29623331361D1C353031D3C1B9C6AEA7B79C96A78983936F6E7E5C5D"
DATA "6E4C4E6B4B4C694A4A682D2F9C5E4FAF4F45841A1A522720452C3F5D475ECFBBB1CDBEB5DBD5CEE1DDD79E605CA02E20B2302BB52C2DAA272D9030315B362E000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000000000000000000000001010155232123120E000000000000000000000000140F0B742F2AA86856BB413E8532337D3E3F0C0706020101665D5CCFBDB5C7ADA5B4968E9E7A748B6562"
DATA "795354714B4C6C4B4B6E3E3F883838B6846CA42425791213603D40664E54C4B0A4C5B4A8D5CCC5E2E1DAB28E87A32E21AC312CB42D2DA4292D8F3936542F29000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000602523150908000000000000000000000000190F0C7B2D2BA86859C44C4977313751302E000000000000080707605858B4A19BBFA49BAB897E9C756E"
DATA "8D6460795050714B4B664444843639B37568A64C44881517673B3B724E4EAC968CC4B2A7D5CCC5E1DDD6A87E78A52E24A92F2DAE2E2D9D2D2F9967515C292B000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000000201016329251509080000000000000000000000001C0E0C822A2CA96457AD4646773E441E17150000000000000000000101010908086E605CBB9D92AF8D81"
DATA "9D746C845A587A524E774D4C7A3F3E9E383EBA8D73891E1F6536356F4A4BB19A8FC8B6ACD0C5BEE0DBD3AA837EA42C26AB2D2DA42D2DA9746C8C645066282E000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000160F0C7E3F361C0B0A0000000000000000000000001A0A0A81252BB0685C913D41684B400404030000000000000000000000000000000504044136366F5D57"
DATA "A6807591635E8459557D544F7748458F343EB95951904137683434724B4AAA9188CDBBB0CDC2BAE1DED7C4B1AA9E2E29AC2E2E9E443FC5B7A3853A39642A30000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000000B0706774539200B0A0000000000000000000000001E0C0C83272DA1675B7F47423E2D25000000000000000000000000000000000000000000000000040303"
DATA "3E2F2E8B635C93645E8357527A4E497E383FAF3B4094473D6F3534754A4A91766ED2C0B4CFC4BCE1E0DED9D1CC9D4B47AA302FAC6A58BDA27F924847644E41000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000000101003721192F1D1700000000000000000000000025110F872C3298635685584C16100E000000000000000000000000000000000000000000000000000000"
DATA "0000002D2121805D5690615A83554F76404097353E913F396F3733784B4B8C706AD3C3B6D1C5BBE1DFDDE0DDD99F6E6CA12D2D95423AA883618A6F575D4637000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000000000001A060648271F0704040000000000000000002E17148E4F449C5E536D4D41000000000000000000000000000000000000000000000000000000000000"
DATA "0000000000000604042C1D1F654341704742843740933C3C6F39337C4F4C866862CFBEAFD1C4B9DED9D2E2E1DEC5B5B0933D3F982D31852D31812F34674335030302010101000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000220B0B5C2C250C06060000000000000000003D1A19933F3D91474940312B000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000003020218110F864E4F8A54486D312D784C4A75504EBAA498CEBFB6D7D1CBE1E1DEDDDAD5A47D7B922C2F9A31389B3B3C80463D82776B3935330F0E0D000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000170F0D5331275727230100000000000000000000004B201E924A457F564C1B1211000000000000000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000100008752509739406F4337352124694446AB9389CFBFB5CEC4BBDAD5D0E2E2E2D7D2CE965D5D932C3197333990353B906566CCBFB9ACA099625C57131211000000000000000000"
DATA "000000000000000000000000000000000000000000281E194D372A281C194645420000000000000000000101015D2723957263664638090606000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000794A47A43D457E4C3D130F0C181013917E77D0BEB3CBBEB5D0C7C0E2E2E1E1E1DDC9BBB7925D5E8C3136892A329C5758CABFB6D3CBC4D8CEC8706964080707000000000000"
DATA "00000000000000000000000000000000000028231C38241D08050520363C3F8CA8030A0D000000000000090605762D28996455573831020101000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000744541AB42468A483C292018000000625954D3C3B6D1C3BAC9BDB3DCD8D3E2E1DEE1DFD9D8D1CBB096948D5357924445C2B1ACD9D4CFE2E2E0D5D1CC5F5B58020202000000"
DATA "000000000000000000000000000000221E18776045281D14000000213D482F77BD06161F0000000000001A100C8F5D52A28B6E614C3C000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000743E3DA846469472575646340101014A4441D9C8BDD9CAC2C9B9AFCBBEB7DAD5D0E2E2DFE1E0DCDDD8D3D0C9C3BAA49FBCADA7B8ADA7E0DEDBE2E2E0DBD9D4353331000000"
DATA "0000000000000000000000000908079481608568470B0806000000151E274B55B2080B180000000000004E4031AEA99266523F655442000000000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000004030275313195665D8F7E623E2C220D0A071A1918CDC2B7DDCCC1CEBFB6C3B4A9CBC0B8DEDBD6E2E1E0E2E2E1E2E2E0DDD9D4D4CBC3CDC4BDC6C0BAD3CFC9D9D3CC413E3B000000"
DATA "0000000000000000000000002E291EC0B38D7C604209060400000007060B7438A009050F00000005040477685255483C281C195C4939090806000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000201D167E57439A927B392D255543342115100101017B756EDDCCC0D2C2B6C6B6ACC4B5ABCDC2BADBD7D1E2E1DEE2E2DEE2E2DFE2E1DDE2E1DEDCD8D2C9BDB2D6CFC753504E000000"
DATA "0000000000000000000000003D3627C4B78E836746251C1400000000000062217A030206000000201A153C2C226151438D6F532C1D17090605000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000018120D9074565F55465C4C41B99E7A64534206060621201ECFBEB3D3C2B5D0BFB4C7B6ABC4B4A8CABDB4D6CEC6D5CEC7DAD5CEDCDAD3DEDBD6DDD9D4CBBFB6CEC1B779726E010101"
DATA "000000000000000000000000372E21AE9B738D6F4B4A3828030302000000553A430B0907000000020101423427A19073887155382B20000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000070504553D2B65503FAF9274BAA983A98967544F49040303776C66D1BFB1D3C1B4CBB9ACC6B5A7C7B7AACBBDB2C6B7ABC9BAB1CEC2BAD0C5BCCDC1B8CBBBB0D1BFB1968E86040303"
DATA "00000000000000000000000016110B927B5790704C2920160000000200007E48373C1F18000000000000675542BDB18BA6906D3D2D21000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000574C38674B369B8064C1AA7FDFC997C3A98A2724220F0D0D94887FD8C9BBD2C1B3D0BCAFCFBBADCFBCAFCAB8AAC6B3A5C7B4A6C4AFA0C6B2A4D2BEB2DFD2C6C3C1BC121212"
DATA "0000000000000000000000000100004134238566442C22180000000000004F392A291D160000000100006D5640DCCB9EB6A57F5D4330030202000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000000000027221A372A1E876C50816A4FAC9B74E1C393AF94781D1A16191716ADA299D3C2B4D3C1B1D3BFAED2BFAFD3BFAFD0BCACD2C0B3CAB3A4D0BDAFDAC8BCE2DACE7D7D7A020202"
DATA "0000000000000000000000000000000101004C3B2843332302020100000037291E1F171100000014100D70563FDBCC9DC7B1886E4E3615100B000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000000000000000006040338291E5C453288684DD5AD82CAA077896A4F29221A191716534C47CFBFB1D8C5B4D5BFACD5C0ADD7C6B5DACBBDD6C3B3D7C5B7DCCCC0A69D950B0B0B000000"
DATA "0000000000000000000000000000000000000000000101010000000000000605030403020000000503037E5F45DCC394BC9D756B4B34403023000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000010000100C09372B205F48355C422F55412E040403030303544E49958D85D2C2B4C8B7A9CCBDB0CCC4BAD2C3B5C6B7AC8E837C1D1B19000000000000"
DATA "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000E0B085F4735805F45533A27150F0A000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000020101110F0F0F0E0D1B1A182423221A1A18100E0E000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000906050A0706000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
END
EXTERNAL PICTURE DISP(XX,YY,C(,),M(,))
SET DRAW MODE MASK
MAT PLOT CELLS,IN 0,0;XX-1,YY-1:M
SET DRAW MODE MERGE
MAT PLOT CELLS,IN 0,0;XX-1,YY-1:C
END PICTURE
EXTERNAL FUNCTION GETKEY !'キー入力
LET GETKEY=-1
IF GETKEYSTATE(37)<0 THEN LET GETKEY=4
IF GETKEYSTATE(38)<0 THEN LET GETKEY=8
IF GETKEYSTATE(39)<0 THEN LET GETKEY=6
IF GETKEYSTATE(40)<0 THEN LET GETKEY=2
FOR I=48 TO 57
IF GETKEYSTATE(I)<0 THEN
LET GETKEY=I-48
EXIT FUNCTION
END IF
NEXT I
FOR I=96 TO 105
IF GETKEYSTATE(I)<0 THEN
LET GETKEY=I-96
EXIT FUNCTION
END IF
NEXT I
END FUNCTION
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB RGB(X,R,G,B)
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
ASK PIXEL VALUE (X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
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 CIRCLE(X,Y,RR,R,G,B)
SET COLOR COLORINDEX(R/255,G/255,B/255)
DRAW CIRCLE WITH SCALE(RR)*SHIFT(X,Y)
END SUB
PLOT AREAのSET AREA STYLE文ではHATCHパターンを
6通りの指定ができますが、下記のように色番号を置き換えることで
自由に定義することができます。
リアルタイム描画(アニメーション)はできませんが、印刷目的(プリンターがモノクロ等)なら利用できると
思います。
RANDOMIZE
SET POINT STYLE 1
FOR I=1 TO 100
LET X=RND
LET Y=RND
LET R=RND*.1
LET C=INT(RND*12)+1
CALL CIRCLEFULL(X,Y,R,C)
NEXT I
!'SET DRAW MODE HIDDEN
CALL TILEPAINT
!'SET DRAW MODE EXPLICIT
END
EXTERNAL SUB TILEPAINT
OPTION BASE 0
DIM C(255,30,30),XC(255),YC(255)
MAT XC=(1)*CON
MAT YC=(1)*CON
FOR I=0 TO 255
LET C(I,0,0)=I
NEXT I
DO
READ IF MISSING THEN EXIT DO:CC
READ XC(CC),YC(CC)
FOR J=0 TO YC(CC)-1
FOR I=0 TO XC(CC)-1
READ C(CC,I,J)
NEXT I
NEXT J
LOOP
DATA 0 !'置き換える色
DATA 12,5 !'サイズ
DATA 0,0,0,0,0,0,0,0,0,0,3,3 !'パターン定義(色番号)
DATA 0,0,0,0,0,0,0,0,3,3,0,0
DATA 0,0,0,0,0,3,3,3,0,0,0,0
DATA 0,0,3,3,3,0,0,0,0,0,0,0
DATA 3,3,0,0,0,0,0,0,0,0,0,0
DATA 1
DATA 5,1
DATA 1,0,0,0,0
DATA 2
DATA 5,5
DATA 1,0,0,0,0
DATA 0,1,0,0,0
DATA 0,0,1,0,0
DATA 0,0,0,1,0
DATA 0,0,0,0,1
DATA 3
DATA 7,7
DATA 0,0,0,0,0,0,0
DATA 0,0,0,1,0,0,0
DATA 0,0,0,1,0,0,0
DATA 0,1,1,1,1,1,0
DATA 0,0,0,1,0,0,0
DATA 0,0,0,1,0,0,0
DATA 0,0,0,0,0,0,0
DATA 4
DATA 8,8
DATA 1,1,1,1,0,0,0,0
DATA 1,1,1,1,0,0,0,0
DATA 1,1,1,1,0,0,0,0
DATA 1,1,1,1,0,0,0,0
DATA 0,0,0,0,1,1,1,1
DATA 0,0,0,0,1,1,1,1
DATA 0,0,0,0,1,1,1,1
DATA 0,0,0,0,1,1,1,1
DATA 5
DATA 8,8
DATA 1,1,1,1,1,1,1,1
DATA 0,0,1,0,0,0,1,0
DATA 0,0,1,0,0,0,1,0
DATA 0,0,1,0,0,0,1,0
DATA 1,1,1,1,1,1,1,1
DATA 1,0,0,0,1,0,0,0
DATA 1,0,0,0,1,0,0,0
DATA 1,0,0,0,1,0,0,0
DATA 6
DATA 17,16
DATA 0,0,0,0,1,1,1,1,1,0,0,0,0,0,0,0,0
DATA 0,0,0,1,0,0,0,0,0,1,0,0,0,0,0,0,0
DATA 0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0
DATA 0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1
DATA 0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0
DATA 0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0
DATA 0,0,0,1,0,0,0,0,0,1,0,0,0,0,0,0,0
DATA 0,0,0,0,1,1,1,1,1,0,0,0,0,0,0,0,0
DATA 0,0,0,1,0,0,0,0,0,1,0,0,0,0,0,0,0
DATA 0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0
DATA 0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0
DATA 1,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1
DATA 0,1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0
DATA 0,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0
DATA 0,0,0,1,0,0,0,0,0,1,0,0,0,0,0,0,0
DATA 7
DATA 6,6
DATA 0,0,0,1,0,0
DATA 0,0,1,0,1,0
DATA 0,1,0,0,0,1
DATA 1,0,0,0,0,0
DATA 0,1,0,0,0,1
DATA 0,0,1,0,1,0
DATA 8
DATA 2,2
DATA 7,6
DATA 6,7
DATA 9
DATA 6,5
DATA 4,0,0,0,0,0
DATA 0,4,0,0,0,4
DATA 0,0,4,0,4,0
DATA 0,0,0,4,0,0
DATA 0,0,0,0,0,0
DATA 10
DATA 5,5
DATA 0,0,2,0,0
DATA 0,0,2,0,0
DATA 2,2,2,2,2
DATA 0,0,2,0,0
DATA 0,0,2,0,0
ASK BITMAP SIZE XSIZE,YSIZE
FOR Y=0 TO YSIZE
FOR X=0 TO XSIZE
LET XX=WORLDX(X)
LET YY=WORLDY(YSIZE-Y)
LET CC=GETPOINT(XX,YY)
IF CC<>-1 THEN CALL PSET(XX,YY,C(CC,MOD(X,XC(CC)),MOD(Y,YC(CC))))
NEXT X
NEXT Y
END SUB
EXTERNAL SUB PSET(X,Y,C)
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL FUNCTION GETPOINT(X,Y)
ASK PIXEL VALUE(X,Y) C
LET GETPOINT=C
END FUNCTION
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
PUBLIC NUMERIC L1,L2,LTH,RTH,XSIZE,YSIZE
LET XSIZE=600
LET YSIZE=600
FILE GETSAVENAME F$,"PSファイル|*.ps"
IF F$="" THEN STOP
IF POS(UCASE$(F$),".PS")=0 THEN LET F$=F$ & ".ps"
CALL GINIT(F$,XSIZE,YSIZE)
INPUT PROMPT "LEVEL=":N
LET L1=1/SQR(3)
LET L2=2/3
LET LTH=22.5
LET RTH=0
CALL RECURSIVE(N,0,300,600,300,1,#1)
CALL GCLOSE
SUB GINIT(F$,XSIZE,YSIZE)
OPEN #1:NAME F$
ERASE #1
PRINT #1:"%!"
PRINT #1:"%%BoundingBox: 0 0";XSIZE;YSIZE
PRINT #1:"newpath"
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,0,YSIZE-1
CLEAR
END SUB
SUB GCLOSE
PRINT #1:"showpage"
CLOSE #1
END SUB
END
EXTERNAL SUB RECURSIVE(N,X1,Y1,X2,Y2,SIGN,#1) !'葉脈
IF N=0 THEN
CALL LINE(X1,Y1,X2,Y2,#1)
ELSE
LET AX=L1*(X2-X1)*COS(SIGN*LTH*PI/180)-L1*(Y2-Y1)*SIN(SIGN*LTH*PI/180)+X1
LET AY=L1*(X2-X1)*SIN(SIGN*LTH*PI/180)+L1*(Y2-Y1)*COS(SIGN*LTH*PI/180)+Y1
CALL RECURSIVE(N-1,X1,Y1,AX,AY,-SIGN,#1)
LET AX=L2*(X1-X2)*COS(-SIGN*RTH*PI/180)-L2*(Y1-Y2)*SIN(-SIGN*RTH*PI/180)+X2
LET AY=L2*(X1-X2)*SIN(-SIGN*RTH*PI/180)+L2*(Y1-Y2)*COS(-SIGN*RTH*PI/180)+Y2
CALL RECURSIVE(N-1,AX,AY,X2,Y2,-SIGN,#1)
END IF
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,#1)
PLOT LINES:XS,YS;XE,YE
PRINT #1:PIXELX(XS);PIXELY(YS);"moveto"
PRINT #1:PIXELX(XE);PIXELY(YE);"lineto"
PRINT #1:"stroke"
END SUB
PUBLIC NUMERIC NN,XX,YY,RR,X(40),Y(40),L(40),R(40),S(40),R0,L0,SMIN,SMAX
OPTION ANGLE DEGREES
LET XS=-.5
LET XE=1.5
LET YS=-.5
LET YE=1.5
LET SMIN=10000000
LET SMAX=-SMIN
MAT S=(1)*CON
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW XS,XE,YS,YE
SET COLOR MODE "REGULAR"
CLEAR
DRAW GRID(.1,.1)
SET LINE COLOR 1
DO
MOUSE POLL XX,YY,LEFT,RIGHT
IF RIGHT<>0 THEN
IF NN>2 THEN EXIT DO !'3ヶ所以上で右クリック
END IF
IF LEFT<>0 THEN
DO WHILE LEFT<>0
MOUSE POLL XX,YY,LEFT,RIGHT
LOOP
LET NN=NN+1 !'座標値を記録
LET X(NN)=XX
LET Y(NN)=YY
PLOT LINES:XX,YY;
CALL CIRCLEFULL(X(NN),Y(NN),.01,1)
END IF
LOOP
PLOT LINES:X(NN),Y(NN)
CALL CIRCLEFULL(X(NN),Y(NN),.01,1)
LET R0=ANGLE(X(NN)-X(1),Y(NN)-Y(1))
LET L0=1/SQR((X(NN)-X(1))^2+(Y(NN)-Y(1))^2)
FOR I=1 TO NN-1
LET R(I)=ANGLE(X(I+1)-X(I),Y(I+1)-Y(I))-RR-R0
LET RR=RR+R(I)
LET L(I)=SQR((X(I)-X(I+1))^2+(Y(I+1)-Y(I))^2)*L0
NEXT I
IF RR<>0 THEN LET R(NN)=-RR
FOR N=1 TO 5 !'レベル5まで
CLEAR
LET RR=0
LET XX=X(1)
LET YY=Y(1)
DRAW GRID(.1,.1)
CALL RECURSIVE(N,1) !'再帰呼び出し
WAIT DELAY 1
NEXT N
PRINT "OPTION ANGLE DEGREES"
PRINT "PUBLIC NUMERIC X,Y,R"
PRINT "SET WINDOW ";SMIN;",";SMAX;",";SMIN;",";SMAX
PRINT "SET COLOR MODE ";CHR$(34);"REGULAR";CHR$(34)
PRINT "DRAW GRID(.1,.1)"
PRINT "INPUT PROMPT ";CHR$(34);"LEVEL=";CHR$(34);": N"
PRINT "LET X=";STR$(X(1))
PRINT "LET Y=";STR$(Y(1))
PRINT "CALL RECURSIVE(N,1,1)"
PRINT "END"
PRINT
PRINT "EXTERNAL SUB RECURSIVE(LEV,L,SIGN)"
PRINT "OPTION ANGLE DEGREES"
PRINT "IF LEV=0 THEN"
PRINT "PLOT LINES: X,Y;"
PRINT "LET X=X+L*COS(R";VSTR$(R0);")/";STR$(L0)
PRINT "LET Y=Y+L*SIN(R";VSTR$(R0);")/";STR$(L0)
PRINT "PLOT LINES: X,Y"
PRINT "ELSE"
FOR I=1 TO NN-1
IF R(I)<>0 THEN
IF R(I)>0 THEN PRINT "R=R+";ELSE PRINT "R=R-";
PRINT STR$(ABS(R(I)));"*SIGN"
END IF
PRINT "CALL RECURSIVE(LEV-1,L*";STR$(L(I));",";STR$(S(I));")"
NEXT I
IF R(NN)<>0 THEN
IF R(NN)>0 THEN PRINT "R=R+";ELSE PRINT "R=R-";
PRINT STR$(ABS(R(NN)));"*SIGN"
END IF
PRINT "END IF"
PRINT "END SUB"
END
EXTERNAL SUB RECURSIVE(N,LL)
OPTION ANGLE DEGREES
IF N=0 THEN
PLOT LINES:XX,YY;
LET XX=XX+LL*COS(RR+R0)/L0
LET YY=YY+LL*SIN(RR+R0)/L0
PLOT LINES:XX,YY
LET SMIN=MIN(SMIN,XX)
LET SMAX=MAX(SMAX,XX)
LET SMIN=MIN(SMIN,YY)
LET SMAX=MAX(SMAX,YY)
ELSE
FOR I=1 TO NN-1
LET RR=RR+R(I)
CALL RECURSIVE(N-1,LL*L(I))
NEXT I
IF R(NN)<>0 THEN LET RR=RR+R(NN)
END IF
END SUB
EXTERNAL SUB CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL FUNCTION VSTR$(N)
IF N<0 THEN LET S$="-" ELSE LET S$="+"
LET VSTR$=S$ & STR$(ABS(N))
END FUNCTION
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE,0,YSIZE
DIM LIGHT(3),N(3),COL(3),KD(3),LA(3)
LET RR=.7
MAT READ LIGHT !'光線ベクトル
DATA 1,1,1
MAT READ KD !'拡散反射光
DATA .7,.7,.2
MAT READ LA !'環境光
DATA .3,.3,.3
FOR Y=0 TO YSIZE
LET YY=(Y*2-YSIZE)/YSIZE
FOR X=0 TO XSIZE
LET XX=(X*2-XSIZE)/XSIZE
LET D=RR*RR-XX*XX-YY*YY
IF D>0 THEN
LET ZZ=SQR(D)
LET N(1)=XX
LET N(2)=YY
LET N(3)=ZZ
CALL SHADE(COL,N,LIGHT,LA,KD)
CALL PSET(X,Y,COL)
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB SHADE(COL(),N(),LIGHT(),LA(),KD()) !'lambertシェーディングモデル
MAT N=(1/SQR(DOT(N,N)))*N
MAT LIGHT=(1/SQR(DOT(LIGHT,LIGHT)))*LIGHT
LET C=DOT(N,LIGHT)
MAT COL=(MAX(C,0))*KD
MAT COL=COL+LA
END SUB
EXTERNAL SUB PSET(X,Y,COL())
FOR I=1 TO 3
LET COL(I)=MIN(1,MAX(0,COL(I)))
NEXT I
SET COLOR COLORINDEX(COL(1),COL(2),COL(3))
PLOT POINTS:X,Y
END SUB
拡散反射光 Ed ∝ COSθ
鏡面反射光 Es ∝ COSα^n
背景光 Ea
明るさ E = Ed + Es + Ea フォンシェーディングモデル
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE,0,YSIZE
LET RR=.7
DIM LA(3),N(3),LIGHT(3),COL(3),KS(3)
DIM VIEW(3),LS(3),KD(3)
MAT READ LA !'環境光
DATA .7,.2,.1
MAT READ KD !'拡散反射光
DATA .9,.5,.3
MAT READ LIGHT !'光線ベクトル
DATA 1,1,1
MAT READ KS !'鏡面反射光
DATA .9,.6,.6
MAT READ VIEW !'視線ベクトル
DATA 0,0,1
LET SHININESS=32
FOR Y=0 TO YSIZE
LET YY=(Y*2-YSIZE)/YSIZE
FOR X=0 TO XSIZE
LET XX=(X*2-XSIZE)/XSIZE
LET D=RR*RR-XX*XX-YY*YY
IF D>0 THEN
LET ZZ=SQR(D)
LET N(1)=XX
LET N(2)=YY
LET N(3)=ZZ
CALL SHADE(COL,N,LIGHT,VIEW,LA,KD,KS,SHININESS)
CALL PSET(X,Y,COL)
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB SHADE(COL(),N(),LIGHT(),VIEW(),LA(),KD(),KS(),SHININESS) !'phongシェーディングモデル
DIM LD(3),LS(3),R(3)
MAT N=(1/SQR(DOT(N,N)))*N
MAT LIGHT=(1/SQR(DOT(LIGHT,LIGHT)))*LIGHT
MAT VIEW=(1/SQR(DOT(VIEW,VIEW)))*VIEW
LET C=DOT(N,LIGHT)
MAT LD=(MAX(C,0))*KD
LET MODE=0
SELECT CASE MODE
CASE 0
CALL REFLECT(R,N,LIGHT) !'反射ベクトル phong鏡面反射
LET C=DOT(VIEW,R)
CASE 1
CALL HALF(R,LIGHT,VIEW) !'ハーフベクトル Bllinn-phong鏡面反射
LET C=DOT(R,N)
END SELECT
MAT LS=(MAX(C,0)^SHININESS)*KS
MAT COL=LA+LD
MAT COL=COL+LS
END SUB
EXTERNAL SUB PSET(X,Y,COL())
FOR I=1 TO 3
LET COL(I)=MIN(1,MAX(0,COL(I)))
NEXT I
SET COLOR COLORINDEX(COL(1),COL(2),COL(3))
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB REFLECT(R(),NORMAL(),LIGHT()) !'反射ベクトル
LET C=DOT(NORMAL,LIGHT)
MAT R=(MAX(2*C,0))*NORMAL
MAT R=R-LIGHT
MAT R=SQR(1/SQR(DOT(R,R)))*R
END SUB
EXTERNAL SUB HALF(H(),LIGHT(),VIEW()) !'ハーフベクトル
MAT H=LIGHT+VIEW
MAT H=(1/SQR(DOT(H,H)))*H
END SUB
D(α)=1/(4m^2cosα^4)exp{-(tanα/m)^2}
G=min{1,2(N・H)(N・E)/2(E・H),2(N・H)(N・L)/(E・H)}
F={.5(g-c)^2/(g+c)^2}[1+{c(g+c)-1}^2/{c(g-c)+1}^2]
鏡面反射光 Es ∝ DGF/(N・E) クックトランスシェーディングモデル
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
DIM COL(3),LIGHT(3),N(3),VIEW(3),DIFFUSE(3),AMBIENT(3),SPECULAR(3)
ASK BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE,0,YSIZE
LET RR=.7
MAT READ LIGHT !'光線ベクトル
DATA 1,1,1
MAT READ VIEW !'視線ベクトル
DATA 0,0,1
MAT READ DIFFUSE !'拡散反射係数
DATA .3,.5,.1
MAT READ AMBIENT !'環境光
DATA .6,.6,0
MAT READ SPECULAR
DATA .5,.2,.3
LET MICROFACET=.2 !' 面の粗さ
FOR Y=0 TO YSIZE
LET YY=(Y*2-YSIZE)/YSIZE
FOR X=0 TO XSIZE
LET XX=(X*2-XSIZE)/XSIZE
LET D=RR*RR-XX*XX-YY*YY
IF D>0 THEN
LET ZZ=SQR(D)
LET N(1)=XX
LET N(2)=YY
LET N(3)=ZZ
CALL SHADE(COL,N,LIGHT,VIEW,SPECULAR,DIFFUSE,AMBIENT,MICROFACET)
CALL PSET(X,Y,COL)
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB SHADE(COL(),NORMAL(),LIGHT(),VIEW(),SPECULAR(),DIFFUSE(),AMBIENT(),MICROFACET) !' Cook-Torranceシェーディングモデル
DIM L(3),N(3),V(3),H(3),SPE(3),DIF(3),F(3),VR(3)
MAT N=(1/SQR(DOT(NORMAL,NORMAL)))*NORMAL
MAT L=(1/SQR(DOT(LIGHT,LIGHT)))*LIGHT
MAT V=(1/SQR(DOT(VIEW,VIEW)))*VIEW
MAT H = L+V
MAT H = (1/SQR(DOT(H,H)))*H
LET HN = DOT(H, N)
LET LN = DOT(L, N)
LET LH = DOT(L, H)
LET VN = DOT(V, N)
LET VH = DOT(V, H)
LET D = BECHMANNDISTRIBUTION(MICROFACET,HN)
LET T = 2 * HN / VH
LET G = MIN(1, MIN(T * VN, T * LN))
LET M = PI * VN * LN
FOR I=1 TO 3
LET F(I)=FRESNEL(LH,SPECULAR(I))
NEXT I
MAT SPE = (MAX(D*G/M,0)) * F
MAT DIF = (MAX(LN,0)) * DIFFUSE
MAT COL = SPE + DIF
MAT COL = COL + AMBIENT
END SUB
EXTERNAL FUNCTION BECHMANNDISTRIBUTION(M, NH) !' Beckman分布
LET ALPHA=ACOS(NH)
LET BECHMANNDISTRIBUTION=EXP(-TAN(ALPHA)^2/M^2) / (4*M^2 * COS(ALPHA)^4)
END FUNCTION
EXTERNAL FUNCTION FRESNEL(C, F0) !' フレネル項
LET SF = SQR(F0)
LET N = (1 + SF) / (1 - SF)
LET G = SQR(N * N + C * C - 1)
LET GA = (C * (G + C) - 1)^2
LET GB = (C * (G - C) + 1)^2
LET FRESNEL=(G - C)^2 / (2 * (G + C)^2) * (1 + GA / GB)
END FUNCTION
EXTERNAL SUB PSET(X,Y,COL())
FOR I=1 TO 3
LET COL(I)=MIN(1,MAX(0,COL(I)))
NEXT I
SET COLOR COLORINDEX(COL(1),COL(2),COL(3))
PLOT POINTS:X,Y
END SUB
OPTION ARITHMETIC native
LET n=1000
DIM a(n,n)
DIM b(n,n)
FOR j=1 TO n
FOR k=1 TO n
LET a(j,k)=RND
NEXT k
NEXT j
LET t0=TIME
MAT b=INV(a)
PRINT TIME-t0
END
> kikiririさんへのお返事です。
>
> 参考サイト http://hw001.gate01.com/kazuok/geodetic/leveling.html
>
> Full BASICの場合、行列が計算できるので、他の言語よりは簡単に計算できると思います。
> ただ、２項演算までですから、展開しながらこつこつ計算する必要があります。
>
> また、表計算の方がGUIを含めて実用化し易いかもしれません。
>
>
> 上記サイトの例題（PDFファイル内）のサンプルコーディング
>
> <PRE>
> !最小２乗法による測量網平均（条件方程式法）
>
> !Ｈ型
> ! Ａ Ｃ
> ! 1↓ 5 ↓3
> ! Ｐ → Ｑ
> ! 2↑ ↑4
> ! Ｂ Ｄ
>
> !既知点
> LET C=4 !数
>
> DATA 25.645 !Ａ点の標高（m）
> DATA 24.666 !Ｂ点
> DATA 25.024 !Ｃ点
> DATA 25.699 !Ｄ点
> DIM Z(C)
> MAT READ Z
>
> !観測値
> LET P=5 !数
>
> DATA -6.225, 0.44 !路線１ 高低差（m）、路線長（km）
> DATA -5.245, 0.25 !路線２
> DATA 0.278, 0.33 !路線３
> DATA -0.399, 0.26 !路線４
> DATA 5.879, 0.44 !路線５
>
> DIM X(P),G(P,P) !観測値、コアファクタ
> MAT G=ZER
> FOR i=1 TO P
> READ X(i),G(i,i)
> NEXT i
> MAT PRINT X;
> MAT PRINT G;
>
>
> !未知数
> LET Px=2 !求点ＰとＱ
>
>
> !------------------------------
>
> !自由度R ※条件方程式の数
> LET R=P-Px
>
>
> !条件方程式 UV=t
> DIM U(R,P)
> DATA 1,-1,0,0,0 !点Ｐについて HA+h1~=HB+h2~ より、(h1+v1)-(h2+v2)=HB-HA ∴v1-v2=-(h1+HA)+(h2+HB)
> DATA 0,0,1,-1,0 !点Ｑについて HC+h3~=HD+h4~
> DATA 1,0,0,-1,1 !点Ｐと点Ｑについて HA+h1~+h5~=HD+h4~
> MAT READ U
>
> DIM t(R,1)
> FOR i=1 TO R
> LET s=0
> FOR j=1 TO P
> IF j>C THEN LET Zj=0 ELSE LET Zj=Z(j)
> LET s=s-(X(j)+Zj)*U(i,j)
> NEXT j
> LET t(i,1)=s
> NEXT i
> !!!LET t(1,1)=-X(1)+X(2)-Z(1)+Z(2) !0.001
> !!!LET t(2,1)=-X(3)+X(4)-Z(3)+Z(4) !-0.002
> !!!LET t(3,1)=-X(1)+X(4)-X(5)-Z(1)+Z(4) !0.001
> MAT PRINT t;
>
>
> !------------------------------
>
> !相関式 NK=t、N=UG(Ut)より、K=(Ni)tを求める
> DIM Ut(P,R)
> MAT Ut=TRN(U)
> DIM TMP(P,R) !G(Ut) ※次でも使う
> MAT TMP=G*Ut
> DIM N(R,R)
> MAT N=U*TMP
> MAT PRINT N;
>
> DIM invN(R,R)
> MAT invN=INV(N)
> DIM K(R,1)
> MAT K=invN*t
>
> MAT PRINT K;
>
>
> !補正値の計算（mm） V=G(Ut)K
> DIM V(P,1)
> MAT V=TMP*K
>
> MAT PRINT V;
>
>
> !最確値 X~=X+V
> FOR i=1 TO P
> PRINT "路線";STR$(i);"=";X(i)+V(i,1)
> NEXT i
> PRINT "点Ｐ";Z(1)+(X(1)+V(1,1)); Z(2)+(X(2)+V(2,1)) !有効桁数 ##.###
> PRINT "点Ｑ";Z(3)+(X(3)+V(3,1)); Z(4)+(X(4)+V(4,1))
>
>
>
>
> !精度の計算（mm^2） σ^2=(Kt)NK/r
> DIM s2(1,1),Kt(1,R)
> MAT Kt=TRN(K)
> MAT s2=Kt*t !NK=t
> LET sigma2=s2(1,1)/R
>
> PRINT "σ^2=";sigma2
>
>
> !分散行列（mm^2） σ^2*Gx、Gx=G-G(Ut)(Ni)UG
> DIM Gx(P,P)
> MAT Gx=TMP*invN !G(Ut)(Ni)
> MAT Gx=Gx*U
> MAT Gx=Gx*G
> MAT Gx=G-Gx
> MAT Gx=sigma2*Gx
>
> MAT PRINT Gx;
>
>
> END
> </PRE>
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
DIM X0(4),Y0(4),Z0(4),X1(4),Y1(4),Z1(4),X2(4),Y2(4),Z2(4)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3),CPOS(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
CALL TETRAHEDRON(0,0,0,2)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN !'表向きなら
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
SUB TETRAHEDRON(X,Y,Z,L) !'4面体
LET XX1=X+L*COS(0)
LET ZZ1=Z+L*SIN(0)
LET YY1=Y
LET XX2=X+L*COS(120)
LET ZZ2=Z+L*SIN(120)
LET YY2=Y
LET XX3=X+L*COS(240)
LET ZZ3=Z+L*SIN(240)
LET YY3=Y
LET XX4=X
LET ZZ4=Z
LET YY4=Y+L*SQR(2)
LET NUM=NUM+1
LET X0(NUM)=XX4
LET Y0(NUM)=YY4
LET Z0(NUM)=ZZ4
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX3
LET Y0(NUM)=YY3
LET Z0(NUM)=ZZ3
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX1
LET Y2(NUM)=YY1
LET Z2(NUM)=ZZ1
LET NUM=NUM+1
LET X0(NUM)=XX4
LET Y0(NUM)=YY4
LET Z0(NUM)=ZZ4
LET X1(NUM)=XX3
LET Y1(NUM)=YY3
LET Z1(NUM)=ZZ3
LET X2(NUM)=XX1
LET Y2(NUM)=YY1
LET Z2(NUM)=ZZ1
LET NUM=NUM+1
LET X0(NUM)=XX4
LET Y0(NUM)=YY4
LET Z0(NUM)=ZZ4
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
END SUB
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
DIM X0(6),Y0(6),Z0(6),X1(6),Y1(6),Z1(6),X2(6),Y2(6),Z2(6),X3(6),Y3(6),Z3(6)
DIM P0(4),P1(4),P2(4),P3(4)
DIM L(4),M(4),N(3),CPOS(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
CALL CUBE(0,0,0,2)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P3(1)=X3(I)
LET P3(2)=Y3(I)
LET P3(3)=Z3(I)
LET P0(4),P1(4),P2(4),P3(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT P3=P3*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
MAT L=P3-P2
MAT M=P2-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P2,P3)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
SUB CUBE(X,Y,Z,L) !'立方体
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y+L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y+L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y+L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y+L/2
LET Z3(NUM)=Z+L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y+L/2
LET Z0(NUM)=Z+L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y+L/2
LET Z1(NUM)=Z+L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y-L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y-L/2
LET Z3(NUM)=Z+L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y-L/2
LET Z0(NUM)=Z+L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y-L/2
LET Z1(NUM)=Z+L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y-L/2
LET Z2(NUM)=Z-L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y-L/2
LET Z3(NUM)=Z-L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y-L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y-L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y+L/2
LET Z2(NUM)=Z-L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y+L/2
LET Z3(NUM)=Z-L/2
LET NUM=NUM+1
LET X0(NUM)=X+L/2
LET Y0(NUM)=Y+L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y-L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y-L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X+L/2
LET Y3(NUM)=Y+L/2
LET Z3(NUM)=Z+L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y-L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X-L/2
LET Y1(NUM)=Y+L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X-L/2
LET Y2(NUM)=Y+L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y-L/2
LET Z3(NUM)=Z+L/2
END SUB
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
DIM X0(8),Y0(8),Z0(8),X1(8),Y1(8),Z1(8),X2(8),Y2(8),Z2(8)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3),CPOS(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
CALL OCTAH(0,0,0,2,2,2)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
SUB OCTAH(X,Y,Z,XL,YL,ZL) !'8面体
LET XX0=X
LET YY0=Y+YL/2
LET ZZ0=Z
LET XX1=X+XL/2
LET YY1=Y
LET ZZ1=Z
LET XX2=X
LET YY2=Y
LET ZZ2=Z+ZL/2
LET XX3=X-XL/2
LET YY3=Y
LET ZZ3=Z
LET XX4=X
LET YY4=Y
LET ZZ4=Z-ZL/2
LET XX5=X
LET YY5=Y-YL/2
LET ZZ5=Z
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX3
LET Y1(NUM)=YY3
LET Z1(NUM)=ZZ3
LET X2(NUM)=XX4
LET Y2(NUM)=YY4
LET Z2(NUM)=ZZ4
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX4
LET Y1(NUM)=YY4
LET Z1(NUM)=ZZ4
LET X2(NUM)=XX1
LET Y2(NUM)=YY1
LET Z2(NUM)=ZZ1
LET NUM=NUM+1
LET X0(NUM)=XX5
LET Y0(NUM)=YY5
LET Z0(NUM)=ZZ5
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX1
LET Y2(NUM)=YY1
LET Z2(NUM)=ZZ1
LET NUM=NUM+1
LET X0(NUM)=XX5
LET Y0(NUM)=YY5
LET Z0(NUM)=ZZ5
LET X1(NUM)=XX3
LET Y1(NUM)=YY3
LET Z1(NUM)=ZZ3
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX5
LET Y0(NUM)=YY5
LET Z0(NUM)=ZZ5
LET X1(NUM)=XX4
LET Y1(NUM)=YY4
LET Z1(NUM)=ZZ4
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
LET NUM=NUM+1
LET X0(NUM)=XX5
LET Y0(NUM)=YY5
LET Z0(NUM)=ZZ5
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX4
LET Y2(NUM)=YY4
LET Z2(NUM)=ZZ4
END SUB
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
DIM X0(36),Y0(36),Z0(36),X1(36),Y1(36),Z1(36),X2(36),Y2(36),Z2(36)
DIM P0(4),P1(4),P2(4),P3(4)
DIM L(4),M(4),N(3),CPOS(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(20),YY(20),ZZ(20)
LET LL=1
FOR TH=0 TO 359 STEP 72
LET K=K+1
LET XX(K)=LL*COS((TH+18))
LET ZZ(K)=LL*SIN((TH+18))
LET YY(K)=LL*(SQR(5)+3)/4
NEXT TH
FOR TH=0 TO 359 STEP 72
LET K=K+1
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
NEXT TH
FOR TH=0 TO 359 STEP 72
LET K=K+1
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
NEXT TH
FOR TH=0 TO 359 STEP 72
LET K=K+1
LET XX(K)=LL*COS((TH+54))
LET ZZ(K)=LL*SIN((TH+54))
LET YY(K)=-LL*(SQR(5)+3)/4
NEXT TH
FOR I=1 TO 36
READ A,B,C
LET X0(I)=XX(A+1)
LET Y0(I)=YY(A+1)
LET Z0(I)=ZZ(A+1)
LET X1(I)=XX(B+1)
LET Y1(I)=YY(B+1)
LET Z1(I)=ZZ(B+1)
LET X2(I)=XX(C+1)
LET Y2(I)=YY(C+1)
LET Z2(I)=ZZ(C+1)
NEXT I
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
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 36
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(100),Y0(100),Z0(100),X1(100),Y1(100),Z1(100),X2(100),Y2(100),Z2(100)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3),CPOS(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(15),YY(15),ZZ(15)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
LOCATE VALUE NOWAIT(5),RANGE .1 TO 5,AT 2:LL
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
LOCATE VALUE NOWAIT(5):LL
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET XX(1)=X
LET YY(1)=Y
LET ZZ(1)=Z
LET XX(2)=X-LL/2
LET YY(2)=Y-LL*SQR(3)/2
LET ZZ(2)=Z+LL/2
LET XX(3)=X+LL/2
LET YY(3)=Y-LL*SQR(3)/2
LET ZZ(3)=Z+LL/2
LET XX(4)=X+LL/2
LET YY(4)=Y-LL*SQR(3)/2
LET ZZ(4)=Z-LL/2
LET XX(5)=X-LL/2
LET YY(5)=Y-LL*SQR(3)/2
LET ZZ(5)=Z-LL/2
RESTORE
FOR I=1 TO 6
READ A,B,C
LET X0(I)=XX(A+1)
LET Y0(I)=YY(A+1)
LET Z0(I)=ZZ(A+1)
LET X1(I)=XX(B+1)
LET Y1(I)=YY(B+1)
LET Z1(I)=ZZ(B+1)
LET X2(I)=XX(C+1)
LET Y2(I)=YY(C+1)
LET Z2(I)=ZZ(C+1)
NEXT I
DATA 0,2,1 !'メッシュデータ
DATA 0,3,2
DATA 0,4,3
DATA 0,1,4
DATA 1,2,3
DATA 1,3,4
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 6
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(100),Y0(100),Z0(100),X1(100),Y1(100),Z1(100),X2(100),Y2(100),Z2(100)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3),CPOS(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(15),YY(15),ZZ(15)
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
LOCATE VALUE NOWAIT(5),RANGE .1 TO 5,AT 2:LL
LOCATE VALUE NOWAIT(6),RANGE .1 TO 5,AT 1:H
LOCATE VALUE NOWAIT(7),RANGE 3 TO 7,AT 3:NN
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
LOCATE VALUE NOWAIT(5):LL
LOCATE VALUE NOWAIT(6):H
LOCATE VALUE NOWAIT(7):NN
LET NN=INT(NN)
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET NUM=0
FOR TH=0 TO 359 STEP 360/NN
LET NUM=NUM+1
LET XX(NUM)=LL*COS(TH)
LET ZZ(NUM)=LL*SIN(TH)
LET YY(NUM)=0
NEXT TH
FOR TH=0 TO 359 STEP 360/NN
LET NUM=NUM+1
LET XX(NUM)=LL*COS(TH)
LET ZZ(NUM)=LL*SIN(TH)
LET YY(NUM)=H
NEXT TH
LET NUM=0
FOR I=1 TO NN-2
LET NUM=NUM+1
LET X0(NUM)=XX(1)
LET Y0(NUM)=YY(1)
LET Z0(NUM)=ZZ(1)
LET X1(NUM)=XX(I+2)
LET Y1(NUM)=YY(I+2)
LET Z1(NUM)=ZZ(I+2)
LET X2(NUM)=XX(I+1)
LET Y2(NUM)=YY(I+1)
LET Z2(NUM)=ZZ(I+1)
NEXT I
FOR I=NN+1 TO 2*NN-2
LET NUM=NUM+1
LET X0(NUM)=XX(NN+1)
LET Y0(NUM)=YY(NN+1)
LET Z0(NUM)=ZZ(NN+1)
LET X1(NUM)=XX(I+1)
LET Y1(NUM)=YY(I+1)
LET Z1(NUM)=ZZ(I+1)
LET X2(NUM)=XX(I+2)
LET Y2(NUM)=YY(I+2)
LET Z2(NUM)=ZZ(I+2)
NEXT I
FOR I=0 TO NN-2
LET NUM=NUM+1
LET X0(NUM)=XX(I+1)
LET Y0(NUM)=YY(I+1)
LET Z0(NUM)=ZZ(I+1)
LET X1(NUM)=XX(I+2)
LET Y1(NUM)=YY(I+2)
LET Z1(NUM)=ZZ(I+2)
LET X2(NUM)=XX(I+NN+2)
LET Y2(NUM)=YY(I+NN+2)
LET Z2(NUM)=ZZ(I+NN+2)
LET NUM=NUM+1
LET X0(NUM)=XX(I+1)
LET Y0(NUM)=YY(I+1)
LET Z0(NUM)=ZZ(I+1)
LET X1(NUM)=XX(I+NN+2)
LET Y1(NUM)=YY(I+NN+2)
LET Z1(NUM)=ZZ(I+NN+2)
LET X2(NUM)=XX(I+NN+1)
LET Y2(NUM)=YY(I+NN+1)
LET Z2(NUM)=ZZ(I+NN+1)
NEXT I
LET NUM=NUM+1
LET X0(NUM)=XX(NN)
LET Y0(NUM)=YY(NN)
LET Z0(NUM)=ZZ(NN)
LET X1(NUM)=XX(1)
LET Y1(NUM)=YY(1)
LET Z1(NUM)=ZZ(1)
LET X2(NUM)=XX(NN+1)
LET Y2(NUM)=YY(NN+1)
LET Z2(NUM)=ZZ(NN+1)
LET NUM=NUM+1
LET X0(NUM)=XX(NN)
LET Y0(NUM)=YY(NN)
LET Z0(NUM)=ZZ(NN)
LET X1(NUM)=XX(NN+1)
LET Y1(NUM)=YY(NN+1)
LET Z1(NUM)=ZZ(NN+1)
LET X2(NUM)=XX(2*NN)
LET Y2(NUM)=YY(2*NN)
LET Z2(NUM)=ZZ(2*NN)
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
LET NN=30
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
DIM X0(2*NN*NN),Y0(2*NN*NN),Z0(2*NN*NN),X1(2*NN*NN),Y1(2*NN*NN),Z1(2*NN*NN),X2(2*NN*NN),Y2(2*NN*NN),Z2(2*NN*NN)
DIM P0(4),P1(4),P2(4),P3(4),CPOS(3)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
MAT READ CPOS
DATA 0,0,1 !'視線ベクトル
DEF A(N)=360/N
DEF S1(X)=FP(X)
DEF CNP(N,T)=COS(A(N)*S1(T/A(N))-A(N)/2)
DEF PC(N,T)=COS(T)*COS(A(N)/2)/CNP(N,T)
DEF PS(N,T)=SIN(T)*COS(A(N)/2)/CNP(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)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 5,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
LOCATE VALUE NOWAIT(5),RANGE 3 TO 10,AT 3:N0
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
LOCATE VALUE NOWAIT(5):N0
LET N0=INT(N0)
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET NUM=0
FOR I=0 TO NN-1
FOR J=0 TO NN-1
LET NUM=NUM+1
LET XX0=P3X(N0,I*180/NN,J*360/NN)
LET YY0=P3Y(N0,I*180/NN,J*360/NN)
LET ZZ0=P3Z(N0,I*180/NN)
LET XX1=P3X(N0,I*180/NN,(J+1)*360/NN)
LET YY1=P3Y(N0,I*180/NN,(J+1)*360/NN)
LET ZZ1=P3Z(N0,I*180/NN)
LET XX2=P3X(N0,(I+1)*180/NN,(J+1)*360/NN)
LET YY2=P3Y(N0,(I+1)*180/NN,(J+1)*360/NN)
LET ZZ2=P3Z(N0,(I+1)*180/NN)
LET XX3=P3X(N0,(I+1)*180/NN,J*360/NN)
LET YY3=P3Y(N0,(I+1)*180/NN,J*360/NN)
LET ZZ3=P3Z(N0,(I+1)*180/NN)
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
NEXT J
NEXT I
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
LET S=DOT(CPOS,N) !'内積 COS(TH) -90<TH<90...表
IF S>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LA(3),LIGHT(3)
MAT READ LA
DATA .8,.7,.1
MAT READ LIGHT
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
MAT LA=((S+1)/2)*LA
SET COLOR MIX(8) LA(1),LA(2),LA(3)
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(100),Y0(100),Z0(100),X1(100),Y1(100),Z1(100),X2(100),Y2(100),Z2(100),KEY(100),INDEX(100)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(50),YY(50),ZZ(50)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET NUM=0
FOR TH=22.5 TO 359+22.5 STEP 45
LET NUM=NUM+1
LET XX(NUM)=COS(TH)
LET YY(NUM)=COS(22.5)
LET ZZ(NUM)=SIN(TH)
NEXT TH
FOR TH=22.5 TO 359+22.5 STEP 45
LET NUM=NUM+1
LET XX(NUM)=-COS(22.5)
LET YY(NUM)=COS(TH)
LET ZZ(NUM)=SIN(TH)
NEXT TH
FOR TH=22.5 TO 359+22.5 STEP 45
LET NUM=NUM+1
LET XX(NUM)=COS(TH)
LET YY(NUM)=-COS(22.5)
LET ZZ(NUM)=SIN(TH)
NEXT TH
FOR TH=22.5 TO 359+22.5 STEP 45
LET NUM=NUM+1
LET XX(NUM)=COS(22.5)
LET YY(NUM)=COS(TH)
LET ZZ(NUM)=SIN(TH)
NEXT TH
FOR TH=22.5 TO 359+22.5 STEP 45
LET NUM=NUM+1
LET XX(NUM)=COS(TH)
LET YY(NUM)=SIN(TH)
LET ZZ(NUM)=-COS(22.5)
NEXT TH
FOR TH=22.5 TO 359+22.5 STEP 45
LET NUM=NUM+1
LET XX(NUM)=COS(TH)
LET YY(NUM)=SIN(TH)
LET ZZ(NUM)=COS(22.5)
NEXT TH
RESTORE
FOR I=1 TO 44
READ A,B,C
LET X0(I)=XX(A+1)
LET Y0(I)=YY(A+1)
LET Z0(I)=ZZ(A+1)
LET X1(I)=XX(B+1)
LET Y1(I)=YY(B+1)
LET Z1(I)=ZZ(B+1)
LET X2(I)=XX(C+1)
LET Y2(I)=YY(C+1)
LET Z2(I)=ZZ(C+1)
NEXT I
DATA 0,1,2 !'メッシュデータ
DATA 0,2,3
DATA 0,3,4
DATA 0,4,5
DATA 0,5,6
DATA 0,6,7
DATA 8,9,10
DATA 8,10,11
DATA 8,11,12
DATA 8,12,13
DATA 8,13,14
DATA 8,14,15
DATA 16,18,17
DATA 16,19,18
DATA 16,20,19
DATA 16,21,20
DATA 16,22,21
DATA 16,23,22
DATA 24,26,25
DATA 24,27,26
DATA 24,28,27
DATA 24,29,28
DATA 24,30,29
DATA 24,31,30
DATA 32,33,34
DATA 32,34,35
DATA 32,35,36
DATA 32,36,37
DATA 32,37,38
DATA 32,38,39
DATA 40,42,41
DATA 40,43,42
DATA 40,44,43
DATA 40,45,44
DATA 40,46,45
DATA 40,47,46
DATA 0,25,1
DATA 8,2,9
DATA 10,18,11
DATA 16,17,26
DATA 30,31,6
DATA 14,5,15
DATA 28,29,22
DATA 20,21,13
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
FOR I=1 TO 44
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,44,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 44
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S*.7+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(200),Y0(200),Z0(200),X1(200),Y1(200),Z1(200),X2(200),Y2(200),Z2(200),KEY(200),INDEX(200)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(100),YY(100),ZZ(100)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 5:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
RESTORE
FOR I=1 TO 60
READ XX(I),YY(I),ZZ(I)
NEXT I
DATA -.16838141 , .83850515 ,-.51822468 !'座標データ
DATA -.44082824 , .83850515 ,-.32028047
DATA -.54489368 , .83850515 , 0
DATA -.44082824 , .83850515 , .32028047
DATA -.16838141 , .83850515 , .51822468
DATA .16838141 , .83850515 , .51822468
DATA .44082824 , .83850515 , .32028047
DATA .54489368 , .83850515 , 0
DATA .44082824 , .83850515 ,-.32028047
DATA .16838141 , .83850515 ,-.51822468
DATA 0 , .66145846 ,-.7499818
DATA 0 , .3749909 ,-.92702849
DATA .16838141 , .08852334 ,-.98173893
DATA .44082824 ,-.08852334 ,-.89321558
DATA .71327508 ,-.08852334 ,-.69527137
DATA .88165649 , .08852334 ,-.46351425
DATA .88165649 , .3749909 ,-.28646756
DATA .71327508 , .66145846 ,-.23175712
DATA -.16838141 , .08852334 ,-.98173893
DATA -.44082824 ,-.08852334 ,-.89321558
DATA -.71327508 ,-.08852334 ,-.69527137
DATA -.88165649 , .08852334 ,-.46351425
DATA -.88165649 , .3749909 ,-.28646756
DATA -.71327508 , .66145846 ,-.23175712
DATA -.98572192 , .08852334 ,-.14323378
DATA -.98572192 ,-.08852334 , .14323378
DATA -.88165649 ,-.08852334 , .46351425
DATA -.71327508 , .08852334 , .69527137
DATA -.54489368 , .3749909 , .7499818
DATA -.44082824 , .66145846 , .60674802
DATA -.44082824 , .08852334 , .89321558
DATA -.16838141 ,-.08852334 , .98173893
DATA .16838141 ,-.08852334 , .98173893
DATA .44082824 , .08852334 , .89321558
DATA .54489368 , .3749909 , .7499818
DATA .44082824 , .66145846 , .60674802
DATA .71327508 , .08852334 , .69527137
DATA .88165649 ,-.08852334 , .46351425
DATA .98572192 ,-.08852334 , .14323378
DATA .98572192 , .08852334 ,-.14323378
DATA .54489368 ,-.3749909 ,-.7499818
DATA .44082824 ,-.66145846 ,-.60674802
DATA .16838141 ,-.83850515 ,-.51822468
DATA -.16838141 ,-.83850515 ,-.51822468
DATA -.44082824 ,-.66145846 ,-.60674802
DATA -.54489368 ,-.3749909 ,-.7499818
DATA -.44082824 ,-.83850515 ,-.32028047
DATA -.54489367 ,-.83850515 , 0
DATA -.71327508 ,-.66145846 , .23175712
DATA -.88165649 ,-.3749909 , .28646756
DATA -.44082824 ,-.83850515 , .32028047
DATA -.16838141 ,-.83850515 , .51822468
DATA 0 ,-.66145846 , .7499818
DATA 0 ,-.3749909 , .92702849
DATA .16838141 ,-.83850515 , .51822468
DATA .44082824 ,-.83850515 , .32028047
DATA .71327508 ,-.66145846 , .23175712
DATA .88165649 ,-.3749909 , .28646756
DATA .54489368 ,-.83850515 , 0
DATA .44082824 ,-.83850515 ,-.32028047
FOR I=1 TO 116
READ A,B,C
LET X0(I)=XX(A)
LET Y0(I)=YY(A)
LET Z0(I)=ZZ(A)
LET X1(I)=XX(B)
LET Y1(I)=YY(B)
LET Z1(I)=ZZ(B)
LET X2(I)=XX(C)
LET Y2(I)=YY(C)
LET Z2(I)=ZZ(C)
NEXT I
DATA 1,2,24 !'メッシュデータ
DATA 1,24,23
DATA 1,23,22
DATA 1,22,21
DATA 1,21,20
DATA 1,20,19
DATA 1,19,12
DATA 1,12,11
DATA 1,11,10
DATA 1,10,9
DATA 1,9,8
DATA 1,8,7
DATA 1,7,6
DATA 1,6,5
DATA 1,5,4
DATA 1,4,3
DATA 1,3,2
DATA 2,3,24
DATA 3,4,30
DATA 3,30,29
DATA 3,29,28
DATA 3,28,27
DATA 3,27,26
DATA 3,26,25
DATA 3,25,23
DATA 3,23,24
DATA 4,5,30
DATA 5,6,36
DATA 5,36,35
DATA 5,35,34
DATA 5,34,33
DATA 5,33,32
DATA 5,32,31
DATA 5,31,29
DATA 5,29,30
DATA 6,7,36
DATA 7,8,18
DATA 7,18,17
DATA 7,17,40
DATA 7,40,39
DATA 7,39,38
DATA 7,38,37
DATA 7,37,35
DATA 7,35,36
DATA 8,9,18
DATA 9,10,11
DATA 9,11,12
DATA 9,12,13
DATA 9,13,14
DATA 9,14,15
DATA 9,15,16
DATA 9,16,17
DATA 9,17,18
DATA 12,19,13
DATA 13,19,20
DATA 13,20,46
DATA 13,46,45
DATA 13,45,44
DATA 13,44,43
DATA 13,43,42
DATA 13,42,41
DATA 13,41,14
DATA 14,41,15
DATA 15,41,42
DATA 15,42,60
DATA 15,60,59
DATA 15,59,57
DATA 15,57,58
DATA 15,58,39
DATA 15,39,40
DATA 15,40,16
DATA 16,40,17
DATA 20,21,46
DATA 21,22,25
DATA 21,25,26
DATA 21,26,50
DATA 21,50,49
DATA 21,49,48
DATA 21,48,47
DATA 21,47,45
DATA 21,45,46
DATA 22,23,25
DATA 26,27,50
DATA 27,28,31
DATA 27,31,32
DATA 27,32,54
DATA 27,54,53
DATA 27,53,52
DATA 27,52,51
DATA 27,51,49
DATA 27,49,50
DATA 28,29,31
DATA 32,33,54
DATA 33,34,37
DATA 33,37,38
DATA 33,38,58
DATA 33,58,57
DATA 33,57,56
DATA 33,56,55
DATA 33,55,53
DATA 33,53,54
DATA 34,35,37
DATA 38,39,58
DATA 42,43,60
DATA 43,44,47
DATA 43,47,48
DATA 43,48,51
DATA 43,51,52
DATA 43,52,55
DATA 43,55,56
DATA 43,56,59
DATA 43,59,60
DATA 44,45,47
DATA 48,49,51
DATA 52,53,55
DATA 56,57,59
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 116
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,116,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 116
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LIGHT(3)
MAT READ LIGHT ! 光源の向き
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(200),Y0(200),Z0(200),X1(200),Y1(200),Z1(200),X2(200),Y2(200),Z2(200),KEY(200),INDEX(200)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(100),YY(100),ZZ(100)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 5:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
RESTORE
FOR I=1 TO 60
READ XX(I),YY(I),ZZ(I)
NEXT I
DATA -.20177411 , .93923362 ,-.27771823 !'座標データ
DATA -.40354821 , .72707577 ,-.55543646
DATA -.20177411 , .51491792 ,-.8331547
DATA .20177411 , .51491792 ,-.8331547
DATA .40354821 , .72707577 ,-.55543646
DATA .20177411 , .93923362 ,-.27771823
DATA -.32647736 , .93923362 , .10607893
DATA -.65295472 , .72707577 , .21215785
DATA -.85472883 , .51491792 ,-.06556038
DATA -.73002557 , .51491792 ,-.44935754
DATA -.73002557 , .17163931 ,-.66151539
DATA -.40354821 , .17163931 ,-.89871508
DATA -.20177411 ,-.17163931 ,-.96427546
DATA .20177411 ,-.17163931 ,-.96427546
DATA .40354821 , .17163931 ,-.89871508
DATA .73002557 , .17163931 ,-.66151539
DATA .73002557 , .51491792 ,-.44935754
DATA .85472883 , .51491792 ,-.06556038
DATA .65295472 , .72707577 , .21215785
DATA .32647736 , .93923362 , .10607893
DATA 0 , .93923362 , .34327861
DATA -.65295472 , .51491792 , .55543646
DATA -.85472883 , .17163931 , .48987608
DATA -.97943209 , .17163931 , .10607893
DATA -.97943209 ,-.17163931 ,-.10607892
DATA -.85472883 ,-.17163931 ,-.48987608
DATA -.65295472 ,-.51491792 ,-.55543646
DATA -.32647736 ,-.51491792 ,-.79263615
DATA 0 ,-.72707577 ,-.68655723
DATA .32647736 ,-.51491792 ,-.79263615
DATA .65295472 ,-.51491792 ,-.55543646
DATA .85472883 ,-.17163931 ,-.48987608
DATA .97943209 ,-.17163931 ,-.10607893
DATA .97943209 , .17163931 , .10607893
DATA .85472883 , .17163931 , .48987608
DATA .65295472 , .51491792 , .55543646
DATA .32647736 , .51491792 , .79263615
DATA 0 , .72707577 , .68655723
DATA -.32647736 , .51491792 , .79263615
DATA -.73002557 ,-.17163931 , .66151539
DATA -.73002557 ,-.51491792 , .44935754
DATA -.85472883 ,-.51491792 , .06556038
DATA -.65295472 ,-.72707577 ,-.21215785
DATA -.32647736 ,-.93923362 ,-.10607892
DATA 0 ,-.93923362 ,-.34327861
DATA .32647736 ,-.93923362 ,-.10607892
DATA .65295472 ,-.72707577 ,-.21215785
DATA .85472883 ,-.51491792 , .06556038
DATA .73002557 ,-.51491792 , .44935754
DATA .73002557 ,-.17163931 , .66151539
DATA .40354821 ,-.17163931 , .89871508
DATA .20177411 , .17163931 , .96427546
DATA -.20177411 , .17163931 , .96427546
DATA -.40354821 ,-.17163931 , .89871508
DATA -.20177411 ,-.51491792 , .83315469
DATA -.40354821 ,-.72707577 , .55543646
DATA -.20177411 ,-.93923362 , .27771823
DATA .2017741 ,-.93923362 , .27771823
DATA .40354821 ,-.72707577 , .55543646
DATA .20177411 ,-.51491792 , .83315469
FOR I=1 TO 116
READ A,B,C
LET X0(I)=XX(A)
LET Y0(I)=YY(A)
LET Z0(I)=ZZ(A)
LET X1(I)=XX(B)
LET Y1(I)=YY(B)
LET Z1(I)=ZZ(B)
LET X2(I)=XX(C)
LET Y2(I)=YY(C)
LET Z2(I)=ZZ(C)
NEXT I
DATA 1,6,20 !'メッシュデータ
DATA 1,20,21
DATA 1,21,7
DATA 1,7,8
DATA 1,8,9
DATA 1,9,10
DATA 1,10,2
DATA 1,2,3
DATA 1,3,4
DATA 1,4,5
DATA 1,5,6
DATA 2,10,11
DATA 2,11,12
DATA 2,12,3
DATA 3,12,13
DATA 3,13,14
DATA 3,14,15
DATA 3,15,4
DATA 4,15,16
DATA 4,16,17
DATA 4,17,5
DATA 5,17,18
DATA 5,18,19
DATA 5,19,20
DATA 5,20,6
DATA 7,21,38
DATA 7,38,39
DATA 7,39,22
DATA 7,22,8
DATA 8,22,23
DATA 8,23,24
DATA 8,24,9
DATA 9,24,25
DATA 9,25,26
DATA 9,26,11
DATA 9,11,10
DATA 11,26,27
DATA 11,27,28
DATA 11,28,13
DATA 11,13,12
DATA 13,28,29
DATA 13,29,30
DATA 13,30,14
DATA 14,30,31
DATA 14,31,32
DATA 14,32,16
DATA 14,16,15
DATA 16,32,33
DATA 16,33,34
DATA 16,34,18
DATA 16,18,17
DATA 18,34,35
DATA 18,35,36
DATA 18,36,19
DATA 19,36,37
DATA 19,37,38
DATA 19,38,21
DATA 19,21,20
DATA 22,39,53
DATA 22,53,54
DATA 22,54,40
DATA 22,40,23
DATA 23,40,41
DATA 23,41,42
DATA 23,42,25
DATA 23,25,24
DATA 25,42,43
DATA 25,43,27
DATA 25,27,26
DATA 27,43,44
DATA 27,44,45
DATA 27,45,29
DATA 27,29,28
DATA 29,45,46
DATA 29,46,47
DATA 29,47,31
DATA 29,31,30
DATA 31,47,48
DATA 31,48,33
DATA 31,33,32
DATA 33,48,49
DATA 33,49,50
DATA 33,50,35
DATA 33,35,34
DATA 35,50,51
DATA 35,51,52
DATA 35,52,37
DATA 35,37,36
DATA 37,52,53
DATA 37,53,39
DATA 37,39,38
DATA 40,54,55
DATA 40,55,56
DATA 40,56,41
DATA 41,56,57
DATA 41,57,44
DATA 41,44,43
DATA 41,43,42
DATA 44,57,58
DATA 44,58,46
DATA 44,46,45
DATA 46,58,59
DATA 46,59,49
DATA 46,49,48
DATA 46,48,47
DATA 49,59,60
DATA 49,60,51
DATA 49,51,50
DATA 51,60,55
DATA 51,55,54
DATA 51,54,53
DATA 51,53,52
DATA 55,60,59
DATA 55,59,58
DATA 55,58,57
DATA 55,57,56
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 116
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,116,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 116
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LIGHT(3)
MAT READ LIGHT ! 光源の向き
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(200),Y0(200),Z0(200),X1(200),Y1(200),Z1(200),X2(200),Y2(200),Z2(200),KEY(200),INDEX(200)
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
DIM XX(100),YY(100),ZZ(100)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 5:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
RESTORE
FOR I=1 TO 30
READ XX(I),YY(I),ZZ(I)
NEXT I
DATA -.30901699 , 0 ,-.95105652 !'座標データ
DATA -.80901699 , 0 ,-.58778525
DATA -1 , 0 , 0
DATA -.80901699 , 0 , .58778525
DATA -.309017 , 0 , .95105652
DATA .30901699 , 0 , .95105652
DATA .80901699 , 0 , .58778525
DATA 1 , 0 , 0
DATA .80901699 , 0 ,-.58778525
DATA .30901699 , 0 ,-.95105652
DATA 0 ,-.52573111 ,-.85065081
DATA -.80901699 ,-.52573111 ,-.26286556
DATA -.5 ,-.52573111 , .68819096
DATA .5 ,-.52573111 , .68819096
DATA .80901699 ,-.52573111 ,-.26286556
DATA -.30901699 ,-.85065081 ,-.4253254
DATA -.5 ,-.85065081 , .16245985
DATA 0 ,-.85065081 , .52573111
DATA .5 ,-.85065081 , .16245985
DATA .30901699 ,-.85065081 ,-.4253254
DATA -.5 , .52573111 ,-.68819096
DATA .5 , .52573111 ,-.68819096
DATA .80901699 , .52573111 , .26286556
DATA 0 , .52573111 , .85065081
DATA -.80901699 , .52573111 , .26286556
DATA 0 , .85065081 ,-.52573111
DATA .5 , .85065081 ,-.16245985
DATA .30901699 , .85065081 , .4253254
DATA -.30901699 , .85065081 , .4253254
DATA -.5 , .85065081 ,-.16245985
FOR I=1 TO 56
READ A,B,C
LET X0(I)=XX(A)
LET Y0(I)=YY(A)
LET Z0(I)=ZZ(A)
LET X1(I)=XX(B)
LET Y1(I)=YY(B)
LET Z1(I)=ZZ(B)
LET X2(I)=XX(C)
LET Y2(I)=YY(C)
LET Z2(I)=ZZ(C)
NEXT I
DATA 1,2,12 !'メッシュデータ
DATA 1,12,16
DATA 1,16,11
DATA 1,11,10
DATA 1,10,22
DATA 1,22,26
DATA 1,26,21
DATA 1,21,2
DATA 2,3,12
DATA 2,21,30
DATA 2,30,25
DATA 2,25,3
DATA 3,4,13
DATA 3,13,17
DATA 3,17,12
DATA 3,25,4
DATA 4,5,13
DATA 4,25,29
DATA 4,29,24
DATA 4,24,5
DATA 5,6,14
DATA 5,14,18
DATA 5,18,13
DATA 5,24,6
DATA 6,7,14
DATA 6,24,28
DATA 6,28,23
DATA 6,23,7
DATA 7,8,15
DATA 7,15,19
DATA 7,19,14
DATA 7,23,8
DATA 8,9,15
DATA 8,23,27
DATA 8,27,22
DATA 8,22,9
DATA 9,10,11
DATA 9,11,20
DATA 9,20,15
DATA 9,22,10
DATA 11,16,20
DATA 12,17,16
DATA 13,18,17
DATA 14,19,18
DATA 15,20,19
DATA 16,17,18
DATA 16,18,19
DATA 16,19,20
DATA 21,26,30
DATA 22,27,26
DATA 23,28,27
DATA 24,29,28
DATA 25,30,29
DATA 26,27,28
DATA 26,28,29
DATA 26,29,30
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 56
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT L=P2-P1
MAT M=P1-P0
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,56,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO 56
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LIGHT(3)
MAT READ LIGHT ! 光源の向き
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
LET NN=30
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(2*NN*NN),Y0(2*NN*NN),Z0(2*NN*NN),X1(2*NN*NN),Y1(2*NN*NN),Z1(2*NN*NN),X2(2*NN*NN),Y2(2*NN*NN),Z2(2*NN*NN),KEY(2*NN*NN),INDEX(2*NN*NN)
DIM P0(4),P1(4),P2(4),P3(4)
DIM N(3),L(4),M(4)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 30,AT 5 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
LOCATE VALUE NOWAIT(5),RANGE 0 TO 10,AT 0 : K
LOCATE VALUE NOWAIT(6),RANGE 0 TO 8,AT 1 : RR
LOCATE VALUE NOWAIT(7),RANGE 0 TO 8,AT .5 : R0
LOCATE VALUE NOWAIT(8),RANGE 0 TO 8,AT 1 : R1
LOCATE VALUE NOWAIT(9),RANGE 0 TO 8,AT 1 : R2
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
LOCATE VALUE NOWAIT(5):K
LOCATE VALUE NOWAIT(6):RR
LOCATE VALUE NOWAIT(7):R0
LOCATE VALUE NOWAIT(8):R1
LOCATE VALUE NOWAIT(9):R2
LET K=INT(K)
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET NUM=0
FOR I=0 TO NN-1
FOR J=0 TO NN-1
LET NUM=NUM+1
LET ALPHA=I*360/NN
LET BETA=J*360/NN
LET XX0=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*COS(BETA)
LET ZZ0=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*SIN(BETA)
LET YY0=R0*SIN(ALPHA)*(R2+RR*COS(K*BETA))
LET ALPHA=I*360/NN
LET BETA=(J+1)*360/NN
LET XX1=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*COS(BETA)
LET ZZ1=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*SIN(BETA)
LET YY1=R0*SIN(ALPHA)*(R2+RR*COS(K*BETA))
LET ALPHA=(I+1)*360/NN
LET BETA=(J+1)*360/NN
LET XX2=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*COS(BETA)
LET ZZ2=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*SIN(BETA)
LET YY2=R0*SIN(ALPHA)*(R2+RR*COS(K*BETA))
LET ALPHA=(I+1)*360/NN
LET BETA=J*360/NN
LET XX3=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*COS(BETA)
LET ZZ3=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*SIN(BETA)
LET YY3=R0*SIN(ALPHA)*(R2+RR*COS(K*BETA))
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
NEXT J
NEXT I
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,NUM,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
IF DOT(N,N)<>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LA(3),LIGHT(3)
MAT READ LA
DATA .8,.6,.3
MAT READ LIGHT
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
LET S=ABS(S)
MAT LA=((S+1)/2)*LA
SET COLOR MIX(8) LA(1),LA(2),LA(3)
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
LET NN=30
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(2*NN*NN),Y0(2*NN*NN),Z0(2*NN*NN),X1(2*NN*NN),Y1(2*NN*NN),Z1(2*NN*NN),X2(2*NN*NN),Y2(2*NN*NN),Z2(2*NN*NN),KEY(2*NN*NN),INDEX(2*NN*NN)
DIM P0(4),P1(4),P2(4),P3(4)
DIM N(3),L(4),M(4)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 5,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
LOCATE VALUE NOWAIT(5),RANGE 1 TO 10,AT 1:A
LOCATE VALUE NOWAIT(6),RANGE 1 TO 10,AT 1:B
LOCATE VALUE NOWAIT(7),RANGE 1 TO 10,AT 1:N1
LOCATE VALUE NOWAIT(8),RANGE 1 TO 10,AT 1:M1
LOCATE VALUE NOWAIT(9),RANGE 1 TO 10,AT 1:RR
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
LOCATE VALUE NOWAIT(5):A
LOCATE VALUE NOWAIT(6):B
LOCATE VALUE NOWAIT(7):N1
LOCATE VALUE NOWAIT(8):M1
LOCATE VALUE NOWAIT(9):RR
LET N1=INT(N1)
LET M1=INT(M1)
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET NUM=0
FOR I=0 TO NN-1
FOR J=0 TO NN-1
LET NUM=NUM+1
LET R0=FUNC(1,A/20,B/20,N1,M1,RR/10,I*180/NN,J*360/NN)
LET XX0=-R0*SIN(I*180/NN)*COS(J*360/NN)
LET YY0=R0*COS(I*180/NN)
LET ZZ0=R0*SIN(I*180/NN)*SIN(J*360/NN)
LET R0=FUNC(1,A/20,B/20,N1,M1,RR/10,I*180/NN,(J+1)*360/NN)
LET XX1=-R0*SIN(I*180/NN)*COS((J+1)*360/NN)
LET YY1=R0*COS(I*180/NN)
LET ZZ1=R0*SIN(I*180/NN)*SIN((J+1)*360/NN)
LET R0=FUNC(1,A/20,B/20,N1,M1,RR/10,(I+1)*180/NN,(J+1)*360/NN)
LET XX2=-R0*SIN((I+1)*180/NN)*COS((J+1)*360/NN)
LET YY2=R0*COS((I+1)*180/NN)
LET ZZ2=R0*SIN((I+1)*180/NN)*SIN((J+1)*360/NN)
LET R0=FUNC(1,A/20,B/20,N1,M1,RR/10,(I+1)*180/NN,J*360/NN)
LET XX3=-R0*SIN((I+1)*180/NN)*COS(J*360/NN)
LET YY3=R0*COS((I+1)*180/NN)
LET ZZ3=R0*SIN((I+1)*180/NN)*SIN(J*360/NN)
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
NEXT J
NEXT I
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,NUM,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
IF DOT(N,N)<>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL FUNCTION FUNC(R,A,B,N,M,RR,ALPHA,BETA) !'バラ曲線
OPTION ANGLE DEGREES
LET FUNC=ABS(R*(1+A*SIN(ALPHA*N)*(1+B*SIN(BETA*M)+RR)))
END FUNCTION
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LA(3),LIGHT(3)
MAT READ LA
DATA .8,.8,.1
MAT READ LIGHT
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
MAT LA=((S+1)/2)*LA
SET COLOR MIX(8) LA(1),LA(2),LA(3)
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
LET NN=30
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
DIM X0(2*NN*NN),Y0(2*NN*NN),Z0(2*NN*NN),X1(2*NN*NN),Y1(2*NN*NN),Z1(2*NN*NN),X2(2*NN*NN),Y2(2*NN*NN),Z2(2*NN*NN),KEY(2*NN*NN),INDEX(2*NN*NN)
DIM P0(4),P1(4),P2(4),P3(4)
DIM N(3),L(4),M(4)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 5,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
LOCATE VALUE NOWAIT(5),RANGE 0 TO 4,AT 1:N0
LOCATE VALUE NOWAIT(6),RANGE 0 TO 4,AT 1:M0
LOCATE VALUE NOWAIT(7),RANGE .1 TO 4,AT 1:R1
LOCATE VALUE NOWAIT(8),RANGE .1 TO 4,AT 1:R2
LOCATE VALUE NOWAIT(9),RANGE .1 TO 4,AT 1:R3
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
LOCATE VALUE NOWAIT(5):N0
LOCATE VALUE NOWAIT(6):M0
LOCATE VALUE NOWAIT(7):R1
LOCATE VALUE NOWAIT(8):R2
LOCATE VALUE NOWAIT(9):R3
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
LET NUM=0
FOR I=0 TO NN-1
FOR J=0 TO NN-1
LET NUM=NUM+1
LET XX0=-R1*SGN(SIN(I*180/NN))*ABS(SIN(I*180/NN))^N0*SGN(COS(J*360/NN))*ABS(COS(J*360/NN))^M0
LET YY0=R2*SGN(COS(I*180/NN))*ABS(COS(I*180/NN))^N0
LET ZZ0=R3*SGN(SIN(I*180/NN))*ABS(SIN(I*180/NN))^N0*SGN(SIN(J*360/NN))*ABS(SIN(J*360/NN))^M0
LET XX1=-R1*SGN(SIN(I*180/NN))*ABS(SIN(I*180/NN))^N0*SGN(COS((J+1)*360/NN))*ABS(COS((J+1)*360/NN))^M0
LET YY1=R2*SGN(COS(I*180/NN))*ABS(COS(I*180/NN))^N0
LET ZZ1=R3*SGN(SIN(I*180/NN))*ABS(SIN(I*180/NN))^N0*SGN(SIN((J+1)*360/NN))*ABS(SIN((J+1)*360/NN))^M0
LET XX2=-R1*SGN(SIN((I+1)*180/NN))*ABS(SIN((I+1)*180/NN))^N0*SGN(COS((J+1)*360/NN))*ABS(COS((J+1)*360/NN))^M0
LET YY2=R2*SGN(COS((I+1)*180/NN))*ABS(COS((I+1)*180/NN))^N0
LET ZZ2=R3*SGN(SIN((I+1)*180/NN))*ABS(SIN((I+1)*180/NN))^N0*SGN(SIN((J+1)*360/NN))*ABS(SIN((J+1)*360/NN))^M0
LET XX3=-R1*SGN(SIN((I+1)*180/NN))*ABS(SIN((I+1)*180/NN))^N0*SGN(COS(J*360/NN))*ABS(COS(J*360/NN))^M0
LET YY3=R2*SGN(COS((I+1)*180/NN))*ABS(COS((I+1)*180/NN))^N0
LET ZZ3=R3*SGN(SIN((I+1)*180/NN))*ABS(SIN((I+1)*180/NN))^N0*SGN(SIN(J*360/NN))*ABS(SIN(J*360/NN))^M0
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX0
LET Y0(NUM)=YY0
LET Z0(NUM)=ZZ0
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
NEXT J
NEXT I
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,NUM,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
IF DOT(N,N)<>0 THEN
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
END IF
NEXT I
SET DRAW MODE EXPLICIT
LOOP
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM LA(3),LIGHT(3)
MAT READ LA
DATA .8,.8,.1
MAT READ LIGHT
DATA 1,1,1
LET S=DOT(LIGHT,N)/(SQR(DOT(LIGHT,LIGHT))*SQR(DOT(N,N)))
LET S=ABS(S)
MAT LA=((S+1)/2)*LA
SET COLOR MIX(8) LA(1),LA(2),LA(3)
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
CLEAR
INPUT PROMPT "LEVEL (1-4)=":LEV
DIM X0(4^(LEV+1)),Y0(4^(LEV+1)),Z0(4^(LEV+1)),X1(4^(LEV+1)),Y1(4^(LEV+1)),Z1(4^(LEV+1)),X2(4^(LEV+1)),Y2(4^(LEV+1)),Z2(4^(LEV+1)),KEY(4^(LEV+1)),INDEX(4^(LEV+1))
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
LOCATE VALUE NOWAIT(1),RANGE 1 TO 10,AT 3:SCALE
LOCATE VALUE NOWAIT(2),RANGE -360 TO 360,AT 0:XTH
LOCATE VALUE NOWAIT(3),RANGE -360 TO 360,AT 0:YTH
LOCATE VALUE NOWAIT(4),RANGE -360 TO 360,AT 0:ZTH
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):XTH
LOCATE VALUE NOWAIT(3):YTH
LOCATE VALUE NOWAIT(4):ZTH
SET WINDOW -SCALE,SCALE,-SCALE,SCALE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
LET NUM=0
CALL RECURSIVE(LEV,0,0,0,1)
LET MX=0
LET MY=0
LET MZ=0
FOR I=1 TO NUM !'重心を求める
LET MX=MX+X0(I)
LET MY=MY+Y0(I)
LET MZ=MZ+Z0(I)
LET MX=MX+X1(I)
LET MY=MY+Y1(I)
LET MZ=MZ+Z1(I)
LET MX=MX+X2(I)
LET MY=MY+Y2(I)
LET MZ=MZ+Z2(I)
NEXT I
LET MX=MX/3/NUM
LET MY=MY/3/NUM
LET MZ=MZ/3/NUM
FOR I=1 TO NUM
LET P0(1)=X0(I)-MX
LET P0(2)=Y0(I)-MY
LET P0(3)=Z0(I)-MZ
LET P1(1)=X1(I)-MX
LET P1(2)=Y1(I)-MY
LET P1(3)=Z1(I)-MZ
LET P2(1)=X2(I)-MX
LET P2(2)=Y2(I)-MY
LET P2(3)=Z2(I)-MZ
LET P0(4),P1(4),P2(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I))/3 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,NUM,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SETBRIGHTNESS(N)
CALL PLOT3(P0,P1,P2)
NEXT I
SET DRAW MODE EXPLICIT
LOOP
SUB TETRAHEDRON(X,Y,Z,L) !'4面体
LET XX1=X+L*COS(0)
LET ZZ1=Z+L*SIN(0)
LET YY1=Y
LET XX2=X+L*COS(120)
LET ZZ2=Z+L*SIN(120)
LET YY2=Y
LET XX3=X+L*COS(240)
LET ZZ3=Z+L*SIN(240)
LET YY3=Y
LET XX4=X
LET ZZ4=Z
LET YY4=Y+L*SQR(2)
LET NUM=NUM+1
LET X0(NUM)=XX4
LET Y0(NUM)=YY4
LET Z0(NUM)=ZZ4
LET X1(NUM)=XX1
LET Y1(NUM)=YY1
LET Z1(NUM)=ZZ1
LET X2(NUM)=XX2
LET Y2(NUM)=YY2
LET Z2(NUM)=ZZ2
LET NUM=NUM+1
LET X0(NUM)=XX3
LET Y0(NUM)=YY3
LET Z0(NUM)=ZZ3
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX1
LET Y2(NUM)=YY1
LET Z2(NUM)=ZZ1
LET NUM=NUM+1
LET X0(NUM)=XX4
LET Y0(NUM)=YY4
LET Z0(NUM)=ZZ4
LET X1(NUM)=XX3
LET Y1(NUM)=YY3
LET Z1(NUM)=ZZ3
LET X2(NUM)=XX1
LET Y2(NUM)=YY1
LET Z2(NUM)=ZZ1
LET NUM=NUM+1
LET X0(NUM)=XX4
LET Y0(NUM)=YY4
LET Z0(NUM)=ZZ4
LET X1(NUM)=XX2
LET Y1(NUM)=YY2
LET Z1(NUM)=ZZ2
LET X2(NUM)=XX3
LET Y2(NUM)=YY3
LET Z2(NUM)=ZZ3
END SUB
SUB RECURSIVE(LEV,X,Y,Z,L) !'シェルピンスキー
IF LEV=0 THEN
CALL TETRAHEDRON(X,Y,Z,L*2)
ELSE
CALL RECURSIVE(LEV-1,X,Y+L*SQR(2),Z,L/2)
CALL RECURSIVE(LEV-1,X+L*COS(0),Y,Z+L*SIN(0),L/2)
CALL RECURSIVE(LEV-1,X+L*COS(120),Y,Z+L*SIN(120),L/2)
CALL RECURSIVE(LEV-1,X+L*COS(240),Y,Z+L*SIN(240),L/2)
END IF
END SUB
END
EXTERNAL SUB PLOT3(P0(),P1(),P2()) !'3角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=20 ! x軸のまわりの回転角初期値
LET YTH=10 ! y軸のまわりの回転角初期値
FOR I=0 TO 7
SET COLOR MIX(I) BITAND(I,2)/2,BITAND(I,4)/4,BITAND(I,1)
NEXT I
LET LEV=4
DIM X0(6*20^LEV),Y0(6*20^LEV),Z0(6*20^LEV),X1(6*20^LEV),Y1(6*20^LEV),Z1(6*20^LEV),X2(6*20^LEV),Y2(6*20^LEV),Z2(6*20^LEV)
DIM X3(6*20^LEV),Y3(6*20^LEV),Z3(6*20^LEV),KEY(6*20^LEV),INDEX(6*20^LEV)
DIM P0(4),P1(4),P2(4),P3(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
CALL RECURSIVE(LEV,0,0,0,2)
SET WINDOW -1.5,1.5,-1.5,1.5
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
FOR I=1 TO NUM
LET P0(1)=X0(I)
LET P0(2)=Y0(I)
LET P0(3)=Z0(I)
LET P1(1)=X1(I)
LET P1(2)=Y1(I)
LET P1(3)=Z1(I)
LET P2(1)=X2(I)
LET P2(2)=Y2(I)
LET P2(3)=Z2(I)
LET P3(1)=X3(I)
LET P3(2)=Y3(I)
LET P3(3)=Z3(I)
LET P0(4),P1(4),P2(4),P3(4)=1
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
MAT P3=P3*Q
LET X0(I)=P0(1)
LET Y0(I)=P0(2)
LET Z0(I)=P0(3)
LET X1(I)=P1(1)
LET Y1(I)=P1(2)
LET Z1(I)=P1(3)
LET X2(I)=P2(1)
LET Y2(I)=P2(2)
LET Z2(I)=P2(3)
LET X3(I)=P3(1)
LET Y3(I)=P3(2)
LET Z3(I)=P3(3)
LET KEY(I)=(Z0(I)+Z1(I)+Z2(I)+Z3(I))/4 !'各頂点のZ座標値の平均
LET INDEX(I)=I
NEXT I
CALL QUICKSORT(1,NUM,KEY,INDEX) !'Zソート
SET DRAW MODE HIDDEN
CLEAR
FOR I=1 TO NUM
LET P0(1)=X0(INDEX(I))
LET P0(2)=Y0(INDEX(I))
LET P0(3)=Z0(INDEX(I))
LET P1(1)=X1(INDEX(I))
LET P1(2)=Y1(INDEX(I))
LET P1(3)=Z1(INDEX(I))
LET P2(1)=X2(INDEX(I))
LET P2(2)=Y2(INDEX(I))
LET P2(3)=Z2(INDEX(I))
LET P3(1)=X3(INDEX(I))
LET P3(2)=Y3(INDEX(I))
LET P3(3)=Z3(INDEX(I))
MAT L=P3-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SETBRIGHTNESS(N)
CALL PLOT4(P0,P1,P2,P3)
NEXT I
SET DRAW MODE EXPLICIT
SUB CUBE(X,Y,Z,L) !'立方体
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y+L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y+L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y+L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y+L/2
LET Z3(NUM)=Z+L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y+L/2
LET Z0(NUM)=Z+L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y+L/2
LET Z1(NUM)=Z+L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y-L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y-L/2
LET Z3(NUM)=Z+L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y-L/2
LET Z0(NUM)=Z+L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y-L/2
LET Z1(NUM)=Z+L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y-L/2
LET Z2(NUM)=Z-L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y-L/2
LET Z3(NUM)=Z-L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y-L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y-L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y+L/2
LET Z2(NUM)=Z-L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y+L/2
LET Z3(NUM)=Z-L/2
LET NUM=NUM+1
LET X0(NUM)=X+L/2
LET Y0(NUM)=Y+L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X+L/2
LET Y1(NUM)=Y-L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X+L/2
LET Y2(NUM)=Y-L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X+L/2
LET Y3(NUM)=Y+L/2
LET Z3(NUM)=Z+L/2
LET NUM=NUM+1
LET X0(NUM)=X-L/2
LET Y0(NUM)=Y-L/2
LET Z0(NUM)=Z-L/2
LET X1(NUM)=X-L/2
LET Y1(NUM)=Y+L/2
LET Z1(NUM)=Z-L/2
LET X2(NUM)=X-L/2
LET Y2(NUM)=Y+L/2
LET Z2(NUM)=Z+L/2
LET X3(NUM)=X-L/2
LET Y3(NUM)=Y-L/2
LET Z3(NUM)=Z+L/2
END SUB
SUB RECURSIVE(N,X,Y,Z,L) !'メンガー
IF N=0 THEN
CALL CUBE(X,Y,Z,L)
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
EXTERNAL SUB PLOT4(P0(),P1(),P2(),P3()) !'4角形描画
PLOT AREA :P0(1),P0(2);P1(1),P1(2);P2(1),P2(2);P3(1),P3(2)
END SUB
EXTERNAL SUB SETBRIGHTNESS(N())
DIM A(3)
MAT READ A ! 光源の向き
DATA 1,1,1
LET S=DOT(A,N)/(SQR(DOT(A,A))*SQR(DOT(N,N)))
LET S=(S+1)/2
SET COLOR MIX(8) S,S,S
SET AREA COLOR 8
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
EXTERNAL SUB QUICKSORT(FI,LA,A(),INDEX())
LET X=A(INDEX((FI+LA)/2))
LET I=FI
LET J=LA
DO
DO WHILE A(INDEX(I))<X
LET I=I+1
LOOP
DO WHILE X<A(INDEX(J))
LET J=J-1
LOOP
IF I>=J THEN EXIT DO
SWAP INDEX(I),INDEX(J)
LET I=I+1
LET J=J-1
LOOP
IF FI<I-1 THEN CALL QUICKSORT(FI,I-1,A,INDEX)
IF J+1<LA THEN CALL QUICKSORT(J+1,LA,A,INDEX)
END SUB
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=30 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
LET XS,YS,ZS=-5
LET XE,YE,ZE=5
SET WINDOW XS,XE,YS,YE
ASK BITMAP SIZE XSIZE,YSIZE
DIM ZBUFF(0 TO XSIZE,0 TO YSIZE),COLORMAP(0 TO XSIZE,0 TO YSIZE)
MAT ZBUFF=(-1000000000)*CON !' Zバッファー 無限遠 ∞
DIM P0(4),P1(4),P2(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),ROTX(4,4),ROTY(4,4)
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET TEXT HEIGHT (YE-YS)/10
SET TEXT BACKGROUND "OPAQUE"
SET COLOR COLORINDEX(1,1,1)
LET YMIN=-1
LET YMAX=1
LET RMIN=0
LET RMAX=1
LET GMIN,GMAX=0
LET BMIN=1
LET BMAX=0
FOR I=0 TO YSIZE STEP 1/8
PLOT TEXT ,AT XS,YS:USING$("###.##",I/YSIZE*100)&"%"
FOR J=0 TO XSIZE STEP 1/8
LET P0(1)=XS+(XE-XS)/XSIZE*J
LET P0(3)=ZS+(ZE-ZS)/YSIZE*I
LET P0(2)=FUNC(P0(1),P0(3))
LET P1(1)=XS+(XE-XS)/XSIZE*(J+1)
LET P1(3)=ZS+(ZE-ZS)/YSIZE*I
LET P1(2)=FUNC(P1(1),P1(3))
LET P2(1)=XS+(XE-XS)/XSIZE*(J+1)
LET P2(3)=ZS+(ZE-ZS)/YSIZE*(I+1)
LET P2(2)=FUNC(P2(1),P2(3))
LET P0(4),P1(4),P2(4)=1
LET Y0=P0(2)
MAT P0=P0*Q
MAT P1=P1*Q
MAT P2=P2*Q
LET XX=PIXELX(P0(1))
LET YY=PIXELY(P0(2))
LET ZZ=P0(3)
IF XX>=0 AND XX<=XSIZE AND YY>=0 AND YY<=YSIZE THEN
IF ZBUFF(XX,YY)<ZZ THEN !'手前なら
LET ZBUFF(XX,YY)=ZZ !'Zバッファー値更新
MAT L=P2-P1
MAT M=P1-P0
CALL OUTER(N,L,M)
CALL SHADE(N,COLORMAP(XX,YY))
!'CALL GRADATION(Y0,YMIN,YMAX,RMIN,RMAX,GMIN,GMAX,BMIN,BMAX,COLORMAP(XX,YY))
END IF
END IF
NEXT J
NEXT I
MAT PLOT CELLS, IN XS,YS ; XE,YE : COLORMAP
END
EXTERNAL FUNCTION FUNC(X,Z) !'3D陽関数
OPTION ANGLE RADIANS
LET FUNC=COS(3*SQR(X*X+Z*Z))
END FUNCTION
EXTERNAL SUB GRADATION(X,SMIN,SMAX,RMIN,RMAX,GMIN,GMAX,BMIN,BMAX,COL)
LET T=(X-SMIN)/(SMAX-SMIN)
LET R=RMIN+T*(RMAX-RMIN)
LET G=GMIN+T*(GMAX-GMIN)
LET B=BMIN+T*(BMAX-BMIN)
LET COL=COLORINDEX(R,G,B)
END SUB
EXTERNAL SUB SHADE(N(),COL)
DIM LIGHT(3),CPOS(3),LA(3),KD(3),KS(3),KA(3),LC(3)
DIM VR(3),BR(3)
MAT READ CPOS !'視線ベクトル
DATA 0,0,1
MAT READ LA !'背景の色
DATA .2,.5,.8
MAT READ KD !'拡散反射係数
DATA 0.6,0.3,0.4
MAT READ KS !'鏡面反射係数
DATA 0.8,0.7,0.6
MAT READ KA !'環境光係数
DATA 0.3,0.2,0.1
MAT READ LC !'光源の色
DATA 1,.8,.7
MAT READ LIGHT !'光線ベクトル
DATA 1,1,1
LET NS=16
IF DOT(N,N)<>0 THEN MAT N=(1/SQR(DOT(N,N)))*N
MAT LIGHT=(1/SQR(DOT(LIGHT,LIGHT)))*LIGHT
LET COSTHETA=DOT(N,LIGHT)
IF COSTHETA<0 THEN
IF BACK<>0 THEN LET COSTHETA=-COSTHETA ELSE LET COSTHETA=0
END IF
FOR I=1 TO 3
LET VR(I)=2*COSTHETA*N(I)-LIGHT(I)
NEXT I
MAT CPOS=(1/SQR(DOT(CPOS,CPOS)))*CPOS
MAT VR=(1/SQR(DOT(VR,VR)))*VR
LET COSALPHA=DOT(CPOS,VR)
IF COSALPHA>0 THEN LET EA=COSALPHA^NS ELSE LET EA=0
FOR I=1 TO 3
LET BR(I)=LC(I)*KD(I)*COSTHETA+LA(I)*KA(I)+LC(I)*KS(I)*EA
LET BR(I)=MIN(1,MAX(0,BR(I)))
NEXT I
LET COL=COLORINDEX(BR(1),BR(2),BR(3))
END SUB
EXTERNAL SUB OUTER(C(),A(),B()) !'外積
LET C(1)=A(2)*B(3)-A(3)*B(2)
LET C(2)=A(3)*B(1)-A(1)*B(3)
LET C(3)=A(1)*B(2)-A(2)*B(1)
END SUB
OPTION ANGLE DEGREES
LET ZTH=10 ! z軸のまわりの回転角
LET XTH=20 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
SET COLOR MIX(0) 0,0,0
CLEAR
SET COLOR MODE "NATIVE"
LET XS,YS=-5
LET XE,YE=5
SET WINDOW XS,XE,YS,YE
ASK BITMAP SIZE XSIZE,YSIZE
DIM ZBUFF(0 TO XSIZE,0 TO YSIZE),COLORMAP(0 TO XSIZE,0 TO YSIZE)
MAT ZBUFF=(-1000000000)*CON !' Zバッファー 無限遠 ∞
DIM P0(4)
DIM L(4),M(4),N(3)
DIM Q(4,4),Q0(4),ROTX(4,4),ROTY(4,4)
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT Q=ROTATE(ZTH)
MAT Q=Q*ROTY*ROTX
SET TEXT HEIGHT (YE-YS)/10
SET TEXT BACKGROUND "OPAQUE"
SET COLOR COLORINDEX(1,1,1)
LET YMIN=-.5
LET YMAX=.5
LET RMIN=0
LET RMAX=1
LET GMIN=0
LET GMAX=0
LET BMIN=1
LET BMAX=0
FOR I=0 TO 180 STEP 1/8
PLOT TEXT ,AT XS,YS:USING$("###.##",I/180*100)&"%"
FOR J=0 TO 360 STEP 1/8
FOR K=0 TO 359 !'オブジェクトを移動させる
LET X=COS(3*K)*RAD(K)/1.5
LET Z=SIN(3*K)*RAD(K)/1.5
LET Y=RAD(360-K)/2
LET P0(1)=-.5*SIN(I)*COS(J)+X
LET P0(2)=.5*COS(I)+Y
LET P0(3)=.5*SIN(I)*SIN(J)+Z
LET P0(4)=1
LET Y0=P0(2)-Y
MAT Q0=P0*Q
LET XX=PIXELX(Q0(1))
LET YY=PIXELY(Q0(2))
LET ZZ=Q0(3)
IF XX>=0 AND XX<=XSIZE AND YY>=0 AND YY<=YSIZE THEN
IF ZBUFF(XX,YY)<ZZ THEN !'手前なら
LET ZBUFF(XX,YY)=ZZ !'Zバッファー値更新
CALL GRADATION(Y0,YMIN,YMAX,RMIN,RMAX,GMIN,GMAX,BMIN,BMAX,COLORMAP(XX,YY))
END IF
END IF
NEXT K
NEXT J
NEXT I
MAT PLOT CELLS, IN XS,YS ; XE,YE : COLORMAP
END
EXTERNAL SUB GRADATION(X,SMIN,SMAX,RMIN,RMAX,GMIN,GMAX,BMIN,BMAX,COL)
LET T=(X-SMIN)/(SMAX-SMIN)
LET R=RMIN+T*(RMAX-RMIN)
LET G=GMIN+T*(GMAX-GMIN)
LET B=BMIN+T*(BMAX-BMIN)
LET COL=COLORINDEX(R,G,B)
END SUB
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 1,1,1
CLEAR
SET POINT STYLE 1
RANDOMIZE
LET X1=RND
LET Y1=RND
LET X2=RND
LET Y2=RND
LET X3=RND
LET Y3=RND
SET LINE COLOR 1
PLOT LINES:X1,Y1;X2,Y2;X3,Y3;X1,Y1
FOR I=1 TO 10000
LET PX=RND
LET PY=RND
IF AREA4(X1,Y1,X2,Y2,X3,Y3,PX,PY)<>0 THEN
SET POINT COLOR 4
ELSE
SET POINT COLOR 3
END IF
PLOT POINTS: PX,PY
NEXT I
END
EXTERNAL FUNCTION AREA(X1,Y1,X2,Y2,X3,Y3,PX,PY) !'面積
LET T=TRIANGLE(X1,Y1,X2,Y2,X3,Y3)
LET A=TRIANGLE(X1,Y1,X2,Y2,PX,PY)
LET B=TRIANGLE(X2,Y2,X3,Y3,PX,PY)
LET C=TRIANGLE(X1,Y1,X3,Y3,PX,PY)
ASK BITMAP SIZE XSIZE,YSIZE
IF ABS(A+B+C-T)<1/SQR(XSIZE^2+YSIZE^2) THEN LET AREA=-1 ELSE LET AREA=0
END FUNCTION
EXTERNAL FUNCTION TRIANGLE(X1,Y1,X2,Y2,X3,Y3)
LET TRIANGLE=ABS(X1*Y2+X2*Y3+X3*Y1-X2*Y1-X3*Y2-Y3*X1)/2
END FUNCTION
EXTERNAL FUNCTION AREA2(OX,OY,AX,AY,BX,BY,X,Y) !'ベクトル
LET A=AX-OX
LET B=BX-OX
LET C=AY-OY
LET D=BY-OY
LET PX=X-OX
LET PY=Y-OY
LET DET=A*D-B*C
IF DET=0 THEN
LET AREA2=0
EXIT FUNCTION
END IF
LET S=(D*PX-B*PY)/DET
IF S<0 THEN
LET AREA2=0
EXIT FUNCTION
END IF
LET T=(A*PY-C*PX)/DET
IF T<0 THEN
LET AREA2=0
EXIT FUNCTION
END IF
IF S+T<=1 THEN LET AREA2=-1 ELSE LET AREA2=0
END FUNCTION
EXTERNAL FUNCTION AREA3(X1,Y1,X2,Y2,X3,Y3,PX,PY) !'外積
DIM P(3),P0(3),P1(3),P2(3),P3(3),N1(3),N2(3),N3(3),L(3),M(3)
LET P(1)=PX
LET P(2)=PY
LET P(3)=PZ
LET P1(1)=X1
LET P1(2)=Y1
LET P1(3)=Z1
LET P2(1)=X2
LET P2(2)=Y2
LET P2(3)=Z2
LET P3(1)=X3
LET P3(2)=Y3
LET P3(3)=Z3
MAT L=P1-P
MAT M=P2-P
MAT N1=CROSS(L,M)
MAT L=P2-P
MAT M=P3-P
MAT N2=CROSS(L,M)
MAT L=P3-P
MAT M=P1-P
MAT N3=CROSS(L,M)
LET AREA3=-1
FOR I=1 TO 3
IF SGN(N1(I))<>SGN(N2(I)) OR SGN(N2(I))<>SGN(N3(I)) THEN LET AREA3=0
NEXT I
END FUNCTION
EXTERNAL FUNCTION AREA4(X1,Y1,X2,Y2,X3,Y3,PX,PY) !'内角の和
OPTION ANGLE DEGREES
LET LX=X1-PX
LET LY=Y1-PY
LET MX=X2-PX
LET MY=Y2-PY
LET NX=X3-PX
LET NY=Y3-PY
LET S=ACOS((LX*MX+LY*MY)/SQR(LX*LX+LY*LY)/SQR(MX*MX+MY*MY))
LET S=S+ACOS((NX*MX+NY*MY)/SQR(NX*NX+NY*NY)/SQR(MX*MX+MY*MY))
LET S=S+ACOS((NX*LX+NY*LY)/SQR(NX*NX+NY*NY)/SQR(LX*LX+LY*LY))
IF ABS(S-360)<1 THEN LET AREA4=-1 ELSE LET AREA4=0
END FUNCTION
FUNCTION STR_E2$(x,n)
LOCAL u$,e,i
IF x=0 OR ROUND(n)=0 THEN ! 有効数字0桁の数値は0
IF n>0 THEN LET u$=" 0."&REPEAT$("0",n-1)&"E+0" ELSE LET u$=" 0"
ELSE
LET e=INT(LOG10(ABS(x)))
LET u$=USING$("-%."&REPEAT$("#",n-1)&REPEAT$("^",LEN(STR$(ABS(e)))+2),ROUND(x,n-e-1))
END IF
! ここからはオプション[1～6]
!LET u$=LTRIM$(u$) ![オプション1]xが非負のときの先頭空白を削除 " 3.45E+6"→"3.45E+6"
FOR i=POS(u$,"E")-1 TO 2 STEP -1 ![オプション2]仮数部末尾の"0"を削除 n=4,"-6.700E+8"→"-6.7E+8"
IF u$(i:i)="0" THEN LET u$(i:i)="" ELSE EXIT FOR
NEXT i
!LET u$(POS(u$,".E"):POS(u$,".E"))="" ![オプション3]仮数部が1桁のとき小数点を削除 "-7.E4"→"-7E4"
IF POS(u$,"E+0")>0 THEN ![オプション4]指数が0のとき指数部を削除 n=5," 6.5400E+0"→" 6.5400"
LET u$=u$(1:POS(u$,"E")-1)
IF u$(LEN(u$):LEN(u$))="." THEN LET u$=u$(1:LEN(u$)-1) ! "-4.E+0"→"-4."→"-4"
END IF
LET u$(POS(u$,"+",3):POS(u$,"+",3))="" ![オプション5]指数部の"+"を削除 " 1.23E+5"→" 1.23E5"
LET u$=u$&" " ![オプション6]文字列の末尾に空白を付加 " 5.678900E-3"→" 5.678900E-3 "
LET STR_E2$=u$
END FUNCTION
DO
READ IF MISSING THEN EXIT DO: a,n
PRINT a;n
PRINT STR_E1$(a,n)
PRINT STR_E2$(a,n)
PRINT
LOOP
DATA 2496376014,5, -6715400000000,8, 0.000007102385,6, 3.95180751,4, -218.60135,7
OPTION CHARACTER byte
LET q=op(-1100,0) !第１引数は-1100(directmusic)か-1(win mapper)
LET q=al("e:\落ちゲー\data\music\maoudamashii-3-theme01.mid",0,2) !MIDIは任意のMIDIフアイル名、フアイルIDは第３引数
LET q=pl(0,2,0,0,0) !フアイルIDは第２引数
DO
WAIT DELAY 1
LET w$=REPEAT$(" ",20)
CALL gs(w$,20) !第２引数は20(getplayerstatus),36(getsmfinformation)固定
IF ORD(left$(q$,1))=0THEN !終了が0,再生中が1,一時停止中が2
CALL st(0)
EXIT DO
END IF
LOOP
CALL cl !プログラム終了前に必ずClosedeviceしないとフリイズするので注意
END
EXTERNAL FUNCTION op(q,w)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4OpenDevice" !関数識別冠詞「GGS4」は必ず必要
END FUNCTION
EXTERNAL FUNCTION al(q$,w,e)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4AddListFromFileA"
END FUNCTION
EXTERNAL FUNCTION pl(q,w,e,r,t)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4Play"
END FUNCTION
EXTERNAL SUB cl
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4CloseDevice"
END SUB
EXTERNAL SUB gs(w$,l)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4GetPlayerStatus"
END SUB
EXTERNAL SUB st(q)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4Stop"
END SUB
OPTION CHARACTER byte
LET q=op(-1100,0) !第１引数は-1100(directmusic)か-1(win mapper)
LET q=al("e:\落ちゲー\data\music\net.mid",0,2) !MIDIは任意のMIDIフアイル名、フアイルIDは第３引数
LET q=pl(0,2,0,0,0) !フアイルIDは第２引数
DO
WAIT DELAY 1
LET q$=REPEAT$(" ",20)
CALL gs(q$,20) !第２引数は20(getplayerstatus),36(getsmfinformation)固定
IF ORD(left$(q$,1))=0THEN !終了が0,再生中が1,一時停止中が2
CALL st(0)
EXIT DO
END IF
LOOP
call ci !修正部分!
CALL cl !プログラム終了前に必ずClosedeviceしないとフリイズするので注意
END
EXTERNAL SUB ci !修正部分!
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4ClearList" !修正部分!
END SUB !修正部分!
EXTERNAL FUNCTION op(q,w)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4OpenDevice" !関数識別冠詞「GGS4」は必ず必要
END FUNCTION
EXTERNAL FUNCTION al(q$,w,e)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4AddListFromFileA"
END FUNCTION
EXTERNAL FUNCTION pl(q,w,e,r,t)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4Play"
END FUNCTION
EXTERNAL SUB cl
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4CloseDevice"
END SUB
EXTERNAL SUB gs(q$,w)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4GetPlayerStatus"
END SUB
EXTERNAL SUB st(q)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4Stop"
END SUB
OPTION CHARACTER byte
LET q=op(-1100,0) !第１引数は-1100(directmusic)か-1(win mapper)
LET q=al("e:\落ちゲー\data\music\net.mid",0,2) !MIDIは任意のMIDIフアイル名、フアイルIDは第３引数
LET q=pl(0,2,0,0,0) !フアイルIDは第２引数
DO
WAIT DELAY 1
LET q$=REPEAT$(" ",20)
CALL gs(q$,20) !第２引数は20(getplayerstatus),36(getsmfinformation)固定
IF ORD(left$(q$,1))=0THEN !終了が0,再生中が1,一時停止中が2
CALL st(0)
EXIT DO
END IF
LET q$="" !修正部分!
LOOP
LET q$="" !修正部分!
call ci !修正部分!
CALL cl !プログラム終了前に必ずClosedeviceしないとフリイズするので注意
END
EXTERNAL SUB ci !修正部分!
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4ClearList" !修正部分!
END SUB !修正部分!
EXTERNAL FUNCTION op(q,w)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4OpenDevice" !関数識別冠詞「GGS4」は必ず必要
END FUNCTION
EXTERNAL FUNCTION al(q$,w,e)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4AddListFromFileA"
END FUNCTION
EXTERNAL FUNCTION pl(q,w,e,r,t)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4Play"
END FUNCTION
EXTERNAL SUB cl
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4CloseDevice"
END SUB
EXTERNAL SUB gs(q$,w)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4GetPlayerStatus"
END SUB
EXTERNAL SUB st(q)
assign"c:\gurugurusmf4-0-6\gurugurusmf4.dll","GGS4Stop"
END SUB
LET A$="SQRT(3)/2"
!!INPUT A$
PRINT PARSER(A$)
PRINT PARSER("SIN(PI/3)")
PRINT PARSER("2^PI")
PRINT PARSER("EXP(PI*LOG(2))")
FOR X=0 TO 180 STEP 15
LET X$="COS("&STR$(X)&"*PI/180)"
PRINT X$;":";PARSER(X$)
NEXT X
END
EXTERNAL FUNCTION PARSER(X$)
OPTION CHARACTER BYTE
IF X$="" THEN
PRINT "ERROR"
STOP
END IF
LET PARSER=PARSER16(LCASE$(X$))
FUNCTION PARSER16(X$)
ASSIGN ".\DLL\parser16.dll","parser16",FPU
END FUNCTION
END FUNCTION
-----------------------------------------------------------------
こちらはパラメータにu,v,w,x,y,zが使用できます。
LET EXPRESSION$="SIN(2*PI/X)"
FOR X=1 TO 10
PRINT X;":";PARSER(EXPRESSION$,U,V,W,X,Y,Z);SIN(2*PI/X)
NEXT X
PRINT INTEGRAL("1/X",1,2,500);LOG(2)
END
EXTERNAL FUNCTION INTEGRAL(A$,A,B,N)
DIM R(0 TO 3)
LET R(0)=3/8
LET R(1)=9/8
LET R(2)=9/8
LET R(3)=3/8
LET H=(B-A)/N/3
FOR K=0 TO N-1
FOR J=0 TO 3
LET X=A+H*(3*K+J)
LET S=S+R(J)*H*PARSER(A$,U,V,W,X,Y,Z)
NEXT J
NEXT K
LET INTEGRAL=S
END FUNCTION
EXTERNAL FUNCTION PARSER(EXPRESSION$,U,V,W,X,Y,Z)
OPTION CHARACTER BYTE
LET U$=PACKDBL$(U)
LET V$=PACKDBL$(V)
LET W$=PACKDBL$(W)
LET X$=PACKDBL$(X)
LET Y$=PACKDBL$(Y)
LET Z$=PACKDBL$(Z)
IF EXPRESSION$="" THEN
PRINT "ERROR"
STOP
END IF
LET PARSER=PARSER16(LCASE$(EXPRESSION$),U$,V$,W$,X$,Y$,Z$)
FUNCTION PARSER16(INPUT$,U$,V$,W$,X$,Y$,Z$)
ASSIGN ".\DLL\parser16_2.dll","parser16",FPU
END FUNCTION
END FUNCTION
PRINT PARSER("GAMMA(1.5)",U,V,W,X,Y,Z);SQR(PI)/2
LET U=4.125
LET V=3
PRINT PARSER("COMB(U,V)",U,V,W,X,Y,Z);COMB(U,V) !'パラメータは u,v,w,x,y,zのみ
PRINT PARSER("COMB(3.125,2.75)",U,V,W,X,Y,Z)
PRINT PARSER("PERM(5.375,3.125)",U,V,W,X,Y,Z)
END
EXTERNAL FUNCTION PARSER(EXPRESSION$,U,V,W,X,Y,Z)
OPTION CHARACTER BYTE
LET U$=PACKDBL$(U)
LET V$=PACKDBL$(V)
LET W$=PACKDBL$(W)
LET X$=PACKDBL$(X)
LET Y$=PACKDBL$(Y)
LET Z$=PACKDBL$(Z)
IF EXPRESSION$="" THEN
PRINT "ERROR"
STOP
END IF
LET PARSER=PARSER16(LCASE$(EXPRESSION$),U$,V$,W$,X$,Y$,Z$)
FUNCTION PARSER16(INPUT$,U$,V$,W$,X$,Y$,Z$)
ASSIGN ".\DLL\parser16_4.dll","parser16",FPU
END FUNCTION
END FUNCTION
OPTION BASE 0
DIM S(10)
PRINT PARSER("SIN(PI/3)","",1,S)
PRINT PARSER("SQRT(5)","",1,S)
PRINT PARSER("EXP(2*LOG(5))","",1,S)
PRINT PARSER("CBRT(2)","",1,S)
PRINT PARSER("LOG10(2)","",1,S)
FOR X=0 TO 180 STEP 15
LET S(0)=X
PRINT X;":";PARSER("SIN(X*PI/180)","X",1,S)
NEXT X
LET S(0)=4
LET S(1)=3
LET S(2)=-10
LET S(3)=6
LET S(4)=2
LET S(5)=10
LET S(6)=-5
LET S(7)=6
PRINT PARSER("3*A^3+2*B^2+C/5-D*3*E+F/G+H*3","A,B,C,D,E,F,G,H",8,S)
PRINT 3*S(0)^3+2*S(1)^2+S(2)/5-S(3)*3*S(4)+S(5)/S(6)+S(7)*3
INPUT T
LET XX=T
LET S$="(X*X-T)/(2*X)"
!LET S$="(X*X*X-T)/(3*X*X)"
DO
LET X=XX
LET S(0)=X
LET S(1)=T
LET XX=X-PARSER(S$,"X,T",2,S)
LOOP UNTIL ABS(XX-X)<1E-12
PRINT XX
END
EXTERNAL FUNCTION PARSER(INPUT$,PARA$,N,A())
OPTION CHARACTER BYTE
IF INPUT$="" OR N=0 THEN
PRINT "ERROR"
STOP
END IF
LET A$=REPEAT$(CHR$(0),8*N)
FOR I=0 TO N-1
LET A$(8*I+1:8*I+8)=PACKDBL$(A(I))
NEXT I
IF PARA$="" THEN LET PARA$="X"
LET PARSER=PARSER_(LCASE$(INPUT$),LCASE$(PARA$),A$)
FUNCTION PARSER_(INPUT$,PARA$,A$)
ASSIGN ".\DLL\parser.dll","parser16",FPU
END FUNCTION
END FUNCTION
OPTION CHARACTER BYTE
LET PARA$="X" ! Xで微分
DO
READ IF MISSING THEN EXIT DO:F$
DATA "4*X^4+3*X^3-2*X^2+X+1"
DATA "SIN(X)/X"
DATA "LOG(X)"
DATA "X^X"
DATA "SQRT(X)"
DATA "COS(X*SIN(3*X))"
DATA "X^2*EXP(X)"
DATA "COS(1/X)"
DATA "SINH(X)"
DATA "ATAN(X)"
CALL DIFF(F$,PARA$,DIFF$)
PRINT "f(x)=";F$
PRINT "f'(x)=";DIFF$
CALL DIFF(DIFF$,PARA$,DIFF2$)
PRINT "f''(x)=";DIFF2$
PRINT
LOOP
END
EXTERNAL SUB DIFF(INPUT$,PARA$,OUTPUT$)
OPTION CHARACTER BYTE
LET S$=REPEAT$(CHR$(0),5000) !バッファサイズ 5000文字分
CALL DIFF_(LCASE$(INPUT$),LCASE$(PARA$),S$)
FOR I=1 TO LEN(S$)
IF ORD(S$(I:I))<32 THEN EXIT FOR
NEXT I
LET OUTPUT$=S$(1:I-1)
SUB DIFF_(INPUT$,PARA$,OUTPUT$)
ASSIGN ".\DLL\parserdiff.dll","parserdiff"
END SUB
END SUB
INPUT U
LET XX=U
LET S$="X^2-U"
!LET S$="X^3-U"
!LET S$="X^4-U"
CALL DIFF(S$,"X",DIFF$)
LET F$="("&S$&")/("&DIFF$&")"
PRINT F$
DO
LET X=XX
LET XX=X-PARSER(F$,U,V,W,X,Y,Z)
LOOP UNTIL ABS(XX-X)<1E-12
PRINT XX;SQR(U)
END
EXTERNAL FUNCTION PARSER(INPUT$,U,V,W,X,Y,Z)
OPTION CHARACTER BYTE
LET U$=PACKDBL$(U)
LET V$=PACKDBL$(V)
LET W$=PACKDBL$(W)
LET X$=PACKDBL$(X)
LET Y$=PACKDBL$(Y)
LET Z$=PACKDBL$(Z)
IF INPUT$="" THEN
PRINT "ERROR"
STOP
END IF
LET PARSER=PARSER_(LCASE$(INPUT$),U$,V$,W$,X$,Y$,Z$)
FUNCTION PARSER_(INPUT$,U$,V$,W$,X$,Y$,Z$)
ASSIGN ".\DLL\parser2.dll","parser",FPU
END FUNCTION
END FUNCTION
EXTERNAL SUB DIFF(INPUT$,PARA$,OUTPUT$)
中略
END SUB
CALL GINIT(800,800)
SET WINDOW -5,5,-5,5
DRAW GRID(1,1)
SET LINE COLOR 2
FOR X=-5 TO 5 STEP 1/128
IF FP(X)<>0 OR X>0 THEN
LET Y=GAMMA(X)
PLOT LINES:X,Y;
ELSE
PLOT LINES
END IF
NEXT X
PAUSE
CLEAR
SET WINDOW 0,5,-1,5
DRAW GRID(1,1)
SET LINE COLOR 3
FOR X=1/128 TO 5 STEP 1/128
LET Y=GammaLib.LogGamma(X) ! 負数側が計算できない(X>0 のみ)
PLOT LINES:X,Y;
NEXT X
PAUSE
CLEAR
SET WINDOW -5,5,-5,5
DRAW GRID(1,1)
SET LINE COLOR 4
FOR X=-5 TO 5 STEP 1/128
IF FP(X)<>0 OR X>0 THEN
LET Y=1/GAMMA(X) ! 1/GAMMA(0)=1/GAMMA(-1)=1/GAMMA(-2)=ゼロ ???
PLOT LINES:X,Y;
ELSE
PLOT LINES
END IF
NEXT X
PAUSE
CLEAR
SET WINDOW -1,6,-1,20
DRAW GRID(1,1)
FOR N=1 TO 6 STEP 1/4
LET COL=COL+1
SET LINE COLOR COL
FOR K=0 TO N STEP 1/8
PLOT LINES:K,BINOM(N,K);
NEXT K
PLOT LINES
NEXT N
END
MODULE GammaLib
PUBLIC FUNCTION LogGamma
SHARE NUMERIC LOG_2PI
SHARE NUMERIC N,B0,B1,B2,B4,B6,B8,B10,B12,B14,B16
LET LOG_2PI=1.83787706640934548 !/* $\LOG 2\pi$ */
LET N = 8
LET B0 = 1 !/* 以下はBernoulli数 */
LET B1 = (-1.0 / 2.0)
LET B2 = ( 1.0 / 6.0)
LET B4 = (-1.0 / 30.0)
LET B6 = ( 1.0 / 42.0)
LET B8 = (-1.0 / 30.0)
LET B10 =( 5.0 / 66.0)
LET B12 =(-691.0 / 2730.0)
LET B14 =( 7.0 / 6.0)
LET B16 =(-3617.0 / 510.0)
EXTERNAL FUNCTION LogGamma(x) !/* ガンマ関数の対数 */
DECLARE NUMERIC v, w
LET v = 1
DO WHILE x < N
LET v = v * x
LET x = x+1
LOOP
LET w = 1 / (x * x)
LET LogGamma=((((((((B16 / (16 * 15)) * w + (B14 / (14 * 13))) * w &
& + (B12 / (12 * 11))) * w + (B10 / (10 * 9))) * w &
& + (B8 / ( 8 * 7))) * w + (B6 / ( 6 * 5))) * w &
& + (B4 / ( 4 * 3))) * w + (B2 / ( 2 * 1))) / x &
& + 0.5 * LOG_2PI - LOG(v) - x + (x - 0.5) * LOG(x)
END FUNCTION
END MODULE
EXTERNAL FUNCTION Gamma(x) !/* ガンマ関数 */
DECLARE EXTERNAL FUNCTION GammaLib.LogGamma
IF x < 0 THEN
LET Gamma= PI / (SIN(PI * x) * EXP(LogGamma(1 - x)))
ELSE
LET Gamma= EXP(LogGamma(x))
END IF
END FUNCTION
EXTERNAL FUNCTION Beta(x, y) !/* ベータ関数 */
DECLARE EXTERNAL FUNCTION GammaLib.LogGamma
LET Beta= EXP(loggamma(x) + loggamma(y) - loggamma(x + y))
END FUNCTION
EXTERNAL FUNCTION BINOM(N,K) !'二項係数 COMB(N,K)
LET BINOM=GAMMA(N+1)/GAMMA(N-K+1)/GAMMA(K+1)
END FUNCTION
!EXTERNAL FUNCTION BINOM(N,K) !'二項係数 COMB(N,K)
!LET BINOM=1/(N+1)/BETA(N-K+1,K+1)
!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 -5,5,-5,5
DRAW GRID(1,1)
SET LINE COLOR 3
FOR X=-5 TO 5 STEP 1/128
IF FP(X)<>0 OR X>0 THEN
LET Y=LogGamma(X)
PLOT LINES:X,Y;
ELSE
PLOT LINES
END IF
NEXT X
PAUSE
CLEAR
SET WINDOW -5,5,-5,5
DRAW GRID(1,1)
SET LINE COLOR 4
FOR X=-5 TO 5 STEP 1/128
IF FP(X)<>0 OR X>0 THEN
LET Y=DIGAMMA(X)
PLOT LINES:X,Y;
ELSE
PLOT LINES
END IF
NEXT X
PAUSE
CLEAR
SET WINDOW -5,5,-5,5
DRAW GRID(1,1)
SET LINE COLOR 5
FOR X=-5 TO 5 STEP 1/128
IF FP(X)<>0 OR X>0 THEN
LET Y=GAMMA(X)*DIGAMMA(X) !' ガンマ関数の微分
PLOT LINES:X,Y;
ELSE
PLOT LINES
END IF
NEXT X
そして、モジュールGammaLibを下記と修正してください。、
IF X < 0 THEN から END IFまでの4行(赤色)を加筆しています。
ディガンマ関数も付け足して下さい。
MODULE GammaLib
PUBLIC FUNCTION LogGamma
SHARE NUMERIC LOG_2PI
SHARE NUMERIC N,B0,B1,B2,B4,B6,B8,B10,B12,B14,B16
LET LOG_2PI=1.83787706640934548 !/* $\LOG 2\pi$ */
LET N = 8
LET B0 = 1 !/* 以下はBernoulli数 */
LET B1 = (-1.0 / 2.0)
LET B2 = ( 1.0 / 6.0)
LET B4 = (-1.0 / 30.0)
LET B6 = ( 1.0 / 42.0)
LET B8 = (-1.0 / 30.0)
LET B10 =( 5.0 / 66.0)
LET B12 =(-691.0 / 2730.0)
LET B14 =( 7.0 / 6.0)
LET B16 =(-3617.0 / 510.0)
EXTERNAL FUNCTION LogGamma(x) !/* ガンマ関数の対数 */
DECLARE NUMERIC v, w
IF X < 0 THEN
LET LogGamma=LOG(ABS(PI/SIN(PI*x)))-LogGamma(1-x)
EXIT FUNCTION
END IF
LET v = 1
DO WHILE x < N
LET v = v * x
LET x = x+1
LOOP
LET w = 1 / (x * x)
LET LogGamma=((((((((B16 / (16 * 15)) * w + (B14 / (14 * 13))) * w &
& + (B12 / (12 * 11))) * w + (B10 / (10 * 9))) * w &
& + (B8 / ( 8 * 7))) * w + (B6 / ( 6 * 5))) * w &
& + (B4 / ( 4 * 3))) * w + (B2 / ( 2 * 1))) / x &
& + 0.5 * LOG_2PI - LOG(v) - x + (x - 0.5) * LOG(x)
END FUNCTION
END MODULE
EXTERNAL FUNCTION DIGAMMA(X)
IF X<0 THEN
LET DIGAMMA=DIGAMMA(1-X)-PI/TAN(PI*X)
EXIT FUNCTION
END IF
LET EULER=0.577215664901532860606512
FOR N=0 TO 1000
LET S=S-(1/(X+N)-1/(N+1))
NEXT N
LET DIGAMMA=S-EULER
END FUNCTION
EXTERNAL SUB MOVETEXTWINDOW(A$,X,Y)
SUB SETWINDOWPOS(HWND,HWNDINSAFTER,X,Y,CX,CY,NFLAGS)
ASSIGN "user32.dll","SetWindowPos"
END SUB
CALL SETWINDOWPOS(WINHANDLE(A$),0,X,Y,0,0,1)
END SUB
EXTERNAL SUB RESIZETEXTWINDOW(A$,X,Y)
SUB SETWINDOWPOS(HWND,HWNDINSAFTER,X,Y,CX,CY,NFLAGS) !nFLG: 0=x0,y0,xw,yw 1=x0,y0 2=xw,yw
ASSIGN "user32.dll","SetWindowPos"
END SUB
CALL SETWINDOWPOS(WINHANDLE(A$),0,0,0,X,Y,2)
END SUB
EXTERNAL FUNCTION FUNC(X)
LET FUNC=1/X
END FUNCTION
EXTERNAL FUNCTION INTEGRAL(A,B,N) !'リーマン和
LET H=(B-A)/(N+1)
FOR J=0 TO N
LET S=S+H*FUNC(A+H*J)
NEXT J
LET INTEGRAL=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL2(A,B,N) !'台形則
DIM R(0 TO 1)
LET R(0)=1/2
LET R(1)=1/2
LET H=(B-A)/N
FOR K=0 TO N-1
FOR J=0 TO 1
LET S=S+R(J)*H*FUNC(A+H*(K+J))
NEXT J
NEXT K
LET INTEGRAL2=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL3(A,B,N) !'シンプソン則
DIM R(0 TO 2)
LET R(0)=1/3
LET R(1)=4/3
LET R(2)=1/3
LET H=(B-A)/N/2
FOR K=0 TO N-1
FOR J=0 TO 2
LET S=S+R(J)*H*FUNC(A+H*(2*K+J))
NEXT J
NEXT K
LET INTEGRAL3=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL4(A,B,N)
DIM R(0 TO 3)
LET R(0)=3/8
LET R(1)=9/8
LET R(2)=9/8
LET R(3)=3/8
LET H=(B-A)/N/3
FOR K=0 TO N-1
FOR J=0 TO 3
LET S=S+R(J)*H*FUNC(A+H*(3*K+J))
NEXT J
NEXT K
LET INTEGRAL4=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL5(A,B,N)
DIM R(0 TO 4)
LET R(0)=14/45
LET R(1)=64/45
LET R(2)=8/15
LET R(3)=64/45
LET R(4)=14/45
LET H=(B-A)/N/4
FOR K=0 TO N-1
FOR J=0 TO 4
LET S=S+R(J)*H*FUNC(A+H*(4*K+J))
NEXT J
NEXT K
LET INTEGRAL5=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL6(A,B,N)
DIM R(0 TO 5)
LET R(0)=95/288
LET R(1)=125/96
LET R(2)=125/144
LET R(3)=125/144
LET R(4)=125/96
LET R(5)=95/288
LET H=(B-A)/N/5
FOR K=0 TO N-1
FOR J=0 TO 5
LET S=S+R(J)*H*FUNC(A+H*(5*K+J))
NEXT J
NEXT K
LET INTEGRAL6=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL7(A,B,N)
DIM R(0 TO 6)
LET R(0)=41/140
LET R(1)=54/35
LET R(2)=27/140
LET R(3)=68/35
LET R(4)=27/140
LET R(5)=54/35
LET R(6)=41/140
LET H=(B-A)/N/6
FOR K=0 TO N-1
FOR J=0 TO 6
LET S=S+R(J)*H*FUNC(A+H*(6*K+J))
NEXT J
NEXT K
LET INTEGRAL7=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL8(A,B,N)
DIM R(0 TO 7)
LET R(0)=5257/17280
LET R(1)=25039/17280
LET R(2)=343/640
LET R(3)=20923/17280
LET R(4)=20923/17280
LET R(5)=343/640
LET R(6)=25039/17280
LET R(7)=5257/17280
LET H=(B-A)/N/7
FOR K=0 TO N-1
FOR J=0 TO 7
LET S=S+R(J)*H*FUNC(A+H*(7*K+J))
NEXT J
NEXT K
LET INTEGRAL8=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL9(A,B,N)
DIM R(0 TO 8)
LET R(0)=3956/14175
LET R(1)=23552/14175
LET R(2)=-3712/14175
LET R(3)=41984/14175
LET R(4)=-3632/2835
LET R(5)=41984/14175
LET R(6)=-3712/14175
LET R(7)=23552/14175
LET R(8)=3956/14175
LET H=(B-A)/N/8
FOR K=0 TO N-1
FOR J=0 TO 8
LET S=S+R(J)*H*FUNC(A+H*(8*K+J))
NEXT J
NEXT K
LET INTEGRAL9=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL10(A,B,N)
DIM R(0 TO 9)
LET R(0)=25713/89600
LET R(1)=141669/89600
LET R(2)=243/2240
LET R(3)=10881/5600
LET R(4)=26001/44800
LET R(5)=26001/44800
LET R(6)=10881/5600
LET R(7)=243/2240
LET R(8)=141669/89600
LET R(9)=25713/89600
LET H=(B-A)/N/9
FOR K=0 TO N-1
FOR J=0 TO 9
LET S=S+R(J)*H*FUNC(A+H*(9*K+J))
NEXT J
NEXT K
LET INTEGRAL10=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL11(A,B,N)
DIM R(0 TO 10)
LET R(0)=80335/299376
LET R(1)=132875/74844
LET R(2)=-80875/99792
LET R(3)=28375/6237
LET R(4)=-24125/5544
LET R(5)=89035/12474
LET R(6)=-24125/5544
LET R(7)=28375/6237
LET R(8)=-80875/99792
LET R(9)=132875/74844
LET R(10)=80335/299376
LET H=(B-A)/N/10
FOR K=0 TO N-1
FOR J=0 TO 10
LET S=S+R(J)*H*FUNC(A+H*(10*K+J))
NEXT J
NEXT K
LET INTEGRAL11=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL12(A,B,N)
DIM R(0 TO 11)
LET R(0)=4777223/17418240
LET R(1)=49450643/29030400
LET R(2)=-35608243/87091200
LET R(3)=6166523/1935360
LET R(4)=-17591827/14515200
LET R(5)=28404871/14515200
LET R(6)=28404871/14515200
LET R(7)=-17591827/14515200
LET R(8)=6166523/1935360
LET R(9)=-35608243/87091200
LET R(10)=49450643/29030400
LET R(11)=4777223/17418240
LET H=(B-A)/N/11
FOR K=0 TO N-1
FOR J=0 TO 11
LET S=S+R(J)*H*FUNC(A+H*(11*K+J))
NEXT J
NEXT K
LET INTEGRAL12=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL13(A,B,N)
DIM R(0 TO 12)
LET R(0)=1364651/5255250
LET R(1)=150048/79625
LET R(2)=-1264644/875875
LET R(3)=3572512/525525
LET R(4)=-3432753/350350
LET R(5)=14586048/875875
LET R(6)=-2090408/125125
LET R(7)=14586048/875875
LET R(8)=-3432753/350350
LET R(9)=3572512/525525
LET R(10)=-1264644/875875
LET R(11)=150048/79625
LET R(12)=1364651/5255250
LET H=(B-A)/N/12
FOR K=0 TO N-1
FOR J=0 TO 12
LET S=S+R(J)*H*FUNC(A+H*(12*K+J))
NEXT J
NEXT K
LET INTEGRAL13=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL14(A,B,N)
DIM R(0 TO 13)
LET R(0)=106364763817/402361344000
LET R(1)=731649485593/402361344000
LET R(2)=-22582626859/22353408000
LET R(3)=144926245243/28740096000
LET R(4)=-78862978129/16094453760
LET R(5)=298542743759/44706816000
LET R(6)=-46704658663/33530112000
LET R(7)=-46704658663/33530112000
LET R(8)=298542743759/44706816000
LET R(9)=-78862978129/16094453760
LET R(10)=144926245243/28740096000
LET R(11)=-22582626859/22353408000
LET R(12)=731649485593/402361344000
LET R(13)=106364763817/402361344000
LET H=(B-A)/N/13
FOR K=0 TO N-1
FOR J=0 TO 13
LET S=S+R(J)*H*FUNC(A+H*(13*K+J))
NEXT J
NEXT K
LET INTEGRAL14=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL15(A,B,N)
DIM R(0 TO 14)
LET R(0)=631693279/2501928000
LET R(1)=311056753/156370500
LET R(2)=-5395044599/2501928000
LET R(3)=765940609/78185250
LET R(4)=-46375653541/2501928000
LET R(5)=5525678207/156370500
LET R(6)=-39205297537/833976000
LET R(7)=712193069/13030875
LET R(8)=-39205297537/833976000
LET R(9)=5525678207/156370500
LET R(10)=-46375653541/2501928000
LET R(11)=765940609/78185250
LET R(12)=-5395044599/2501928000
LET R(13)=311056753/156370500
LET R(14)=631693279/2501928000
LET H=(B-A)/N/14
FOR K=0 TO N-1
FOR J=0 TO 14
LET S=S+R(J)*H*FUNC(A+H*(14*K+J))
NEXT J
NEXT K
LET INTEGRAL15=S
END FUNCTION
EXTERNAL FUNCTION DE(A,B,N) !'二重指数関数法(DE法)
LET U=(B-A)/2
LET V=(B+A)/2
LET H=(B-A)/N
FOR K=-4 TO 4 STEP H
LET X=Q(K)
LET S=S+H*FUNC(U*X+V)*U*QQ(K)
NEXT K
LET DE=S
FUNCTION Q(X)
LET Q=TANH(PI/2*SINH(X))
END FUNCTION
FUNCTION QQ(X)
LET QQ=PI/2*COSH(X)/COSH(PI/2*SINH(X))^2
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION LEGENDRE(A,B) !'ガウス・ルジャンドル則(80次)
LET U=(B+A)/2
LET V=(B-A)/2
FOR I=1 TO 80
READ X,W
LET S=S+W*FUNC(U+V*X)*V
NEXT I
LET LEGENDRE=S
DATA -.9995538226516306298800805,1.1449500031869415345441719E-03
DATA -.9976498643982376888994942,2.6635335895126816692935358E-03
DATA -.9942275409656882778920635,4.1803131246948952367393042E-03
DATA -.9892913024997555310265032,5.6909224514031986492691071E-03
DATA -.9828485727386290704182880,7.1929047681173127526755709E-03
DATA -.9749091405857277933856452,8.6839452692608584264094522E-03
DATA -.9654850890437992514522732,1.0161766041103064520831850E-02
DATA -.9545907663436349054934815,1.1624114120797826916466770E-02
DATA -.9422427613098726747522660,1.3068761592401339293786826E-02
DATA -.9284598771724457959530460,1.4493508040509076116962075E-02
DATA -.9132631025717576541647337,1.5896183583725688044902909E-02
DATA -.8966755794387706831943241,1.7274652056269306358584207E-02
DATA -.8787225676782138287037733,1.8626814208299031428735414E-02
DATA -.8594314066631110969771921,1.9950610878141998928891929E-02
DATA -.8388314735802552756166230,2.1244026115782006388710737E-02
DATA -.8169541386814634703711250,2.2505090246332461926221590E-02
DATA -.7938327175046054499486393,2.3731882865930101293192525E-02
DATA -.7695024201350413738656161,2.4922535764115491105117847E-02
DATA -.7440002975835972723165405,2.6075235767565117902968744E-02
DATA -.7173651853620998802540683,2.7188227500486380674418707E-02
DATA -.6896376443420276007712076,2.8259816057276862396753198E-02
DATA -.6608598989861198017359671,2.9288369583267847692767586E-02
DATA -.6310757730468719662479284,3.0272321759557980661220010E-02
DATA -.6003306228297517431547463,3.1210174188114701642442867E-02
DATA -.5686712681227097847254858,3.2100498673487773148056490E-02
DATA -.5361459208971319320198573,3.2941939397645401382836181E-02
DATA -.5028041118887849875936728,3.3733214984611522816675163E-02
DATA -.4686966151705444770360784,3.4473120451753928794364227E-02
DATA -.4338753708317560930623867,3.5160529044747593495526592E-02
DATA -.3983934058819692270243796,3.5794393953416054602861589E-02
DATA -.3623047534994873156190433,3.6373749905835978043964991E-02
DATA -.3256643707477019146191129,3.6897714638276008839150997E-02
DATA -.2885280548845118531091393,3.7365490238730490026705377E-02
DATA -.2509523583922721204931588,3.7776364362001397489774976E-02
DATA -.2129945028576661325723885,3.8129711314477638344206792E-02
DATA -.1747122918326468125593390,3.8424993006959423185212436E-02
DATA -.1361640228091438865592411,3.8661759774076463327077110E-02
DATA -.0974083984415845990632785,3.8839651059051968931774183E-02
DATA -.0585044371524206686289933,3.8958395962769531198625525E-02
DATA -.0195113832567939976543512,3.9017813656306654811280439E-02
DATA .0195113832567939976543512,3.9017813656306654811280439E-02
DATA .0585044371524206686289933,3.8958395962769531198625525E-02
DATA .0974083984415845990632785,3.8839651059051968931774183E-02
DATA .1361640228091438865592411,3.8661759774076463327077110E-02
DATA .1747122918326468125593390,3.8424993006959423185212436E-02
DATA .2129945028576661325723885,3.8129711314477638344206792E-02
DATA .2509523583922721204931588,3.7776364362001397489774976E-02
DATA .2885280548845118531091393,3.7365490238730490026705377E-02
DATA .3256643707477019146191129,3.6897714638276008839150997E-02
DATA .3623047534994873156190433,3.6373749905835978043964991E-02
DATA .3983934058819692270243796,3.5794393953416054602861589E-02
DATA .4338753708317560930623867,3.5160529044747593495526592E-02
DATA .4686966151705444770360784,3.4473120451753928794364227E-02
DATA .5028041118887849875936728,3.3733214984611522816675163E-02
DATA .5361459208971319320198573,3.2941939397645401382836181E-02
DATA .5686712681227097847254858,3.2100498673487773148056490E-02
DATA .6003306228297517431547463,3.1210174188114701642442867E-02
DATA .6310757730468719662479284,3.0272321759557980661220010E-02
DATA .6608598989861198017359671,2.9288369583267847692767586E-02
DATA .6896376443420276007712076,2.8259816057276862396753198E-02
DATA .7173651853620998802540683,2.7188227500486380674418707E-02
DATA .7440002975835972723165405,2.6075235767565117902968744E-02
DATA .7695024201350413738656161,2.4922535764115491105117847E-02
DATA .7938327175046054499486393,2.3731882865930101293192525E-02
DATA .8169541386814634703711250,2.2505090246332461926221590E-02
DATA .8388314735802552756166230,2.1244026115782006388710737E-02
DATA .8594314066631110969771921,1.9950610878141998928891929E-02
DATA .8787225676782138287037733,1.8626814208299031428735414E-02
DATA .8966755794387706831943241,1.7274652056269306358584207E-02
DATA .9132631025717576541647337,1.5896183583725688044902909E-02
DATA .9284598771724457959530460,1.4493508040509076116962075E-02
DATA .9422427613098726747522660,1.3068761592401339293786826E-02
DATA .9545907663436349054934815,1.1624114120797826916466770E-02
DATA .9654850890437992514522732,1.0161766041103064520831850E-02
DATA .9749091405857277933856452,8.6839452692608584264094522E-03
DATA .9828485727386290704182880,7.1929047681173127526755709E-03
DATA .9892913024997555310265032,5.6909224514031986492691071E-03
DATA .9942275409656882778920635,4.1803131246948952367393042E-03
DATA .9976498643982376888994942,2.6635335895126816692935358E-03
DATA .9995538226516306298800805,1.1449500031869415345441719E-03
END FUNCTION
EXTERNAL FUNCTION CLENSHAW(A,B) !'クレンショ・カーティス則(51次)
LET U=(B+A)/2
LET V=(B-A)/2
FOR I=1 TO 51
READ X,W
LET S=S+W*FUNC(U+V*X)*V
NEXT I
LET CLENSHAW=S
DATA 1.00000000000000000e+00 , 4.00160064025610244e-04
DATA 9.98026728428271562e-01 , 3.85156958477016962e-03
DATA 9.92114701314477831e-01 , 7.90787777387773065e-03
DATA 9.82287250728688681e-01 , 1.17571702393763373e-02
DATA 9.68583161128631119e-01 , 1.56353432816211783e-02
DATA 9.51056516295153572e-01 , 1.94096870342574738e-02
DATA 9.29776485888251404e-01 , 2.31345330553685722e-02
DATA 9.04827052466019528e-01 , 2.67490465016775492e-02
DATA 8.76306680043863587e-01 , 3.02721896767790866e-02
DATA 8.44327925502015079e-01 , 3.36647886957266792e-02
DATA 8.09016994374947424e-01 , 3.69334712479578906e-02
DATA 7.70513242775789231e-01 , 4.00489673231533687e-02
DATA 7.28968627421411523e-01 , 4.30127205858580039e-02
DATA 6.84547105928688674e-01 , 4.58012512695708427e-02
DATA 6.37423989748689710e-01 , 4.84138485266917921e-02
DATA 5.87785252292473129e-01 , 5.08310623057877259e-02
DATA 5.35826794978996618e-01 , 5.30515834900600101e-02
DATA 4.81753674101715275e-01 , 5.50591409946138935e-02
DATA 4.25779291565072649e-01 , 5.68527406895258182e-02
DATA 3.68124552684677959e-01 , 5.84188403643660493e-02
DATA 3.09016994374947424e-01 , 5.97573499442651138e-02
DATA 2.48689887164854788e-01 , 6.08571934325762743e-02
DATA 1.87381314585724631e-01 , 6.17195908592974985e-02
DATA 1.25333233564304245e-01 , 6.23357554958117397e-02
DATA 6.27905195293133761e-02 , 6.27085107726588897e-02
DATA -1.66091007405623902e-130 , 6.28312135806494038e-02
DATA -6.27905195293133761e-02 , 6.27085107726588897e-02
DATA -1.25333233564304245e-01 , 6.23357554958117397e-02
DATA -1.87381314585724631e-01 , 6.17195908592974985e-02
DATA -2.48689887164854788e-01 , 6.08571934325762743e-02
DATA -3.09016994374947424e-01 , 5.97573499442651138e-02
DATA -3.68124552684677959e-01 , 5.84188403643660493e-02
DATA -4.25779291565072649e-01 , 5.68527406895258182e-02
DATA -4.81753674101715275e-01 , 5.50591409946138935e-02
DATA -5.35826794978996618e-01 , 5.30515834900600101e-02
DATA -5.87785252292473129e-01 , 5.08310623057877259e-02
DATA -6.37423989748689710e-01 , 4.84138485266917921e-02
DATA -6.84547105928688674e-01 , 4.58012512695708427e-02
DATA -7.28968627421411523e-01 , 4.30127205858580039e-02
DATA -7.70513242775789231e-01 , 4.00489673231533687e-02
DATA -8.09016994374947424e-01 , 3.69334712479578906e-02
DATA -8.44327925502015079e-01 , 3.36647886957266792e-02
DATA -8.76306680043863587e-01 , 3.02721896767790866e-02
DATA -9.04827052466019528e-01 , 2.67490465016775492e-02
DATA -9.29776485888251404e-01 , 2.31345330553685722e-02
DATA -9.51056516295153572e-01 , 1.94096870342574738e-02
DATA -9.68583161128631119e-01 , 1.56353432816211783e-02
DATA -9.82287250728688681e-01 , 1.17571702393763373e-02
DATA -9.92114701314477831e-01 , 7.90787777387773065e-03
DATA -9.98026728428271562e-01 , 3.85156958477016962e-03
DATA -1.00000000000000000e+00 , 4.00160064025610244e-04
END FUNCTION
DECLARE EXTERNAL FUNCTION LEGENDRE,HERMITE,DE
PRINT INTEGRAL(8192)
PRINT INTEGRAL2(1024)
PRINT INTEGRAL3(1024)
PRINT LEGENDRE
PRINT HERMITE
PRINT DE
PRINT "----------------------"
PRINT SQR(PI) !'真値
END
EXTERNAL FUNCTION FUNC(X)
LET FUNC=EXP(-X*X)
END FUNCTION
EXTERNAL FUNCTION INTEGRAL(N) !'リーマン和
LET A=0
LET B=1
LET H=(B-A)/(N+1)
FOR J=0 TO N
LET T=A+H*J
IF T<>0 THEN LET S=S+H*(FUNC((1-T)/T)+FUNC(-(1-T)/T))/T/T
NEXT J
LET INTEGRAL=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL2(N) !'台形則
DIM R(0 TO 1)
LET A=0
LET B=1
LET R(0)=1/2
LET R(1)=1/2
LET H=(B-A)/N
FOR K=0 TO N-1
FOR J=0 TO 1
LET T=A+H*(K+J)
IF T<>0 THEN
LET S=S+H*R(J)*(FUNC((1-T)/T)+FUNC(-(1-T)/T))/T/T
END IF
NEXT J
NEXT K
LET INTEGRAL2=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL3(N) !'シンプソン則
DIM R(0 TO 2)
LET A=0
LET B=1
LET R(0)=1/3
LET R(1)=4/3
LET R(2)=1/3
LET H=(B-A)/N/2
FOR K=0 TO N-1
FOR J=0 TO 2
LET T=A+H*(2*K+J)
IF T<>0 THEN
LET S=S+H*R(J)*(FUNC((1-T)/T)+FUNC(-(1-T)/T))/T/T
END IF
NEXT J
NEXT K
LET INTEGRAL3=S
END FUNCTION
EXTERNAL FUNCTION DE !'二重指数関数法(DE法)
LET H=1/1024
FOR T=-4 TO 4 STEP H
LET S=S+H*FUNC(Q(T))*QQ(T)
NEXT T
LET DE=S
FUNCTION Q(X)
LET Q=SINH(PI/2*SINH(X))
END FUNCTION
FUNCTION QQ(X)
LET QQ=PI/2*COSH(X)*COSH(PI/2*SINH(X))
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION LEGENDRE !'ガウス・ルジャンドル則(100次)
LET A=0
LET B=1
LET U=(B+A)/2
LET V=(B-A)/2
FOR I=1 TO 100
READ X,W
LET T=U+V*X
LET S=S+W*(FUNC((1-T)/T)+FUNC(-(1-T)/T))/T/T*V
NEXT I
LET LEGENDRE=S
DATA -.9997137267734412336782285,7.3463449050567173040632066E-04
DATA -.9984919506395958184001634,1.7093926535181052395293584E-03
DATA -.9962951347331251491861317,2.6839253715534824194395904E-03
DATA -.9931249370374434596520099,3.6559612013263751823424587E-03
DATA -.9889843952429917480044187,4.6244500634221193510957891E-03
DATA -.9838775407060570154961002,5.5884280038655151572119463E-03
DATA -.9778093584869182885537811,6.5469484508453227641521033E-03
DATA -.9707857757637063319308979,7.4990732554647115788287440E-03
DATA -.9628136542558155272936593,8.4438714696689714026208349E-03
DATA -.9539007829254917428493369,9.3804196536944579514182377E-03
DATA -.9440558701362559779627747,1.0307802574868969585782102E-02
DATA -.9332885350430795459243337,1.1225114023185977117221573E-02
DATA -.9216092981453339526669513,1.2131457662979497407744792E-02
DATA -.9090295709825296904671263,1.3025947892971542285558584E-02
DATA -.8955616449707269866985210,1.3907710703718772687954149E-02
DATA -.8812186793850184155733168,1.4775884527441301768879988E-02
DATA -.8660146884971646234107400,1.5629621077546002723936866E-02
DATA -.8499645278795912842933626,1.6468086176145212643104980E-02
DATA -.8330838798884008235429158,1.7290460568323582439344198E-02
DATA -.8153892383391762543939888,1.8095940722128116664390751E-02
DATA -.7968978923903144763895729,1.8883739613374904552941166E-02
DATA -.7776279096494954756275514,1.9653087494435305865381470E-02
DATA -.7575981185197071760356680,2.0403232646209432766838852E-02
DATA -.7368280898020207055124277,2.1133442112527641542672300E-02
DATA -.7153381175730564464599671,2.1843002416247386313953741E-02
DATA -.6931491993558019659486479,2.2531220256336272701796971E-02
DATA -.6702830156031410158025870,2.3197423185254121622488854E-02
DATA -.6467619085141292798326303,2.3840960265968205962560412E-02
DATA -.6226088602037077716041908,2.4461202707957052719975023E-02
DATA -.5978474702471787212648065,2.5057544481579589703764226E-02
DATA -.5725019326213811913168704,2.5629402910208116075642010E-02
DATA -.5465970120650941674679943,2.6176219239545676342308742E-02
DATA -.5201580198817630566468157,2.6697459183570962660384664E-02
DATA -.4932107892081909335693088,2.7192613446576880136491568E-02
DATA -.4657816497733580422492166,2.7661198220792388294204156E-02
DATA -.4378974021720315131089780,2.8102755659101173317648330E-02
DATA -.4095852916783015425288684,2.8516854322395097990936763E-02
DATA -.3808729816246299567633625,2.8903089601125203134876228E-02
DATA -.3517885263724217209723438,2.9261084110638276620119023E-02
DATA -.3223603439005291517224766,2.9590488059912642511754511E-02
DATA -.2926171880384719647375559,2.9890979593332830916836807E-02
DATA -.2625881203715034791689293,3.0162265105169144919068682E-02
DATA -.2323024818449739696495100,3.0404079526454820016507860E-02
DATA -.2017898640957359972360489,3.0616186583980448496459443E-02
DATA -.1710800805386032748875324,3.0798379031152590427713903E-02
DATA -.1402031372361139732075146,3.0950478850490988234063463E-02
DATA -.1091892035800611150034260,3.1072337427566516587810170E-02
DATA -.0780685828134366366948174,3.1163835696209906783818321E-02
DATA -.0468716824215916316149239,3.1224884254849357732376499E-02
DATA -.0156289844215430828722167,3.1255423453863356947642474E-02
DATA .0156289844215430828722167,3.1255423453863356947642474E-02
DATA .0468716824215916316149239,3.1224884254849357732376499E-02
DATA .0780685828134366366948174,3.1163835696209906783818321E-02
DATA .1091892035800611150034260,3.1072337427566516587810170E-02
DATA .1402031372361139732075146,3.0950478850490988234063463E-02
DATA .1710800805386032748875324,3.0798379031152590427713903E-02
DATA .2017898640957359972360489,3.0616186583980448496459443E-02
DATA .2323024818449739696495100,3.0404079526454820016507860E-02
DATA .2625881203715034791689293,3.0162265105169144919068682E-02
DATA .2926171880384719647375559,2.9890979593332830916836807E-02
DATA .3223603439005291517224766,2.9590488059912642511754511E-02
DATA .3517885263724217209723438,2.9261084110638276620119023E-02
DATA .3808729816246299567633625,2.8903089601125203134876228E-02
DATA .4095852916783015425288684,2.8516854322395097990936763E-02
DATA .4378974021720315131089780,2.8102755659101173317648330E-02
DATA .4657816497733580422492166,2.7661198220792388294204156E-02
DATA .4932107892081909335693088,2.7192613446576880136491568E-02
DATA .5201580198817630566468157,2.6697459183570962660384664E-02
DATA .5465970120650941674679943,2.6176219239545676342308742E-02
DATA .5725019326213811913168704,2.5629402910208116075642010E-02
DATA .5978474702471787212648065,2.5057544481579589703764226E-02
DATA .6226088602037077716041908,2.4461202707957052719975023E-02
DATA .6467619085141292798326303,2.3840960265968205962560412E-02
DATA .6702830156031410158025870,2.3197423185254121622488854E-02
DATA .6931491993558019659486479,2.2531220256336272701796971E-02
DATA .7153381175730564464599671,2.1843002416247386313953741E-02
DATA .7368280898020207055124277,2.1133442112527641542672300E-02
DATA .7575981185197071760356680,2.0403232646209432766838852E-02
DATA .7776279096494954756275514,1.9653087494435305865381470E-02
DATA .7968978923903144763895729,1.8883739613374904552941166E-02
DATA .8153892383391762543939888,1.8095940722128116664390751E-02
DATA .8330838798884008235429158,1.7290460568323582439344198E-02
DATA .8499645278795912842933626,1.6468086176145212643104980E-02
DATA .8660146884971646234107400,1.5629621077546002723936866E-02
DATA .8812186793850184155733168,1.4775884527441301768879988E-02
DATA .8955616449707269866985210,1.3907710703718772687954149E-02
DATA .9090295709825296904671263,1.3025947892971542285558584E-02
DATA .9216092981453339526669513,1.2131457662979497407744792E-02
DATA .9332885350430795459243337,1.1225114023185977117221573E-02
DATA .9440558701362559779627747,1.0307802574868969585782102E-02
DATA .9539007829254917428493369,9.3804196536944579514182377E-03
DATA .9628136542558155272936593,8.4438714696689714026208349E-03
DATA .9707857757637063319308979,7.4990732554647115788287440E-03
DATA .9778093584869182885537811,6.5469484508453227641521033E-03
DATA .9838775407060570154961002,5.5884280038655151572119463E-03
DATA .9889843952429917480044187,4.6244500634221193510957891E-03
DATA .9931249370374434596520099,3.6559612013263751823424587E-03
DATA .9962951347331251491861317,2.6839253715534824194395904E-03
DATA .9984919506395958184001634,1.7093926535181052395293584E-03
DATA .9997137267734412336782285,7.3463449050567173040632066E-04
END FUNCTION
EXTERNAL FUNCTION HERMITE !'ガウス・エルミート則(50次)
FOR I=1 TO 50
READ X,W
LET S=S+FUNC(X)*W
NEXT I
LET HERMITE=S
DATA -9.18240695812931737e+00 , 7.61348691118076750e-01
DATA -8.52277103091780419e+00 , 5.88605297377289840e-01
DATA -7.97562236820563655e+00 , 5.13304797851540890e-01
DATA -7.48640942986419427e+00 , 4.68326211942547493e-01
DATA -7.03432350977061065e+00 , 4.37553282300047560e-01
DATA -6.60864797385535901e+00 , 4.14838821059022497e-01
DATA -6.20295251927467162e+00 , 3.97244943775846315e-01
DATA -5.81299467542040606e+00 , 3.83161392196479355e-01
DATA -5.43578608722494814e+00 , 3.71619771249915029e-01
DATA -5.06911758491723503e+00 , 3.61997265091617451e-01
DATA -4.71129366616904279e+00 , 3.53872469979461721e-01
DATA -4.36097316045457866e+00 , 3.46948769599378382e-01
DATA -4.01706817285813439e+00 , 3.41010727258747851e-01
DATA -3.67867706251526928e+00 , 3.35897876837685552e-01
DATA -3.34503831393789109e+00 , 3.31488254247521860e-01
DATA -3.01549776957452242e+00 , 3.27687661354606420e-01
DATA -2.68948470226774507e+00 , 3.24422448708866827e-01
DATA -2.36649390429866383e+00 , 3.21634537962055980e-01
DATA -2.04607196868640921e+00 , 3.19277915993180742e-01
DATA -1.72780654751589856e+00 , 3.17316124349604326e-01
DATA -1.41131775489830006e+00 , 3.15720440230093699e-01
DATA -1.09625112895768164e+00 , 3.14468550882471922e-01
DATA -7.82271729554606886e-01 , 3.13543589989641611e-01
DATA -4.69059056678236086e-01 , 3.12933448052389891e-01
DATA -1.56302546889468676e-01 , 3.12630298030359123e-01
DATA 1.56302546889468676e-01 , 3.12630298030359123e-01
DATA 4.69059056678236086e-01 , 3.12933448052389891e-01
DATA 7.82271729554606886e-01 , 3.13543589989641611e-01
DATA 1.09625112895768164e+00 , 3.14468550882471922e-01
DATA 1.41131775489830006e+00 , 3.15720440230093699e-01
DATA 1.72780654751589856e+00 , 3.17316124349604326e-01
DATA 2.04607196868640921e+00 , 3.19277915993180742e-01
DATA 2.36649390429866383e+00 , 3.21634537962055980e-01
DATA 2.68948470226774507e+00 , 3.24422448708866827e-01
DATA 3.01549776957452242e+00 , 3.27687661354606420e-01
DATA 3.34503831393789109e+00 , 3.31488254247521860e-01
DATA 3.67867706251526928e+00 , 3.35897876837685552e-01
DATA 4.01706817285813439e+00 , 3.41010727258747851e-01
DATA 4.36097316045457866e+00 , 3.46948769599378382e-01
DATA 4.71129366616904279e+00 , 3.53872469979461721e-01
DATA 5.06911758491723503e+00 , 3.61997265091617451e-01
DATA 5.43578608722494814e+00 , 3.71619771249915029e-01
DATA 5.81299467542040606e+00 , 3.83161392196479355e-01
DATA 6.20295251927467162e+00 , 3.97244943775846315e-01
DATA 6.60864797385535901e+00 , 4.14838821059022497e-01
DATA 7.03432350977061065e+00 , 4.37553282300047560e-01
DATA 7.48640942986419427e+00 , 4.68326211942547493e-01
DATA 7.97562236820563655e+00 , 5.13304797851540890e-01
DATA 8.52277103091780419e+00 , 5.88605297377289840e-01
DATA 9.18240695812931737e+00 , 7.61348691118076750e-01
END FUNCTION
DECLARE EXTERNAL FUNCTION LAGUERRE,DE
PRINT INTEGRAL(0,8192)
PRINT INTEGRAL2(0,8192)
PRINT INTEGRAL3(0,8192)
PRINT CLENSHAW(0)
PRINT LAGUERRE
PRINT DE
PRINT "----------------------"
PRINT PI/2 !'真値
END
EXTERNAL FUNCTION FUNC(X)
LET FUNC=1/(X*X+1)
END FUNCTION
EXTERNAL FUNCTION INTEGRAL(C,N) !'リーマン和
LET A=0
LET B=1
LET H=(B-A)/(N+1)
FOR J=0 TO N
LET T=A+H*J
IF T<>0 THEN LET S=S+H*FUNC(C+(1-T)/T)/T/T
NEXT J
LET INTEGRAL=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL2(C,N) !'台形則
DIM R(0 TO 1)
LET A=0
LET B=1
LET R(0)=1/2
LET R(1)=1/2
LET H=(B-A)/N
FOR K=0 TO N-1
FOR J=0 TO 1
LET T=A+H*(K+J)
IF T<>0 THEN
LET S=S+H*R(J)*FUNC(C+(1-T)/T)/T/T
END IF
NEXT J
NEXT K
LET INTEGRAL2=S
END FUNCTION
EXTERNAL FUNCTION INTEGRAL3(C,N) !'シンプソン則
DIM R(0 TO 2)
LET A=0
LET B=1
LET R(0)=1/3
LET R(1)=4/3
LET R(2)=1/3
LET H=(B-A)/N/2
FOR K=0 TO N-1
FOR J=0 TO 2
LET T=A+H*(2*K+J)
IF T<>0 THEN
LET S=S+H*R(J)*FUNC(C+(1-T)/T)/T/T
END IF
NEXT J
NEXT K
LET INTEGRAL3=S
END FUNCTION
EXTERNAL FUNCTION DE !'二重指数関数法
LET H=1/1024
FOR T=-4 TO 4 STEP H
LET S=S+FUNC(G(T))*GG(T)*H
NEXT T
LET DE=S
FUNCTION G(X)
LET G=EXP(PI/2*SINH(X))
END FUNCTION
FUNCTION GG(X)
LET GG=PI/2*COSH(X)*EXP(PI/2*SINH(X))
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION CLENSHAW(C) !'クレンショ・カーティス則(101次)
LET A=0
LET B=1
LET U=(B+A)/2
LET V=(B-A)/2
FOR I=1 TO 101
READ X,W
LET T=U+V*X
IF T<>0 THEN
LET S=S+W*FUNC(C+(1-T)/T)/T/T*V
END IF
NEXT I
LET CLENSHAW=S
DATA 1.00000000000000000e+00 , 1.00010001000100010e-04
DATA 9.99506560365731557e-01 , 9.63427864108456136e-04
DATA 9.98026728428271562e-01 , 1.98081792719822447e-03
DATA 9.95561964603080013e-01 , 2.95245609614722172e-03
DATA 9.92114701314477831e-01 , 3.93984190353666597e-03
DATA 9.87688340595137726e-01 , 4.91296972502008171e-03
DATA 9.82287250728688681e-01 , 5.88786182087318069e-03
DATA 9.75916761938747399e-01 , 6.85235068906842241e-03
DATA 9.68583161128631119e-01 , 7.81345860526407593e-03
DATA 9.60293685676943072e-01 , 8.76425733912219235e-03
DATA 9.51056516295153572e-01 , 9.70846937364847499e-03
DATA 9.40880768954225472e-01 , 1.06414202312393182e-02
DATA 9.29776485888251404e-01 , 1.15652668005788029e-02
DATA 9.17754625683981141e-01 , 1.24765169990625641e-02
DATA 9.04827052466019528e-01 , 1.33764703665677760e-02
DATA 8.91006524188367862e-01 , 1.42623390377151899e-02
DATA 8.76306680043863587e-01 , 1.51349096730287363e-02
DATA 8.60742027003943637e-01 , 1.59918539088989191e-02
DATA 8.44327925502015079e-01 , 1.68336341074041766e-02
DATA 8.27080574274561825e-01 , 1.76582438497441395e-02
DATA 8.09016994374947424e-01 , 1.84659337977986137e-02
DATA 7.90155012375690365e-01 , 1.92549367222920903e-02
DATA 7.70513242775789231e-01 , 2.00253634902182446e-02
DATA 7.50111069630459542e-01 , 2.07756336735078458e-02
DATA 7.28968627421411523e-01 , 2.15057668174786011e-02
DATA 7.07106781186547524e-01 , 2.22143348022439743e-02
DATA 6.84547105928688674e-01 , 2.29013000253010056e-02
DATA 6.61311865323651877e-01 , 2.35653632474046753e-02
DATA 6.37423989748689710e-01 , 2.42064547365992693e-02
DATA 6.12907053652976493e-01 , 2.48233878124713492e-02
DATA 5.87785252292473129e-01 , 2.54160795253789001e-02
DATA 5.62083377852130600e-01 , 2.59834441304292331e-02
DATA 5.35826794978996618e-01 , 2.65254001512226545e-02
DATA 5.09041415750371300e-01 , 2.70409543299964853e-02
DATA 4.81753674101715275e-01 , 2.75300383431524965e-02
DATA 4.53990499739546792e-01 , 2.79917451479671329e-02
DATA 4.25779291565072649e-01 , 2.84260290424975911e-02
DATA 3.97147890634780614e-01 , 2.88320644280818968e-02
DATA 3.68124552684677959e-01 , 2.92098360279121910e-02
DATA 3.38737920245291381e-01 , 2.95585959478977955e-02
DATA 3.09016994374947424e-01 , 2.98783658559102421e-02
DATA 2.78991106039229252e-01 , 3.01684725189225605e-02
DATA 2.48689887164854788e-01 , 3.04289800589999179e-02
DATA 2.18143241396542552e-01 , 3.06592873105537182e-02
DATA 1.87381314585724631e-01 , 3.08595055515359825e-02
DATA 1.56434465040230869e-01 , 3.10291033544936972e-02
DATA 1.25333233564304245e-01 , 3.11682432011530392e-02
DATA 9.41083133185143185e-02 , 3.12764611929747937e-02
DATA 6.27905195293133761e-02 , 3.13539745312858345e-02
DATA 3.14107590781282938e-02 , 3.14003846411362968e-02
DATA -1.01615129213537628e-64 , 3.14159665279103048e-02
DATA -3.14107590781282938e-02 , 3.14003846411362968e-02
DATA -6.27905195293133761e-02 , 3.13539745312858345e-02
DATA -9.41083133185143185e-02 , 3.12764611929747937e-02
DATA -1.25333233564304245e-01 , 3.11682432011530392e-02
DATA -1.56434465040230869e-01 , 3.10291033544936972e-02
DATA -1.87381314585724631e-01 , 3.08595055515359825e-02
DATA -2.18143241396542552e-01 , 3.06592873105537182e-02
DATA -2.48689887164854788e-01 , 3.04289800589999179e-02
DATA -2.78991106039229252e-01 , 3.01684725189225605e-02
DATA -3.09016994374947424e-01 , 2.98783658559102421e-02
DATA -3.38737920245291381e-01 , 2.95585959478977955e-02
DATA -3.68124552684677959e-01 , 2.92098360279121910e-02
DATA -3.97147890634780614e-01 , 2.88320644280818968e-02
DATA -4.25779291565072649e-01 , 2.84260290424975911e-02
DATA -4.53990499739546792e-01 , 2.79917451479671329e-02
DATA -4.81753674101715275e-01 , 2.75300383431524965e-02
DATA -5.09041415750371300e-01 , 2.70409543299964853e-02
DATA -5.35826794978996618e-01 , 2.65254001512226545e-02
DATA -5.62083377852130600e-01 , 2.59834441304292331e-02
DATA -5.87785252292473129e-01 , 2.54160795253789001e-02
DATA -6.12907053652976493e-01 , 2.48233878124713492e-02
DATA -6.37423989748689710e-01 , 2.42064547365992693e-02
DATA -6.61311865323651877e-01 , 2.35653632474046753e-02
DATA -6.84547105928688674e-01 , 2.29013000253010056e-02
DATA -7.07106781186547524e-01 , 2.22143348022439743e-02
DATA -7.28968627421411523e-01 , 2.15057668174786011e-02
DATA -7.50111069630459542e-01 , 2.07756336735078458e-02
DATA -7.70513242775789231e-01 , 2.00253634902182446e-02
DATA -7.90155012375690365e-01 , 1.92549367222920903e-02
DATA -8.09016994374947424e-01 , 1.84659337977986137e-02
DATA -8.27080574274561825e-01 , 1.76582438497441395e-02
DATA -8.44327925502015079e-01 , 1.68336341074041766e-02
DATA -8.60742027003943637e-01 , 1.59918539088989191e-02
DATA -8.76306680043863587e-01 , 1.51349096730287363e-02
DATA -8.91006524188367862e-01 , 1.42623390377151899e-02
DATA -9.04827052466019528e-01 , 1.33764703665677760e-02
DATA -9.17754625683981141e-01 , 1.24765169990625641e-02
DATA -9.29776485888251404e-01 , 1.15652668005788029e-02
DATA -9.40880768954225472e-01 , 1.06414202312393182e-02
DATA -9.51056516295153572e-01 , 9.70846937364847499e-03
DATA -9.60293685676943072e-01 , 8.76425733912219235e-03
DATA -9.68583161128631119e-01 , 7.81345860526407593e-03
DATA -9.75916761938747399e-01 , 6.85235068906842241e-03
DATA -9.82287250728688681e-01 , 5.88786182087318069e-03
DATA -9.87688340595137726e-01 , 4.91296972502008171e-03
DATA -9.92114701314477831e-01 , 3.93984190353666597e-03
DATA -9.95561964603080013e-01 , 2.95245609614722172e-03
DATA -9.98026728428271562e-01 , 1.98081792719822447e-03
DATA -9.99506560365731557e-01 , 9.63427864108456136e-04
DATA -1.00000000000000000e+00 , 1.00010001000100010e-04
END FUNCTION
EXTERNAL FUNCTION LAGUERRE !'ガウス・ラゲール則(100次)
FOR I=1 TO 100
READ X,W
LET S=S+FUNC(X)*W
NEXT I
LET LAGUERRE=S
DATA 1.43861469954196695e-02 , 3.69199393145479939e-02
DATA 7.58036120233571246e-02 , 8.59513457259213541e-02
DATA 1.86314102057187174e-01 , 1.35076347286164061e-01
DATA 3.45969180991429091e-01 , 1.84240699565007308e-01
DATA 5.54810937580915510e-01 , 2.33451446141280422e-01
DATA 8.12891284115668845e-01 , 2.82719843781644522e-01
DATA 1.12027383500754015e+00 , 3.32057878360216897e-01
DATA 1.47703432992382707e+00 , 3.81477785290452048e-01
DATA 1.88326082634239471e+00 , 4.30991959306325214e-01
DATA 2.33905384964603417e+00 , 4.80612941774710562e-01
DATA 2.84452654275535907e+00 , 5.30353428454059706e-01
DATA 3.39980482744571194e+00 , 5.80226284010330321e-01
DATA 4.00502758175865202e+00 , 6.30244559347020600e-01
DATA 4.66034683556890846e+00 , 6.80421510469613842e-01
DATA 5.36592798558511701e+00 , 7.30770618450149420e-01
DATA 6.12195003080401979e+00 , 7.81305610360941495e-01
DATA 6.92860582937617306e+00 , 8.32040481168061617e-01
DATA 7.78610237786251743e+00 , 8.82989516630006836e-01
DATA 8.69466111392216799e+00 , 9.34167317275462091e-01
DATA 9.65451824355508073e+00 , 9.85588823551736638e-01
DATA 1.06659250941216756e+01 , 1.03726934224870702e+00
DATA 1.17291484944722251e+01 , 1.08922457431477066e+00
DATA 1.28444711836410306e+01 , 1.14147064419276526e+00
DATA 1.40121922496942746e+01 , 1.19402413081576064e+00
DATA 1.52326276004666978e+01 , 1.24690210041551574e+00
DATA 1.65061104680819896e+01 , 1.30012214131052377e+00
DATA 1.78329919493263874e+01 , 1.35370240085620041e+00
DATA 1.92136415841360667e+01 , 1.40766162475714888e+00
DATA 2.06484479746683495e+01 , 1.46201919896081676e+00
DATA 2.21378194476567044e+01 , 1.51679519437351904e+00
DATA 2.36821847630023761e+01 , 1.57201041466404978e+00
DATA 2.52819938718340415e+01 , 1.62768644744729268e+00
DATA 2.69377187275742649e+01 , 1.68384571917076918e+00
DATA 2.86498541538912922e+01 , 1.74051155406139489e+00
DATA 3.04189187737909429e+01 , 1.79770823752838185e+00
DATA 3.22454560045206658e+01 , 1.85546108446184369e+00
DATA 3.41300351234215165e+01 , 1.91379651291594614e+00
DATA 3.60732524103799732e+01 , 1.97274212372123051e+00
DATA 3.80757323731070932e+01 , 2.03232678663398895e+00
DATA 4.01381290621155458e+01 , 2.09258073370242274e+00
DATA 4.22611274829847942e+01 , 2.15353566061109276e+00
DATA 4.44454451143118061e+01 , 2.21522483685843270e+00
DATA 4.66918335406515394e+01 , 2.27768322572867333e+00
DATA 4.90010802107724370e+01 , 2.34094761514158334e+00
DATA 5.13740103327039945e+01 , 2.40505676060352910e+00
DATA 5.38114889183556604e+01 , 2.47005154164453003e+00
DATA 5.63144229919617082e+01 , 2.53597513331185434e+00
DATA 5.88837639782820903e+01 , 2.60287319450557844e+00
DATA 6.15205102883961426e+01 , 2.67079407519059121e+00
DATA 6.42257101231015602e+01 , 2.73978904480897195e+00
DATA 6.70004645164193116e+01 , 2.80991254455399482e+00
DATA 6.98459306445583743e+01 , 2.88122246656126653e+00
DATA 7.27633254289745863e+01 , 2.95378046353468113e+00
DATA 7.57539294659399362e+01 , 3.02765229286837076e+00
DATA 7.88190913194114722e+01 , 3.10290819996702723e+00
DATA 8.19602322190601240e+01 , 3.17962334622599305e+00
DATA 8.51788512112189002e+01 , 3.25787828803419159e+00
DATA 8.84765308173946112e+01 , 3.33775951423803578e+00
DATA 9.18549432630493089e+01 , 3.41936005079119265e+00
DATA 9.53158573488317206e+01 , 3.50278014286134288e+00
DATA 9.88611460476135277e+01 , 3.58812802653100353e+00
DATA 1.02492794923916561e+02 , 3.67552080449106105e+00
DATA 1.06212911488046816e+02 , 3.76508544287940603e+00
DATA 1.10023735616030917e+02 , 3.85695990978628010e+00
DATA 1.13927651188971624e+02 , 3.95129448009112296e+00
DATA 1.17927199132573227e+02 , 4.04825323641783232e+00
DATA 1.22025092070441621e+02 , 4.14801580236332780e+00
DATA 1.26224230844750388e+02 , 4.25077935211810824e+00
DATA 1.30527723206799413e+02 , 4.35676095061938881e+00
DATA 1.34938905040227408e+02 , 4.46620029107281231e+00
DATA 1.39461364554240157e+02 , 4.57936291287371349e+00
DATA 1.44098969977212724e+02 , 4.69654400377203816e+00
DATA 1.48855901397758249e+02 , 4.81807291708503687e+00
DATA 1.53736687547973031e+02 , 4.94431856997887791e+00
DATA 1.58746248511713104e+02 , 5.07569593525772319e+00
DATA 1.63889945582587233e+02 , 5.21267390086865928e+00
DATA 1.69173639810003025e+02 , 5.35578485438125065e+00
DATA 1.74603761182376627e+02 , 5.50563646260515840e+00
DATA 1.80187390940245696e+02 , 5.66292627184206617e+00
DATA 1.85932360239666971e+02 , 5.82845997074786263e+00
DATA 1.91847369372248329e+02 , 6.00317446373080380e+00
DATA 1.97942133102143257e+02 , 6.18816734184945025e+00
DATA 2.04227559567030508e+02 , 6.38473497877833258e+00
DATA 2.10715972861576943e+02 , 6.59442243137378966e+00
DATA 2.17421393272001481e+02 , 6.81908976786267612e+00
DATA 2.24359894788874608e+02 , 7.06100168500251082e+00
DATA 2.31550068025172484e+02 , 7.32295083409584501e+00
DATA 2.39013629751314924e+02 , 7.60843109395601347e+00
DATA 2.46776240967248490e+02 , 7.92188684818860845e+00
DATA 2.54868629257047430e+02 , 8.26908150662496626e+00
DATA 2.63328168469157893e+02 , 8.65765985897392721e+00
DATA 2.72201170024092537e+02 , 9.09803889452292582e+00
DATA 2.81546328283897389e+02 , 9.60488355686549461e+00
DATA 2.91440133616377107e+02 , 1.01996888715856387e+01
DATA 3.01985855251639154e+02 , 1.09156175227240177e+01
DATA 3.13329534004075524e+02 , 1.18073985027212477e+01
DATA 3.25691263437026520e+02 , 1.29741341509108124e+01
DATA 3.39435101923449617e+02 , 1.46215810644517866e+01
DATA 3.55261311888534132e+02 , 1.72847396480859001e+01
DATA 3.74984112834342679e+02 , 2.31715523384710306e+01
END FUNCTION
EXTERNAL FUNCTION DIFF3(X)
LET DIFF3=(-F(X-H)+F(X+H))/(2*H)
END FUNCTION
EXTERNAL FUNCTION DIFF4(X)
LET DIFF4=(F(X-2*H)-6*F(X-H)+3*F(X)+2*F(X+H))/(6*H)
END FUNCTION
EXTERNAL FUNCTION DIFF5(X)
LET DIFF5=(F(X-2*H)-8*F(X-H)+8*F(X+H)-F(X+2*H))/(12*H)
END FUNCTION
EXTERNAL FUNCTION DIFF6(X)
LET DIFF6=(-2*F(X-3*H)+15*F(X-2*H)-60*F(X-H)+20*F(X)+30*F(X+H)-3*F(X+2*H))/(60*H)
END FUNCTION
EXTERNAL FUNCTION DIFF7(X)
LET DIFF7=(-F(X-3*H)+9*F(X-2*H)-45*F(X-H)+45*F(X+H)-9*F(X+2*H)+F(X+3*H))/(60*H)
END FUNCTION
EXTERNAL FUNCTION DIFF8(X)
LET DIFF8=(3*F(X-4*H)-28*F(X-3*H)+126*F(X-2*H)-420*F(X-H)+105*F(X)+252*F(X+H)-42*F(X+2*H)+4*F(X+3*H))/(420*H)
END FUNCTION
EXTERNAL FUNCTION DIFF9(X)
LET DIFF9=(3*F(X-4*H)-32*F(X-3*H)+168*F(X-2*H)-672*F(X-H)+672*F(X+H)-168*F(X+2*H)+32*F(X+3*H)-3*F(X+4*H))/(840*H)
END FUNCTION
EXTERNAL FUNCTION DIFF10(X)
LET DIFF10=(-4*F(X-5*H)+45*F(X-4*H)-240*F(X-3*H)+840*F(X-2*H)-2520*F(X-H)+504*F(X)+1680*F(X+H)-360*F(X+2*H)+60*F(X+3*H)-5*F(X+4*H))/(2520*H)
END FUNCTION
EXTERNAL FUNCTION DIFF11(X)
LET DIFF11=(-2*F(X-5*H)+25*F(X-4*H)-150*F(X-3*H)+600*F(X-2*H)-2100*F(X-H)+2100*F(X+H)-600*F(X+2*H)+150*F(X+3*H)-25*F(X+4*H)+2*F(X+5*H))/(2520*H)
END FUNCTION
EXTERNAL FUNCTION DIFF12(X)
LET DIFF12=(10*F(X-6*H)-132*F(X-5*H)+825*F(X-4*H)-3300*F(X-3*H)+9900*F(X-2*H)-27720*F(X-H)+4620*F(X)+19800*F(X+H)-4950*F(X+2*H)+1100*F(X+3*H)-165*F(X+4*H)+12*F(X+5*H))/(27720*H)
END FUNCTION
EXTERNAL FUNCTION DIFF13(X)
LET DIFF13=(5*F(X-6*H)-72*F(X-5*H)+495*F(X-4*H)-2200*F(X-3*H)+7425*F(X-2*H)-23760*F(X-H)+23760*F(X+H)-7425*F(X+2*H)+2200*F(X+3*H)-495*F(X+4*H)+72*F(X+5*H)-5*F(X+6*H))/(27720*H)
END FUNCTION
EXTERNAL FUNCTION DIFF14(X)
LET DIFF14=(-30*F(X-7*H)+455*F(X-6*H)-3276*F(X-5*H)+15015*F(X-4*H)-50050*F(X-3*H)+135135*F(X-2*H)-360360*F(X-H)+51480*F(X)+270270*F(X+H)-75075*F(X+2*H)+20020*F(X+3*H)-4095*F(X+4*H)+546*F(X+5*H)-35*F(X+6*H))/(360360*H)
END FUNCTION
EXTERNAL FUNCTION DIFF15(X)
LET DIFF15=(-15*F(X-7*H)+245*F(X-6*H)-1911*F(X-5*H)+9555*F(X-4*H)-35035*F(X-3*H)+105105*F(X-2*H)-315315*F(X-H)+315315*F(X+H)-105105*F(X+2*H)+35035*F(X+3*H)-9555*F(X+4*H)+1911*F(X+5*H)-245*F(X+6*H)+15*F(X+7*H))/(360360*H)
END FUNCTION
EXTERNAL FUNCTION DIFF16(X)
LET DIFF16=(7*F(X-8*H)-120*F(X-7*H)+980*F(X-6*H)-5096*F(X-5*H)+19110*F(X-4*H)-56056*F(X-3*H)+140140*F(X-2*H)-360360*F(X-H)+45045*F(X)+280280*F(X+H)-84084*F(X+2*H)+25480*F(X+3*H)-6370*F(X+4*H)+1176*F(X+5*H)-140*F(X+6*H)+8*F(X+7*H))/(360360*H)
END FUNCTION
EXTERNAL FUNCTION DIFF17(X)
LET DIFF17=(7*F(X-8*H)-128*F(X-7*H)+1120*F(X-6*H)-6272*F(X-5*H)+25480*F(X-4*H)-81536*F(X-3*H)+224224*F(X-2*H)-640640*F(X-H)+640640*F(X+H)-224224*F(X+2*H)+81536*F(X+3*H)-25480*F(X+4*H)+6272*F(X+5*H)-1120*F(X+6*H)+128*F(X+7*H)-7*F(X+8*H))/(720720*H)
END FUNCTION
EXTERNAL FUNCTION DIFF18(X)
LET DIFF18=(-56*F(X-9*H)+1071*F(X-8*H)-9792*F(X-7*H)+57120*F(X-6*H)-239904*F(X-5*H)+779688*F(X-4*H)-2079168*F(X-3*H)+4900896*F(X-2*H)-12252240*F(X-H)+1361360*F(X)+9801792*F(X+H)-3118752*F(X+2*H)+1039584*F(X+3*H)-299880*F(X+4*H)+68544*F(X+5*H)-11424*F(X+6*H)+1224*F(X+7*H)-63*F(X+8*H))/(12252240*H)
END FUNCTION
EXTERNAL FUNCTION DIFF19(X)
LET DIFF19=(-28*F(X-9*H)+567*F(X-8*H)-5508*F(X-7*H)+34272*F(X-6*H)-154224*F(X-5*H)+539784*F(X-4*H)-1559376*F(X-3*H)+4009824*F(X-2*H)-11027016*F(X-H)+11027016*F(X+H)-4009824*F(X+2*H)+1559376*F(X+3*H)-539784*F(X+4*H)+154224*F(X+5*H)-34272*F(X+6*H)+5508*F(X+7*H)-567*F(X+8*H)+28*F(X+9*H))/(12252240*H)
END FUNCTION
EXTERNAL FUNCTION DIFF20(X)
LET DIFF20=(252*F(X-10*H)-5320*F(X-9*H)+53865*F(X-8*H)-348840*F(X-7*H)+1627920*F(X-6*H)-5860512*F(X-5*H)+17093160*F(X-4*H)-42325920*F(X-3*H)+95233320*F(X-2*H)-232792560*F(X-H)+23279256*F(X)+190466640*F(X+H)-63488880*F(X+2*H)+22790880*F(X+3*H)-7325640*F(X+4*H)+1953504*F(X+5*H)-406980*F(X+6*H)+61560*F(X+7*H)-5985*F(X+8*H)+280*F(X+9*H))/(232792560*H)
END FUNCTION
EXTERNAL FUNCTION DIFF51(X)
LET DIFF51=(-980628*F(X-25*H)+51074375*F(X-24*H)-1305727500*F(X-23*H)+21841260000*F(X-22*H)-268855510000*F(X-21*H)+2597144226600*F(X-20*H)-20503770210000*F(X-19*H)+136040888060000*F(X-18*H)-774232701165000*F(X-17*H)+3838903809943125*F(X-16*H)-16788805995484600*F(X-15*H)+65410932449940000*F(X-14*H)-228938263574790000*F(X-13*H)+724971167986835000*F(X-12*H)-2090176614195810000*F(X-11*H)+5518066261476938400*F(X-10*H)-13411966607756447500*F(X-9*H)+30176924867452006875*F(X-8*H)-63227842579423252500*F(X-7*H)+124237164366586040000*F(X-6*H)-231081125721850034400*F(X-5*H)+412644867360446490000*F(X-4*H)-725254615360784740000*F(X-3*H)+1324377993267519960000*F(X-2*H)-2979850484851919910000*F(X-H)+2979850484851919910000*F(X+H)-1324377993267519960000*F(X+2*H)+725254615360784740000*F(X+3*H)-412644867360446490000*F(X+4*H)+231081125721850034400*F(X+5*H)-124237164366586040000*F(X+6*H)+63227842579423252500*F(X+7*H)-30176924867452006875*F(X+8*H)+13411966607756447500*F(X+9*H)-5518066261476938400*F(X+10*H)+2090176614195810000*F(X+11*H)-724971167986835000*F(X+12*H)+228938263574790000*F(X+13*H)-65410932449940000*F(X+14*H)+16788805995484600*F(X+15*H)-3838903809943125*F(X+16*H)+774232701165000*F(X+17*H)-136040888060000*F(X+18*H)+20503770210000*F(X+19*H)-2597144226600*F(X+20*H)+268855510000*F(X+21*H)-21841260000*F(X+22*H)+1305727500*F(X+23*H)-51074375*F(X+24*H)+980628*F(X+25*H))/(3099044504245996706400*H)
END FUNCTION
EXTERNAL FUNCTION DIFF75(X)
LET DIFF75=(-6354671400*F(X-37*H)+483308063700*F(X-36*H)-18144765591480*F(X-35*H)+448282444024800*F(X-34*H)-8198134999059600*F(X-33*H)+118360574048922975*F(X-32*H)-1405054556451730800*F(X-31*H)+14104071452382135840*F(X-30*H)-122194756979690056200*F(X-29*H)+928098273250503045900*F(X-28*H)-6256069841910798309400*F(X-27*H)+37798911492384124051200*F(X-26*H)-206382056748417317319552*F(X-25*H)+1025295474230919364888800*F(X-24*H)-4661591845571633385705600*F(X-23*H)+19493929536026830522041600*F(X-22*H)-75306906362389363147648800*F(X-21*H)+269775917498206600923047760*F(X-20*H)-899253058327355336410159200*F(X-19*H)+2797676181462883268831606400*F(X-18*H)-8146174763671336576892030400*F(X-17*H)+22256513193602044576151440200*F(X-16*H)-57192494509619799395686125120*F(X-15*H)+138540825209638023380854588800*F(X-14*H)-317045349998979322736955693600*F(X-13*H)+686931591664455199263404002800*F(X-12*H)-1412292922722726074010075362400*F(X-11*H)+2761817271102219878064147375360*F(X-10*H)-5151008402452552947183132009600*F(X-9*H)+9191885683686883276438864879200*F(X-8*H)-15757518314891799902466625507200*F(X-7*H)+26093094844014378333116777721600*F(X-6*H)-42075115435973185062150804076080*F(X-5*H)+66937683648139158053421733757400*F(X-4*H)-107625295277400214909423179766800*F(X-3*H)+184500506189828939844725451028800*F(X-2*H)-399751096744629369663571810562400*F(X-H)+399751096744629369663571810562400*F(X+H)-184500506189828939844725451028800*F(X+2*H)+107625295277400214909423179766800*F(X+3*H)-66937683648139158053421733757400*F(X+4*H)+42075115435973185062150804076080*F(X+5*H)-26093094844014378333116777721600*F(X+6*H)+15757518314891799902466625507200*F(X+7*H)-9191885683686883276438864879200*F(X+8*H)+5151008402452552947183132009600*F(X+9*H)-2761817271102219878064147375360*F(X+10*H)+1412292922722726074010075362400*F(X+11*H)-686931591664455199263404002800*F(X+12*H)+317045349998979322736955693600*F(X+13*H)-138540825209638023380854588800*F(X+14*H)+57192494509619799395686125120*F(X+15*H)-22256513193602044576151440200*F(X+16*H)+8146174763671336576892030400*F(X+17*H)-2797676181462883268831606400*F(X+18*H)+899253058327355336410159200*F(X+19*H)-269775917498206600923047760*F(X+20*H)+75306906362389363147648800*F(X+21*H)-19493929536026830522041600*F(X+22*H)+4661591845571633385705600*F(X+23*H)-1025295474230919364888800*F(X+24*H)+206382056748417317319552*F(X+25*H)-37798911492384124051200*F(X+26*H)+6256069841910798309400*F(X+27*H)-928098273250503045900*F(X+28*H)+122194756979690056200*F(X+29*H)-14104071452382135840*F(X+30*H)+1405054556451730800*F(X+31*H)-118360574048922975*F(X+32*H)+8198134999059600*F(X+33*H)-448282444024800*F(X+34*H)+18144765591480*F(X+35*H)-483308063700*F(X+36*H)+6354671400*F(X+37*H))/(410555180440430163438262940577600*H)
END FUNCTION
EXTERNAL FUNCTION DIFF101(X)
LET DIFF101=(13820883356*F(X-50*H)-1410294220000*F(X-49*H)+71263929804375*F(X-48*H)-2377485998580000*F(X-47*H)+58907384062642500*F(X-46*H)-1156155591202796800*F(X-45*H)+18721837698454380000*F(X-44*H)-257254221663811680000*F(X-43*H)+3061784620338044370000*F(X-42*H)-32061614560938220720000*F(X-41*H)+299054709817151253765800*F(X-40*H)-2509550012451618912720000*F(X-39*H)+19102298450042915013270000*F(X-38*H)-132802673631899184624480000*F(X-37*H)+848198028613260863702780000*F(X-36*H)-5001944945879344064807251200*F(X-35*H)+27354386422777662854414655000*F(X-34*H)-139258694515959010895201880000*F(X-33*H)+662204104651409254933954773125*F(X-32*H)-2950124907649062622999486120000*F(X-31*H)+12346272738511327077252849412200*F(X-30*H)-48655262023689958925134381920000*F(X-29*H)+180956502104340415417991670420000*F(X-28*H)-636407408366955663885497275680000*F(X-27*H)+2120338144222597476310815442530000*F(X-26*H)-6703661076774164181104274103102848*F(X-25*H)+20143212370114676024952746704035000*F(X-24*H)-57607641174434242544792396370960000*F(X-23*H)+157018229759537489014133820627990000*F(X-22*H)-408402095138107360588485996510240000*F(X-21*H)+1014879206418196791062387701327946400*F(X-20*H)-2412276551758022932915692329132640000*F(X-19*H)+5490441943324250112938320561619602500*F(X-18*H)-11979146058162000246410881225351860000*F(X-17*H)+25081337059276688015922782565580456875*F(X-16*H)-50449317970659395323456111217624690400*F(X-15*H)+97595406788477996905495453248381097500*F(X-14*H)-181799344038412235399841842225674560000*F(X-13*H)+326521190279516712264189624523744440000*F(X-12*H)-566274511813427584905727460712507840000*F(X-11*H)+949925493567024773679357815345231901600*F(X-10*H)-1544594298482967111673752545276799840000*F(X-9*H)+2441010632423974810412983933160656890000*F(X-8*H)-3762886822075496053261211112912108960000*F(X-7*H)+5687090310636829262315239522923982860000*F(X-6*H)-8492721530550998365057424354233147737600*F(X-5*H)+12692926200551763860819520094641932760000*F(X-4*H)-19444482690206957403808626527962109760000*F(X-3*H)+32204924455655273200058037686937244290000*F(X-2*H)-68353309048737722710327263662070885840000*F(X-H)+68353309048737722710327263662070885840000*F(X+H)-32204924455655273200058037686937244290000*F(X+2*H)+19444482690206957403808626527962109760000*F(X+3*H)-12692926200551763860819520094641932760000*F(X+4*H) &
& +8492721530550998365057424354233147737600*F(X+5*H)-5687090310636829262315239522923982860000*F(X+6*H)+3762886822075496053261211112912108960000*F(X+7*H)-2441010632423974810412983933160656890000*F(X+8*H)+1544594298482967111673752545276799840000*F(X+9*H)-949925493567024773679357815345231901600*F(X+10*H)+566274511813427584905727460712507840000*F(X+11*H)-326521190279516712264189624523744440000*F(X+12*H)+181799344038412235399841842225674560000*F(X+13*H)-97595406788477996905495453248381097500*F(X+14*H)+50449317970659395323456111217624690400*F(X+15*H)-25081337059276688015922782565580456875*F(X+16*H)+11979146058162000246410881225351860000*F(X+17*H)-5490441943324250112938320561619602500*F(X+18*H)+2412276551758022932915692329132640000*F(X+19*H)-1014879206418196791062387701327946400*F(X+20*H)+408402095138107360588485996510240000*F(X+21*H)-157018229759537489014133820627990000*F(X+22*H)+57607641174434242544792396370960000*F(X+23*H)-20143212370114676024952746704035000*F(X+24*H)+6703661076774164181104274103102848*F(X+25*H)-2120338144222597476310815442530000*F(X+26*H)+636407408366955663885497275680000*F(X+27*H)-180956502104340415417991670420000*F(X+28*H)+48655262023689958925134381920000*F(X+29*H)-12346272738511327077252849412200*F(X+30*H)+2950124907649062622999486120000*F(X+31*H)-662204104651409254933954773125*F(X+32*H)+139258694515959010895201880000*F(X+33*H)-27354386422777662854414655000*F(X+34*H)+5001944945879344064807251200*F(X+35*H)-848198028613260863702780000*F(X+36*H)+132802673631899184624480000*F(X+37*H)-19102298450042915013270000*F(X+38*H)+2509550012451618912720000*F(X+39*H)-299054709817151253765800*F(X+40*H)+32061614560938220720000*F(X+41*H)-3061784620338044370000*F(X+42*H)+257254221663811680000*F(X+43*H)-18721837698454380000*F(X+44*H)+1156155591202796800*F(X+45*H)-58907384062642500*F(X+46*H)+2377485998580000*F(X+47*H)-71263929804375*F(X+48*H)+1410294220000*F(X+49*H)-13820883356*F(X+50*H))/(69720375229712477164533808935312303556800*H)
END FUNCTION
EXTERNAL FUNCTION DIFF(X,K)
FOR N=1 TO K
FOR J=0 TO N
LET S=S+(-1)^J*COMB(N,J)*F(X-J*H)/N
NEXT J
NEXT N
LET DIFF=S/H
END FUNCTION
PUBLIC NUMERIC H
!'LET H=1/10^25 !1000桁モード
LET H=1/65536
INPUT PROMPT "X=":X
PRINT F(X)
PRINT DIFF3(X)
PRINT DIFF5(X)
PRINT DIFF7(X)
PRINT DIFF9(X)
PRINT DIFF11(X)
PRINT DIFF13(X)
PRINT DIFF15(X)
PRINT DIFF17(X)
PRINT DIFF19(X)
END
EXTERNAL FUNCTION F(X)
LET F=1/X
END FUNCTION
EXTERNAL FUNCTION DIFF3(X)
LET DIFF3=(F(X-H)-2*F(X)+1*F(X+H))/(H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF5(X)
LET DIFF5=(-1*F(X-2*H)+16*F(X-H)-30*F(X)+16*F(X+H)-1*F(X+2*H))/(12*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF7(X)
LET DIFF7=(2*F(X-3*H)-27*F(X-2*H)+270*F(X-H)-490*F(X)+270*F(X+H)-27*F(X+2*H)+2*F(X+3*H))/(180*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF9(X)
LET DIFF9=(-9*F(X-4*H)+128*F(X-3*H)-1008*F(X-2*H)+8064*F(X-H)-14350*F(X)+8064*F(X+H)-1008*F(X+2*H)+128*F(X+3*H)-9*F(X+4*H))/(5040*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF11(X)
LET DIFF11=(8*F(X-5*H)-125*F(X-4*H)+1000*F(X-3*H)-6000*F(X-2*H)+42000*F(X-H)-73766*F(X)+42000*F(X+H)-6000*F(X+2*H)+1000*F(X+3*H)-125*F(X+4*H)+8*F(X+5*H))/(25200*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF13(X)
LET DIFF13=(-50*F(X-6*H)+864*F(X-5*H)-7425*F(X-4*H)+44000*F(X-3*H)-222750*F(X-2*H)+1425600*F(X-H)-2480478*F(X)+1425600*F(X+H)-222750*F(X+2*H)+44000*F(X+3*H)-7425*F(X+4*H)+864*F(X+5*H)-50*F(X+6*H))/(831600*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF15(X)
LET DIFF15=(900*F(X-7*H)-17150*F(X-6*H)+160524*F(X-5*H)-1003275*F(X-4*H)+4904900*F(X-3*H)-22072050*F(X-2*H)+132432300*F(X-H)-228812298*F(X)+132432300*F(X+H)-22072050*F(X+2*H)+4904900*F(X+3*H)-1003275*F(X+4*H)+160524*F(X+5*H)-17150*F(X+6*H)+900*F(X+7*H))/(75675600*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF17(X)
LET DIFF17=(-735*F(X-8*H)+15360*F(X-7*H)-156800*F(X-6*H)+1053696*F(X-5*H)-5350800*F(X-4*H)+22830080*F(X-3*H)-94174080*F(X-2*H)+538137600*F(X-H)-924708642*F(X)+538137600*F(X+H)-94174080*F(X+2*H)+22830080*F(X+3*H)-5350800*F(X+4*H)+1053696*F(X+5*H)-156800*F(X+6*H)+15360*F(X+7*H)-735*F(X+8*H))/(302702400*H^2)
END FUNCTION
EXTERNAL FUNCTION DIFF19(X)
LET DIFF19=(7840*F(X-9*H)-178605*F(X-8*H)+1982880*F(X-7*H)-14394240*F(X-6*H)+77728896*F(X-5*H)-340063920*F(X-4*H)+1309875840*F(X-3*H)-5052378240*F(X-2*H)+27788080320*F(X-H)-47541321542*F(X)+27788080320*F(X+H)-5052378240*F(X+2*H)+1309875840*F(X+3*H)-340063920*F(X+4*H)+77728896*F(X+5*H)-14394240*F(X+6*H)+1982880*F(X+7*H)-178605*F(X+8*H)+7840*F(X+9*H))/(15437822400*H^2)
END FUNCTION
PUBLIC NUMERIC H
!'LET H=1/10^10 !1000桁モード
LET H=1/2^10
INPUT PROMPT "X=":X
PRINT F(X)
PRINT DIFF5(X)
PRINT DIFF7(X)
PRINT DIFF9(X)
PRINT DIFF11(X)
PRINT DIFF13(X)
PRINT DIFF15(X)
PRINT DIFF17(X)
PRINT DIFF19(X)
END
EXTERNAL FUNCTION F(X)
LET F=1/X
END FUNCTION
EXTERNAL FUNCTION DIFF5(X)
LET DIFF5=(-F(X-2*H)+2*F(X-H)-2*F(X+H)+F(X+2*H))/(2*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF7(X)
LET DIFF7=(F(X-3*H)-8*F(X-2*H)+13*F(X-H)+0*F(X)-13*F(X+H)+8*F(X+2*H)-1*F(X+3*H))/(8*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF9(X)
LET DIFF9=(-7*F(X-4*H)+72*F(X-3*H)-338*F(X-2*H)+488*F(X-H)-488*F(X+H)+338*F(X+2*H)-72*F(X+3*H)+7*F(X+4*H))/(240*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF11(X)
LET DIFF11=(205*F(X-5*H)-2522*F(X-4*H)+14607*F(X-3*H)-52428*F(X-2*H)+70098*F(X-H)-70098*F(X+H)+52428*F(X+2*H)-14607*F(X+3*H)+2522*F(X+4*H)-205*F(X+5*H))/(30240*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF13(X)
LET DIFF13=(-479*F(X-6*H)+6840*F(X-5*H)-46296*F(X-4*H)+198760*F(X-3*H)-603315*F(X-2*H)+764208*F(X-H)-764208*F(X+H)+603315*F(X+2*H)-198760*F(X+3*H)+46296*F(X+4*H)-6840*F(X+5*H)+479*F(X+6*H))/(302400*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF15(X)
LET DIFF15=(1239*F(X-7*H)-20137*F(X-6*H)+155775*F(X-5*H)-766968*F(X-4*H)+2717891*F(X-3*H)-7345173*F(X-2*H)+8937819*F(X-H)-8937819*F(X+H)+7345173*F(X+2*H)-2717891*F(X+3*H)+766968*F(X+4*H)-155775*F(X+5*H)+20137*F(X+6*H)-1239*F(X+7*H))/(3326400*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF17(X)
LET DIFF17=(-266681*F(X-8*H)+4861024*F(X-7*H)-42325960*F(X-6*H)+235093600*F(X-5*H)-940620590*F(X-4*H)+2910104288*F(X-3*H)-7218002792*F(X-2*H)+8514769120*F(X-H)-8514769120*F(X+H)+7218002792*F(X+2*H)-2910104288*F(X+3*H)+940620590*F(X+4*H)-235093600*F(X+5*H)+42325960*F(X+6*H)-4861024*F(X+7*H)+266681*F(X+8*H))/(3027024000*H^3)
END FUNCTION
EXTERNAL FUNCTION DIFF19(X)
LET DIFF19=(63397*F(X-9*H)-1281033*F(X-8*H)+12405267*F(X-7*H)-76813928*F(X-6*H)+342868500*F(X-5*H)-1182036366*F(X-4*H)+3302404924*F(X-3*H)-7666346376*F(X-2*H)+8823005334*F(X-H)-8823005334*F(X+H)+7666346376*F(X+2*H)-3302404924*F(X+3*H)+1182036366*F(X+4*H)-342868500*F(X+5*H)+76813928*F(X+6*H)-12405267*F(X+7*H)+1281033*F(X+8*H)-63397*F(X+9*H))/(3027024000*H^3)
END FUNCTION
PUBLIC NUMERIC H
LET H=1/128
LET X=.5
FOR I=1 TO 6
PRINT DIFF(X,I);DIFFN(X,I)
NEXT I
END
EXTERNAL FUNCTION F(X)
LET F=X^7
END FUNCTION
EXTERNAL FUNCTION DIFF(X,N) !'再帰呼び出しによる高階数値微分
IF N=0 THEN
LET DIFF=F(X)
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 FUNCTION DIFFN(X,K)
FOR J=0 TO K
LET S=S+(-1)^J*COMB(K,J)*F(X+(K/2-J)*H)
NEXT J
LET DIFFN=S/(H^K)
END FUNCTION
FOR I=1 TO 3
SELECT CASE MESSAGEBOX("よろしいですか "&STR$(I))
CASE 1
PRINT "OK"
CASE 2
PRINT "CANCEL"
END SELECT
NEXT I
END
EXTERNAL FUNCTION MESSAGEBOX(M$)
!flagの値
LET MB_OK=00000000 !［OK］
LET MB_OKCANCEL=00000001 !［OK］［キャンセル］
LET MB_ABORTRETRYIGNORE=00000002 !［中止］［再試行］［無視］
LET MB_YESNOCANCEL=00000003 !［はい］［いいえ］［キャンセル］
LET MB_YESNO=00000004 !［はい］［いいえ］
LET MB_RETRYCANCEL=00000005 !［再試行］［キャンセル］
!定数名 値 アイコンの種類
LET MB_ICONSTOP=16 !0x00000010 停止のアイコン
LET MB_ICONQUESTION=32 !0x00000020 疑問符のアイコン
LET MB_ICONEXCLAMATION=48 !0x00000030 感嘆符のアイコン
LET MB_ICONINFORMATION=64 !0x00000040 吹き出しに「i」のアイコン
LET MESSAGEBOX=MESSBOX(0,M$,"BASIC",BITOR(MB_OKCANCEL,MB_ICONEXCLAMATION))
END FUNCTION
EXTERNAL FUNCTION MESSBOX(OWNER,TEXT$,CAPTION$,FLAG)
ASSIGN "user32.dll","MessageBoxA"
END FUNCTION
CALL GINIT(800,800)
DIM B$(128)
DO
READ IF MISSING THEN EXIT DO:A$
READ B$(ORD(A$))
LOOP
INPUT X$
FOR I=1 TO LEN(X$)
LET Z$=Z$&B$(ORD(UCASE$(X$(I:I))))&"/"
NEXT I
LET Y=20
LET X=20
CALL BOX(295,495,505,705,4)
SET LINE WIDTH 10
SET LINE COLOR 7
FOR I=1 TO LEN(Z$)
IF Z$(I:I)="0" THEN
IF X+20<800 THEN
PLOT LINES:X,Y;X+20,Y
LET X=X+40
ELSE
LET X=20
LET Y=Y+40
PLOT LINES:X,Y;X+20,Y
LET X=X+40
END IF
ELSEIF Z$(I:I)="1" THEN
IF X+60<800 THEN
PLOT LINES:X,Y;X+60,Y
LET X=X+80
ELSE
LET Y=Y+40
LET X=20
PLOT LINES:X,Y;X+60,Y
LET X=X+80
END IF
ELSEIF Z$(I:I)="/" THEN
IF X+20<800 THEN
LET X=X+20
ELSE
LET X=20
LET Y=Y+40
END IF
END IF
NEXT I
LET X=20
LET Y=20
LOCATE VALUE NOWAIT(1),RANGE .2 TO 1.5,AT 1:SPEED
FOR I=1 TO LEN(Z$)-1
LOCATE VALUE NOWAIT(1):SPEED
SET LINE COLOR 2
SELECT CASE Z$(I:I)
CASE "0"
IF X+20<800 THEN
PLOT LINES:X,Y;X+20,Y
LET X=X+40
ELSE
LET X=20
LET Y=Y+40
PLOT LINES:X,Y;X+20,Y
LET X=X+40
END IF
CALL CIRCLEFULL(400,600,90,7)
BEEP 440,150*SPEED
CALL CIRCLEFULL(400,600,90,0)
WAIT DELAY .15*SPEED
CASE "1"
IF X+60<800 THEN
PLOT LINES:X,Y;X+60,Y
LET X=X+80
ELSE
LET Y=Y+40
LET X=20
PLOT LINES:X,Y;X+60,Y
LET X=X+80
END IF
CALL CIRCLEFULL(400,600,90,7)
BEEP 440,450*SPEED
CALL CIRCLEFULL(400,600,90,0)
WAIT DELAY .15*SPEED
CASE "/" !文字間隔区切り
IF X+20<800 THEN
LET X=X+20
ELSE
LET X=20
LET Y=Y+40
END IF
WAIT DELAY .45*SPEED
CASE "2" !語間隔区切り
WAIT DELAY .15*SPEED
END SELECT
NEXT I
DATA A,01
DATA B,1000
DATA C,1010
DATA D,100
DATA E,0
DATA F,0010
DATA G,110
DATA H,0000
DATA I,00
DATA J,0111
DATA K,101
DATA L,0100
DATA M,11
DATA N,10
DATA O,111
DATA P,0110
DATA Q,1101
DATA R,010
DATA S,000
DATA T,1
DATA U,001
DATA V,0001
DATA W,011
DATA X,1001
DATA Y,1011
DATA Z,1100
DATA 1,0111
DATA 2,00111
DATA 3,00011
DATA 4,00001
DATA 5,00000
DATA 6,10000
DATA 7,11000
DATA 8,11100
DATA 9,11110
DATA 0,11111
DATA ".",010101
DATA ",",110011
DATA "?",001100
DATA "!",101011
DATA "-",100001
DATA "/",10010
DATA @,011010
DATA "(",10110
DATA ")",101101
DATA " ",2222222
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
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 CIRCLEFULL(X,Y,RR,C)
SET COLOR C
DRAW DISK WITH SCALE(RR)*SHIFT(X,Y)
END SUB
EXTERNAL SUB BOX(XS,YS,XE,YE,C)
CALL LINE(XS,YS,XE,YS,C)
CALL LINE(XE,YS,XE,YE,C)
CALL LINE(XE,YE,XS,YE,C)
CALL LINE(XS,YE,XS,YS,C)
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES
PLOT LINES:XS,YS;XE,YE
END SUB
FOR I=1 TO 3
SELECT CASE MESSAGEBOX(ANSI$("よろしいですか ")&STR$(I))
CASE 1
PRINT "OK"
CASE 2
PRINT "CANCEL"
END SELECT
NEXT I
END
EXTERNAL FUNCTION MESSAGEBOX(M$)
!flagの値
LET MB_OK=00000000 !［OK］
LET MB_OKCANCEL=00000001 !［OK］［キャンセル］
LET MB_ABORTRETRYIGNORE=00000002 !［中止］［再試行］［無視］
LET MB_YESNOCANCEL=00000003 !［はい］［いいえ］［キャンセル］
LET MB_YESNO=00000004 !［はい］［いいえ］
LET MB_RETRYCANCEL=00000005 !［再試行］［キャンセル］
!定数名 値 アイコンの種類
LET MB_ICONSTOP=16 !0x00000010 停止のアイコン
LET MB_ICONQUESTION=32 !0x00000020 疑問符のアイコン
LET MB_ICONEXCLAMATION=48 !0x00000030 感嘆符のアイコン
LET MB_ICONINFORMATION=64 !0x00000040 吹き出しに「i」のアイコン
LET MESSAGEBOX=MESSBOX(0,M$,"BASIC",BITOR(MB_OKCANCEL,MB_ICONEXCLAMATION))
END FUNCTION
EXTERNAL FUNCTION MESSBOX(OWNER,TEXT$,CAPTION$,FLAG)
ASSIGN "user32.dll","MessageBoxA",GUI
END FUNCTION
FOR I=1 TO 3
SELECT CASE MESSAGEBOX(ANSI$("よろしいですか ")&STR$(I))
CASE 1
PRINT "OK"
CASE 2
PRINT "CANCEL"
END SELECT
NEXT I
END
EXTERNAL FUNCTION MESSAGEBOX(M$)
!flagの値
LET MB_OK=00000000 !［OK］
LET MB_OKCANCEL=00000001 !［OK］［キャンセル］
LET MB_ABORTRETRYIGNORE=00000002 !［中止］［再試行］［無視］
LET MB_YESNOCANCEL=00000003 !［はい］［いいえ］［キャンセル］
LET MB_YESNO=00000004 !［はい］［いいえ］
LET MB_RETRYCANCEL=00000005 !［再試行］［キャンセル］
!定数名 値 アイコンの種類
LET MB_ICONSTOP=16 !0x00000010 停止のアイコン
LET MB_ICONQUESTION=32 !0x00000020 疑問符のアイコン
LET MB_ICONEXCLAMATION=48 !0x00000030 感嘆符のアイコン
LET MB_ICONINFORMATION=64 !0x00000040 吹き出しに「i」のアイコン
LET MESSAGEBOX=MESSBOX(0,M$,"BASIC",BITOR(MB_OKCANCEL,MB_ICONEXCLAMATION))
END FUNCTION
EXTERNAL FUNCTION MESSBOX(OWNER,TEXT$,CAPTION$,FLAG)
ASSIGN "user32.dll","MessageBoxA"
END FUNCTION
function add(a,b:Int64): Int64; cdecl;
begin
add:=a+b
end;
function sub(a,b:Int64): Int64; cdecl;
begin
sub:=a-b
end;
exports add, sub;
end.
BASICAccを64ビットでコンパイルしたものを使用
100 FUNCTION ADD(a,b)
110 ASSIGN "Sample.dll","add"
120 END FUNCTION
130
140 FUNCTION SUB(a,b)
150 ASSIGN "Sample.dll","sub"
160 END FUNCTION
170
180 PRINT ADD(5,-4),SUB(4,7)
190 END
OPTION CHARACTER BYTE
LET A$=REPEAT$(CHR$(0),2048)
FILE GETNAME F$,"実行ファイル|*.EXE;*.DLL"
IF F$="" THEN STOP
OPEN #1:NAME F$
FOR I=1 TO 2048
CHARACTER INPUT #1,IF MISSING THEN EXIT FOR:A$(I:I)
NEXT I
CLOSE #1
LET X86$=HEXCHR$("504500004C01")
LET X64$=HEXCHR$("504500006486")
FOR I=1 TO 2043
LET X$=A$(I:I+5)
IF X$=X86$ THEN
PRINT "WIN32(x86)"
STOP
ELSEIF X$=X64$ THEN
PRINT "WIN64(x64)"
STOP
END IF
NEXT I
PRINT "不明"
END
EXTERNAL FUNCTION HEXCHR$(X$)
OPTION CHARACTER BYTE
IF MOD(LEN(X$),2)=1 THEN LET X$=X$ & "0"
FOR I=1 TO LEN(X$) STEP 2
LET S$=S$&CHR$(BVAL(MID$(X$,I,2),16))
NEXT I
LET HEXCHR$=S$
END FUNCTION
!'INPUT TEXT$
LET TEXT$="https://6317.teacup.com/basic/bbs"
CALL QRCODEGENERATE(TEXT$)
END
EXTERNAL SUB QRCODEGENERATE(INPUT$)
OPTION CHARACTER BYTE
LET OUTPUT$=REPEAT$(CHR$(0),177*177)
LET N=QRCODEGENERATE_(INPUT$,OUTPUT$,2)
PRINT "SIZE=";N
LET BOADER=4
LET SCALE=10
DIM MAP(-BOADER TO N-1+BOADER,-BOADER TO N-1+BOADER)
FOR Y=-BOADER TO N-1+BOADER
FOR X=-BOADER TO N-1+BOADER
LET ADR=Y*N+X+1
IF X>=0 AND Y>=0 AND X<N AND Y<N AND OUTPUT$(ADR:ADR)="1" THEN
LET MAP(X,Y)=1
END IF
NEXT X
NEXT Y
SET BITMAP SIZE (BOADER+N)*SCALE,(BOADER+N)*SCALE
SET WINDOW 0,1,1,0
MAT PLOT CELLS, IN 0 , 0 ; 1 , 1 :MAP
!'
FUNCTION QRCODEGENERATE_(INPUT$,OUTPUT$,LEV)
ASSIGN ".\DLL\qrcodegenerate.dll","qrcodegenerate"
END FUNCTION
END SUB
if (lev==0)
errCorLvl=QrCode::Ecc::LOW;
else if (lev==1)
errCorLvl=QrCode::Ecc::MEDIUM;
else if (lev==2)
errCorLvl=QrCode::Ecc::HIGH;
else
errCorLvl=QrCode::Ecc::HIGH;
const QrCode qr = QrCode::encodeText(input, errCorLvl);
for (int y = 0; y < qr.getSize(); y++)
for (int x = 0; x < qr.getSize(); x++)
if(qr.getModule(x, y)) out=out+"1";
else out=out+"0";
OPTION BASE 0
FILE GETNAME IMAGENAME$,"画像ファイル|*.jpg;*.png"
CALL PICTURELOAD(IMAGENAME$,XSIZE,YSIZE)
LET CASCADEFILENAME$="haarcascade_frontalface_default.xml" !'カスケードファイル(学習済みデータ) ※絶対パスか画像と同じフォルダ
LET N=100 !'バッファサイズ(誤認識分を含む100人分)
DIM XS(N),YS(N),XE(N),YE(N)
CALL IMAGEDETECTION(IMAGENAME$,CASCADEFILENAME$,N,XS,YS,XE,YE)
SET LINE WIDTH 4
FOR I=0 TO N-1
CALL BOX(XS(I),YS(I),XE(I),YE(I),255,0,0)
!'CALL ELLIPSE((XS(I)+XE(I))/2,(YS(I)+YE(I))/2,(XE(I)-XS(I))/2,(YE(I)-YS(I))/2,0,255,0)
PRINT XS(I);YS(I);XE(I);YE(I)
NEXT I
END
EXTERNAL SUB IMAGEDETECTION(FILENAME$,CASCADEFIENAME$,N,XS(),YS(),XE(),YE())
OPTION CHARACTER BYTE
LET X0$=REPEAT$(CHR$(0),8*N)
LET X1$=REPEAT$(CHR$(0),8*N)
LET Y0$=REPEAT$(CHR$(0),8*N)
LET Y1$=REPEAT$(CHR$(0),8*N)
LET NUM=IMAGEDETECTION_(FILENAME$,CASCADEFIENAME$,N,X0$,Y0$,X1$,Y1$)
IF NUM=-1 THEN
PRINT "画像ファイルをロードできません"
STOP
ELSEIF NUM=-2 THEN
PRINT "カスケードファイルをロードできません"
STOP
END IF
IF N>NUM THEN
FOR I=0 TO NUM-1
LET XS(I)=UNPACKDBL(X0$(8*I+1:8*I+8))
LET XE(I)=UNPACKDBL(X1$(8*I+1:8*I+8))
LET YS(I)=UNPACKDBL(Y0$(8*I+1:8*I+8))
LET YE(I)=UNPACKDBL(Y1$(8*I+1:8*I+8))
NEXT I
ELSE
PRINT "バッファ不足です"
END IF
LET N=NUM
!'
FUNCTION IMAGEDETECTION_(FILENAME$,CASCADEFIENAME$,NUM,X0$,Y0$,X1$,Y1$)
ASSIGN ".\DLL\imagedetection.dll","imagedetection"
END FUNCTION
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
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
EXTERNAL SUB BOX(XS,YS,XE,YE,R,G,B)
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES:XS,YS;XE,YS
PLOT LINES:XE,YS;XE,YE
PLOT LINES:XE,YE;XS,YE
PLOT LINES:XS,YE;XS,YS
END SUB
EXTERNAL SUB ELLIPSE(X,Y,XR,YR,R,G,B)
OPTION ANGLE DEGREES
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES
FOR T=0 TO 360
LET XX=X+XR*COS(T)
LET YY=Y+YR*SIN(T)
PLOT LINES:XX,YY;
NEXT T
PLOT LINES
END SUB
OPTION BASE 0
FILE GETNAME VIDEONAME$,"動画ファイル|*.mp4;*.avi;*.wmv;*.mkv;*.flv;*.mpg;*.mov"
IF VIDEONAME$="" THEN STOP
CALL VIDEOINFO(VIDEONAME$,WIDTH,HEIGHT,MAXFRAME,FPS)
PRINT WIDTH;HEIGHT;MAXFRAME;FPS
DIM M(WIDTH,HEIGHT) !'バッファー
CALL GINIT(WIDTH,HEIGHT)
LET T=INT(TIME)
DO
LOOP WHILE INT(TIME)=T
LET I=0 !'動画フレームナンバー
LOCATE VALUE NOWAIT(1),RANGE .3 TO 2,AT 1:SECOND
DO
LOCATE VALUE NOWAIT(1):SECOND !'表示間隔
LET SECOND=ROUND(SECOND,2)
LET T=TIME
PRINT I;"/";MAXFRAME-1
CALL GETVIDEOFRAME(VIDEONAME$,WIDTH,HEIGHT,M,I)
MAT PLOT CELLS,IN 0,0;WIDTH-1,HEIGHT-1:M !'画像表示
DO
LOOP WHILE TIME-T<=SECOND !'ウェイト
LET I=I+INT(FPS*SECOND+.1)
IF INT(FPS*SECOND+.1)=0 THEN LET I=I+1
LOOP WHILE I<MAXFRAME-1
PRINT MAXFRAME-1;"/";MAXFRAME-1
CALL GETVIDEOFRAME(VIDEONAME$,WIDTH,HEIGHT,M,MAXFRAME-1)
MAT PLOT CELLS,IN 0,0;WIDTH-1,HEIGHT-1:M !'画像表示
END
EXTERNAL SUB VIDEOINFO(VIDEONAME$,WIDTH,HEIGHT,MAXFRAME,FPS)
OPTION CHARACTER BYTE
LET WIDTH$=REPEAT$(CHR$(0),8)
LET HEIGHT$=REPEAT$(CHR$(0),8)
LET MAXFRAME$=REPEAT$(CHR$(0),8)
LET FPS$=REPEAT$(CHR$(0),8)
LET NUM=VIDEOINFO_(VIDEONAME$,WIDTH$,HEIGHT$,MAXFRAME$,FPS$)
IF NUM=-1 THEN
PRINT "動画ファイルをロードできません"
STOP
END IF
LET WIDTH=UNPACKDBL(WIDTH$)
LET HEIGHT=UNPACKDBL(HEIGHT$)
LET MAXFRAME=UNPACKDBL(MAXFRAME$)
LET FPS=UNPACKDBL(FPS$)
!'
FUNCTION VIDEOINFO_(VIDEONAME$,WIDTH$,HEIGHT$,MAXFRAME$,FPS$)
ASSIGN ".\DLL\getvideoframe.dll","videoinfo"
END FUNCTION
END SUB
EXTERNAL SUB GETVIDEOFRAME(VIDEONAME$,XSIZE,YSIZE,M(,),N)
OPTION CHARACTER BYTE
LET MAP$=REPEAT$(CHR$(0),XSIZE*YSIZE*3)
LET NUM=GETVIDEOFRAME_(VIDEONAME$,MAP$,INT(N+.5))
IF NUM=-1 THEN
PRINT "動画ファイルをロードできません"
STOP
END IF
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET ADR=(Y*XSIZE+X)*3+1
LET R=ORD(MAP$(ADR+2:ADR+2))
LET G=ORD(MAP$(ADR+1:ADR+1))
LET B=ORD(MAP$(ADR:ADR))
LET M(X,Y)=COLORINDEX(R/255,G/255,B/255)
NEXT X
NEXT Y
!'
FUNCTION GETVIDEOFRAME_(VIDEONAME$,MAP$,NUM)
ASSIGN ".\DLL\getvideoframe.dll","getvideoframe"
END FUNCTION
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
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
!'USBカメラ映像を表示する
OPTION BASE 0
LET XSIZE=640 !'カメラデバイス対応の解像度を指定すること
LET YSIZE=480
LET ID=0 !'カメラデバイスナンバー
DIM M(XSIZE,YSIZE)
CALL GINIT(XSIZE,YSIZE)
DO
CALL GETCAMERAFRAME(ID,XSIZE,YSIZE,M)
MAT PLOT CELLS,IN 0,0;XSIZE-1,YSIZE-1:M
WAIT DELAY .3
LOOP
END
EXTERNAL SUB GETCAMERAFRAME(ID,WIDTH,HEIGHT,M(,))
OPTION CHARACTER BYTE
LET MAP$=REPEAT$(CHR$(0),WIDTH*HEIGHT*3)
LET NUM=GETCAMERAFRAME_(ID,WIDTH,HEIGHT,MAP$)
IF NUM=-1 THEN
PRINT "カメラデバイスが見つかりません"
STOP
ELSEIF NUM=-2 THEN
PRINT "データが読み出せません"
STOP
END IF
FOR Y=0 TO HEIGHT-1
FOR X=0 TO WIDTH-1
LET ADR=(Y*WIDTH+X)*3+1
LET R=ORD(MAP$(ADR+2:ADR+2))
LET G=ORD(MAP$(ADR+1:ADR+1))
LET B=ORD(MAP$(ADR:ADR))
LET M(X,Y)=COLORINDEX(R/255,G/255,B/255)
NEXT X
NEXT Y
!'
FUNCTION GETCAMERAFRAME_(ID,WIDTH,HEIGHT,MAP$)
ASSIGN ".\DLL\getcameraframe.dll","getcameraframe"
END FUNCTION
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
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
OPTION BASE 0
FILE GETNAME F$,"ソース画像ファイル|*.jpg;*.png;*.bmp"
IF F$="" THEN STOP
CALL PICTURELOAD(F$,XSIZE,YSIZE)
SET WINDOW 0,XSIZE-1,YSIZE-1,0
DIM SRC(XSIZE,YSIZE)
ASK PIXEL ARRAY (0,0) SRC
FILE GETNAME T$,"テンプレート画像ファイル|*.jpg;*.png;*.bmp" !'検索画像
IF T$="" THEN STOP
CALL PICTURELOAD(T$,XSIZE_T,YSIZE_T)
PAUSE !'一旦停止(テンプレート画像表示)
CALL GINIT(XSIZE,YSIZE)
MAT PLOT CELLS,IN 0,0; XSIZE-1,YSIZE-1:SRC !'画像表示
CALL TEMPLATEMATCHING(F$,T$,3,XS,YS,XE,YE,LMIN,LMAX)
SET LINE WIDTH 3
CALL BOX(XS,YS,XE,YE,255,0,0)
PRINT XS;YS;XE;YE
PRINT LMIN;LMAX
END
EXTERNAL SUB TEMPLATEMATCHING(FILENAME$,TEMPLATENAME$,SW,XS,YS,XE,YE,LMIN,LMAX)
LET XS$=REPEAT$(CHR$(0),8)
LET YS$=REPEAT$(CHR$(0),8)
LET XE$=REPEAT$(CHR$(0),8)
LET YE$=REPEAT$(CHR$(0),8)
LET LMIN$=REPEAT$(CHR$(0),8)
LET LMAX$=REPEAT$(CHR$(0),8)
LET NUM=TEMPLATEMATCHING_(FILENAME$,TEMPLATENAME$,SW,XS$,YS$,XE$,YE$,LMIN$,LMAX$)
IF NUM=-1 THEN
PRINT "ソース画像ファイルが読めません"
STOP
ELSEIF NUM=-2 THEN
PRINT "テンプレート画像ファイルが読めません"
STOP
END IF
LET LMIN=UNPACKDBL(LMIN$)
LET LMAX=UNPACKDBL(LMAX$)
LET XS=UNPACKDBL(XS$)
LET YS=UNPACKDBL(YS$)
LET XE=UNPACKDBL(XE$)
LET YE=UNPACKDBL(YE$)
!'
FUNCTION TEMPLATEMATCHING_(FILENAME$,TEMPLATENAME$,SW,XS$,YS$,XE$,YE$,LMIN$,LMAX$)
ASSIGN ".\DLL\templatematching.dll","templatematching"
END FUNCTION
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
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 PICTURELOAD(N$,XSIZE,YSIZE)
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
END SUB
EXTERNAL SUB BOX(XS,YS,XE,YE,R,G,B)
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES:XS,YS;XE,YS
PLOT LINES:XE,YS;XE,YE
PLOT LINES:XE,YE;XS,YE
PLOT LINES:XS,YE;XS,YS
END SUB
FILE GETNAME IMAGENAME$,"画像ファイル|*.bmp;*.dib;*.jpg;*.jpe;*.jpeg;*.jp2;*.png;*.pbm;*.pgm;*.ppm;*.sr;*.ras;*.tif;*.tiff;*.webp"
CALL IMAGELOAD(IMAGENAME$)
END
EXTERNAL SUB IMAGEINFO(FILENAME$,WIDTH,HEIGHT)
OPTION CHARACTER BYTE
LET WIDTH$=REPEAT$(CHR$(0),8)
LET HEIGHT$=REPEAT$(CHR$(0),8)
LET NUM=IMAGEINFO_(FILENAME$,WIDTH$,HEIGHT$)
IF NUM=-1 THEN
PRINT "画像ファイルをロードできません"
STOP
END IF
LET WIDTH=UNPACKDBL(WIDTH$)
LET HEIGHT=UNPACKDBL(HEIGHT$)
PRINT WIDTH;HEIGHT
!'
FUNCTION IMAGEINFO_(FILENAME$,WIDTH$,HEIGHT$)
ASSIGN ".\DLL\imageload.dll","imageinfo"
END FUNCTION
END SUB
EXTERNAL SUB IMAGELOAD(FILENAME$)
OPTION BASE 0
OPTION CHARACTER BYTE
IF FILENAME$="" THEN STOP
CALL IMAGEINFO(FILENAME$,WIDTH,HEIGHT)
LET MAP$=REPEAT$(CHR$(0),WIDTH*HEIGHT*3+100)
LET NUM=IMAGELOAD_(FILENAME$,MAP$)
IF NUM=-1 THEN
PRINT "画像ファイルをロードできません"
STOP
END IF
DIM M(WIDTH,HEIGHT)
CALL GINIT(WIDTH,HEIGHT)
FOR Y=0 TO HEIGHT-1
FOR X=0 TO WIDTH-1
LET ADR=(Y*WIDTH+X)*3+1
LET R=ORD(MAP$(ADR+2:ADR+2))
LET G=ORD(MAP$(ADR+1:ADR+1))
LET B=ORD(MAP$(ADR:ADR))
LET M(X,Y)=COLORINDEX(R/255,G/255,B/255)
NEXT X
NEXT Y
MAT PLOT CELLS,IN 0,0;WIDTH-1,HEIGHT-1:M
!'
FUNCTION IMAGELOAD_(FILENAME$,MAP$)
ASSIGN ".\DLL\imageload.dll","loadimage"
END FUNCTION
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
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
FILE GETNAME F$,"画像ファイル|*.jpg;*.jpeg;*.png;*.gif;*.bmp"
CALL PICTURELOAD(F$,XSIZE,YSIZE)
CALL GRAY(XSIZE*.2,YSIZE*.2,XSIZE*.8,YSIZE*.8)
END
EXTERNAL SUB GRAY(XS,YS,XE,YE)
OPTION BASE 0
OPTION CHARACTER BYTE
LET XSIZE=INT(XE)-INT(XS)+1
LET YSIZE=INT(YE)-INT(YS)+1
DIM IN(XSIZE,YSIZE),OUT(XSIZE,YSIZE)
ASK PIXEL ARRAY (XS,YS) IN
LET IN$=REPEAT$(CHR$(0),XSIZE*YSIZE*3)
LET OUT$=REPEAT$(CHR$(0),XSIZE*YSIZE*3)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET ADR=(Y*XSIZE+X)*3+1
CALL RGB(IN(X,Y),R,G,B)
LET IN$(ADR:ADR)=CHR$(B)
LET IN$(ADR+1:ADR+1)=CHR$(G)
LET IN$(ADR+2:ADR+2)=CHR$(R)
NEXT X
NEXT Y
CALL GRAY_(IN$,OUT$,XSIZE,YSIZE)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET ADR=(Y*XSIZE+X)+1
LET R=ORD(OUT$(ADR:ADR))
LET G=ORD(OUT$(ADR:ADR))
LET B=ORD(OUT$(ADR:ADR))
LET OUT(X,Y)=COLORINDEX(R/255,G/255,B/255)
NEXT X
NEXT Y
MAT PLOT CELLS,IN XS,YS;XE,YE:OUT !'画像表示
!'
SUB GRAY_(INIMAGE$,OUTIMAGE$,WIDTH,HEIGHT)
ASSIGN ".\DLL\imageprocessing.dll","gray_"
END SUB
END SUB
OPTION BASE 0
OPTION ARITHMETIC RATIONAL
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=50
DIM X(MAXLEVEL+1)
OPEN #1:NAME "和の公式.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>和の公式</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>和の公式</h1>"
LET X(1)=1
FOR K=1 TO MAXLEVEL
CALL SHORTMUL(X,K)
CALL INTEGRAL(X)
LET S=1
FOR I=MAXLEVEL TO 2 STEP-1
LET S=S-X(I)
NEXT I
LET X(1)=S
PRINT #1:"<math>"
PRINT #1:" <munderover>"
PRINT #1:" <mi>∑</mi>"
PRINT #1:" <mrow>"
PRINT #1:" <mi>k</mi>"
PRINT #1:" <mo>=</mo>"
PRINT #1:" <mn>1</mn>"
PRINT #1:" </mrow>"
PRINT #1:" <mi>n</mi>"
PRINT #1:" </munderover>"
PRINT #1:" <msup>"
PRINT #1:" <mi>k</mi>"
IF K>1 THEN PRINT #1:" <mn>";STR$(K);"</mn>"
PRINT #1:" </msup>"
PRINT #1:"<mo>=</mo>"
CALL DISPLAY(X,#1)
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
NEXT K
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB INTEGRAL(A())
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
DIM B(MAXLEVEL)
FOR I=MAXLEVEL-1 TO 0 STEP-1
LET B(I+1)=A(I)/(I+1)
NEXT I
CALL COPY(A,B)
END SUB
EXTERNAL FUNCTION DIMCHECK(X())
OPTION ARITHMETIC RATIONAL
FOR N=MAXLEVEL TO 0 STEP -1
IF X(N)<>0 THEN EXIT FOR
NEXT N
LET DIMCHECK=N
END FUNCTION
EXTERNAL SUB DISPLAY(A(),#1)
OPTION ARITHMETIC RATIONAL
LET N=DIMCHECK(A)
IF N>1 THEN
IF A(N)<0 THEN PRINT #1:"<mo>-</mo>"
IF ABS(A(N))<>1 THEN
IF ABS(DENOM(A(N)))=1 THEN
PRINT #1:" <mn>";STR$(ABS(A(N)));"</mn>"
ELSE
PRINT #1:"<mfrac>"
PRINT #1:" <mn>";STR$(ABS(NUMER(A(N))));"</mn>"
PRINT #1:" <mn>";STR$(ABS(DENOM(A(N))));"</mn>"
PRINT #1:"</mfrac>"
END IF
PRINT #1:"<msup>"
PRINT #1:" <mi>n</mi>"
PRINT #1:" <mn>";STR$(N);"</mn>"
PRINT #1:"</msup>"
ELSE
IF ABS(DENOM(A(N)))=1 THEN
PRINT #1:" <mn>";STR$(ABS(A(N)));"</mn>"
ELSE
PRINT #1:"<mfrac>"
PRINT #1:" <mn>";STR$(ABS(NUMER(A(N))));"</mn>"
PRINT #1:" <mn>";STR$(ABS(DENOM(A(N))));"</mn>"
PRINT #1:"</mfrac>"
END IF
PRINT #1:"<msup>"
PRINT #1:" <mi>n</mi>"
PRINT #1:"</msup>"
END IF
END IF
FOR I=N-1 TO 2 STEP-1
IF A(I)<>0 THEN
IF A(I)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
IF ABS(A(I))<>1 THEN
IF ABS(DENOM(A(I)))=1 THEN
PRINT #1:" <mn>";STR$(ABS(A(I)));"</mn>"
ELSE
PRINT #1:"<mfrac>"
PRINT #1:" <mn>";STR$(ABS(NUMER(A(I))));"</mn>"
PRINT #1:" <mn>";STR$(ABS(DENOM(A(I))));"</mn>"
PRINT #1:"</mfrac>"
END IF
PRINT #1:"<msup>"
PRINT #1:" <mi>n</mi>"
PRINT #1:" <mn>";STR$(I);"</mn>"
PRINT #1:"</msup>"
ELSEIF ABS(A(I))=1 THEN
PRINT #1:"<msup>"
PRINT #1:" <mi>n</mi>"
PRINT #1:" <mn>";STR$(I);"</mn>"
PRINT #1:"</msup>"
END IF
END IF
NEXT I
IF A(1)<>0 THEN
IF N>1 THEN
IF A(1)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
END IF
IF ABS(A(1))<>1 THEN
IF ABS(DENOM(A(1)))=1 THEN
PRINT #1:" <mn>";STR$(ABS(A(1)));"</mn>"
ELSE
PRINT #1:"<mfrac>"
PRINT #1:" <mn>";STR$(ABS(NUMER(A(1))));"</mn>"
PRINT #1:" <mn>";STR$(ABS(DENOM(A(1))));"</mn>"
PRINT #1:"</mfrac>"
END IF
PRINT #1:"<mi>n</mi>"
ELSEIF ABS(A(1))=1 THEN
PRINT #1:"<mi>n</mi>"
END IF
END IF
IF A(0)<>0 THEN
IF A(0)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
IF ABS(DENOM(A(0)))=1 THEN
PRINT #1:" <mn>";STR$(ABS(A(0)));"</mn>"
ELSE
PRINT #1:"<mfrac>"
PRINT #1:" <mn>";STR$(ABS(NUMER(A(0))));"</mn>"
PRINT #1:" <mn>";STR$(ABS(DENOM(A(0))));"</mn>"
PRINT #1:"</mfrac>"
END IF
END IF
END SUB
EXTERNAL SUB COPY(X(),Y())
OPTION ARITHMETIC RATIONAL
MAT X=Y
END SUB
EXTERNAL SUB SHORTMUL(X(),S)
OPTION ARITHMETIC RATIONAL
MAT X=(S)*X
END SUB
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
LET MAXLEVEL=50
DIM S(MAXLEVEL,MAXLEVEL)
OPEN #1:NAME "SIN倍角公式.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>SIN倍角公式</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>SIN倍角公式</h1>"
FOR N=2 TO MAXLEVEL
PRINT #1:"<math>"
PRINT #1:"<mi>sin</mi>"
PRINT #1:"<mn>";STR$(N);"</mn>"
PRINT #1:"<mi>θ</mi>"
PRINT #1:"<mo>=</mo>"
FOR K=0 TO N/2
IF N-2*K-1>=0 THEN LET S(2*K+1,N-2*K-1)=(-1)^K*COMB(N,2*K+1)
NEXT K
CALL DISPLAYSIN(S,N,#1)
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
MAT S=ZER
NEXT N
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB DISPLAYSIN(SINE(,),K,#1)
OPTION ARITHMETIC RATIONAL
DIM S(0 TO 2)
LET S(0)=1
LET S(2)=-1
FOR L=K TO 2 STEP-1
FOR I=0 TO K-2
FOR J=0 TO 2
LET SINE(I+J,L-2)=SINE(I+J,L-2)+SINE(I,L)*S(J)
NEXT J
LET SINE(I,L)=0
NEXT I
NEXT L
FOR I=K TO 0 STEP-1
FOR J=K TO 0 STEP-1
IF SINE(I,J)<>0 THEN
IF FL=0 THEN
IF SINE(I,J)<0 THEN PRINT #1:"<mo>-</mo>"
END IF
IF FL=1 THEN
IF SINE(I,J)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
END IF
IF I>1 THEN
PRINT #1:"<mn>";STR$(ABS(SINE(I,J)));"</mn>"
PRINT #1:"<msup>"
PRINT #1:" <mi>sin</mi>"
PRINT #1:" <mn>";STR$(I);"</mn>"
PRINT #1:"</msup>"
PRINT #1:" <mi>θ</mi>"
ELSEIF I=1 THEN
PRINT #1:"<mn>";STR$(ABS(SINE(I,J)));"</mn>"
PRINT #1:"<mi>sin</mi>"
PRINT #1:" <mi>θ</mi>"
END IF
IF J>1 THEN
PRINT #1:"<msup>"
PRINT #1:" <mi>cos</mi>"
PRINT #1:" <mn>";STR$(J);"</mn>"
PRINT #1:"</msup>"
PRINT #1:" <mi>θ</mi>"
ELSEIF J=1 THEN
PRINT #1:"<mi>cos</mi>"
PRINT #1:" <mi>θ</mi>"
END IF
LET FL=1
END IF
NEXT J
NEXT I
END SUB
OPTION BASE 0
OPTION ARITHMETIC RATIONAL
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=50
DIM NEWCOSINE(MAXLEVEL+1),COSINE(MAXLEVEL),OLDCOSINE(MAXLEVEL)
OPEN #1:NAME "COS倍角公式.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>COS倍角公式</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>COS倍角公式</h1>"
LET OLDCOSINE(0)=1
LET COSINE(1)=1
FOR K=2 TO MAXLEVEL
FOR J=0 TO K
LET NEWCOSINE(J+1)=NEWCOSINE(J+1)+2*COSINE(J)
LET NEWCOSINE(J)=NEWCOSINE(J)-OLDCOSINE(J)
NEXT J
PRINT #1:"<math>"
PRINT #1:"<mi>cos</mi>"
PRINT #1:"<mn>";STR$(K);"</mn>"
PRINT #1:"<mi>θ</mi>"
PRINT #1:"<mo>=</mo>"
CALL DISPLAYCOS(K,NEWCOSINE,#1)
PRINT
FOR I=0 TO K
LET OLDCOSINE(I)=COSINE(I)
LET COSINE(I)=NEWCOSINE(I)
LET NEWCOSINE(I)=0
NEXT I
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
NEXT K
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB DISPLAYCOS(K,COSINE(),#1)
OPTION ARITHMETIC RATIONAL
PRINT #1:"<mn>";STR$(COSINE(K));"</mn>"
PRINT #1:"<msup>"
PRINT #1:" <mi>cos</mi>"
PRINT #1:" <mn>";STR$(K);"</mn>"
PRINT #1:"</msup>"
PRINT #1:"<mi>θ</mi>"
FOR I=K-1 TO 1 STEP-1
IF COSINE(I)<>0 THEN
IF COSINE(I)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
IF I>1 THEN
PRINT #1:"<mn>";STR$(ABS(COSINE(I)));"</mn>"
PRINT #1:"<msup>"
PRINT #1:" <mi>cos</mi>"
PRINT #1:" <mn>";STR$(I);"</mn>"
PRINT #1:"</msup>"
PRINT #1:" <mi>θ</mi>"
ELSE
PRINT #1:"<mn>";STR$(ABS(COSINE(I)));"</mn>"
PRINT #1:"<mi>cos</mi>"
PRINT #1:"<mi>θ</mi>"
END IF
END IF
NEXT I
IF COSINE(0)<>0 THEN
IF COSINE(0)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
PRINT #1:"<mn>";STR$(ABS(COSINE(0)));"</mn>"
END IF
PRINT
END SUB
OPTION BASE 0
OPTION ARITHMETIC RATIONAL
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=50
DIM A(MAXLEVEL),B(MAXLEVEL),AA(MAXLEVEL),BB(MAXLEVEL),C(1),D(1)
LET C(0)=1
LET D(1)=1
LET B(1)=1
LET A(0)=1
OPEN #1:NAME "TAN倍角公式.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>TAN倍角公式</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>TAN倍角公式</h1>"
FOR K=2 TO MAXLEVEL
FOR J=0 TO 1
FOR I=0 TO MAXLEVEL-J
LET AA(I+J)=AA(I+J)+A(I)*C(J)-B(I)*D(J)
LET BB(I+J)=BB(I+J)+B(I)*C(J)+A(I)*D(J)
NEXT I
NEXT J
MAT A=AA
MAT B=BB
MAT AA=ZER
MAT BB=ZER
PRINT #1:"<math>"
PRINT #1:"<mi>tan</mi>"
PRINT #1:"<mn>";STR$(K);"</mn>"
PRINT #1:"<mi>θ</mi>"
PRINT #1:"<mo>=</mo>"
PRINT #1:"<mfrac>"
PRINT #1:"<mrow>"
CALL DISPLAY(B,#1)
PRINT #1:"</mrow>"
PRINT #1:"<mrow>"
CALL DISPLAY(A,#1)
PRINT #1:"</mrow>"
PRINT #1:"</mfrac>"
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
NEXT K
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB DISPLAY(B(),#1)
OPTION ARITHMETIC RATIONAL
FOR JJ=MAXLEVEL TO 0 STEP-1
IF B(JJ)<>0 THEN EXIT FOR
NEXT JJ
IF ABS(B(JJ))<>1 AND JJ>1 THEN
PRINT #1:"<mn>";STR$(B(JJ));"</mn>"
PRINT #1:"<msup>"
PRINT #1:" <mi>tan</mi>"
PRINT #1:" <mn>";STR$(JJ);"</mn>"
PRINT #1:"</msup>"
PRINT #1:" <mi>θ</mi>"
ELSEIF ABS(B(JJ))=1 AND JJ>1 THEN
IF B(JJ)<0 THEN PRINT #1:"<mo>-</mo>"
PRINT #1:"<msup>"
PRINT #1:" <mi>tan</mi>"
PRINT #1:" <mn>";STR$(JJ);"</mn>"
PRINT #1:"</msup>"
PRINT #1:"<mi>θ</mi>"
END IF
FOR J=JJ-1 TO 2 STEP-1
IF B(J)<>0 THEN
IF B(J)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
IF B(J)<>1 THEN
PRINT #1:"<mn>";STR$(ABS(B(J)));"</mn>"
PRINT #1:"<msup>"
PRINT #1:" <mi>tan</mi>"
PRINT #1:" <mn>";STR$(J);"</mn>"
PRINT #1:"</msup>"
PRINT #1:"<mi>θ</mi>"
ELSEIF B(J)=1 THEN
PRINT #1:"<msup>"
PRINT #1:" <mi>tan</mi>"
PRINT #1:" <mn>";STR$(J);"</mn>"
PRINT #1:"</msup>"
PRINT #1:"<mi>θ</mi>"
END IF
END IF
NEXT J
IF B(1)<>0 THEN
IF JJ>1 THEN
IF B(1)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
END IF
IF B(1)<>1 THEN
PRINT #1:"<mn>";STR$(ABS(B(1)));"</mn>"
PRINT #1:"<mi>tan</mi>"
PRINT #1:"<mi>θ</mi>"
ELSEIF B(1)=1 THEN
PRINT #1:"<mi>tan</mi>"
PRINT #1:"<mi>θ</mi>"
END IF
END IF
IF B(0)<>0 THEN
IF B(0)<0 THEN PRINT #1:"<mo>-</mo>" ELSE PRINT #1:"<mo>+</mo>"
PRINT #1:"<mn>";STR$(ABS(B(0)));"</mn>"
END IF
END SUB
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=51
DIM X(1),Y(MAXLEVEL),L(MAXLEVEL),M(MAXLEVEL)
INPUT PROMPT "微分階数=":NN
IF MOD(NN,2)=0 THEN LET N1=1 ELSE LET N1=2
OPEN #1:NAME "数値"&STR$(NN)&"次微分公式.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>数値"&STR$(NN)&"次微分公式</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>数値"&STR$(NN)&"次微分公式</h1>"
FOR N=NN+N1 TO MAXLEVEL STEP 2
LET P=INT(N/2+1) !'中央差分式
!' FOR P=1 TO N
FOR K=1 TO N
MAT Y=ZER
LET Y(0)=1
FOR I=1 TO N
IF K<>I THEN
LET X(0)=-I
LET X(1)=1
CALL MUL(Y,X)
END IF
NEXT I
LET L(K)=HORNER(Y,K)
FOR I=1 TO NN
CALL DERIVATIVE(Y)
NEXT I
LET M(K)=HORNER(Y,P)
NEXT K
PRINT #1:"<math>"
PRINT #1:"<mfrac>"
PRINT #1:" <mrow>"
PRINT #1:" <msup>"
PRINT #1:" <mi>d</mi>"
IF NN>1 THEN PRINT #1:" <mn>";STR$(NN);"</mn>"
PRINT #1:" </msup>"
PRINT #1:" </mrow>"
PRINT #1:" <mrow>"
PRINT #1:" <msup>"
PRINT #1:" <mi>dx</mi>"
IF NN>1 THEN PRINT #1:" <mn>";STR$(NN);"</mn>"
PRINT #1:" </msup>"
PRINT #1:" </mrow>"
PRINT #1:"</mfrac>"
PRINT #1:"<mi>f</mi>"
PRINT #1:"<mfenced>"
PRINT #1:" <mi>x</mi>"
PRINT #1:"</mfenced>"
PRINT #1:"<mo>=</mo>"
FOR I=1 TO N
LET GM=GCD(M(I),L(I))
LET M(I)=M(I)/GM
LET L(I)=L(I)/GM
NEXT I
LET LM=L(1)
FOR I=2 TO N
LET LM=LCM(LM,L(I))
NEXT I
FOR I=1 TO N
LET B=LM/L(I)
LET M(I)=M(I)*B
LET L(I)=L(I)*B
NEXT I
PRINT #1:"<mfrac>"
PRINT #1:"<mrow>"
FOR I=1 TO N
IF ABS(M(I))<>0 THEN
IF M(I)*L(I)<0 THEN
PRINT #1:"<mo>-</mo>"
ELSE
IF I>1 THEN PRINT #1:"<mo>+</mo>"
END IF
IF ABS(M(I))<>1 THEN PRINT #1:"<mn>";STR$(ABS(M(I)));"</mn>"
PRINT #1:"<mi>f</mi>"
PRINT #1:"<mfenced>"
PRINT #1:"<mrow>"
PRINT #1:"<mi>x</mi>"
IF ABS(P-I)>0 THEN
IF P-I<0 THEN PRINT #1:"<mo>+</mo>" ELSE PRINT #1:"<mo>-</mo>"
IF ABS(P-I)>1 THEN PRINT #1:"<mn>";STR$(ABS(P-I));"</mn>"
PRINT #1:"<mi>h</mi>"
END IF
PRINT #1:"</mrow>"
PRINT #1:"</mfenced>"
END IF
NEXT I
PRINT #1:"</mrow>"
PRINT #1:"<mrow>"
PRINT #1:"<mn>";STR$(ABS(L(1)));"</mn>"
PRINT #1:"<msup>"
PRINT #1:"<mi>h</mi>"
IF NN>1 THEN PRINT #1:"<mn>";STR$(NN);"</mn>"
PRINT #1:"</msup>"
PRINT #1:"</mrow>"
PRINT #1:"</mfrac>"
!'NEXT P
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
NEXT N
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB MUL(A(),B())
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
DIM C(MAXLEVEL)
FOR I=0 TO 1
FOR J=0 TO MAXLEVEL-I
LET C(I+J)=C(I+J)+A(J)*B(I)
NEXT J
NEXT I
MAT A=C
END SUB
EXTERNAL SUB DERIVATIVE(A())
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
DIM B(MAXLEVEL)
FOR I=MAXLEVEL TO 1 STEP-1
LET B(I-1)=I*A(I)
NEXT I
MAT A=B
END SUB
EXTERNAL FUNCTION HORNER(A(),XX)
OPTION ARITHMETIC RATIONAL
LET Y=A(MAXLEVEL)
FOR I=MAXLEVEL-1 TO 0 STEP-1
LET Y=Y*XX+A(I)
NEXT I
LET HORNER=Y
END FUNCTION
EXTERNAL FUNCTION LCM(A,B)
OPTION ARITHMETIC RATIONAL
LET LCM=A*B/GCD(A,B)
END FUNCTION
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
PUBLIC NUMERIC MAXLEVEL
LET MAXLEVEL=20
DIM X(1),Y(MAXLEVEL+1),L(MAXLEVEL+1)
OPEN #1:NAME "数値積分公式.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>数値積分公式</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>数値積分公式</h1>"
FOR N=1 TO MAXLEVEL
FOR I=0 TO N
CALL CLR(Y)
LET P=1
LET Y(0)=1
FOR J=0 TO N
IF I<>J THEN
LET X(0)=-J
LET X(1)=1
CALL MUL(Y,X)
LET P=P*(I-J)
END IF
NEXT J
CALL INTEGRAL(Y)
LET L(I)=HORNER(Y,N)/P
NEXT I
PRINT #1:"<math>"
PRINT #1:"<msubsup>"
PRINT #1:" <mo>∫</mo>"
PRINT #1:" <mi>x0</mi>"
PRINT #1:" <mi>x";STR$(N);"</mi>"
PRINT #1:"</msubsup>"
PRINT #1:"<mi>f</mi>"
PRINT #1:"<mfenced>"
PRINT #1:" <mi>x</mi>"
PRINT #1:"</mfenced>"
PRINT #1:"<mrow>"
PRINT #1:" <mi>d</mi>"
PRINT #1:" <mi>x</mi>"
PRINT #1:"</mrow>"
PRINT #1:"<mo>=</mo>"
FOR I=0 TO N
IF L(I)<0 THEN
PRINT #1:"<mo>-</mo>"
ELSE
IF I<>0 THEN PRINT #1:"<mo>+</mo>"
END IF
IF ABS(DENOM(L(I)))=1 THEN
PRINT #1:" <mn>";STR$(ABS(L(I)));"</mn>"
ELSE
PRINT #1:"<mfrac>"
PRINT #1:" <mn>";STR$(ABS(NUMER(L(I))));"</mn>"
PRINT #1:" <mn>";STR$(ABS(DENOM(L(I))));"</mn>"
PRINT #1:"</mfrac>"
END IF
PRINT #1:"<mi>h</mi>"
PRINT #1:"<mi>f</mi>"
PRINT #1:"<mfenced>"
PRINT #1:" <mi>x";STR$(I);"</mi>"
PRINT #1:"</mfenced>"
NEXT I
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
NEXT N
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB MUL(A(),B())
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
DIM C(MAXLEVEL)
FOR I=0 TO 1
FOR J=0 TO MAXLEVEL-I
LET C(I+J)=C(I+J)+A(J)*B(I)
NEXT J
NEXT I
CALL COPY(A,C)
END SUB
EXTERNAL FUNCTION HORNER(A(),XX)
OPTION ARITHMETIC RATIONAL
LET N=DIMCHECK(A)
LET Y=A(N)
FOR I=N-1 TO 0 STEP-1
LET Y=Y*XX+A(I)
NEXT I
LET HORNER=Y
END FUNCTION
EXTERNAL SUB COPY(X(),Y())
OPTION ARITHMETIC RATIONAL
MAT X=Y
END SUB
EXTERNAL FUNCTION DIMCHECK(X())
OPTION ARITHMETIC RATIONAL
FOR N=MAXLEVEL TO 0 STEP-1
IF X(N)<>0 THEN EXIT FOR
NEXT N
LET DIMCHECK=N
END FUNCTION
EXTERNAL SUB CLR(X())
OPTION ARITHMETIC RATIONAL
MAT X=ZER
END SUB
EXTERNAL SUB INTEGRAL(A())
OPTION ARITHMETIC RATIONAL
OPTION BASE 0
DIM B(MAXLEVEL)
FOR I=MAXLEVEL-1 TO 0 STEP-1
LET B(I+1)=A(I)/(I+1)
NEXT I
CALL COPY(A,B)
END SUB
LET NN=4
LET MM=3
PUBLIC STRING A$(10,26,26),X$(26,26),SS$
DIM A(MM+1)
LET S$="abcdefghijklmnopqrstuvwxyz"
OPEN #1:NAME "行列掛け算.html"
ERASE #1
PRINT #1:"<!DOCTYPE html>"
PRINT #1:"<html>"
PRINT #1:"<head>"
PRINT #1:" <title>行列掛け算</title>"
PRINT #1:" <script async src=";CHR$(34);"https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2/MathJax.js?config=TeX-MML-AM_CHTML";CHR$(34);"></script>"
PRINT #1:"</head>"
PRINT #1:"<body>"
PRINT #1:"<h1>行列掛け算</h1>"
FOR M=1 TO MM
FOR I=1 TO NN
FOR J=1 TO NN
LET A$(M,I,J)="<msub><mi>"&S$(M:M)&"</mi><mn>"&STR$(I)&STR$(J)&"</mn></msub>"
NEXT J
NEXT I
NEXT M
FOR I=2 TO NN
FOR P=2 TO MM
PRINT #1:"<math>"
CALL RECURSIVE(1,P+1,I,A)
FOR M=1 TO P
PRINT #1:"<mfenced>"
PRINT #1:"<mtable>"
FOR J=1 TO I
PRINT #1:"<mtr>"
FOR K=1 TO I-1
PRINT #1:"<mtd>"
PRINT #1:A$(M,J,K)
PRINT #1:"</mtd>"
NEXT K
PRINT #1:"<mtd>"
PRINT #1:A$(M,J,I)
PRINT #1:"</mtd>"
PRINT #1:"</mtr>"
NEXT J
PRINT #1:"</mtable>"
PRINT #1:"</mfenced>"
NEXT M
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
PRINT #1:"<math>"
PRINT #1:"<mo>=</mo>"
CALL DISPLAY(I,X$,#1)
PRINT #1:"</math>"
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
PRINT #1:CHR$(60);CHR$(98);CHR$(114);CHR$(62)
NEXT P
NEXT I
PRINT #1:"</body>"
PRINT #1:"</html>"
CLOSE #1
END
EXTERNAL SUB RECURSIVE(NN,N,M,A())
IF N<NN THEN
LET SS$=SS$&"<mo>+</mo><mi>"&A$(1,A(1),A(3))&"</mi>"
FOR J=2 TO N-2
LET SS$=SS$&"<mi>"&A$(J,A(J+1),A(J+2))&"</mi>"
NEXT J
LET SS$=SS$&"<mi>"&A$(N-1,A(N),A(2))&"</mi>"
LET FL=0
FOR J=3 TO N
IF A(J)<>M THEN LET FL=1
NEXT J
IF FL=0 THEN
LET SS$(1:10)=""
LET X$(A(1),A(2))=SS$
LET SS$=""
END IF
ELSE
FOR I=1 TO M
LET A(NN)=I
CALL RECURSIVE(NN+1,N,M,A)
NEXT I
END IF
END SUB
EXTERNAL SUB DISPLAY(N,P$(,),#1)
PRINT #1:"<mfenced>"
PRINT #1:"<mtable>"
FOR I=1 TO N
PRINT #1:"<mtr>"
FOR J=1 TO N-1
PRINT #1:"<mtd>"
PRINT #1:P$(I,J)
PRINT #1:"</mtd>"
NEXT J
PRINT #1:"<mtd>"
PRINT #1:P$(I,N)
PRINT #1:"</mtd>"
PRINT #1:"</mtr>"
NEXT I
PRINT #1:"</mtable>"
PRINT #1:"</mfenced>"
END SUB
extern "C" __declspec(dllexport) unsigned int test(unsigned int a,unsigned int b)
{
int c;
c=a*b;
return c;
}
LET X=-3.2354885
LET Y=5.657321
LET X=INT(X+.5)
LET Y=INT(Y+.5)
PRINT TEST(X,Y);X*Y;
LET X=MOD(X+2^32,2^32)
LET Y=MOD(Y+2^32,2^32)
LET Z=MOD(X*Y+2^32,2^32)-2^32
PRINT Z
END
EXTERNAL FUNCTION TEST(X,Y)
ASSIGN "sample.dll","test"
END FUNCTION
OPTION CHARACTER BYTE
LET N=100
DIM A(N)
FOR I=1 TO N
LET A(I)=RND*100
NEXT
LET X$=REPEAT$(" ",8*N)
FOR I=0 TO N-1
LET X$(8*I+1:8*I+8)=PACKDBL$(A(I+1))
NEXT I
PRINT TEST(N,X$)
END
EXTERNAL FUNCTION TEST(N,X$)
OPTION CHARACTER BYTE
ASSIGN "sample.dll","sum",FPU
END FUNCTION
OPTION CHARACTER BYTE
LET N=100
LET M=50
DIM A(N,M)
FOR I=1 TO N
FOR J=1 TO M
LET A(I,J)=RND*100
NEXT J
NEXT I
LET X$=REPEAT$(" ",8*N*M)
FOR I=0 TO N-1
FOR J=0 TO M-1
LET X$(8*(I*M+J)+1:8*(I*M+J)+8)=PACKDBL$(A(I+1,J+1))
NEXT J
NEXT I
PRINT TEST(N,M,X$)
END
EXTERNAL FUNCTION TEST(N,M,X$)
OPTION CHARACTER BYTE
ASSIGN "sample.dll","sum",FPU
END FUNCTION
OPTION CHARACTER BYTE
RANDOMIZE
LET M=100
DIM XR(M),XI(M),YR(M),YI(M)
FOR I=1 TO M
LET XR(I)=INT(RND*1000)
LET XI(I)=0
NEXT I
LET XR$=REPEAT$(" ",M*8)
LET XI$=REPEAT$(" ",M*8)
LET YR$=REPEAT$(" ",M*8)
LET YI$=REPEAT$(" ",M*8)
FOR I=0 TO M-1
LET XR$(8*I+1:8*I+8)=PACKDBL$(XR(I+1))
LET XI$(8*I+1:8*I+8)=PACKDBL$(XI(I+1))
NEXT I
CALL DFT(M,XR$,XI$,YR$,YI$,0) !'dft
CALL DFT(M,YR$,YI$,XR$,XI$,1) !'idft
FOR I=0 TO M-1
PRINT INT(UNPACKDBL(XR$(8*I+1:8*I+8))/M+.5);XR(I+1)
NEXT I
END
EXTERNAL SUB DFT(M,XR$,XI$,YR$,YI$,SW)
OPTION CHARACTER BYTE
ASSIGN "dft.dll","dft"
END SUB
extern "C" __declspec(dllexport) void test(int n,long long int *a,long long int *s)
{
*s=0;
for(int i=0; i<n; i++) *s+=a[i];
}
OPTION ARITHMETIC RATIONAL
OPTION CHARACTER BYTE
RANDOMIZE
LET N=100
DIM A(N)
LET N$=REPEAT$(" ",8*N)
LET ANS$=REPEAT$(" ",8)
FOR I=0 TO N-1
LET A(I+1)=INT(RND*2^63)
LET S=MOD(S+A(I+1),2^63)
LET N$(8*I+1:8*I+8)=LWORD$(A(I+1))
NEXT I
CALL TEST(N,N$,ANS$)
PRINT INT64(ANS$)
PRINT S
END
EXTERNAL SUB TEST(NUM,N$,ANS$)
OPTION ARITHMETIC RATIONAL
OPTION CHARACTER BYTE
ASSIGN "sample.dll","test"
END SUB
EXTERNAL FUNCTION LWORD$(N)
OPTION ARITHMETIC RATIONAL
OPTION CHARACTER BYTE
DIM A$(8)
IF N<0 THEN LET N=N+2^64
FOR I=1 TO 8
LET A$(I)=CHR$(MOD(N,256))
LET N=INT(N/256)
NEXT I
LET LWORD$=A$(1)&A$(2)&A$(3)&A$(4)&A$(5)&A$(6)&A$(7)&A$(8)
END FUNCTION
EXTERNAL FUNCTION INT64(S$)
OPTION ARITHMETIC RATIONAL
OPTION CHARACTER BYTE
FOR I=1 TO 8
LET N=N+256^(I-1)*ORD(S$(I:I))
NEXT I
IF N>2^63 THEN LET N=N-2^63
LET INT64=N
END FUNCTION
long long int型は64bitの整数で8バイトです。
それに個数分のバッファーを用意して1次元配列を渡します。
受け取りはlong long int型1つなので8バイト分のバッファーを用意しておきます。
long long int型はBASIC側ではサポートされていないので自前で関数を用意します。
OPTION ARITHMETIC COMPLEX
OPTION CHARACTER BYTE
LET X=COMPLEX(.5,.5)
LET XX$=REPEAT$(" ",16)
LET YY$=REPEAT$(" ",16)
LET XX$(1:8)=PACKDBL$(RE(X))
LET XX$(9:16)=PACKDBL$(IM(X))
CALL CEXP(XX$,YY$)
PRINT UNPACKDBL(YY$(1:8));UNPACKDBL(YY$(9:16))
PRINT EXP(X)
END
EXTERNAL SUB CEXP(XX$,YY$)
OPTION ARITHMETIC COMPLEX
OPTION CHARACTER BYTE
ASSIGN "j:\src\cexp.dll","cexp"
END sub
BASICAcc -NR %1.bas
del .\output\*.o
del .\output\*.a
del .\output\*.ppu
del .\output\*.lfm
del .\output\*.err
del .\output\*.lpr
del .\output\*.pas
del .\output\*.rsj
Private Declare Function op Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4OpenDevice"(Byval q as Long,Byval w as Long) as Long
Private Declare Function al Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4AddListFromFileA"(Byval q as String,Byval w as Long,Byval e as Long) as Long
Private Declare Function pl Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4Play"(Byval q as Long,Byval w as Long,Byval e as Long,Byval r as Long,Byval t as Long) as Long
Private Declare Sub st Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4SetMasterTempo"(Byval q as double)
Private Declare Sub cl Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias "GGS4ClearList"()
Private Declare Sub co Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias "GGS4CloseDevice"()
Sub main()
dim w as double
e=op(-1100,0) 'この行は書き換え禁止！
e=al("ddd.mid",0,0) '""の中は任意のMIDIファイル名
e=pl(0,0,0,0,0)
for w=1to 3step.5
Call st(w)
Application.Wait((Timer+3)/86400) 'EXCELのWAITの引数の単位は丸１日を1とする小数
next
call cl:co:End
End Sub
Private Declare Function op Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4OpenDevice"(Byval q as Long,Byval w as Long) as Long
Private Declare Function al Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4AddListFromFileA"(Byval q as String,Byval w as Long,Byval e as Long) as Long
Private Declare Function pl Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4Play"(Byval q as Long,Byval w as Long,Byval e as Long,Byval r as Long,Byval t as Long) as Long
Private Declare Sub st Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4SetMasterTempo"(Byval q as single)
Private Declare Sub cl Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4ClearList"()
Private Declare Sub co Lib"c:\gurugurusmf\gurugurusmf4.dll"Alias"GGS4CloseDevice"()
Sub main()
dim w as single
e=op(-1100,0) 'この行は書き換え禁止！
e=al("ddd.mid",0,0) '""の中は任意のMIDIファイル名
e=pl(0,0,0,0,0)
for w=1to 3step.5
Call st(w)
Application.Wait((Timer+2)/86400)
next
call cl:co:End
End Sub
次はこれを十進BASICに移植しようと思い、以下のコオドを実行する。
e=op(-1100,0)
e=al("ddd.mid",0,0)
e=pl(0,0,0,0,0)
for w=1to 3step.5
Call st(w)
Wait DELAY 2
next
call cl
CALL co
End
EXTERNAL Function op(Q,W)
ASSIGN"c:\gurugurusmf\gurugurusmf4.dll","GGS4OpenDevice"
END FUNDTION
EXTERNAL FUNCTION al(q$,w,e)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4AddListFromFileA"
END FUNCTION
EXTERNAL FUNCTION pl(q,w,e,r,t)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4Play"
END FUNCTION
EXTERNAL SUB st(q)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4SetMasterTempo"
END SUB
EXTERNAL SUB ci
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4ClearList"
END SUB
EXTERNAL SUB cl
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4CloseDevice"
END SUB
OPTION CHARACTER byte
DECLARE EXTERNAL FUNCTION op,al,pl
open #1:NAME"f:\tenpuhairu\dum.dat",ACCESS INPUT
INPUT #1:I$
CLOSE #1
LET q=op(-1100,0)
LET q=al("DDD.mid",0,2)
LET q=pl(0,2,0,0,0)
FOR W=0TO 4
LET q$=I$(4*W+1:4*W+4)
CALL ST(q$)
WAIT DELAY 1
q$=""
NEXT
CALL ci
CALL cl
END
EXTERNAL FUNCTION op(q,w)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4OpenDevice"
END FUNCTION
EXTERNAL FUNCTION al(q$,w,e)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4AddListFromFileA"
END FUNCTION
EXTERNAL FUNCTION pl(q,w,e,r,t)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4Play"
END FUNCTION
EXTERNAL SUB ST(q$)
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4SetMasterTempo"
END SUB
EXTERNAL SUB ci
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4ClearList"
END SUB
EXTERNAL SUB cl
assign"c:\gurugurusmf\gurugurusmf4.dll","GGS4CloseDevice"
END SUB
矢張り結果は同じだった。もう十進Ｂの組み込み関数、PACKDBL$を用いて４バイト小数イメエジをを８バイト小数に換えたりしても全くダメ(ソース略)(もっとも十進Ｂは、普通のＤＬＬ関数の整数型変数を当てるべきところに文字列型変数を当てること自体受け付けないのだが...)。
すなわち、MSO VBA では４バイト小数型変数が使えるが、十進Bでは使えない、という結論に終わった(もっともVBAのほうも、GGSの使用はどうにかこうにかというレベルなのだが)。
しかしこれは、十進Bのバグと言うより、十進Bタイプの言語の限界なのだろう。
十進Bが、JIS FULL BASICの機能を実現するために作られたもので、JISに準拠しなければならないんだから仕方ないんですよね、白石先生。
FOR X=0 TO 1 STEP 1/8
LET N=FLOAT2INT(STR$(X))
PRINT N;TEST(N);X
NEXT X
END
EXTERNAL FUNCTION FLOAT2INT(A$)
OPTION CHARACTER BYTE
ASSIGN ".\DLL\float2int.dll","float2int"
END FUNCTION
EXTERNAL FUNCTION TEST(N)
ASSIGN ".\DLL\floattest.dll","test",FPU
END FUNCTION
------------------------------------------------------------------------
float2int.cpp
#include <cstdlib>
using namespace std;
extern "C" __declspec(dllexport) int float2int(char *a)
{
int n;
union {
float f;
unsigned char c[4];
} image;
BASICAcc1.2 source\Winlib.pasの226行目
result:=ProcAddr;
の直後に，
// restore stack (assume Cdecl)
for i:=0 to High(a) do
begin
asm
pop EAX
end;
end;
を追加すればCdeclの32ビットDLLが使えます。
（Lazarusを起動する必要はありません）
ただし，stdcallとは両立しません。
OPTION BASE 0
DIM bs(0 TO 2)
DIM ds(0 TO 2)
LET s=0
LET bs(0)=60
LET bs(1)=40
LET bs(2)=70
LET ds(0)=-0.25
LET ds(1)=-0.5
LET ds(2)=-0.7
SET WINDOW 0,250,-50,200
PRINT "タイミングよく←左↑真ん中→右"
DO
SET DRAW MODE HIDDEN
CLEAR
FOR i=0 TO 2
LET ds(i)=ds(i)+1.0/24.0
NEXT i
FOR i=0 TO 2
IF bs(i)>-50 THEN
LET bs(i)=bs(i)-ds(i)
DRAW disk WITH SCALE(10)*SHIFT(i*50+50,bs(i))
END IF
NEXT i
PLOT LINES: 0, 30 ; 400, 30
PLOT LINES: 0, 0 ; 400, 0
PLOT LINES: 0,-30 ; 400, -30
SET DRAW MODE EXPLICIT
IF s=0 THEN
LET s=1
LET sTime=TIME
DO
SET TEXT HEIGHT 40
PLOT TEXT ,AT 100, 100: STR$(CEIL(3-(TIME-sTime)))
SET TEXT HEIGHT 40
PLOT TEXT ,AT 100, 100: " "
FOR i=0 TO 2
DRAW disk WITH SCALE(10)*SHIFT(i*50+50,bs(i))
PLOT LINES: 0, 30 ; 400, 30
PLOT LINES: 0, 0 ; 400, 0
PLOT LINES: 0,-30 ; 400, -30
NEXT i
WAIT DELAY 1
CLEAR
LOOP WHILE (TIME-stime)<3
END IF
IF bs(0)<-49 OR bs(1)<-49 OR bs(2)<-49 THEN
EXIT DO
END IF
LET n=-1
LET enemyTime=TIME
DO
IF GetKeyState(37)<0 THEN
LET n=0
ELSeIF GetKeyState(38)<0 THEN
LET n=1
ELSeIF GetKeyState(39)<0 THEN
LET n=2
END IF
LOOP UNTIL (TIME-enemyTime)>(1.0/60.0)
IF n>-1 THEN
IF (bs(n)<30.0) AND (bs(n)>-30.0) AND (ds(n)>0.0) THEN
LET d=ABS(bs(n))/60.0-1.2
LET ds(n)=ds(n)*d
END IF
END IF
LOOP
