1000 ' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 1010 ' *                                                                 *
 1020 ' *   Ｃｏｐｙｒｉｇｈｔ（Ｃ） 応用流体第二研究室　in 1989/02/21    *
 1030 ' *                                                                 *
 1040 ' *      [TETRIS] Made by   ..... Kunio_Yamazaki                    *
 1050 ' *                    for  ..... 富士通 FMR-50FD [F-BASIC(86)HG]   *
 1060 ' *                                                                 *
 1070 ' * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 1080 :
 2000 on error goto *PROC_ERR
 2010 defint A-Z:randomize time/4
 2020 dim FONT(8,4,4,4),RATE(5),TETRIS(4),T(6),M(6),NM$(6)
 2030 :
 2040 *COLD_START
 2050 open "I",#1,"TETRIS.DAT"
 2060 for I=1 to 5
 2070   input #1,T(I),M(I),NM$(I)
 2080 next
 2090 close
 2100 :
 2110 I=0:J=0:X=0:Y=0:K=0:L=0:BUF=0:BUF2=0:PAT=0:REV=0
 2120 BUF_X=0:BUF_Y=0:CCOL=0:DEL_Y=0:DUMY_REV=0:DUMY_X=0:DUMY_Y=0
 2130 D_TOUCH=0:U_TOUCH=0:G_STAGE=0:DEL_BUF=0:PROC=0:FC=0:NO=0
 2140 SCORE_D=0:LINE_D=0:STAGE_D=0
 2150 INIT_WT=80:FLAG_ERR=0
 2160 :
 2170 '0      1        2        3        4
 2180 data 0,0,0,0, 0,2,0,0, 0,2,2,0, 0,0,2,0
 2190 data 0,2,2,0, 0,2,0,0, 0,0,0,0, 0,0,2,0
 2200 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2210 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2220 '1
 2230 data 0,0,1,0, 0,1,0,0, 0,0,0,0, 1,1,0,0
 2240 data 1,1,1,0, 0,1,0,0, 1,1,1,0, 0,1,0,0
 2250 data 0,0,0,0, 0,1,1,0, 1,0,0,0, 0,1,0,0
 2260 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2270 '2
 2280 data 2,0,0,0, 0,2,2,0, 0,0,0,0, 0,2,0,0
 2290 data 2,2,2,0, 0,2,0,0, 2,2,2,0, 0,2,0,0
 2300 data 0,0,0,0, 0,2,0,0, 0,0,2,0, 2,2,0,0
 2310 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2320 '3
 2330 data 0,3,3,0, 0,3,3,0, 0,3,3,0, 0,3,3,0
 2340 data 0,3,3,0, 0,3,3,0, 0,3,3,0, 0,3,3,0
 2350 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2360 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2370 '4
 2380 data 0,0,0,0, 0,4,0,0, 0,0,0,0, 0,0,4,0
 2390 data 0,0,0,0, 0,4,0,0, 4,4,4,4, 0,0,4,0
 2400 data 4,4,4,4, 0,4,0,0, 0,0,0,0, 0,0,4,0
 2410 data 0,0,0,0, 0,4,0,0, 0,0,0,0, 0,0,4,0
 2420 '5
 2430 data 0,5,5,0, 0,5,0,0, 0,0,0,0, 5,0,0,0
 2440 data 5,5,0,0, 0,5,5,0, 0,5,5,0, 5,5,0,0
 2450 data 0,0,0,0, 0,0,5,0, 5,5,0,0, 0,5,0,0
 2460 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2470 '6
 2480 data 6,6,0,0, 0,0,6,0, 0,0,0,0, 0,6,0,0
 2490 data 0,6,6,0, 0,6,6,0, 6,6,0,0, 6,6,0,0
 2500 data 0,0,0,0, 0,6,0,0, 0,6,6,0, 6,0,0,0
 2510 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2520 '7
 2530 data 0,7,0,0, 0,7,0,0, 0,0,0,0, 0,7,0,0
 2540 data 7,7,7,0, 0,7,7,0, 7,7,7,0, 7,7,0,0
 2550 data 0,0,0,0, 0,7,0,0, 0,7,0,0, 0,7,0,0
 2560 data 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0
 2570 '8
 2580 data 2,7,7,2, 7,2,2,2, 7,2,2,2, 2,2,2,7
 2590 data 2,7,7,2, 7,2,7,7, 7,2,7,7, 2,7,7,2
 2600 data 2,7,7,2, 7,7,2,7, 7,7,2,7, 2,2,2,7
 2610 data 7,2,2,7, 2,2,2,7, 2,2,2,7, 2,7,7,2
 2620 restore 2180
 2630 for L = 0 to 8
 2640   for J = 1 to 4
 2650     for K = 1 to 4
 2660       for I = 1 to 4
 2670         read FONT(L, K, I, J)
 2680       next
 2690     next
 2700   next
 2710 next
 2720 :
 2730 data 40,100,300,1200
 2740 restore 2730
 2750 for I = 1 to 4
 2760   read RATE(I)
 2770 next
 2780 :
 2790 for I=1 to 4
 2800   BASEK(I)=I
 2810 next
 2820 BASEK(0)=4:BASEK(5)=1
 2830 :
 2840 data 127, 252, 135, 250, 191, 250, 191, 250, 191, 250, 255, 250, 255
 2850 data 250, 255, 250, 255, 250, 255, 250, 255, 250, 255, 250, 255, 250
 2860 data 192, 2, 127, 252, 0, 0
 2870 :
 2880 data 255, 255, 131, 193, 143, 241, 152, 57, 144, 25, 161, 205, 163
 2890 data 141, 135, 13, 133, 141, 128, 201, 136, 121, 134, 49, 143, 217
 2900 data 156, 13, 152, 7, 255, 255
 2910 :
 2920 restore 2840
 2930 for J=1 to 2
 2940   Z$=""
 2950   for I=1 to 32
 2960     read K
 2970     Z$=Z$+chr$(K)
 2980   next
 2990   def kanji &H7520+J,Z$
 3000 next
 3010 :
 3020 data 128,0,0,0,8,0,0,0
 3030 restore 3020:TILE$=""
 3040 for I=0 to 7
 3050   read J
 3060   TILE$=TILE$+chr$(J)+chr$(0)+chr$(0)
 3070 next
 3080 :
 3090 goto *HOT_START
 3100 :
 3110 *積木判断
 3120 BUF=0
 3130 K=3-(PAT=4)
 3140 for J=1 to K
 3150   for I=1 to K
 3160     if FONT(PAT,DUMY_REV,I,J)>0 then
 3170       if screen(DUMY_X+(I-1)*2,DUMY_Y+J-1,1)\8 >0 then 3220
 3180     endif
 3190   next
 3200 next
 3210 BUF=1
 3220 return
 3230 :
 3240 *消去判断
 3250 DEL_Y=Y:DEL_BUF=0:J=Y
 3260 while J<=Y+4 and J<24
 3270   BUF=1
 3280   for I=30 to 48 step 2
 3290     BUF=BUF and ((screen(I+1,J)=&H21) and (screen(I,J,1)>0))
 3300   next
 3310   if BUF=0 then
 3320     if DEL_Y<J then
 3330       color@ (30,DEL_Y)-(49,J-1),0,4
 3342       for K=0 to 315*(WT+1):next
 3350       color@ (30,DEL_Y)-(49,J-1),0,0
 3362       for K=0 to 315*(WT+1):next
 3370       BUF=1:L=0
 3380       while BUF
 3390         BUF=0:L=L+1
 3400         for K=30 to 48 step 2
 3410           CCOL=screen(K,DEL_Y-L,1)
 3420           color@ (K,J-L)-(K+1,J-L),CCOL mod 8,CCOL\8
 3430           BUF=BUF+sgn(CCOL)
 3440         next
 3450       wend
 3460       color@ (30,2)-(49,J-L-1),0,0
 3470       DEL_BUF=DEL_BUF+J-DEL_Y
 3480     endif
 3490     DEL_Y=J+1
 3500   endif
 3510   J=J+1
 3520 wend
 3530 if DEL_BUF>0 then BUF=DEL_BUF:gosub *得点
 3540 return
 3550 :
 3560 *積木描写
 3570 K=3-(PAT=4)
 3580 for J=1 to K
 3590   for I=1 to K
 3600     if FONT(PAT,REV,I,J)>0 then
 3610       BUF_X=X+(I-1)*2:BUF_Y=Y+J-1
 3620       color@ (BUF_X,BUF_Y)-(BUF_X+1,BUF_Y),FONT(PAT,REV,I,J)*BUF,BUF2
 3630     endif
 3640   next
 3650 next
 3660 return
 3670 :
 3680 *回転
 3690 DUMY_REV=BASEK(REV+BUF)
 3700 gosub *積木判断
 3710 if BUF then 
 3720   BUF=0:BUF2=0:gosub *積木描写
 3730   REV=DUMY_REV
 3740 endif
 3750 return
 3760 :
 3770 *落下
 3780 DUMY_Y=Y
 3790 while BUF=1
 3800   DUMY_Y=DUMY_Y+1
 3810   gosub *積木判断
 3820 wend
 3830 BUF=0:BUF2=0:gosub *積木描写
 3840 if DUMY_Y-Y-1>0 then
 3850   BUF=((DUMY_Y-Y)\7+1)*10
 3860   SCORE_D=SCORE_D+BUF
 3870   locate 18,8:color 4:print using "######";SCORE_D
 3880 endif
 3890 Y=DUMY_Y-1
 3900 return
 3910 :
 3920 *得点
 3930 SCORE_D=SCORE_D+RATE(BUF)
 3940 locate 18,8:color 4:print using "######";SCORE_D
 3950 :
 3960 LINE_D=LINE_D+BUF
 3970 locate 18,11:color 5:print using "######";LINE_D
 3980 :
 3990 STAGE_D=LINE_D\3+1
 4000 locate 18,14:color 3:print using "######";STAGE_D
 4010 if WT>0 then
 4020   WT=INIT_WT-STAGE_D
 4030 endif
 4040 :
 4050 if STAGE_D>19 and Y<7 then
 4060   G_TETRIS=G_TETRIS+BUF
 4070 endif
 4080 :
 4090 TETRIS(BUF)=TETRIS(BUF)+1
 4100 locate 66,14+(BUF-1)*2:color 6-BUF
 4110 print using " #### �A";TETRIS(BUF);
 4120 return
 4130 :
 4140 *データ記録
 4150 open "O",#1,"TETRIS.DAT"
 4160 for I=1 to 5
 4170   write #1,T(I),M(I),NM$(I)
 4180 next
 4190 close
 4200 return
 4210 :
 4220 *PROC_ERR
 4230 if err=64 then
 4240   kill "TETRIS.DAT"
 4250   resume
 4260 else
 4270   if err=63 then
 4280     print  "データ・ファイルがない！　なんとかして下さい。"
 4290     Z$=input$(1):resume *COLD_START
 4300   endif
 4310 endif
 4320 beep:print err;"in";erl:Z$=input$(1)
 4330 FLAG_ERR=1
 4340 resume *START
 4350 :
 4360 *HOT_START
 4370 cls:width 80,25:console 0,25,0:locate 0,0,0
 4380 screen 6,0,1
 4390 symbol@ (50,20),"ТЕТЯＩＳ",4,4,2,,pset
 4400 symbol@ (54,22),"ТЕТЯＩＳ",4,4,2,,pset
 4410 symbol@ (53,23),"ТЕТЯＩＳ",4,4,2,,xor
 4420 screen ,0,0
 4430 locate 16,6:color 7
 4440 print tab(8);"�@�@�@  ＜＜　使用説明　USSR-TETRIS ＞＞  �@�@�@�@�@�@�@�@�@�@�@"
 4450 print tab(8);"�@";tab(70);"�@"
 4460 print tab(8);"�@　　上から落下してくるブロックを下から順番になるべく隙間な　�@"
 4470 print tab(8);"�@　く多くつめることを競います。                              �@"
 4480 print tab(8);"�@　　数字の４または６で、左右にうごかします。　ブロックの回　�@"
 4490 print tab(8);"�@　転は小文字のｚまたはｘで行われます。　すばやく落下させた　�@"
 4500 print tab(8);"�@　い時は数字の２を押します。　なお横１列すべてにブロックが　�@"
 4510 print tab(8);"�@　敷詰められるとその列は消滅し上に載っているブロックが落下　�@"
 4520 print tab(8);"�@　してきます。　　　　　　　　　　　　　　　　　　　　　　　�@"
 4530 print tab(8);"�@";tab(70);"�@"
 4540 print tab(8);"�@　　尚、このプログラムはソ連のプログラマによってつくられた　�@"
 4550 print tab(8);"�@　もののため、一部ロシア文字がつかわれております。　御了承　�@"
 4560 print tab(8);"�@　下さい。";
 4570 color 2:print "�A";:color 7:print tab(70);"�@"
 4580 print tab(8);"�@";tab(70);"�@"
 4590 print tab(8);"�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@�@"
 4600 print tab(50);"何かキーを押して下さい。"
 4610 Z$=input$(1):stop off
 4620 :
 4630 *START
 4640 SCORE_D=0:LINE_D=0:STAGE_D=1:G_TETRIS=0:WT=80
 4650 for I=1 to 4
 4660   TETRIS(I)=0
 4670 next
 4680 cls:width 80,25:console 0,25,0:screen 6,0,1:locate 0,0,0
 4690 line (0, 0)-(639, 399),pset,6, bf
 4700 line (6, 5)-(633, 394),pset,0, bf,TILE$
 4710 line (3, 3)-(636, 396),pset,0, b
 4720 line (224, 16)-(416, 384),pset,0, bf
 4730 line (454, 61)-(554, 164),pset,6, bf
 4740 line (457, 64)-(551, 161),pset,0, bf
 4750 line (454, 20)-(554, 56),pset,6, bf
 4760 line (457, 23)-(551, 53),pset,0, bf
 4770 for I = 0 to 96 step 48
 4780   line (33, 116+I)-(203, 154+I),pset,5,bf,7
 4790   line (36, 119+I)-(200, 151+I),pset,5,bf,0
 4800 next
 4810 line (33, 292)-(203, 330),pset,5,bf,4
 4820 line (36, 295)-(200, 327),pset,5,bf,0
 4830 symbol@ (20,20),"ТЕТЯＩＳ",2,3,2,,pset
 4840 symbol@ (22,20),"ТЕТЯＩＳ",2,3,2,,pset
 4850 symbol@ (20,21),"ТЕТЯＩＳ",2,3,2,,xor
 4860 line (20,68)-(211,73),pset,1,bf
 4870 line (20,70)-(211,71),pset,0,bf
 4880 for I=0 to 3
 4890   line (440,240+I*32)-(600,242+I*32),pset,1,b
 4900 next
 4910 screen ,0,0
 4920 :
 4930 locate 6, 8:color 6:print "ＳСＯЯЕ :";:color 4:print "     0"
 4940 locate 6,11:color 6:print "ＬＩИЕＳ :";:color 5:print "     0"
 4950 locate 6,14:color 6:print "ＳＴАＧЕ :";:color 3:print "     1"
 4960 locate 6,19:color 2:print "�A      �A :";
 4970 locate 8,19:color 6:print "ＴＯＰ";
 4980 locate 18,19:color 2:print using "######";T(1)
 4990 locate 59,2:color 6:print "ИЕХТ"
 5000 locate 56,14:color 5:print "Single";:color 5:print  "        0 �A"
 5010 locate 56,16:color 5:print "Double";:color 4:print  "        0 �A"
 5020 locate 56,18:color 5:print "Triple";:color 3:print  "        0 �A"
 5030 locate 56,20:color 2:print "Tetris";:color 2:print  "        0 �A"
 5040 :
 5050 color 2,,,4
 5060 locate 28,1:print "�A�A�A�A�A�A�A�A�A�A�A�A";
 5070 for I=1 to 21
 5080   locate 28,I+1:print "�A";tab(50);"�A";
 5090 next
 5100 locate 28,23:print "�A�A�A�A�A�A�A�A�A�A�A�A";
 5110 color 1,,,5:locate 34,23:print "ЪЭЙёМУ";
 5120 :
 5130 color 0,,,0
 5140 for I=1 to 21
 5150   locate 30,I+1:print "�@�@�@�@�@�@�@�@�@�@";
 5160 next
 5170 :
 5180 for I=1 to 4
 5190   locate 59,I+4:print "�@�@�@�@";
 5200 next:color 7
 5210 :
 5220 NXT_PAT=int(rnd*7)+1:NXT_REV=int(rnd*4)+1:X=36:Y=2
 5230 U_TOUCH=0
 5240 :
 5250 while U_TOUCH=0 :' [落下開始]
 5260   D_TOUCH=0
 5270   NOW_PAT=NXT_PAT:NOW_REV=NXT_REV
 5280   color@ (59,5)-(66,9),0,0
 5290   BUF_R=BUF_R+3:if BUF_R>49 then BUF_R=BUF_R-49
 5300   PAT=int(rnd*7)+1:REV=int(rnd*4)+1
 5310   if SCORE_D mod 400=0 and SCORE_D>0 then
 5320     PAT=0
 5330     SCORE_D=SCORE_D+50
 5340   endif
 5350   BUF=1:BUF2=0:X=59:Y=5:NXT_PAT=PAT:NXT_REV=REV
 5360   if STAGE_D<21 or G_TETRIS>0 then
 5370     G_TETRIS=G_TETRIS-sgn(G_TETRIS)
 5380   else
 5390     PAT=8
 5400   endif
 5410   gosub *積木描写
 5420   PAT=NOW_PAT:REV=NOW_REV
 5430   DUMY_REV=REV:DUMY_X=36:DUMY_Y=2
 5440   gosub *積木判断
 5450   if BUF=0 then
 5460     U_TOUCH=1
 5470     X=36:Y=2:BUF=1:BUF2=6:gosub *積木描写
 5480   else
 5490     X=36:Y=2:BUF=1:BUF2=0:gosub *積木描写
 5500 :
 5510     while D_TOUCH=0 :' [メイン、鍵入力及び移動・回転]
 5520       DUMY_REV=REV:DUMY_X=X:DUMY_Y=Y+1:'  [下降]
 5530       gosub *積木判断
 5540       if BUF then D_TOUCH=0
 5550       gosub *積木判断
 5560       if BUF then
 5570         BUF=0:BUF2=0:gosub *積木描写
 5580         Y=DUMY_Y
 5590       else
 5600         D_TOUCH=1
 5610       endif
 5620       BUF=1:BUF2=0:gosub *積木描写
 5630 :
 5640       Z$=inkey$+"｢":PROC=instr("｢ ｢4｢6｢5｢x｢",Z$)\2
 5650       N_INKEY=0
 5660       while PROC>0 or N_INKEY<WT
 5670         DUMY_REV=REV:DUMY_X=X:DUMY_Y=Y
 5680         on PROC gosub *落下,5690,5730,5770,5790 :goto 5810
 5690          :DUMY_X=X-2
 5700           gosub *積木判断
 5710           if BUF then BUF=0:BUF2=0:gosub *積木描写:X=DUMY_X
 5720         return
 5730          :DUMY_X=X+2
 5740           gosub *積木判断
 5750           if BUF then BUF=0:BUF2=0:gosub *積木描写:X=DUMY_X
 5760         return
 5770          :BUF=-1:gosub *回転
 5780         return
 5790          :BUF=1:gosub *回転
 5800         return
 5810         BUF=1:BUF2=0:gosub *積木描写
 5820         Z$=inkey$+"｢":PROC=instr("｢ ｢4｢6｢5｢x｢",Z$)\2
 5830         N_INKEY=N_INKEY+1
 5840       wend
 5850       DUMY_REV=REV:DUMY_X=X:DUMY_Y=Y+1:'  [下降]
 5860       gosub *積木判断
 5870       if BUF then D_TOUCH=0
 5880     wend
 5890     BUF=1:BUF2=4:gosub *積木描写
 5900     gosub *消去判断
 5910     if inkey$<>"" then 5910
 5920   endif
 5930 wend
 5940 :
 5950 '  ***** GAME OVER *****
 5960 beep
 5970 line (32,7)-(47,9)," ",7,bf
 5980 locate 34,8,0:color 0,,,6:print "Game Over";:color 2,,,0:print " �A";
 5990 if inkey$<>"" then 5990
 6000 Z$=input$(1):if Z$<>" " then 6000
 6010 :
 6020 cls:width 80,20:console 0,19,1
 6030 NO=6
 6040 if SCORE_D>T(5) or (SCORE_D=T(5) and LINE_D>M(5)) then
 6050   I=1:T(6)=SCORE_D:M(6)=LINE_D
 6060   while T(I)>SCORE_D
 6070     I=I+1
 6080   wend 
 6090   if I<=5 then
 6100     while T(I)=SCORE_D and M(I)>LINE_D
 6110       I=I+1
 6120     wend 
 6130     for J=5 to I step -1
 6140       T(J+1)=T(J)
 6150       M(J+1)=M(J)
 6160       NM$(J+1)=NM$(J)
 6170     next 
 6180     T(I)=SCORE_D:M(I)=LINE_D:NM$(I)="NONAME"
 6190   endif
 6200   NO=I
 6210 endif
 6220 :
 6230 locate 0,8
 6240 color 7:print "        No         SCORE         LINE        NAME"
 6250 for I=1 to 5
 6260   color I+1,,,4*(-(I=NO))
 6270   print using "         #       #######      #######";I,T(I),M(I);
 6280   if I=NO then
 6290     print 
 6300   else
 6310     print using "    &                  &";NM$(I)
 6320   endif
 6330 next 
 6340 if NO<=5 then
 6350   color NO+1,,,6
 6360   locate 4,5:print "おまえも頽廃者の仲間だ！";
 6370   color 2,,,0:print "  �A"
 6380   locate 41,NO+8:color NO+1,,,4
 6390   line input "",Z$
 6400   if len(Z$)>20 or len(Z$)=0 then beep:goto 6380
 6410   NM$(NO)=Z$
 6420   gosub *データ記録
 6430 else
 6440   locate 4,5:print "西欧の頽廃文明にかぶれし者";
 6450   color 2,,,0:print "  �A";
 6460   color 4
 6470   print using "     [ You  Score:####### | Line:#### ]";SCORE_D,LINE_D
 6480 endif
 6490 color 7,,,0:locate 18,17
 6500 print "まだ［ＴＥＴЯＩＳ］を行いますか？ (Y/N)"
 6510 locate 58,17,1,0,15
 6520 Z$=input$(1)
 6530 FC=(instr("YyﾝNnﾐ",Z$)+2)\3
 6540 on FC+1 goto 6550,6560,6560
 6550 beep:goto 6510
 6560 FC=2-FC
 6570 if FC then *START
 6580 if FLAG_ERR=1 then gosub *データ記録:FLAG_ERR=0
 6590 stop on:end