progloaderで「フラクタルグラフィック（一部未内蔵）」をダウンロードすると、
fractalGraphics.bas
TREE.bas
fractal15.bas
fractal16.bas
の４本が追加されます。
前２本が新規分です（後２本は内蔵サンプルと同じです）。
 | |
| fractalGraphics.bas |
 |
| TREE.bas |
ちなみに、以下は同プログラムのオリジナルのMZ-2500版での実行結果です(MZ-2500エミュレーター上での実行結果)。
オリジナルは雑誌I/Oの掲載されていたものですが、残念ながらそのページのコピーだけを持っていたので、何年何月号かは不明です。１９８５年頃だとは思うのですが。
X1-turbo/MZ-2500/PC-9801シリーズ「フラクタルグラフィック」江上邦博、下園真一
元があるので転載禁止です。
以下のリストはオリジナルのもの。動作確認はしてないので打ち込み間違いがあるかも。
1000 'program Fractal graphics
1005 ' for MZ-2500 BASIC-M25 ; 4096色パレット版
1010 INIT "CRT2:640,400,16":CLS 3
1020 '
1030 DEFINT I-K,P,X-Z
1040 DIM X(2200),Y(2200),Z(2200),C$(9)
1050 DEF FNMAXIM(N) = N* ( N+1 )/2
1060 DEF FNMIN(N)=FNMAXIM(N-1)+1
1070 FOR I=1 to 14:COLOR=(I,I+1,I+1,I+1):NEXT
1080 '
1090 '
1100 PAL=15 'How many colors ?
1110 LX=.57735027:LY=.57735027:LZ=-.57735027
1120 '
1130 X(1)=320 :Y(1)=30 :Z(1)=0
1140 X(2)=50 :Y(2)=350 :Z(2)=300
1150 X(3)=590 :Y(3)=350 :Z(3)=300
1160 '
1170 NDIM=2:GOSUB 1700 '*LDRAW
1180 ' *MAIN
1190 FOR LEVEL=1 TO 6
1200 NDIM=NDIM*2-1:GOSUB 1290 '*CALC
1210 CLS 2
1220 LOCATE 0,2 :PRINT "level";LEVEL
1230 GOSUB 1700 '*LDRAW
1240 NEXT
1250 GOSUB 1800 '*PAINT
1260 END
1270 '
1280 '
1290 '*CALC 'calculate
1300 FOR I=NDIM TO 3 STEP -2
1310 FOR K=FNMIN(I) TO FNMAXIM(I) STEP 2
1320 PT1=FNMIN((I+1)/2) :PT2=FNMIN(I)
1330 X(K)=X(PT1+(K-PT2)/2)
1340 Y(K)=Y(PT1+(K-PT2)/2)
1350 Z(K)=Z(PT1+(K-PT2)/2)
1360 NEXT K
1370 FOR K=FNMIN(I)+1 TO FNMAXIM(I)-1 STEP 2
1380 X1=X(K-1) :X2=X(K+1)
1390 Y1=Y(K-1) :Y2=Y(K+1)
1400 Z1=Z(K-1) :Z2=Z(K+1)
1410 GOSUB 1610 '*FRAC_FUNC
1420 X(K)=X:Y(K)=Y:Z(K)=Z
1430 NEXT K
1440 NEXT I
1450 FOR I=NDIM-1 TO 2 STEP -2
1460 FOR K=FNMIN(I) TO FNMAXIM(I)-1
1470 X1=X(K+I) :X2=X(K-I+1)
1480 Y1=Y(K+I) :Y2=Y(K-I+1)
1490 Z1=Z(K+I) :Z2=Z(K-I+1)
1500 GOSUB 1610 '*FRAC_FUNC
1510 X(K)=X :Y(K)=Y :Z(K)=Z
1520 NEXT K
1530 X1=X(K+I+1) :X2=X(K-I)
1540 Y1=Y(K+I+1) :Y2=Y(K-I)
1550 Z1=Z(K+I+1) :Z2=Z(K-I)
1560 GOSUB 1610 '*FHAC_FUNC
1570 PT1=FNMAXIM(I):X(PT1)=X:Y(PT1)=Y:Z(PT1)=Z
1580 NEXT I
1590 RETURN
1600 '
1610 '*FRAC_FUNC ' X,Y < X1.Y1-X2,Y2
1620 DX=ABS(X1-X2)
1630 DY=ABS(Y1-Y2)
1640 DZ=ABS(Z1-Z2)
1650 X=(X1+X2)/2+DX*.3*(RND-.5)
1660 Y=(Y1+Y2)/2+DY*.7*(RND-.5)
1670 Z=(Z1+Z2)/2+DZ*.4*(RND-.5)
1680 RETURN
1690 '
1700 ' *LDRAW LINE DRAW
1710 FOR I=1 TO NDIM-1
1720 FOR K=FNMIN(I) TO FNMAXIM(I)
1730 LINE (X(K) ,Y(K)) -(X(K+I) ,Y(K+I ))
1740 LINE (X(K) ,Y(K)) -(X(K+I+1),Y(K+I+1))
1750 LINE (X(K+I),Y(K+I))-(X(K+1+I),Y(K+1+I))
1760 NEXT K
1770 NEXT I
1780 RETURN
1790 '
1800 ' PAINT
1810 FOR I=1 TO NDIM-1
1820 FOR K=FNMIN(I) TO FNMAXIM(I)
1830 X1=X(K) :Y1=Y(K) :Z1=Z(K) :X2=X(K+I):Y2=Y(K+I):Z2=Z(K+I)
1835 X3=X(K+I+1):Y3=Y(K+I+1):Z3=Z(K+I+1)
1840 GOSUB 1920
1850 IF K=FNMAXIM(I) THEN 1880 'next
1860 X1=X(K) :Y1=Y(K) :Z1=Z(K) :X2=X(K+I+1) :Y2=Y(K+I+1) :Z2=Z(K+I+1)
1865 X3=X(K+1):Y3=Y(K+1):Z3=Z(K+1)
1870 GOSUB 1920
1880 NEXT K
1890 NEXT I
1900 RETURN
1910 '
1920 '*TRIANGLE
1930 X=(X1+X2+X3)/3:Y=(Y1+Y2+Y3)/3:Z=(Z1+Z2+Z3)/3
1940 S = ABS(X1*(Y2-Y3)+X2*(Y3-Y1)+X3*(Y1-Y2))/2:IF S<3 THEN 2060
1950 LINE (X1,Y1)-(X2,Y2),15
1960 LINE (X2,Y2)-(X3,Y3),15
1970 LINE (X3,Y3)-(X1,Y1),15
1980 ' brightness calc.
1990 DAX=X2-X1:DAY=Y2-Y1:DAZ=Z2-Z1:DBX=X3-X1:DBY=Y3-Y1:DBZ=Z3-Z1
2000 VX=DAY*DBZ-DAZ*DBY:VY=DAZ*DBX-DAX*DBZ:VZ=DAX*DBY-DAY*DBX
2010 VNRM=SQR(VX*VX+VY*VY+VZ*VZ):NX!=VX/VNRM:NY!=VY/VNRM:NZ!=VZ/VNRM
2020 BR=LX*NX+LY*NY+LZ*NZ:COL=INT(BR*PAL)
2030 IF COL<0 THEN COL=0 ELSE IF COL>PAL-1 THEN COL=PAL-1
2040 PAINT (X,Y),15,15
2050 PAINT (X,Y),COL,NOT 15:'時々ここでNO MEMORYエラーが出るが、その時は図形が複雑すぎるということで、re-runして
2060 RETURN
2990'
3000 ' *DEF_pattern
3010 RESTORE 3100
3020 FOR I=0 TO 8
3030 FOR K=1 TO 6
3040 READ D$
3050 C$(I)=C$(I)+CHR$(VAL("&H"+D$) )
3060 NEXT K
3070 NEXT I
3080 RETURN
3090 ' Tile Pattern Data
3100 DATA 00,00,00,00,00,00
3110 DATA 88,00,00,22,00,22
3120 DATA AA,00,00,55,00,55
3130 DATA 88,00,88,22,00,22
3140 DATA AA,00,AA,55,00,55
3150 DATA 77,00,77,DD,00,DD
3160 DATA FF,AA,FF,FF,55,FF
3170 DATA FF,77,FF,FF,DD,FF
3180 DATA FF,FF,FF,FF,FF,FF
0 件のコメント:
コメントを投稿