home *** CD-ROM | disk | FTP | other *** search
/ FreeWare Collection 2 / FreeSoftwareCollection2pd199x-jp.img / fbasic / prelude / pds0a / fractal / frademo6.bas < prev    next >
BASIC Source File  |  1990-06-14  |  9KB  |  262 lines

  1. 100 ' F-BASIC386 SAMPLE PROGRAM % COPYRIGHT FUJITSU LIMITED 19900514
  2. 110 ' PUBLIC DOMAIN SOFTWARE by PRELUDE FMC(Fujitsuマイコンクラブ)
  3. 120 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
  4. 130 ' ★ ソフト名:フラクタル・デモ PART6 V3                              ★
  5. 140 ' ★ 登録名 :FRADEMO06.BAS                                   ★
  6. 150 ' ★ 登録者 :PRELUDE(Yuuichi Sasaki)                    ★
  7. 160 ' ★  動作確認:FM-TOWNS 2 F-BASIC386 V1.1L20                ★
  8. 170 ' ★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
  9. 180 ' 初期設定
  10. 190 CLEAR,,4096
  11. 200 ' マウス割込み処理の定義
  12. 210 MOUSE 0:MOUSE 4,0,0,319,239:MOUSE 1,0,0,0
  13. 220 ON MOUSE (5) GOSUB *右放す:MOUSE (5) OFF
  14. 230 ON MOUSE (1) GOSUB *動かす:MOUSE (1) OFF
  15. 240 ' Henon-Mira 関数の定義
  16. 250 DEF FNX(X)=A*X-1+4*X*X/(1+X*X)
  17. 260 ' タイマ割込み処理の定義
  18. 270 INTERVAL 1:ON INTERVAL GOSUB *時計:INTERVAL OFF
  19. 280 ' 異常処理定義
  20. 290 ON ERROR GOTO *異常
  21. 300 ' 音楽設定
  22. 310 BGM 1:PLAY "%C@63T280V15"
  23. 320 ' 32K色モード
  24. 330 SC=1:S=1:SW=0:SCREEN@ 1
  25. 340 WINDOW (0,0)-(319,239)
  26. 350 VIEW (0,0)-(319,239)
  27. 360 ' 題名表示
  28. 370 INTERVAL ON:COLOR 6,0,0,4:CLS
  29. 380 P=3.14159!/180:A=89:B=91:WINDOW (-1.6!,-1.2!)-(1.59!,1.19!)
  30. 390 X=SIN(P*T*A):Y=COS(P*T*B):LINE(X,Y)-(X,Y),PSET,0
  31. 400 T=T+1:IF T>360 THEN T=1
  32. 410 X=SIN(P*T*A):Y=COS(P*T*B):IF T=1 THEN LINE-(X,Y),PSET,0
  33. 420 LINE-(X,Y),PASTEL,GCOL,B
  34. 430 MO=MOUSE (2,1):IF MO=0 GOTO 400 ELSE CLS:MOUSE 1,,,0
  35. 440 COLOR 6,3,0,4:INTERVAL OFF:GOTO *MAIN6
  36. 450 '
  37. 460 *時計 ' タイマ割込み処理
  38. 470 INTERVAL OFF
  39. 480 COLOR COL:IF COL=2 THEN COL=10 ELSE COL=2
  40. 490 GCOL=GCOL+1:IF GCOL=8 THEN GOSUB *消去:GCOL=0:A=A+1:B=B+1
  41. 500 LOCATE 1,1:PRINT "Pattern=";A
  42. 510 LOCATE 15,12
  43. 520 PRINT"Henon-Mira によるカオスを計算表示します。"
  44. 530 LOCATE 15,14
  45. 540 PRINT"マウスの右ボタンを押すとメニューを表示します。"
  46. 550 INTERVAL ON
  47. 560 RETURN
  48. 570 '
  49. 580 *消去
  50. 590 FOR T=1 TO 720
  51. 600 X=SIN(P*T*A):Y=COS(P*T*B):LINE-(X,Y),PSET,0
  52. 610 NEXT:CLS 5
  53. 620 RETURN
  54. 630 '
  55. 640 *END ' 終了します。
  56. 650 LOCATE 0,1:PRINT"Y: 終了?"
  57. 660 GOSUB *座標:IF D$<>"Y:" GOTO 2390
  58. 670 WINDOW (0,0)-(319,239)
  59. 680 VIEW (0,0)-(319,239)
  60. 690 MOUSE 5:CLS 4:END
  61. 700 '
  62. 710 *音楽 ' フラクタル音楽のつもり。
  63. 720 IF SEL=0 THEN SEL=1 ELSE IF SEL=1 THEN SEL=2 ELSE SEL=0
  64. 730 ON SEL GOTO 750,760
  65. 740 PLAY "%L":GOTO 770
  66. 750 PLAY "%C":GOTO 770
  67. 760 PLAY "%R":GOTO 770
  68. 770 DS=T MOD 8:ON DS GOTO 790,800,810,820,830,840,850
  69. 780 PLAY "C":RETURN
  70. 790 PLAY "D":RETURN
  71. 800 PLAY "E":RETURN
  72. 810 PLAY "F":RETURN
  73. 820 PLAY "G":RETURN
  74. 830 PLAY "A":RETURN
  75. 840 PLAY "B":RETURN
  76. 850 PLAY ">C<":RETURN
  77. 860 '
  78. 870 *VIDEO ' 表示中の絵を録画します。
  79. 880 IF SC=0 THEN RETURN ELSE SIMPOSE ON 0:MOUSE 1,,,0
  80. 890 MO=MOUSE (2,0):IF MO=0 GOTO 890 ELSE SIMPOSE OFF:RETURN
  81. 900 '
  82. 910 *初期化
  83. 920 LOCATE 0,1:PRINT"Y:初期化。"
  84. 930 PRINT"H:SPOT表示。"
  85. 940 PRINT"L:ロード。":GOSUB *座標
  86. 950 IF D$="H:" THEN MOUSE 1,,,0:CLS 4:GOTO *動かす
  87. 960 IF D$="L:" THEN GOSUB *書庫:MOUSE 1,,,0:CLS 4:GOTO *動かす
  88. 970 IF D$="Y:" THEN MOUSE 1,,,0:CLS:RETURN *MAIN6 ELSE GOTO 2400
  89. 980 '
  90. 990 *書庫 ' 保存値設定
  91. 1000 ON SC GOTO 1030
  92. 1010 OPEN"I",#1,"\FILE\FR16.DOC"
  93. 1020 LOAD@ "\FILE\FRA16.TIF":GOTO 1050
  94. 1030 OPEN"I",#1,"\FILE\FR32.DOC"
  95. 1040 LOAD@ "\FILE\FRA32.TIF"
  96. 1050 INPUT#1,R,TM,ZX0,ZY0,DD,MD,AR,AI,XL,XU,YL,YU
  97. 1060 CLOSE#1:RETURN
  98. 1070 '
  99. 1080 *座標 ' 文字読み込み
  100. 1090 MO=MOUSE (2,0):IF MO<>0 GOTO 1090
  101. 1100 IF SC=0 THEN S=2 ELSE S=1
  102. 1110 MOX=MOUSE (0) ' X 座標
  103. 1120 MOY=MOUSE (1) ' Y 座標
  104. 1130 MDX=(XU-XL)/(270*S):MDY=(YU-YL)/(220*S)
  105. 1140 XS=XL+MDX*(MOX-40*S):LOCATE 30,0:PRINT"I=";XS;"          "
  106. 1150 YS=YL+MDY*(MOY-10*S):LOCATE 50,0:PRINT"J=";YS;"          "
  107. 1160 D$=CHR$(SCREEN (MOX/(4*S),MOY/(10*S)))
  108. 1170 D$=D$+CHR$(SCREEN (1+MOX/(4*S),MOY/(10*S)))
  109. 1180 LOCATE 0,0:PRINT"選択=>";D$;" 左ボタンを押す。 "
  110. 1190 MO=MOUSE (2,0):IF MO=0 GOTO 1110
  111. 1200 MO=MOUSE (2,0):IF MO<>0 GOTO 1200
  112. 1210 CLS 4:RETURN
  113. 1220 '
  114. 1230 *窓変更 ' 図形拡大
  115. 1240 CLS 4
  116. 1250 LOCATE 30,1:PRINT"左上の座標で左ボタンを押す。"
  117. 1260 GOSUB *座標:MOXL=MOX:MOYL=MOY
  118. 1270 LOCATE 30,1:PRINT"右下の座標で左ボタンを押す。"
  119. 1280 GOSUB *座標:MOXU=MOX:MOYU=MOY
  120. 1290 MDX=(XU-XL)/(270*S):MDY=(YU-YL)/(220*S)
  121. 1300 XLL=XL+MDX*(MOXL-40*S)
  122. 1310 YLL=YL+MDY*(MOYL-10*S)
  123. 1320 XUU=XL+MDX*(MOXU-40*S)
  124. 1330 YUU=YL+MDY*(MOYU-10*S)
  125. 1340 XL=XLL:YL=YLL:XU=XUU:YU=YUU
  126. 1350 RETURN
  127. 1360 '
  128. 1370 *窓 ' Attractors set
  129. 1380 WINDOW (XL,YL)-(XU,YU):VIEW (0,190*S)-(39*S,229*S)
  130. 1390 PSET (I,J),T MOD 8
  131. 1400 WINDOW (-R,-R)-(R,R):VIEW (40*S,10*S)-(309*S,229*S)
  132. 1410 LOCATE 30,0:PRINT"I=";I;"          "
  133. 1420 LOCATE 50,0:PRINT"J=";J;"          "
  134. 1430 RETURN
  135. 1440 '
  136. 1450 *白窓 ' reset
  137. 1460 WINDOW (XL,YL)-(XU,YU):VIEW (0,190*S)-(39*S,229*S)
  138. 1470 LINE (XL,YL)-(XU,YU),PSET,1,BF
  139. 1480 WINDOW (-R,-R)-(R,R):VIEW (40*S,10*S)-(309*S,229*S)
  140. 1490 RETURN
  141. 1500 '
  142. 1510 *保存 ' .TIF形式で保存。
  143. 1520 ON SC GOTO 1570
  144. 1530 KILL "\FILE\FRA16.TIF":KILL "\FILE\FR16.BAS":KILL "\FILE\FR16.DOC"
  145. 1540 SAVE@ "\FILE\FRA16.TIF",(0,0)-(639,479)
  146. 1550 OPEN"A",#1,"\FILE\FR16.BAS":OPEN"A",#2,"\FILE\FR16.DOC"
  147. 1560 GOTO 1600
  148. 1570 KILL "\FILE\FRA32.TIF":KILL "\FILE\FR32.BAS":KILL "\FILE\FR32.DOC"
  149. 1580 SAVE@ "\FILE\FRA32.TIF",(0,0)-(319,239)
  150. 1590 OPEN"A",#1,"\FILE\FR32.BAS":OPEN"A",#2,"\FILE\FR32.DOC"
  151. 1600 PRINT#1,10;"R";R;"TM";TM;"ZX0";ZX0;"ZY0";ZY0;
  152. 1610 PRINT#1,"DD";DD;"MD";MD;"AR";AR;"AI";AI
  153. 1620 PRINT#1,20;"XL";XL;"XU";XU;"YL";YL;"YU";YU
  154. 1630 WRITE#2,R;TM;ZX0;ZY0;DD;MD;AR;AI;XL;XU;YL;YU
  155. 1640 CLOSE#1,#2
  156. 1650 RETURN
  157. 1660 '
  158. 1670 *異常 ' 異常処理。
  159. 1680 OPEN"A",#1,"\FILE\ERROR.BAS":BEEP
  160. 1690 PRINT#1,ERL,"Error number=";ERR,"Error line=";ERL
  161. 1700 CLOSE#1:BEEP
  162. 1710 RESUME NEXT
  163. 1720 '
  164. 1730 *MAIN6
  165. 1740 '
  166. 1750 ' % % % % %  Henon-Mira map  % % % % %
  167. 1760 '
  168. 1770 ' パラメータ初期値
  169. 1780 CLS:R=50:TM=4096:DD=2:MD=0:AR=1.25!:AI=-1:ZX0=.1!:ZY0=0
  170. 1790 XL=-5:XU=5:YL=-5:YU=5:MOUSE (5) ON
  171. 1800 ' 枠作り
  172. 1810 ' 複素数平面サイズ Xmin(XL),Ymin(YL),Xmax(XU),Ymax(YU)
  173. 1820 WINDOW (XL,YL)-(XU,YU)
  174. 1830 ' 表示画面サイズ Xmin(40),Ymin(10),Xmax(309),Ymax(229)
  175. 1840 VIEW (40*S,10*S)-(309*S,229*S)
  176. 1850 GOSUB *白窓:LINE (-R,-R)-(R,R),PSET,0,BF
  177. 1860 DX=DD*(XU-XL)/(40*S):DY=DD*(YU-YL)/(40*S)
  178. 1870 '
  179. 1880 FOR J=YL TO YU STEP DY
  180. 1890 FOR I=XL TO XU STEP DX
  181. 1900 T=0
  182. 1910 IF MD=0 THEN A=I:B=J:X0=ZX0:Y0=ZY0 ELSE A=AR:B=AI:X0=I:Y0=J
  183. 1920 X=Y0-FNX(X0)
  184. 1930 Y=B*X0
  185. 1940 X0=X:Y0=Y
  186. 1950 PSET (X,Y),7-T/10 MOD 7
  187. 1960 IF ABS(X)+ABS(Y)>R GOTO 1980
  188. 1970 T=T+1:IF T<TM GOTO 1920
  189. 1980 GOSUB *窓:IF SW=1 THEN GOSUB *音楽
  190. 1990 LINE (-R,-R)-(R,R),PSET,0,BF
  191. 2000 NEXT I,J:BEEP:GOTO 1880
  192. 2010 '
  193. 2020 *右放す:' マウス割り込み処理
  194. 2030 MOUSE 1,,,1
  195. 2040 CLS 4:LOCATE 0,1
  196. 2050 IF MD=0 THEN PRINT"1:初期ZX=";ZX0 ELSE PRINT"1:定数A=";AR
  197. 2060 IF MD=0 THEN PRINT"2:初期ZY=";ZY0 ELSE PRINT"2:定数B=";AI
  198. 2070 PRINT"3:境界R=";R
  199. 2080 PRINT"4:繰返数TM=";TM
  200. 2090 PRINT"C:画面消去"
  201. 2100 PRINT"D:密度DD=";DD
  202. 2110 PRINT"E:終了"
  203. 2120 PRINT"I:初期化"
  204. 2130 IF MD=0 THEN PRINT"M:C平面" ELSE PRINT"M:Z平面"
  205. 2140 PRINT"N:音楽";SW
  206. 2150 PRINT"R:メニュー消去"
  207. 2160 PRINT"S:画面モード";SC
  208. 2170 PRINT"T:保存"
  209. 2180 PRINT"V:録画:マウス左で戻る"
  210. 2190 WINDOW (XL,YL)-(XU,YU)
  211. 2200 PRINT"W:拡大"
  212. 2210 PRINT"☆XL=";WINDOW(0)
  213. 2220 PRINT"☆YL=";WINDOW(1)
  214. 2230 PRINT"☆XU=";WINDOW(2)
  215. 2240 PRINT"☆YU=";WINDOW(3)
  216. 2250 WINDOW (-R,-R)-(R,R)
  217. 2260 GOSUB *座標
  218. 2270 LOCATE 30,0
  219. 2280 IF D$="1:" THEN IF MD=0 THEN INPUT"実部初期値ZX";ZX0
  220. 2290 IF D$="1:" THEN IF MD=1 THEN INPUT"定数A";AR
  221. 2300 IF D$="2:" THEN IF MD=0 THEN INPUT"虚部初期値ZY";ZY0
  222. 2310 IF D$="2:" THEN IF MD=1 THEN INPUT"定数B";AI
  223. 2320 IF D$="3:" THEN INPUT"吸引境界値R";R:MOUSE 1,,,0
  224. 2330 IF D$="3:" THEN WINDOW (-R,-R)-(R,R):CLS 4:RETURN
  225. 2340 IF D$="4:" THEN INPUT"繰返し数TM";TM
  226. 2350 IF D$="C:" THEN CLS:MOUSE 1,,,0:RETURN 1850
  227. 2360 IF D$="D:" THEN IF DD=2 THEN DD=1 ELSE DD=2
  228. 2370 IF D$="D:" THEN MOUSE 1,,,0:CLS 4:RETURN 1860
  229. 2380 IF D$="E:" GOTO *END
  230. 2390 IF D$="I:" GOTO *初期化
  231. 2400 IF D$="M:" THEN IF MD=0 THEN MD=1 ELSE MD=0
  232. 2410 IF D$="M:" THEN MOUSE 1,,,0:CLS 4:RETURN 1880
  233. 2420 IF D$="N:" THEN IF SW=1 THEN SW=0 ELSE SW=1
  234. 2430 IF D$="R:" THEN CLS 4:MOUSE 1,,,0:RETURN
  235. 2440 IF D$="S:" THEN IF SC=0 THEN SC=1 ELSE SC=0
  236. 2450 IF D$="S:" THEN IF SC=0 THEN S=2:SCREEN@ 0 ELSE S=1:SCREEN@ 1
  237. 2460 IF D$="S:" THEN MOUSE 1,,,0:RETURN 1820
  238. 2470 IF D$="T:" THEN GOSUB *保存
  239. 2480 IF D$="V:" THEN GOSUB *VIDEO:MOUSE 1,,,1
  240. 2490 IF D$="W:" THEN GOSUB *窓変更:D$="":MOUSE 1,,,0:CLS 4:RETURN 1820
  241. 2500 GOTO 2040
  242. 2510 '
  243. 2520 ' 一点処理
  244. 2530 *動かす
  245. 2540 CLS 4:MOUSE (1) OFF:MOUSE 1,,,1
  246. 2550 LINE (-R,-R)-(R,R),PSET,0,BF
  247. 2560 MO=MOUSE (2,0):IF MO<>0 GOTO 2560
  248. 2570 GOSUB *座標:MOUSE 1,,,0:MOUSE (5) OFF:MOUSE (1) ON
  249. 2580 T=0:GOSUB *白窓
  250. 2590 IF MD=0 THEN A=XS:B=YS:X0=ZX0:Y0=ZY0 ELSE A=AR:B=AI:X0=XS:Y0=YS
  251. 2600 X=Y0-FNX(X0)
  252. 2610 Y=B*X0
  253. 2620 X0=X:Y0=Y
  254. 2630 PSET (X,Y),7-T/10 MOD 7
  255. 2640 IF ABS(X)+ABS(Y)>R GOTO 2660
  256. 2650 T=T+1:IF T<TM GOTO 2600
  257. 2660 I=XS:J=YS:T=2:GOSUB *窓:IF SW=1 THEN GOSUB *音楽
  258. 2670 MOUSE 1,,,1:MOUSE (1) OFF
  259. 2680 LOCATE 0,1:PRINT"Y:メニューに戻る?":GOSUB *座標
  260. 2690 IF D$="Y:" THEN MOUSE (5) ON:GOTO *右放す
  261. 2700 GOTO *動かす
  262.