home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FM Towns: Free Software Collection 1
/
FREEWARE.BIN
/
basic
/
fractal
/
frademo5.bas
< prev
next >
Wrap
BASIC Source File
|
1989-10-17
|
6KB
|
159 lines
100 '
110 ' F-BASIC386 SAMPLE PROGRAM % COPYRIGHT FUJITSU LIMITED 19890918
120 '
130 ' PUBLIC DOMAIN SOFTWARE by PRELUDE FMC(富士通マイコンクラブ)
140 '
150 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
160 ' ★ ソフト名:フラクタル・デモ PART5 V5 ★
170 ' ★ 登録名 :FRADEMO5.BAS ★
180 ' ★ 登録者 :PRELUDE(佐々木裕一) ★
190 ' ★ 動作確認:FM-TOWNS F-BASIC386 ★
200 ' ★ 備考 :このプログラムはビデオカード対応です。 ★
210 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
220 '
230 ' マウス割り込みルーチンの定義
240 CLEAR,,4096:MOUSE 0:MOUSE 4,0,0,319,239:MOUSE 1,,,0
250 ON MOUSE (5) GOSUB *マウス:MOUSE (5) OFF
260 ' 音楽設定
270 BGM 1:PART 0,0:PLAY "@3V15T280L4O5CDEFGABO6CCO5BAGFEDC"
280 ' 3万2千色モード
290 SC=1:S=1:SW=0:SCREEN@ 1:COLOR 6,0,0,4
300 ' 宣伝表示
310 WINDOW (0,0)-(319,239)
320 VIEW (0,0)-(319,239)
330 CLS:LOCATE 0,10
340 PRINT"..... The VP series expands the range of supercomputing applications."
350 PRINT" "
360 PRINT" Supercomputers ・・・・"
370 SYMBOL (0,50),"VP2000",3,7,2,0,PSET,3,0
380 PRINT" "
390 PRINT" "
400 PRINT" "
410 PRINT" マウスの右ボタンを押して下さい。"
420 PRINT" "
430 PRINT" マンデルブロート集合f(z)=z^2+cを計算表示します。"
440 PRINT" "
450 PRINT" マウスの右ボタンを押すとメニューを表示します。"
460 MO=MOUSE (2,1):IF MO=0 GOTO 460 ELSE CLS:MOUSE 1,,,0
470 MOUSE (5) ON:COLOR 6,2,0,4:GOTO *PROC1
480 '
490 ' 終了をします。
500 *END
510 WINDOW (0,0)-(319,239)
520 VIEW (0,0)-(319,239)
530 MOUSE 5:END
540 '
550 ' フラクタル音楽をします。
560 *MUS
570 DS=T MOD 8
580 IF DS=0 THEN PLAY "C" ELSE IF DS=1 THEN PLAY "D"
590 IF DS=2 THEN PLAY "E" ELSE IF DS=3 THEN PLAY "F"
600 IF DS=4 THEN PLAY "G" ELSE IF DS=5 THEN PLAY "A"
610 IF DS=6 THEN PLAY "B" ELSE IF DS=7 THEN PLAY ">C<"
620 RETURN
630 '
640 ' 表示中の絵を録画します。
650 *VIDEO
660 IF SC=0 THEN RETURN ELSE SIMPOSE ON 0:MOUSE 1,,,0
670 MO=MOUSE (2,0):IF MO=0 GOTO 670 ELSE SIMPOSE OFF:RETURN
680 '
690 *PROC1:CLS
700 '
710 ' % % % % % Mandelbrot set of f(z)=z^2+c % % % % %
720 '
730 ' パラメータ初期値
740 R=5:TM=16:ZX0=0:ZY0=0:DD=5:MD=0:AR=-.74543!:AI=.11301!
750 XL=-2.2!:XU=1.6!:YL=-1.4!:YU=1.4!
760 ' 枠作り
770 ' 複素数平面サイズ Xmin(XL),Ymin(YL),Xmax(XU),Ymax(YU)
780 WINDOW (XL,YL)-(XU,YU)
790 ' 表示画面サイズ Xmin(40),Ymin(10),Xmax(309),Ymax(229)
800 VIEW (40*S,10*S)-(309*S,229*S)
810 LINE (XL,YL)-(XU,YU),PSET,0,BF:GOSUB *JURES
820 DX=DD*(XU-XL)/(270*S):DY=DD*(YU-YL)/(220*S)
830 '
840 FOR I=XL TO XU STEP DX
850 FOR J=YL TO YU STEP DY
860 T=0:IF MD=0 THEN ZX=ZX0:ZY=ZY0:A=I:B=J ELSE ZX=I:ZY=J:A=AR:B=AI
870 ZX2=ZX*ZX:ZY2=ZY*ZY
880 ZXN=ZX2-ZY2+A:ZYN=2*ZX*ZY+B
890 ZX=ZXN:ZY=ZYN
900 ZX2=ZX*ZX:ZY2=ZY*ZY:GOSUB *JULIA
910 IF ZX2+ZY2>R GOTO 930
920 T=T+1:IF T<TM GOTO 880
930 PSET (I,J),T MOD 8:GOSUB *JURES:IF SW=1 THEN GOSUB *MUS
940 NEXT J,I:GOTO 840
950 '
960 *マウス:' マウス割り込み処理
970 MOUSE 1,,,1:GOSUB *JURES
980 CLS 4:LOCATE 0,1
990 IF MD=0 THEN PRINT"1:初期値ZX=";ZX0 ELSE PRINT"1:実定数AR=";AR
1000 IF MD=0 THEN PRINT"2:初期値ZY=";ZY0 ELSE PRINT"2:虚定数AI=";AI
1010 PRINT"3:吸引境界値R=";R
1020 PRINT"4:繰返し数TM=";TM
1030 PRINT"C:画面消去"
1040 PRINT"D:密度DD=";DD
1050 PRINT"E:終了"
1060 PRINT"I:初期状態に戻す"
1070 IF MD=0 THEN PRINT"M:C平面" ELSE PRINT"M:Z平面"
1080 PRINT"R:メニュー消去"
1090 PRINT"S:画面モード";SC
1100 PRINT"V:録画:マウス左で戻る"
1110 PRINT"W:拡大(左上隅XL)";WINDOW(0)
1120 PRINT" (左上隅YL)";WINDOW(1)
1130 PRINT" (右下隅XU)";WINDOW(2)
1140 PRINT" (右下隅YU)";WINDOW(3)
1150 GOSUB *SER
1160 LOCATE 0,18
1170 IF D$="1:" THEN IF MD=0 THEN INPUT"実部初期値ZX";ZX0 ELSE INPUT"実定数AR";AR
1180 IF D$="2:" THEN IF MD=0 THEN INPUT"虚部初期値ZY";ZY0 ELSE INPUT"虚定数AI";AI
1190 IF D$="3:" THEN INPUT"吸引境界値R";R
1200 IF D$="4:" THEN INPUT"繰返し数TM";TM
1210 IF D$="C:" THEN CLS:MOUSE 1,,,0:RETURN 810
1220 IF D$="D:" THEN IF DD=1 THEN DD=5:MOUSE 1,,,0:CLS 4:RETURN 820 ELSE DD=1:MOUSE 1,,,0:CLS 4:RETURN 820
1230 IF D$="E:" THEN PRINT"終了? Y: ":GOSUB *SER:IF D$="Y:" GOTO *END
1240 IF D$="I:" THEN PRINT"初期値に戻します。Y: ":GOSUB *SER:IF D$="Y:" THEN MOUSE 1,,,0:CLS:RETURN *PROC1
1250 IF D$="M:" THEN IF MD=0 THEN MD=1:MOUSE 1,,,0:CLS 4:RETURN 840 ELSE MD=0:MOUSE 1,,,0:CLS 4:RETURN 840
1260 IF D$="R:" THEN CLS 4:MOUSE 1,,,0:RETURN
1270 IF D$="S:" THEN MOUSE 1,,,0:IF SC=0 THEN SC=1:S=1:SCREEN@ 1:RETURN ELSE SC=0:S=2:SCREEN@ 0:RETURN
1280 IF D$="V:" THEN GOSUB *VIDEO:MOUSE 1,,,1
1290 IF D$="W:" THEN GOSUB *WIN:D$="":MOUSE 1,,,0:CLS 4:RETURN 780
1300 PRINT"左ボタンで、音を出すなら Y: を入れて下さい。":GOSUB *SER:IF D$="Y:" THEN SW=1 ELSE SW=0
1310 GOTO 980
1320 ' 文字読み込み
1330 *SER
1340 MO=MOUSE (2,0):IF MO<>0 GOTO 1340
1350 IF SC=1 THEN S=1 ELSE S=2
1360 MOX=MOUSE (0):' X 座標
1370 MOY=MOUSE (1):' Y 座標
1380 D$=CHR$(SCREEN (MOX/(4*S),MOY/(10*S)))+CHR$(SCREEN (1+MOX/(4*S),MOY/(10*S)))
1390 LOCATE 0,17:PRINT"選択=>";D$;" 良ければマウスの左ボタンを押して下さい。 "
1400 MO=MOUSE (2,0):IF MO=0 GOTO 1360
1410 MO=MOUSE (2,0):IF MO<>0 GOTO 1410
1420 RETURN
1430 ' 図形拡大
1440 *WIN
1450 LOCATE 0,18:PRINT"左上の座標を選択し、マウスの左ボタンを押して下さい。"
1460 GOSUB *SER:XLL=MOX:YLL=MOY
1470 LOCATE 0,17:PRINT"右下の座標を選択し、マウスの左ボタンを押して下さい。"
1480 GOSUB *SER:XUU=MOX:YUU=MOY
1490 DX=(XU-XL)/(270*S):DY=(YU-YL)/(220*S)
1500 XLLL=XL+DX*(XLL-40*S)
1510 YLLL=YL+DY*(YLL-10*S)
1520 XUUU=XL+DX*(XUU-40*S)
1530 YUUU=YL+DY*(YUU-10*S)
1540 XL=XLLL:YL=YLLL:XU=XUUU:YU=YUUU
1550 RETURN
1560 ' Attractors set
1570 *JULIA
1580 WINDOW (-5,-5)-(5,5):VIEW (0,190*S)-(39*S,229*S)
1590 PSET (ZX,ZY),7
1600 WINDOW (XL,YL)-(XU,YU):VIEW (40*S,10*S)-(309*S,229*S)
1610 RETURN
1620 ' reset
1630 *JURES
1640 WINDOW (-5,-5)-(5,5):VIEW (0,190*S)-(39*S,229*S)
1650 LINE (-5,-5)-(5,5),PSET,1,BF
1660 WINDOW (XL,YL)-(XU,YU):VIEW (40*S,10*S)-(309*S,229*S)
1670 RETURN