home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FreeWare Collection 2
/
FreeSoftwareCollection2pd199x-jp.img
/
fbasic
/
prelude
/
pds0a
/
fractal
/
frademo6.bas
< prev
next >
Wrap
BASIC Source File
|
1990-06-14
|
9KB
|
262 lines
100 ' F-BASIC386 SAMPLE PROGRAM % COPYRIGHT FUJITSU LIMITED 19900514
110 ' PUBLIC DOMAIN SOFTWARE by PRELUDE FMC(Fujitsuマイコンクラブ)
120 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
130 ' ★ ソフト名:フラクタル・デモ PART6 V3 ★
140 ' ★ 登録名 :FRADEMO06.BAS ★
150 ' ★ 登録者 :PRELUDE(Yuuichi Sasaki) ★
160 ' ★ 動作確認:FM-TOWNS 2 F-BASIC386 V1.1L20 ★
170 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
180 ' 初期設定
190 CLEAR,,4096
200 ' マウス割込み処理の定義
210 MOUSE 0:MOUSE 4,0,0,319,239:MOUSE 1,0,0,0
220 ON MOUSE (5) GOSUB *右放す:MOUSE (5) OFF
230 ON MOUSE (1) GOSUB *動かす:MOUSE (1) OFF
240 ' Henon-Mira 関数の定義
250 DEF FNX(X)=A*X-1+4*X*X/(1+X*X)
260 ' タイマ割込み処理の定義
270 INTERVAL 1:ON INTERVAL GOSUB *時計:INTERVAL OFF
280 ' 異常処理定義
290 ON ERROR GOTO *異常
300 ' 音楽設定
310 BGM 1:PLAY "%C@63T280V15"
320 ' 32K色モード
330 SC=1:S=1:SW=0:SCREEN@ 1
340 WINDOW (0,0)-(319,239)
350 VIEW (0,0)-(319,239)
360 ' 題名表示
370 INTERVAL ON:COLOR 6,0,0,4:CLS
380 P=3.14159!/180:A=89:B=91:WINDOW (-1.6!,-1.2!)-(1.59!,1.19!)
390 X=SIN(P*T*A):Y=COS(P*T*B):LINE(X,Y)-(X,Y),PSET,0
400 T=T+1:IF T>360 THEN T=1
410 X=SIN(P*T*A):Y=COS(P*T*B):IF T=1 THEN LINE-(X,Y),PSET,0
420 LINE-(X,Y),PASTEL,GCOL,B
430 MO=MOUSE (2,1):IF MO=0 GOTO 400 ELSE CLS:MOUSE 1,,,0
440 COLOR 6,3,0,4:INTERVAL OFF:GOTO *MAIN6
450 '
460 *時計 ' タイマ割込み処理
470 INTERVAL OFF
480 COLOR COL:IF COL=2 THEN COL=10 ELSE COL=2
490 GCOL=GCOL+1:IF GCOL=8 THEN GOSUB *消去:GCOL=0:A=A+1:B=B+1
500 LOCATE 1,1:PRINT "Pattern=";A
510 LOCATE 15,12
520 PRINT"Henon-Mira によるカオスを計算表示します。"
530 LOCATE 15,14
540 PRINT"マウスの右ボタンを押すとメニューを表示します。"
550 INTERVAL ON
560 RETURN
570 '
580 *消去
590 FOR T=1 TO 720
600 X=SIN(P*T*A):Y=COS(P*T*B):LINE-(X,Y),PSET,0
610 NEXT:CLS 5
620 RETURN
630 '
640 *END ' 終了します。
650 LOCATE 0,1:PRINT"Y: 終了?"
660 GOSUB *座標:IF D$<>"Y:" GOTO 2390
670 WINDOW (0,0)-(319,239)
680 VIEW (0,0)-(319,239)
690 MOUSE 5:CLS 4:END
700 '
710 *音楽 ' フラクタル音楽のつもり。
720 IF SEL=0 THEN SEL=1 ELSE IF SEL=1 THEN SEL=2 ELSE SEL=0
730 ON SEL GOTO 750,760
740 PLAY "%L":GOTO 770
750 PLAY "%C":GOTO 770
760 PLAY "%R":GOTO 770
770 DS=T MOD 8:ON DS GOTO 790,800,810,820,830,840,850
780 PLAY "C":RETURN
790 PLAY "D":RETURN
800 PLAY "E":RETURN
810 PLAY "F":RETURN
820 PLAY "G":RETURN
830 PLAY "A":RETURN
840 PLAY "B":RETURN
850 PLAY ">C<":RETURN
860 '
870 *VIDEO ' 表示中の絵を録画します。
880 IF SC=0 THEN RETURN ELSE SIMPOSE ON 0:MOUSE 1,,,0
890 MO=MOUSE (2,0):IF MO=0 GOTO 890 ELSE SIMPOSE OFF:RETURN
900 '
910 *初期化
920 LOCATE 0,1:PRINT"Y:初期化。"
930 PRINT"H:SPOT表示。"
940 PRINT"L:ロード。":GOSUB *座標
950 IF D$="H:" THEN MOUSE 1,,,0:CLS 4:GOTO *動かす
960 IF D$="L:" THEN GOSUB *書庫:MOUSE 1,,,0:CLS 4:GOTO *動かす
970 IF D$="Y:" THEN MOUSE 1,,,0:CLS:RETURN *MAIN6 ELSE GOTO 2400
980 '
990 *書庫 ' 保存値設定
1000 ON SC GOTO 1030
1010 OPEN"I",#1,"\FILE\FR16.DOC"
1020 LOAD@ "\FILE\FRA16.TIF":GOTO 1050
1030 OPEN"I",#1,"\FILE\FR32.DOC"
1040 LOAD@ "\FILE\FRA32.TIF"
1050 INPUT#1,R,TM,ZX0,ZY0,DD,MD,AR,AI,XL,XU,YL,YU
1060 CLOSE#1:RETURN
1070 '
1080 *座標 ' 文字読み込み
1090 MO=MOUSE (2,0):IF MO<>0 GOTO 1090
1100 IF SC=0 THEN S=2 ELSE S=1
1110 MOX=MOUSE (0) ' X 座標
1120 MOY=MOUSE (1) ' Y 座標
1130 MDX=(XU-XL)/(270*S):MDY=(YU-YL)/(220*S)
1140 XS=XL+MDX*(MOX-40*S):LOCATE 30,0:PRINT"I=";XS;" "
1150 YS=YL+MDY*(MOY-10*S):LOCATE 50,0:PRINT"J=";YS;" "
1160 D$=CHR$(SCREEN (MOX/(4*S),MOY/(10*S)))
1170 D$=D$+CHR$(SCREEN (1+MOX/(4*S),MOY/(10*S)))
1180 LOCATE 0,0:PRINT"選択=>";D$;" 左ボタンを押す。 "
1190 MO=MOUSE (2,0):IF MO=0 GOTO 1110
1200 MO=MOUSE (2,0):IF MO<>0 GOTO 1200
1210 CLS 4:RETURN
1220 '
1230 *窓変更 ' 図形拡大
1240 CLS 4
1250 LOCATE 30,1:PRINT"左上の座標で左ボタンを押す。"
1260 GOSUB *座標:MOXL=MOX:MOYL=MOY
1270 LOCATE 30,1:PRINT"右下の座標で左ボタンを押す。"
1280 GOSUB *座標:MOXU=MOX:MOYU=MOY
1290 MDX=(XU-XL)/(270*S):MDY=(YU-YL)/(220*S)
1300 XLL=XL+MDX*(MOXL-40*S)
1310 YLL=YL+MDY*(MOYL-10*S)
1320 XUU=XL+MDX*(MOXU-40*S)
1330 YUU=YL+MDY*(MOYU-10*S)
1340 XL=XLL:YL=YLL:XU=XUU:YU=YUU
1350 RETURN
1360 '
1370 *窓 ' Attractors set
1380 WINDOW (XL,YL)-(XU,YU):VIEW (0,190*S)-(39*S,229*S)
1390 PSET (I,J),T MOD 8
1400 WINDOW (-R,-R)-(R,R):VIEW (40*S,10*S)-(309*S,229*S)
1410 LOCATE 30,0:PRINT"I=";I;" "
1420 LOCATE 50,0:PRINT"J=";J;" "
1430 RETURN
1440 '
1450 *白窓 ' reset
1460 WINDOW (XL,YL)-(XU,YU):VIEW (0,190*S)-(39*S,229*S)
1470 LINE (XL,YL)-(XU,YU),PSET,1,BF
1480 WINDOW (-R,-R)-(R,R):VIEW (40*S,10*S)-(309*S,229*S)
1490 RETURN
1500 '
1510 *保存 ' .TIF形式で保存。
1520 ON SC GOTO 1570
1530 KILL "\FILE\FRA16.TIF":KILL "\FILE\FR16.BAS":KILL "\FILE\FR16.DOC"
1540 SAVE@ "\FILE\FRA16.TIF",(0,0)-(639,479)
1550 OPEN"A",#1,"\FILE\FR16.BAS":OPEN"A",#2,"\FILE\FR16.DOC"
1560 GOTO 1600
1570 KILL "\FILE\FRA32.TIF":KILL "\FILE\FR32.BAS":KILL "\FILE\FR32.DOC"
1580 SAVE@ "\FILE\FRA32.TIF",(0,0)-(319,239)
1590 OPEN"A",#1,"\FILE\FR32.BAS":OPEN"A",#2,"\FILE\FR32.DOC"
1600 PRINT#1,10;"R";R;"TM";TM;"ZX0";ZX0;"ZY0";ZY0;
1610 PRINT#1,"DD";DD;"MD";MD;"AR";AR;"AI";AI
1620 PRINT#1,20;"XL";XL;"XU";XU;"YL";YL;"YU";YU
1630 WRITE#2,R;TM;ZX0;ZY0;DD;MD;AR;AI;XL;XU;YL;YU
1640 CLOSE#1,#2
1650 RETURN
1660 '
1670 *異常 ' 異常処理。
1680 OPEN"A",#1,"\FILE\ERROR.BAS":BEEP
1690 PRINT#1,ERL,"Error number=";ERR,"Error line=";ERL
1700 CLOSE#1:BEEP
1710 RESUME NEXT
1720 '
1730 *MAIN6
1740 '
1750 ' % % % % % Henon-Mira map % % % % %
1760 '
1770 ' パラメータ初期値
1780 CLS:R=50:TM=4096:DD=2:MD=0:AR=1.25!:AI=-1:ZX0=.1!:ZY0=0
1790 XL=-5:XU=5:YL=-5:YU=5:MOUSE (5) ON
1800 ' 枠作り
1810 ' 複素数平面サイズ Xmin(XL),Ymin(YL),Xmax(XU),Ymax(YU)
1820 WINDOW (XL,YL)-(XU,YU)
1830 ' 表示画面サイズ Xmin(40),Ymin(10),Xmax(309),Ymax(229)
1840 VIEW (40*S,10*S)-(309*S,229*S)
1850 GOSUB *白窓:LINE (-R,-R)-(R,R),PSET,0,BF
1860 DX=DD*(XU-XL)/(40*S):DY=DD*(YU-YL)/(40*S)
1870 '
1880 FOR J=YL TO YU STEP DY
1890 FOR I=XL TO XU STEP DX
1900 T=0
1910 IF MD=0 THEN A=I:B=J:X0=ZX0:Y0=ZY0 ELSE A=AR:B=AI:X0=I:Y0=J
1920 X=Y0-FNX(X0)
1930 Y=B*X0
1940 X0=X:Y0=Y
1950 PSET (X,Y),7-T/10 MOD 7
1960 IF ABS(X)+ABS(Y)>R GOTO 1980
1970 T=T+1:IF T<TM GOTO 1920
1980 GOSUB *窓:IF SW=1 THEN GOSUB *音楽
1990 LINE (-R,-R)-(R,R),PSET,0,BF
2000 NEXT I,J:BEEP:GOTO 1880
2010 '
2020 *右放す:' マウス割り込み処理
2030 MOUSE 1,,,1
2040 CLS 4:LOCATE 0,1
2050 IF MD=0 THEN PRINT"1:初期ZX=";ZX0 ELSE PRINT"1:定数A=";AR
2060 IF MD=0 THEN PRINT"2:初期ZY=";ZY0 ELSE PRINT"2:定数B=";AI
2070 PRINT"3:境界R=";R
2080 PRINT"4:繰返数TM=";TM
2090 PRINT"C:画面消去"
2100 PRINT"D:密度DD=";DD
2110 PRINT"E:終了"
2120 PRINT"I:初期化"
2130 IF MD=0 THEN PRINT"M:C平面" ELSE PRINT"M:Z平面"
2140 PRINT"N:音楽";SW
2150 PRINT"R:メニュー消去"
2160 PRINT"S:画面モード";SC
2170 PRINT"T:保存"
2180 PRINT"V:録画:マウス左で戻る"
2190 WINDOW (XL,YL)-(XU,YU)
2200 PRINT"W:拡大"
2210 PRINT"☆XL=";WINDOW(0)
2220 PRINT"☆YL=";WINDOW(1)
2230 PRINT"☆XU=";WINDOW(2)
2240 PRINT"☆YU=";WINDOW(3)
2250 WINDOW (-R,-R)-(R,R)
2260 GOSUB *座標
2270 LOCATE 30,0
2280 IF D$="1:" THEN IF MD=0 THEN INPUT"実部初期値ZX";ZX0
2290 IF D$="1:" THEN IF MD=1 THEN INPUT"定数A";AR
2300 IF D$="2:" THEN IF MD=0 THEN INPUT"虚部初期値ZY";ZY0
2310 IF D$="2:" THEN IF MD=1 THEN INPUT"定数B";AI
2320 IF D$="3:" THEN INPUT"吸引境界値R";R:MOUSE 1,,,0
2330 IF D$="3:" THEN WINDOW (-R,-R)-(R,R):CLS 4:RETURN
2340 IF D$="4:" THEN INPUT"繰返し数TM";TM
2350 IF D$="C:" THEN CLS:MOUSE 1,,,0:RETURN 1850
2360 IF D$="D:" THEN IF DD=2 THEN DD=1 ELSE DD=2
2370 IF D$="D:" THEN MOUSE 1,,,0:CLS 4:RETURN 1860
2380 IF D$="E:" GOTO *END
2390 IF D$="I:" GOTO *初期化
2400 IF D$="M:" THEN IF MD=0 THEN MD=1 ELSE MD=0
2410 IF D$="M:" THEN MOUSE 1,,,0:CLS 4:RETURN 1880
2420 IF D$="N:" THEN IF SW=1 THEN SW=0 ELSE SW=1
2430 IF D$="R:" THEN CLS 4:MOUSE 1,,,0:RETURN
2440 IF D$="S:" THEN IF SC=0 THEN SC=1 ELSE SC=0
2450 IF D$="S:" THEN IF SC=0 THEN S=2:SCREEN@ 0 ELSE S=1:SCREEN@ 1
2460 IF D$="S:" THEN MOUSE 1,,,0:RETURN 1820
2470 IF D$="T:" THEN GOSUB *保存
2480 IF D$="V:" THEN GOSUB *VIDEO:MOUSE 1,,,1
2490 IF D$="W:" THEN GOSUB *窓変更:D$="":MOUSE 1,,,0:CLS 4:RETURN 1820
2500 GOTO 2040
2510 '
2520 ' 一点処理
2530 *動かす
2540 CLS 4:MOUSE (1) OFF:MOUSE 1,,,1
2550 LINE (-R,-R)-(R,R),PSET,0,BF
2560 MO=MOUSE (2,0):IF MO<>0 GOTO 2560
2570 GOSUB *座標:MOUSE 1,,,0:MOUSE (5) OFF:MOUSE (1) ON
2580 T=0:GOSUB *白窓
2590 IF MD=0 THEN A=XS:B=YS:X0=ZX0:Y0=ZY0 ELSE A=AR:B=AI:X0=XS:Y0=YS
2600 X=Y0-FNX(X0)
2610 Y=B*X0
2620 X0=X:Y0=Y
2630 PSET (X,Y),7-T/10 MOD 7
2640 IF ABS(X)+ABS(Y)>R GOTO 2660
2650 T=T+1:IF T<TM GOTO 2600
2660 I=XS:J=YS:T=2:GOSUB *窓:IF SW=1 THEN GOSUB *音楽
2670 MOUSE 1,,,1:MOUSE (1) OFF
2680 LOCATE 0,1:PRINT"Y:メニューに戻る?":GOSUB *座標
2690 IF D$="Y:" THEN MOUSE (5) ON:GOTO *右放す
2700 GOTO *動かす