    1 REMサンプル No.7
    100 WIDTH,M,N:CLS
    110 ON ERROR GOTO *ERR
    120 DIM P$(35),Q$(35),C(&8F),G(&9,&13),LX(&3),LY(&3)
    125 RANDOMIZE
    130 GOSUB *PINIT
    140 GOSUB *CINIT:GOSUB *SHUFFLE:GOSUB *CGSET:GOSUB *ALLDRAW
    150 LOCATE0,0:PRINT"終了"
    155 P1=-1 : Z=144
    160 *LP1
    170 CALL @11                               :'タッチされるまで待つ
    180 IF TOUCH(&0,&0,&18,&F) THEN *THEEND    :'「終了」ならTHEENDへ
    190 IF NOT TOUCH(&B,&1D,&E2,&9C) THEN *LP1 :'(11,29)-(226,156)以外ならLP1へ
    200 TX = TOUCH X                           :'タッチされた横座標を得る
    210 TY = TOUCH Y                           :'　　　〃　　縦座標を得る
    220 PX = INT((TX+&1)/&C)                   :'牌の座標に変換
    230 PY = INT((TY-&D)/&10)                  :'　　　〃
    240 IF P1<0 THEN X=PX,Y=PY:GOSUB *TC1 ELSE V=PX,W=PY:GOSUB *TC2
    250 IF Z THEN *LP1                           :'まだ牌がある?
    260 GOTO *THEEND
    400 '
    410 *TC1
    420 IF G(Y,X)=-1 THEN RETURN     :'牌がない
    430 P1=G(Y,X)                    :'今の牌の種類を P1 に保存。
    440 GOSUB *HANTENX
    450 RETURN
    460 '
    470 *TC2
    480 IF G(W,V)<>P1 THEN RETURN    :'同じ種類ではない。
    490 IF X=V AND Y=W THEN *CANCEL  :'1つ目と同じ牌なら、キャンセル
    500 GOSUB *HANTEN2
    510 GOSUB *HANTEI:IF OK=&0 THEN GOSUB *HANTEN2:RETURN
    620 '
    630 *T3
    640 CALL@41,(X*12-1,Y*16+13)-(X*12+10,Y*16+28),3,0  :'消去
    650 CALL@41,(V*12-1,W*16+13)-(V*12+10,W*16+28),3,0  :'消去
    660 G(Y,X)=-1,G(W,V)=-1 : 'この行を外すと困ったことが(^_^;)
    670 Z=Z-&2
    680 P1=-1
    690 RETURN
    790 '
    800 *CANCEL
    810 P1=-1
    820 GOSUB *HANTENX
    830 RETURN
    840 '
    850 *HANTENX:CALL@41,(X*12-1,Y*16+13)-(X*12+9,Y*16+27),1,1:RETURN
    860 *HANTEN2:CALL@41,(V*12-1,W*16+13)-(V*12+9,W*16+27),1,1:RETURN
    980 *THEEND:CLS:WIDTH,,N:CALL@20:CALL@18:KEY 0,"":END
    990 *ERR:CLS:WAIT&0:PRINT ERN;ERL:CALL@11:GOTO *THEEND
    1000 '
    1010 *PINIT
    1020 P$(0)="0000101211202123210100FF"
    1030 Q$(0)="0109099FFDB5FDD33F3101FE"
    1040 P$(1)="0000082A29485153111100FF"
    1050 Q$(1)="0109099FFDB5FDD33F3101FE"
    1060 P$(2)="0000045455A8A90B090900FF"
    1070 Q$(2)="0109099FFDB5FDD33F3101FE"
    1080 P$(3)="0000302A3928596B596100FF"
    1090 Q$(3)="0109099FFDB5FDD33F3101FE"
    1100 P$(4)="0000207E855C7D579D0500FF"
    1110 Q$(4)="0109099FFDB5FDD33F3101FE"
    1120 P$(5)="0000283A21C0415B490100FF"
    1130 Q$(5)="0109099FFDB5FDD33F3101FE"
    1140 P$(6)="001010227128494B410100FF"
    1150 Q$(6)="0109099FFDB5FDD33F3101FE"
    1160 P$(7)="0000081A0140311B090900FF"
    1170 Q$(7)="0109099FFDB5FDD33F3101FE"
    1180 P$(8)="00082832E140715B093908FF"
    1190 Q$(8)="0109099FFDB5FDD33F3101FE"
    1200 P$(9)="00229E3359675B6F3C8100FF"
    1210 Q$(9)="018951153DF1E1E5F99101FE"
    1220 P$(10)="00000000447C4400000000FF"
    1230 Q$(10)="0101010189F98901010101FE"
    1240 P$(11)="00000000447C4400000000FF"
    1250 Q$(11)="0189F98901010189F98901FE"
    1260 P$(12)="00447C44000000447C4400FF"
    1270 Q$(12)="0189F98901010189F98901FE"
    1280 P$(13)="00427E42080F08427E4200FF"
    1290 Q$(13)="0185FD8521E12185FD8501FE"
    1300 P$(14)="447C4400447C4400447C44FF"
    1310 Q$(14)="457D4501457D4501457D45FE"
    1320 P$(15)="0203034A7B7B4A03030200FF"
    1330 Q$(15)="A5BDBDA5BDBDA5BDBDA501FE"
    1340 P$(16)="007E7E1C3870381C7E7E00FF"
    1350 Q$(16)="01FDFD71391D3971FDFD01FE"
    1360 P$(17)="4A7B7B4A7B7B4A7B7B4A00FF"
    1370 Q$(17)="A5BDBDA5BDBDA5BDBDA501FE"
    1380 P$(18)="000003070C0C0C07030000FF"
    1390 Q$(18)="010181C1616161C1810101FE"
    1400 P$(19)="00000010386C3810000000FF"
    1410 Q$(19)="01010111396D3911010101FE"
    1420 P$(20)="10386C3913060301000000FF"
    1430 Q$(20)="0101010181C191396D3911FE"
    1440 P$(21)="10386C38100010386C3810FF"
    1450 Q$(21)="11396D39110111396D3911FE"
    1460 P$(22)="10386C39130613396C3810FF"
    1470 Q$(22)="11396D3991C191396D3911FE"
    1480 P$(23)="00113B3B1100113B3B1100FF"
    1490 Q$(23)="0111B9B9110111B9B91101FE"
    1500 P$(24)="70507101382838011D141CFF"
    1510 Q$(24)="0189DDDD890189DDDD8901FE"
    1520 P$(25)="0044EEEE440044EEEE4400FF"
    1530 Q$(25)="0145EFEF450145EFEF4501FE"
    1540 P$(26)="7352730073527300735273FF"
    1550 Q$(26)="9D959D019D959D019D959DFE"
    1560 P$(27)="00003014377F292E2C0000FF"
    1570 Q$(27)="0121419199FD01C1311901FE"
    1580 P$(28)="0001121B167D3B02010000FF"
    1590 Q$(28)="01816101C1D15919F1C101FE"
    1600 P$(29)="0009090B0D091F13111100FF"
    1610 Q$(29)="01F13191711171D939E101FE"
    1620 P$(30)="0004020F013F02060C0000FF"
    1630 Q$(30)="212141F101E11111711101FE"
    1640 P$(31)="0000000000000000000000FF"
    1650 Q$(31)="0101010101010101010101FE"
    1660 P$(32)="00012A2F3B131D2D0B0300FF"
    1670 Q$(32)="012111C9C971C9F1510901FE"
    1680 P$(33)="000007043C3F08090F0C00FF"
    1690 Q$(33)="0101018181F98181010101FE"
    1700 P$(34)="00020100123F1E1E3F1200FF"
    1710 Q$(34)="015199799D3D5D99191101FE"
    1720 P$(35)="02071A7D1A0703061F0601FF"
    1730 Q$(35)="0101C1F1C181C1B17DB1C1FE"
    1740 RETURN
    1750 '
    1760 *CINIT
    1770 FOR J=&0 TO &11:C(J)=J,C(J+&12)=J,C(J+&24)=J,C(J+&36)=J:NEXT
    1780 FOR J=&12 TO &23:C(J+&36)=J,C(J+&48)=J,C(J+&5A)=J,C(J+&6C)=J:NEXT
    1790 RETURN
    1800 '
    1810 *SHUFFLE
    1820 FOR I=&0 TO &120:J=RND144-1,K=RND144-1,L=C(J),C(J)=C(K),C(K)=L:NEXT
    1830 RETURN
    1840 '
    1850 *CGSET
    1860 K=&0
    1870 FOR I=&1 TO &8:FOR J=&1 TO &12:G(I,J)=C(K),K=K+&1:NEXT:NEXT
    1880 FOR I=&1 TO &8:G(I,&0)=-1,G(I,&13)=-1:NEXT
    1890 FOR I=&0 TO &13:G(&0,I)=-1,G(&9,I)=-1:NEXT
    1900 RETURN
    2000 '
    2010 *ALLDRAW
    2020 WAIT&0
    2030 CALL@41,(&0,&12)-(&EE,&A8),&3,&0
    2040 FOR J=1 TO 8
    2050   FOR I=1 TO 18
    2055     IF G(J,I)=-1 THEN *ADSKIP
    2060     XX=I*12-1 : YY=J*16+13+7
    2070     GCURSOR(XX,YY)   : GPRINT P$(G(J,I));
    2080     GCURSOR(XX,YY+8) : GPRINT Q$(G(J,I));
    2085     *ADSKIP
    2090   NEXT
    2100 NEXT
    2110 RETURN
    2710 '
    2720 *HANTEI
    2730 LC=&0:FA=&F
    2735 ' X座標の小さい方を(T1,U1)に、大きい方を(T2,U2)にする。
    2740 IF X<V THEN T1=X,T2=V,U1=Y,U2=W ELSE T1=V,T2=X,U1=W,U2=Y
    2745 ' Y座標の小さい方を UT、大きい方を UB にする。
    2750 IF U1<U2 THEN UT=U1,UB=U2 ELSE UT=U2,UB=U1
    2760 EX=T1,SX=T2
    2765 ' EX:(T1,U1)の牌から、右の方向にどこまで行けるかを入れる変数。
    2770 *L1:IF EX<T2 THEN IF G(U1,EX+1)=-1 THEN EX=EX+1:GOTO *L1
    2775 ' 同一Y座標であり、間に障害がない場合は、水平ライン接続ができる。
    2780 IF Y=W AND EX=T2-1 THEN *T12
    2785 ' SX:(T2,U2)の牌から、左の方向にどこまで行けるかを入れる変数。
    2790 *L2:IF SX>T1 THEN IF G(U2,SX-1)=-1 THEN SX=SX-1:GOTO *L2
    2795 ' (T1,U1)から、(T2,U1)まで来れなければ、右側のコの字型は不可能。
    2800 IF EX<T2 THEN FR=-1:FA=FA AND &D ELSE FR=&0
    2805 ' (T2,U2)から、(T1,U2)まで来れなければ、左側のコの字型は不可能。
    2810 IF SX>T1 THEN FL=-1:FA=FA AND &E ELSE FL=&0
    2845 ' Y座標の大小で処理をわける。
    2850 IF U1>U2 THEN *B1
    2860 '
    2865 ' U1 <= U2 の場合
    2870 EY=U1,SY=U2
    2875 ' EY:(T1,U1)の牌が、下の方向にどこまで行けるかを入れる変数
    2880 *L3:IF EY<U2 THEN IF G(EY+1,T1)=-1 THEN EY=EY+1:GOTO *L3
    2885 ' 同一X座標であり、間に障害がない場合は、垂直ライン接続ができる。
    2890 IF X=V AND EY=UB-1 THEN *U12
    2895 ' SY:(T2,U2)の牌が、上の方向にどこまで行けるかを入れる変数
    2900 *L4:IF SY>U1 THEN IF G(SY-1,T2)=-1 THEN SY=SY-1:GOTO *L4
    2905 ' (T1,U1)から下に真直ぐおろし、そこから右に伸ばして接続できる場合。
    2910 IF SX<=T1 AND U2<=EY THEN *T1T1T2
    2915 ' (T2,U2)から上に真直ぐのばし、そこから左に伸ばして接続できる場合。
    2920 IF T2<=EX AND SY<=U1 THEN *T1T2T2
    2930 GOTO *A1
    2940 '
    2945 ' U1 > U2 の場合
    2950 *B1
    2960 EY=U2,SY=U1
    2965 ' EY:(T2,U2)の牌が、下の方向にどこまで行けるかを入れる変数
    2970 *L5:IF EY<U1 THEN IF G(EY+1,T2)=-1 THEN EY=EY+1:GOTO *L5
    2975 ' 同一X座標であり、間に障害がない場合は、垂直ライン接続ができる。
    2980 IF X=V AND EY=UB-1 THEN *U12
    2985 ' SY:(T1,U1)の牌が、上の方向にどこまで行けるかを入れる変数
    2990 *L6:IF SY>U2 THEN IF G(SY-1,T1)=-1 THEN SY=SY-1:GOTO *L6
    2995 ' (T2,U2)から下に真直ぐおろし、そこから右に伸ばして接続できる場合。
    3000 IF SX<=T1 AND SY<=U2 THEN *T1T1T2
    3005 ' (T1,U1)から上に真直ぐのばし、そこから左に伸ばして接続できる場合。
    3010 IF T2<=EX AND U1<=EY THEN *T1T2T2
    3020 *A1
    3025 ' 先ほど調べた EY が UB に届かない場合は、下側のコの字型は有りえない。
    3030 IF EY<UB THEN FB=-1:FA=FA AND &7 ELSE FB=&0
    3035 ' 先ほど調べた SY が UT に届かない場合は、上側のコの字型は有りえない。
    3040 IF SY>UT THEN FT=-1:FA=FA AND &B ELSE FT=&0
    3045 ' 縦・横・縦の形で接続できるか調べる。
    3050 YW=SY:GOTO *PYSK1
    3060 *PYLP1
    3062 ' Y座標=YWで、X座標 T1～T2 に障害物がないかを調べる。
    3064 GOSUB *XLCHK
    3066 ' なければ、(T1,U1)-(T1,YW)-(T2,YW)-(T2,U2)の経路で取れる。
    3068 IF RC THEN *T1122U1WW2 ELSE YW=YW+1
    3070 *PYSK1:IF YW<=EY THEN *PYLP1
    3075 ' 横・縦・横の形で接続できるか調べる。
    3080 XW=SX:GOTO *PXSK1
    3090 *PXLP1
    3092 ' X座標=XWで、Y座標 UT～UB に障害物がないかを調べる。
    3094 GOSUB *YLCHK
    3096 ' なければ、(T1,U1)-(XW,U1)-(XW,U2)-(T2,U2)の経路で取れる。
    3098 IF RC THEN *T1WW2U1122 ELSE XW=XW+1
    3100 *PXSK1:IF XW<=EX THEN *PXLP1
    3105 ' 左・右・上・下の順番で、コの字型に取れるかを調べる。
    3110 '
    3120 D=&1
    3130 *SKL:IF FL THEN *SKR
    3140 XW=T1-D:IF XW<0 THEN FL=-1:FA=FA AND &E:GOTO *SKR
    3145 ' X座標=XWで、Y座標 UT～UB に障害物がないかを調べる。
    3150 GOSUB *YLCHK:IF RC THEN *T1WW2U1122
    3155 ' １つ左があいているかを調べる。
    3160 IF G(UT,XW)<>-1 OR G(UB,XW)<>-1 THEN FL=-1:FA=FA AND &E
    3165 '
    3170 *SKR:IF FR THEN *SKT
    3180 XW=T2+D:IF XW>19 THEN FR=-1:FA=FA AND &D:GOTO *SKT
    3185 ' X座標=XWで、Y座標 UT～UB に障害物がないかを調べる。
    3190 GOSUB *YLCHK:IF RC THEN *T1WW2U1122
    3195 ' １つ右があいているかを調べる。
    3200 IF G(UT,XW)<>-1 OR G(UB,XW)<>-1 THEN FR=-1:FA=FA AND &D
    3205 '
    3210 *SKT:IF FT THEN *SKB
    3220 YW=UT-D:IF YW<0 THEN FT=-1:FA=FA AND &B:GOTO *SKB
    3225 ' Y座標=YWで、X座標 T1～T2 に障害物がないかを調べる。
    3230 GOSUB *XLCHK:IF RC THEN *T1122U1WW2
    3235 ' １つ上があいているかを調べる。
    3240 IF G(YW,T1)<>-1 OR G(YW,T2)<>-1 THEN FT=-1:FA=FA AND &B
    3245 '
    3250 *SKB:IF FB THEN *SKE
    3260 YW=UB+D:IF YW>9 THEN FB=-1:FA=FA AND &7:GOTO *SKE
    3265 ' Y座標=YWで、X座標 T1～T2 に障害物がないかを調べる。
    3270 GOSUB *XLCHK:IF RC THEN *T1122U1WW2
    3275 ' １つ下があいているかを調べる。
    3280 IF G(YW,T1)<>-1 OR G(YW,T2)<>-1 THEN FB=-1:FA=FA AND &7
    3285 '
    3290 *SKE:D=D+&1:IF FA THEN *SKL
    3300 '
    3310 *NGGET:OK=&0:RETURN
    3320 *OKGET:OK=-1:RETURN
    3330 '
    3340 *T1T1T2:LX(&0)=T1,LY(&0)=U1,LX(&1)=T1,LY(&1)=U2,LX(&2)=T2,LY(&2)=U2,LC=&2:GOTO *OKGET
    3350 *T1T2T2:LX(&0)=T1,LY(&0)=U1,LX(&1)=T2,LY(&1)=U1,LX(&2)=T2,LY(&2)=U2,LC=&2:GOTO *OKGET
    3360 *T1122U1WW2:LX(&0)=T1,LY(&0)=U1,LX(&1)=T1,LY(&1)=YW,LX(&2)=T2,LY(&2)=YW,LX(&3)=T2,LY(&3)=U2,LC=&3:GOTO *OKGET
    3370 *T1WW2U1122:LX(&0)=T1,LY(&0)=U1,LX(&1)=XW,LY(&1)=U1,LX(&2)=XW,LY(&2)=U2,LX(&3)=T2,LY(&3)=U2,LC=&3:GOTO *OKGET
    3380 *U12:LX(&0)=T1,LY(&0)=U1,LX(&1)=T1,LY(&1)=U2,LC=&1:GOTO *OKGET
    3390 *T12:LX(&0)=T1,LY(&0)=U1,LX(&1)=T2,LY(&1)=U1,LC=&1:GOTO *OKGET
    3400 '
    3410 ' Y座標=YWで、X座標 T1～T2 に障害物がないかを調べる。
    3420 '
    3430 *XLCHK
    3440 RC=0,WX=T1
    3450 *XL1:IF WX<=T2 THEN IF G(YW,WX)=-1 THEN WX=WX+1:GOTO *XL1 ELSE RETURN
    3460 RC=1:RETURN
    3470 '
    3480 ' X座標=XWで、Y座標 UT～UB に障害物がないかを調べる。
    3490 '
    3500 *YLCHK
    3510 RC=0,WY=UT
    3520 *YL1:IF WY<=UB THEN IF G(WY,XW)=-1 THEN WY=WY+1:GOTO *YL1 ELSE RETURN
    3530 RC=1:RETURN
