home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FreeWare Collection 2
/
FreeSoftwareCollection2pd199x-jp.img
/
fbasic
/
prelude
/
pds0a
/
fractal
/
frademo2.bas
< prev
next >
Wrap
BASIC Source File
|
1990-06-14
|
9KB
|
297 lines
100 ' F-BASIC386 SAMPLE PROGRAM % COPYRIGHT FUJITSU LIMITED 19900511
110 ' PUBLIC DOMAIN SOFTWARE by PRELUDE FMC(Fujitsuマイコンクラブ)
120 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
130 ' ★ ソフト名:フラクタル・デモ PART2 V4 ★
140 ' ★ 登録名 :FRADEMO02.BAS ★
150 ' ★ 登録者 :PRELUDE(Yuuichi Sasaki) ★
160 ' ★ 動作確認:FM-TOWNS 2 F-BASIC386 V1.1L20 ★
170 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
180 '
190 *環境 ' *** 環境設定 ***
200 CLEAR,,1024:WIDTH 80,25:CONSOLE 0,24,1
210 COLOR 5,1,0,4:CLS:SCREEN@ 1:PASTEL:S=1:PR=0:T=0
220 WINDOW (0,0)-(319,239):VIEW (0,0)-(319,239)
230 ON ERROR GOTO *異常
240 INTERVAL 2:ON INTERVAL GOSUB *時計:INTERVAL ON
250 ON KEY(1) GOSUB *PF1:KEY(1) ON
260 ON KEY(2) GOSUB *PF2:KEY(2) ON
270 ON KEY(3) GOSUB *PF3:KEY(3) ON
280 ON KEY(4) GOSUB *PF4:KEY(4) ON
290 ON KEY(5) GOSUB *PF5:KEY(5) ON
300 ON KEY(6) GOSUB *PF6:KEY(6) ON
310 KEY 1," 終了":KEY 2," ポーズ"
320 KEY 3," 書庫":KEY 4," メニュー"
330 KEY 5," ロード":KEY 6," 初期"
340 KEY 7," PF7":KEY 8," PF8"
350 KEY 9," PF9":KEY 10," PF10"
360 MOUSE 0
370 ON MOUSE(2) GOSUB *左押す:MOUSE(2) ON
380 ON MOUSE(4) GOSUB *右押す:MOUSE(4) ON
390 MOUSE 1,319,239,0
400 GOTO *MENU
410 '
420 *時計 ' *** 時計割込み処理 ***
430 INTERVAL OFF
440 TDT$=DATE$:TTM$=TIME$:TXX=POS(0):TYY=CSRLIN
450 LOCATE 2,1:PRINT TDT$;"†";TTM$;"†"
460 T=T+1:IF T=10 THEN COL=COL+1:COL=COL MOD 8:T=0
470 LOCATE TXX,TYY:INTERVAL ON:RETURN
480 '
490 *右押す ' *** マウス割込(終了) ***
500 MOUSE(2) OFF:MOUSE(4) OFF:INTERVAL OFF:RETURN *PF1
510 'MOUSE(2) ON:MOUSE(4) ON:INTERVAL ON:RETURN *PF1
520 '
530 *左押す ' *** マウス割込(メニュー) ***
540 MOUSE(2) OFF
550 IF PR=1 THEN MOUSE(2) ON:GOTO *OPE1
560 IF PR=2 THEN MOUSE(2) ON:GOTO *OPE2
570 IF PR=3 THEN MOUSE(2) ON:GOTO *OPE3
580 RUN
590 '
600 *PF1 ' *** 終了処理 ***
610 INTERVAL OFF:MOUSE 5:WIDTH 80,25:CONSOLE 0,25,0:END
620 '
630 *PF2 ' *** TV(スーパーインポーズ) ***
640 IF S<>1 THEN RETURN
650 IF SW=0 THEN SW=1:SIMPOSE ON ELSE SW=0:SIMPOSE OFF
660 RETURN
670 '
680 *PF3 ' *** FRA32A.TIF/FRA16A.TIFで保存 ***
690 LOCATE 0,0
700 PRINT"グラフィック画面を書庫(FRAxxA.TIF)に保存? Y で実行します。 "
710 IK$=INKEY$:IF IK$="Y" THEN GOTO 730 ELSE IF IK$="" THEN GOTO 710
720 GOTO 770
730 IF S=1 THEN KILL "\FILE\FRA32A.TIF"
740 IF S=1 THEN SAVE@ "\FILE\FRA32A.TIF",(0,0)-(319,239)
750 IF S=2 THEN KILL "\FILE\FRA16A.TIF"
760 IF S=2 THEN SAVE@ "\FILE\FRA16A.TIF",(0,0)-(639,479)
770 LOCATE 0,0
780 PRINT" "
790 RETURN
800 '
810 *PF4 ' *** メニュー表示 ***
820 SCREEN@ 1:S=1:WINDOW (0,0)-(319*S,239*S)
830 VIEW (0,0)-(319*S,239*S):COLOR 5,1,0,4:CLS:RUN
840 '
850 *PF5 ' *** LOAD ***
860 LOCATE 0,0
870 PRINT"グラフィック画面を書庫(FRAxxA.TIF)から読む? Y で実行します。"
880 IK$=INKEY$:IF IK$="Y" THEN GOTO 900 ELSE IF IK$="" THEN GOTO 880
890 GOTO 920
900 IF S=1 THEN LOAD@ "\FILE\FRA32A.TIF"
910 IF S=2 THEN LOAD@ "\FILE\FRA16A.TIF"
920 LOCATE 0,0
930 PRINT" "
940 RETURN
950 '
960 *PF6 ' *** 初期 ***
970 PXX=POS(0):PYY=CSRLIN
980 IF PR=1 THEN GOTO *OPE1
990 IF PR=2 THEN GOTO *OPE2
1000 LOCATE PXX,PYY:RETURN
1010 '
1020 *異常 ' 異常処理。
1030 OPEN"A",#1,"\FILE\ERROR.BAS"
1040 PRINT#1,ERL,"Error number=";ERR,"Error line=";ERL
1050 CLOSE#1
1060 BEEP:RESUME NEXT
1070 '
1080 *MENU
1090 LOCATE 0,0:PRINT:PRINT
1100 PRINT "◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆"
1110 PRINT "1: HENON-MIRA MAP"
1120 PRINT "2: JULIA SET OF f(z)=z^2+a"
1130 PRINT "3: HENON MAP"
1140 PRINT "4: CIRCLE MAP"
1150 PRINT "◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆"
1160 GOSUB *読む:KY=VAL(D$):IF KY<1 OR KY>4 THEN KY=0
1170 ON KY GOSUB *MIRA,*JULIA,*HENON1,*CIRCLE
1180 GOTO *MENU
1190 '
1200 *読む ' 文字読み
1210 MOUSE(2) OFF:MOUSE 1,100,100,1
1220 MO=MOUSE (2,0):IF MO<>0 GOTO 1210
1230 MOX=MOUSE (0):' X 座標
1240 MOY=MOUSE (1):' Y 座標
1250 D$=CHR$(SCREEN (MOX/(4*S),MOY/(9.5!*S)))
1260 LOCATE 0,0:PRINT"選択=>";D$;" マウス左クリックで選択。 "
1270 MO=MOUSE (2,0):IF MO=0 GOTO 1230
1280 MO=MOUSE (2,0):IF MO<>0 GOTO 1280
1290 MOUSE 1,100,100,0::MOUSE(2) ON
1300 LOCATE 0,0:PRINT" ";:RETURN
1310 '
1320 *MIRA
1330 '
1340 ' % % % % % Henon-Mira map % % % % %
1350 '
1360 WI=10:R=20:COL=2:PR=1:S=1
1370 X0=0:Y0=.4!:A=.97!:B=-.98!
1380 VIEW (40,0)-(319,239)
1390 WINDOW (-WI,-WI)-(WI,WI)
1400 DEF FNH(X)=-1+A*X+4*X*X/(1+X*X)
1410 GOSUB *OPE1:CLS:LINE (-WI,-WI)-(WI,WI),PASTEL,7,BF
1420 '
1430 WHILE 1
1440 X=Y0-FNH(X0):Y=B*X0
1450 PSET(X,-Y),COL:X0=X:Y0=Y
1460 IF ABS(X)+ABS(Y) > R THEN GOSUB *OVR
1470 WEND
1480 '
1490 *OPE1
1500 CLS 4:COLOR 6:LOCATE 0,2
1510 PRINT"0:色COL=";COL;"+1"
1520 PRINT"1:定数A+=";A+.001!
1530 PRINT"2:定数A-=";A-.001!
1540 PRINT"A:定数A=";A
1550 PRINT"B:定数B=";B
1560 PRINT"C:画面消去"
1570 PRINT"E:メニュー表示"
1580 PRINT"R:発散値R=";R
1590 PRINT"W:窓WI=";WI
1600 PRINT"X:変数X=";X0
1610 PRINT"Y:変数Y=";Y0
1620 GOSUB *読む
1630 IF D$="0" THEN COL=COL+1:IF COL=8 THEN COL=1
1640 IF D$="1" THEN A=A+.001!
1650 IF D$="2" THEN A=A-.001!
1660 IF D$="A" THEN INPUT" A";A
1670 IF D$="B" THEN INPUT" B";B
1680 IF D$="C" THEN CLS 5:LINE (-WI,-WI)-(WI,WI),PASTEL,7,BF
1690 IF D$="E" THEN RUN
1700 IF D$="R" THEN INPUT" R";R
1710 IF D$="W" THEN INPUT" WI";WI:D$="":RETURN 1390
1720 IF D$="X" THEN INPUT" X0";X0
1730 IF D$="Y" THEN INPUT" Y0";Y0
1740 CLS 4
1750 RETURN
1760 '
1770 *OVR:CLS 4:LOCATE 0,6:COLOR 2:PRINT" 発散!"
1780 PRINT" *** マウス左を押して下さい!***"
1790 A=-1.54!:B=-1:X0=0:Y0=.4!:COL=COL+1:COL=COL MOD 8:CLS 5
1800 WI=50:R=60
1810 RETURN 1390
1820 '
1830 *JULIA
1840 '
1850 ' % % % % % julia set of f(z)=z^2+a % % % % %
1860 '
1870 AR=-.74543!:AI=-.11301!:COL=2:PR=2:S=1
1880 RX=319:RY=239
1890 XS=-2:XE=2:YS=-1.4!:YE=1.4!
1900 XD=RX/(XE-XS):YD=RY/(YE-YS)
1910 ZX=.25!-AR:ZY=-AI
1920 R=.5!*(SQR(ZX*ZX+ZY*ZY)+ZX)
1930 ZY=SGN(ZY)*SQR(ABS(R-ZX)):ZX=SQR(ABS(R))
1940 ZX=ZX+.5!:GOSUB *OPE2
1950 LINE (0,0)-(319,239),PASTEL,7,BF
1960 '
1970 WHILE 1
1980 ZX=ZX-AR:ZY=ZY-AI
1990 R=.5!*(SQR(ZX*ZX+ZY*ZY)+ZX)
2000 ZY=SGN(ZY)*SQR(ABS(R-ZX)):ZX=SQR(ABS(R))
2010 IF RND>.5! THEN ZX=-ZX:ZY=-ZY
2020 PSET (INT((ZX-XS)*XD),INT((YE-ZY)*YD)),COL
2030 WEND
2040 '
2050 *OPE2
2060 CLS 4:COLOR 6:LOCATE 0,2
2070 PRINT"0:色COL=";COL;"+1"
2080 PRINT"1:定数AR=";AR
2090 PRINT"2:定数AI=";AI
2100 PRINT"C:画面消去"
2110 PRINT"E:メニュー表示"
2120 GOSUB *読む
2130 IF D$="0" THEN COL=COL+1:COL=COL MOD 8
2140 IF D$="1" THEN INPUT" AR";AR
2150 IF D$="2" THEN INPUT" AI";AI
2160 IF D$="C" THEN CLS 5:LINE (0,0)-(319,239),PASTEL,7,BF
2170 IF D$="E" THEN RUN
2180 CLS 4
2190 RETURN
2200 '
2210 *HENON1
2220 SCREEN@ 0:COLOR 6,0,0,0:CLS:S=2
2230 WINDOW (0,0)-(639,479):VIEW (0,0)-(639,479)
2240 '
2250 ' % % % % % HENON MAP % % % % %
2260 '
2270 A=1.4!:B=.3!:XC=.83!:YC=.15!:VC=99.5!
2280 DIM C(3),D(3),W(3,3),V(3,3)
2290 D(0)=2.5!:D(1)=.4!:D(2)=.08!:D(3)=.0125!
2300 C(0)=XC:C(1)=YC:C(2)=XC:C(3)=YC
2310 FOR I=0 TO 3:FOR J=0 TO 3
2320 W(I,J)=C(J)+(2*INT(J/2)-1)*D(I)
2330 READ V(I,J)
2340 NEXT J:NEXT I
2350 '
2360 FOR I=0 TO 2
2370 WINDOW(W(I,0),W(I,1))-(W(I,2),W(I,3))
2380 VIEW(V(I,0),V(I,1))-(V(I,2),V(I,3))
2390 LINE(W(I,0),W(I,1))-(W(I,2),W(I,3)),PSET,1,B
2400 LINE(W(I+1,0),W(I+1,1))-(W(I+1,2),W(I+1,3)),PSET,1,BF
2410 NEXT I
2420 WINDOW(W(3,0),W(3,1))-(W(3,2),W(3,3))
2430 VIEW(V(3,0),V(3,1))-(V(3,2),V(3,3))
2440 LINE(W(3,0),W(3,1))-(W(3,2),W(3,3)),PSET,1,BF
2450 '
2460 X=1:Y=1
2470 FOR K=0 TO 20
2480 XX=1+Y-A*X*X:YY=B*X:X=XX:Y=YY
2490 NEXT K
2500 '
2510 *HENON
2520 XX=1+Y-A*X*X:YY=B*X
2530 FOR I=0 TO 3
2540 WINDOW(W(I,0),W(I,1))-(W(I,2),W(I,3))
2550 VIEW(V(I,0),V(I,1))-(V(I,2),V(I,3))
2560 PSET(XX,YY),2
2570 NEXT I
2580 X=XX:Y=YY:K=K+1
2590 GOTO *HENON
2600 DATA 0,0,199,199,200,0,399,199
2610 DATA 0,200,199,399,200,200,399,399
2620 '
2630 *CIRCLE
2640 '
2650 ' % % % % % CIRCLE MAP % % % % %
2660 '
2670 R=3:TM=16:DD=2:PI=3.14159!:XO=0:S=1:PR=3:CLS
2680 XL=-.1!:XU=1.1!:YL=-.1!:YU=4.1!
2690 WINDOW (XL,YL)-(XU,YU)
2700 VIEW (40*S,10*S)-(309*S,229*S)
2710 LINE (XL,YL)-(XU,YU),PSET,0,BF
2720 DX=DD*(XU-XL)/(270*S):DY=DD*(YU-YL)/(220*S)
2730 '
2740 FOR I=XL TO XU STEP DX
2750 FOR J=YL TO YU STEP DY
2760 T=0:XO=0
2770 XN=XO+I-J*SIN(2*PI*XO)/2*PI
2780 XO=XN:IF XN>R GOTO 2800
2790 T=T+1:IF T<TM GOTO 2770
2800 PSET (I,J),T MOD 8
2810 NEXT J
2820 NEXT I:BEEP:GOTO 2740
2830 '
2840 *OPE3
2850 CLS 4:COLOR 6:LOCATE 0,2:PRINT"CIRCLE MAP"
2860 PRINT"I:横":PRINT I;" "
2870 PRINT"J:縦":PRINT J;" "
2880 PRINT"XN:状態":PRINT XN;" "
2890 PRINT"R:境界";R
2900 PRINT"S:モード";S
2910 PRINT"TM:繰返";TM
2920 PRINT"DD:密度";DD
2930 PRINT"C:画面消去"
2940 PRINT"E:メニュー表示"
2950 GOSUB *読む
2960 IF D$="S" THEN IF S=1 THEN S=2:SCREEN@ 0 ELSE S=1:SCREEN@ 1
2970 IF D$="S" THEN RETURN 2690
2980 IF D$="D" THEN IF DD=1 THEN DD=2 ELSE DD=1
2990 IF D$="D" THEN CLS 4:RETURN 2720
3000 IF D$="T" THEN INPUT" TM";TM
3010 IF D$="R" THEN INPUT" R";R
3020 IF D$="C" THEN CLS 5:LINE (XL,YL)-(XU,YU),PASTEL,7,BF
3030 IF D$="E" THEN RUN
3040 CLS 4
3050 RETURN