home *** CD-ROM | disk | FTP | other *** search
/ FreeWare Collection 2 / FreeSoftwareCollection2pd199x-jp.img / ms_dos / life / life.bas next >
BASIC Source File  |  1990-06-14  |  11KB  |  617 lines
  1.  
  2. '==================================================================
  3. '*ＬＩＦＥ　ＧＡＭＥ     by ASF
  4. '*(LIFE.EXE v0.8)
  5. '*1990.5.10
  6. '*for FM TOWNS /FMR50(ms-dos v3.1)
  7. '==================================================================
  8. '*data load/save用のディレクトリを環境変数("LIFE")で指定する。
  9. '         SET LIFE=XXXXXXXXXX
  10. '
  11.  
  12.  
  13. DECLARE SUB PtrEdit ()
  14. DECLARE SUB NextGen ()
  15. DECLARE SUB Plot (x%, y%, col%)
  16. DECLARE SUB Gcur (x1%, y1%, x2%, y2%)
  17. DECLARE SUB ChrClr (l%, c%, clm%, lin%)
  18. DECLARE SUB DrawMat ()
  19. DECLARE SUB DataLoad (switch%)
  20. DECLARE SUB DataSave (switch%)
  21. DECLARE SUB PtrClear ()
  22. DECLARE SUB LineCur (x%, y%, col%)
  23. DECLARE FUNCTION FileCheck% (path$, filename$)
  24. DECLARE FUNCTION GetFileName$ ()
  25. DECLARE FUNCTION EndChk% ()
  26. DECLARE FUNCTION Break% ()
  27.  
  28. DEFINT A-Z
  29.  
  30. COMMON SHARED Scnt:  '石の総数
  31. COMMON SHARED path$: '環境変数保存用
  32. COMMON SHARED Flag:  '誕生･死滅のチェック
  33.  
  34. '*座標データ
  35. DIM SHARED PrePtr(0 TO 99, 0 TO 99)
  36. DIM SHARED NxtPtr(0 TO 99, 0 TO 99)
  37.  
  38. '環境変数のチェック
  39. path$ = ENVIRON$("LIFE")
  40. SELECT CASE path$
  41.     CASE ""
  42.         path$ = "\"
  43.     CASE ELSE
  44.         IF RIGHT$(path$, 1) <> "\" THEN path$ = path$ + "\"
  45. END SELECT
  46.  
  47. ON ERROR GOTO errTrap
  48.  
  49.  
  50. PRINT "LIFE GAME ver 0.8 だよぉ (By ASF)"
  51.  
  52. SCREEN 0, 3, 0, 1: '描いているところを見ないように････
  53.  
  54. DrawMat
  55.  
  56. PALETTE
  57. PALETTE 1, &H37
  58. PALETTE 0, &H444
  59.  
  60. '* タイトル
  61. CLS 2
  62. COLOR 3
  63. LOCATE 2, 58: PRINT "*****************"
  64. LOCATE 3, 58: PRINT "*  LIFE GAME    *"
  65. LOCATE 4, 58: PRINT "*     Ver 0.8   *"
  66. LOCATE 5, 58: PRINT "*      By   ASF *"
  67. LOCATE 6, 58: PRINT "*****************"
  68.  
  69. SCREEN , , , 0
  70.  
  71. start:
  72. PtrEdit
  73.  
  74. LOCATE 20, 53: PRINT "中断 ＝ anykey"
  75. LOCATE 8, 55: PRINT "世代 ＝"
  76. LOCATE 9, 55: PRINT "石数 ＝"
  77.  
  78. gen = 1
  79.  
  80. '*main
  81. DO
  82.     gen = gen + 1
  83.  
  84.     NextGen
  85.  
  86.     LOCATE 8, 62: PRINT gen
  87.     LOCATE 9, 62: PRINT Scnt
  88.  
  89.     IF INKEY$ <> "" THEN
  90.         SELECT CASE Break
  91.             CASE 1
  92.                 COLOR 3
  93.                 ChrClr 11, 55, 17, 5
  94.             CASE 2
  95.                 COLOR 3
  96.                 ChrClr 11, 55, 17, 5
  97.                 E = 0
  98.                 EXIT DO
  99.             CASE ELSE
  100.                 COLOR 7
  101.                 CLS
  102.                 PALETTE
  103.                 END
  104.         END SELECT
  105.     END IF
  106.  
  107.     E = EndChk
  108.  
  109. LOOP UNTIL E <> 0
  110.  
  111. '* end
  112. SELECT CASE E
  113.     CASE 0
  114.         '編集画面(^_^;)に戻る
  115.         PtrClear
  116.         ERASE NxtPtr
  117.         GOTO start
  118.     CASE 1
  119.         LOCATE 19, 10: PRINT "死滅しました"
  120.     CASE 2
  121.         LOCATE 19, 10: PRINT "完全に安定しました"
  122.     CASE 3
  123.         LOCATE 19, 10: PRINT "境界に達しました"
  124. END SELECT
  125.  
  126. LOCATE 21, 10: PRINT "終了しますか < Y / anykey > "
  127. VIEW PRINT 22 TO 23
  128. PRINT TAB(10);
  129. INPUT ; i$
  130. VIEW PRINT
  131.  
  132. IF i$ = "Y" OR i$ = "y" THEN
  133.     CLS
  134.     COLOR 7
  135.     PALETTE
  136.     END
  137. ELSE
  138.     ChrClr 19, 10, 30, 4
  139.     ERASE NxtPtr
  140.     PtrClear
  141.     GOTO start
  142. END IF
  143.  
  144. '-------------------------
  145.  
  146. errTrap:
  147.  
  148. RESUME NEXT
  149.  
  150. FUNCTION Break
  151. '中断処理
  152.  
  153. COLOR 20:        '←これが曲者･･･FMRだとブリンクしちゃいます
  154. LOCATE 11, 55: PRINT "  ＊＊中断＊＊   "
  155. LOCATE 12, 55: PRINT " 1)   継続       "
  156. LOCATE 13, 55: PRINT " 2)   編集       "
  157. LOCATE 14, 55: PRINT " 3)   終了       "
  158. LOCATE 15, 55: PRINT " < push 1 - 3 >  "
  159.  
  160. DO
  161.     i = VAL(INKEY$)
  162. LOOP WHILE i < 1 OR i > 3
  163.  
  164. Break = i
  165.  
  166. END FUNCTION
  167.  
  168. SUB ChrClr (l, c, clm, lin)
  169. '指定されたキャラクタ座標からclm個,lin行のスペースを出力する
  170.  
  171. FOR x = 1 TO lin
  172.     LOCATE l, c, 0: PRINT SPACE$(clm);
  173.     l = l + 1
  174. NEXT
  175.  
  176. END SUB
  177.  
  178. SUB DataLoad (s)
  179. 's=0:life.dat用､s=1:その他
  180.  
  181. IF s = 0 THEN
  182.     IF FileCheck(path$, "LIFE.DAT") = 1 THEN
  183.         filename$ = "life.dat"
  184.     ELSE
  185.         EXIT SUB
  186.     END IF
  187. ELSE
  188.     filename$ = GetFileName$
  189. END IF
  190.  
  191. IF filename$ = "" THEN EXIT SUB
  192.  
  193. PtrClear
  194.  
  195. filename$ = path$ + filename$
  196. OPEN filename$ FOR INPUT AS #1
  197.  
  198. s$ = INPUT$(4, #1)
  199. Scnt = VAL(s$)
  200. LOCATE 9, 55, 0: PRINT "石数 ＝"; Scnt
  201.  
  202. FOR i = 1 TO Scnt
  203.     x = VAL(INPUT$(4, #1))
  204.     y = VAL(INPUT$(4, #1))
  205.     Plot x, y, 7
  206.     PrePtr(x, y) = 1
  207. NEXT
  208.  
  209. CLOSE
  210.  
  211. END SUB
  212.  
  213. SUB DataSave (s)
  214. 's=0:life.dat用､s=1:その他
  215.  
  216. IF s = 0 THEN
  217.     filename$ = path$ + "life.dat"
  218. ELSE
  219.     LOCATE 12, 55: PRINT "ファイル名";
  220.     LOCATE 14, 55: PRINT "  ~~~~~~~~"
  221.     LOCATE 13, 55: INPUT ; f$
  222.  
  223.     filename$ = RTRIM$(f$)
  224.     ChrClr 12, 55, 25, 3
  225.      
  226.     IF filename$ = "" THEN EXIT SUB
  227.   
  228.     '拡張子を無視する
  229.     c = INSTR(filename$, ".")
  230.     IF c = 0 THEN c = 9
  231.     filename$ = path$ + LEFT$(filename$, c - 1) + ".lif"
  232. END IF
  233.  
  234. OPEN filename$ FOR OUTPUT AS #1
  235.  
  236. 'エラートラップ後の処理
  237. IF ERR = 36 OR ERR = 76 THEN
  238.     BEEP
  239.     ChrClr 12, 55, 25, 3
  240.     PRINT SPACE$(50)
  241.     EXIT SUB
  242. END IF
  243.  
  244. PRINT #1, USING "####"; Scnt;
  245.  
  246. FOR y = 1 TO 98
  247.     FOR x = 1 TO 98
  248.         IF PrePtr(x, y) THEN
  249.             PRINT #1, USING "####"; x; y;
  250.         END IF
  251.     NEXT
  252. NEXT
  253. PRINT #1, " "
  254.  
  255. CLOSE
  256.  
  257. LOCATE 13, 57: PRINT SPACE$(LEN(f$));
  258.  
  259. END SUB
  260.  
  261. SUB DrawMat
  262. 'ます目を描く
  263.  
  264. LINE (2, 2)-(398, 398), 2, BF
  265. LINE (4, 4)-(396, 396), 0, BF
  266. LINE (4, 4)-(396, 396), 1, B
  267.  
  268. FOR i = 8 TO 392 STEP 4
  269.     LINE (5, i)-(395, i), 1
  270.     LINE (i, 5)-(i, 395), 1
  271. NEXT
  272.  
  273. END SUB
  274.  
  275. FUNCTION EndChk STATIC
  276. '終了チェック  1:石が無くなった 2:完全に安定した 3:境界に達した
  277.  
  278. IF Scnt = 0 THEN
  279.     EndChk = 1
  280.     EXIT FUNCTION
  281. END IF
  282.  
  283. IF Flag = 0 THEN
  284.     EndChk = 2
  285.     EXIT FUNCTION
  286. END IF
  287.  
  288. FOR i = 1 TO 98
  289.     IF NxtPtr(i, 1) + NxtPtr(i, 98) + NxtPtr(1, i) + NxtPtr(98, i) THEN
  290.         EndChk = 3
  291.         EXIT FUNCTION
  292.     END IF
  293. NEXT
  294.  
  295. EndChk = 0
  296.  
  297. END FUNCTION
  298.  
  299. FUNCTION FileCheck (p$, f$)
  300. 'ファイルの有無を調べる
  301. 'ファイル名は、大文字で入力する
  302.  
  303. LOCATE 10, 10, 0
  304. SHELL "dir " + p$ + f$ + " > dummy"
  305. f$ = RTRIM$(LEFT$(f$, INSTR(f$, ".") - 1))
  306.  
  307. OPEN "dummy" FOR INPUT AS #1
  308. DO UNTIL EOF(1)
  309.     LINE INPUT #1, a$
  310.     IF RTRIM$(LEFT$(a$, 1)) <> "" AND INSTR(a$, f$) <> 0 THEN
  311.         FileCheck = 1
  312.         CLOSE
  313.         KILL "dummy"
  314.         EXIT FUNCTION
  315.     END IF
  316. LOOP
  317.  
  318. CLOSE
  319. KILL "dummy"
  320.  
  321. ChrClr 9, 10, 25, 2
  322.  
  323. FileCheck = 0
  324.  
  325. END FUNCTION
  326.  
  327. SUB Gcur (x1, y1, x2, y2)
  328. 'グラフィックカーソル
  329. 'x1,y1=old ,x2,y2=new:x2=y2=0→カーソルオフ
  330.  
  331. IF x2 + y2 = 0 THEN
  332.     LINE (x1 * 4, y1 * 4)-STEP(4, 4), 1, B
  333.     EXIT SUB
  334. END IF
  335.  
  336. LINE (x1 * 4, y1 * 4)-STEP(4, 4), 1, B
  337. LINE (x2 * 4, y2 * 4)-STEP(4, 4), 12, B
  338.  
  339. END SUB
  340.  
  341. FUNCTION GetFileName$
  342. '
  343. 'ここは、qbに付いてくる sampleをかなり｢参考｣にしてます(^^;)
  344. '                               ~~~~~~
  345. DIM file$(99)
  346.  
  347. SCREEN , , 1, 1
  348. LOCATE 10, 10, 0
  349.  
  350. SHELL "dir " + path$ + "*.lif > dummy"
  351.  
  352. OPEN "DUMMY" FOR INPUT AS #1
  353. DO UNTIL EOF(1)
  354.     LINE INPUT #1, a$
  355.     IF RTRIM$(LEFT$(a$, 1)) <> "" AND INSTR(a$, "<DIR>") = 0 THEN
  356.         N = N + 1
  357.         file$(N) = RTRIM$(LEFT$(a$, 8))
  358.     END IF
  359. LOOP
  360.  
  361. CLOSE
  362. KILL "DUMMY"
  363.  
  364. IF N = 0 THEN
  365.     GetFileName$ = ""
  366.     BEEP
  367.     SCREEN , , 0, 0
  368.     EXIT FUNCTION
  369. END IF
  370.  
  371. LOCATE 1, 1: PRINT " <" + path$ + " *.lif >    取消 = [ESC]"
  372.  
  373. DO
  374.     z = z + 1
  375.     PRINT USING " &      & "; file$(z);
  376.     IF (z) MOD 5 = 0 THEN PRINT
  377. LOOP UNTIL z > N
  378.  
  379. px = 1: py = 2
  380. x = 1: y = 2: z = 1
  381.  
  382. DO
  383. LineCur x, y, 4
  384. a$ = INKEY$
  385.     SELECT CASE a$
  386.         CASE CHR$(0, 72)
  387.             LineCur x, y, 0
  388.             y = y - 1: IF y < 2 THEN y = 2
  389.         CASE CHR$(0, 75)
  390.             LineCur x, y, 0
  391.             x = (x + 3) MOD 5 + 1
  392.         CASE CHR$(0, 77)
  393.             LineCur x, y, 0
  394.             x = (x) MOD 5 + 1
  395.         CASE CHR$(0, 80)
  396.             LineCur x, y, 0
  397.             y = y + 1
  398.         CASE CHR$(&HD)
  399.             z = (y - 2) * 5 + x
  400.             GetFileName$ = file$(z) + ".lif"
  401.         CASE CHR$(&H1B)
  402.             ChrClr 1, 1, 50, 20
  403.             CLS 1
  404.             SCREEN , , 0, 0
  405.             EXIT FUNCTION
  406.     END SELECT
  407.     z = (y - 2) * 5 + x
  408.     IF z > N THEN
  409.         y = 2
  410.         a$ = ""
  411.     END IF
  412. LOOP WHILE a$ <> CHR$(&HD)
  413.  
  414. ChrClr 1, 1, 50, 20
  415. LineCur x, y, 0
  416. SCREEN , , 0, 0
  417.  
  418. END FUNCTION
  419.  
  420. SUB LineCur (x, y, col)
  421. '
  422. LINE ((x - 1) * 80, (y - 1) * 16)-STEP(79, 15), col, BF
  423.  
  424. END SUB
  425.  
  426. SUB NextGen STATIC
  427. 'ここがほんとのメイン部分
  428. 'c = 周囲の石数(自分自身も含む)
  429. Scnt = 0
  430. Flag = 0
  431.  
  432. FOR y = 1 TO 98
  433.     FOR x = 1 TO 98
  434.    
  435.         c = PrePtr(x + 1, y - 1) + PrePtr(x - 1, y - 1) + PrePtr(x, y - 1) + PrePtr(x + 1, y) + PrePtr(x - 1, y) + PrePtr(x + 1, y + 1) + PrePtr(x - 1, y + 1) + PrePtr(x, y + 1) + PrePtr(x, y)
  436.  
  437.         IF c = 0 GOTO L1
  438.  
  439.         IF PrePtr(x, y) THEN
  440.             IF c = 4 OR c = 3 THEN
  441.                 NxtPtr(x, y) = 1: '生存
  442.                 Scnt = Scnt + 1
  443.             ELSE
  444.                 NxtPtr(x, y) = 0: '死滅
  445.                 LINE (x * 4 + 1, y * 4 + 1)-STEP(2, 2), 0, BF
  446.                 Flag = 1
  447.             END IF
  448.         ELSEIF c = 3 THEN
  449.                 NxtPtr(x, y) = 1:  '誕生
  450.                 Scnt = Scnt + 1
  451.                 LINE (x * 4 + 1, y * 4 + 1)-STEP(2, 2), 7, BF
  452.                 Flag = 1
  453.         END IF
  454. L1:
  455.     NEXT x
  456. NEXT y
  457. '
  458. '* データの入れ換え
  459. '
  460. FOR y = 1 TO 98
  461.     FOR x = 1 TO 98
  462.         PrePtr(x, y) = NxtPtr(x, y)
  463.     NEXT
  464. NEXT
  465.  
  466. END SUB
  467.  
  468. SUB Plot (x, y, col) STATIC
  469. '石を描く＆消す
  470. LINE (x * 4 + 1, y * 4 + 1)-STEP(2, 2), col, BF
  471.  
  472. END SUB
  473.  
  474. SUB PtrClear
  475. '
  476. FOR y = 1 TO 98
  477.     FOR x = 1 TO 98
  478.         IF PrePtr(x, y) THEN Plot x, y, 0
  479.     NEXT
  480. NEXT
  481.  
  482. ERASE PrePtr
  483. Scnt = 0
  484. LOCATE 9, 55: PRINT "石数 ＝ 0   "
  485.  
  486. END SUB
  487.  
  488. SUB PtrEdit
  489. 'パターン編集
  490.  
  491. x = 49: y = 49
  492.  
  493. LOCATE 8, 55:  PRINT "世代 ＝ 1   "
  494. LOCATE 9, 55:  PRINT "石数 ＝ 0   "
  495.  
  496. LOCATE 15, 52: PRINT "＜　パターン編集　＞"
  497. LOCATE 16, 52: PRINT "SET & UNSET = [SPACE]"
  498. LOCATE 17, 52: PRINT "データロード=   [L]"
  499. LOCATE 18, 52: PRINT "データセーブ=   [S]"
  500. LOCATE 19, 52: PRINT "クリア      =   [C]"
  501. LOCATE 20, 52: PRINT "EDIT 終了   =  [C R]"
  502.  
  503. DataLoad 0: 'life.datを読み込む
  504. ChrClr 9, 10, 30, 2
  505.  
  506. Gcur x, y, x, y: 'カーソルオン
  507.  
  508. '石入力用ループ
  509. DO
  510.     i$ = INKEY$
  511.  
  512.     SELECT CASE i$
  513.         CASE CHR$(0, &H48): 'up
  514.             IF y = 1 THEN
  515.                 Gcur x, y, x, 98
  516.                 y = 98
  517.             ELSE
  518.                 Gcur x, y, x, y - 1
  519.                 y = y - 1
  520.             END IF
  521.         CASE CHR$(0, &H4B): 'left
  522.             IF x = 1 THEN
  523.                 Gcur x, y, 98, y
  524.                 x = 98
  525.             ELSE
  526.                 Gcur x, y, x - 1, y
  527.                 x = x - 1
  528.             END IF
  529.         CASE CHR$(0, &H4D): 'right
  530.             IF x = 98 THEN
  531.                 Gcur x, y, 1, y
  532.                 x = 1
  533.             ELSE
  534.                 Gcur x, y, x + 1, y
  535.                 x = x + 1
  536.             END IF
  537.         CASE CHR$(0, &H50): 'down
  538.             IF y = 98 THEN
  539.                 Gcur x, y, x, 1
  540.                 y = 1
  541.             ELSE
  542.                 Gcur x, y, x, y + 1
  543.                 y = y + 1
  544.             END IF
  545.         CASE CHR$(0, &H47): 'home
  546.             Gcur x, y, 49, 49
  547.             x = 49: y = 49
  548.         CASE " ":  'set&unset
  549.             IF PrePtr(x, y) THEN
  550.                 PrePtr(x, y) = 0: 'unset
  551.                 Plot x, y, 0
  552.                 Scnt = Scnt - 1
  553.                 LOCATE 9, 55:  PRINT "石数 ＝"; Scnt
  554.             ELSE
  555.                 PrePtr(x, y) = 1: 'set
  556.                 Plot x, y, 7
  557.                 Scnt = Scnt + 1
  558.                 LOCATE 9, 55:  PRINT "石数 ＝"; Scnt
  559.             END IF
  560.         CASE CHR$(&HD): 'exit
  561.             IF Scnt = 0 THEN
  562.                 LOCATE 21, 52: PRINT "石が有りません・・・"
  563.                 LOCATE 22, 52: PRINT "終了しますか(Y/anykey)"
  564.                 VIEW PRINT 23 TO 24
  565.                 PRINT TAB(52);
  566.                 INPUT ; i$
  567.  
  568.                 CLS 2
  569.  
  570.                 IF i$ = "y" OR i$ = "Y" THEN
  571.                     COLOR 7
  572.                     CLS
  573.                     PALETTE
  574.                     END
  575.                 ELSE
  576.                     VIEW PRINT 1 TO 23
  577.                     ChrClr 21, 52, 24, 3
  578.                 END IF
  579.             ELSE
  580.                 LOCATE 21, 52: PRINT "ＯＫ (Y/anykey)"
  581.                 VIEW PRINT 22 TO 23
  582.                 PRINT TAB(52);
  583.                 INPUT ; i$
  584.  
  585.                 CLS 2
  586.                 VIEW PRINT 1 TO 23
  587.  
  588.                 IF i$ = "y" OR i$ = "Y" THEN
  589.                     EXIT DO
  590.                 ELSE
  591.                     ChrClr 21, 52, 23, 3
  592.                 END IF
  593.             END IF
  594.         CASE "c", "C": 'pattern clear
  595.             Gcur x, y, 0, 0
  596.             PtrClear
  597.             Gcur x, y, x, y
  598.         CASE "l", "L": 'data load
  599.             Gcur x, y, 0, 0
  600.             DataLoad 1
  601.             ChrClr 9, 10, 30, 2
  602.             Gcur x, y, x, y
  603.         CASE "s", "S": 'data save
  604.             DataSave 1
  605.     END SELECT
  606. LOOP
  607.  
  608. 'カーソルを消す
  609. Gcur x, y, 0, 0
  610.  
  611. ChrClr 15, 52, 25, 7
  612.  
  613. DataSave 0: 'life.datをセーブ
  614.  
  615. END SUB
  616.  
  617.