10 REM 7 Card Patience (Main Prog) 20 REM by Carl Wheat 1992 for BBC B 30 REM 8 Bit Software 40 : 50 BJ=&1100:RJ=&111B:GJ=&1130 60 BQ=&113B:RQ=&114A:GQ=&1169 70 BK=&1184:RK=&1199:GK=&11AC 80 P=&11B3:P$=$P:A$=CHR$224 90 C$=CHR$240:D$=CHR$241 100 H$=CHR$242:S$=CHR$243 110 L$=CHR$8:X$=CHR$9 120 Y$=CHR$10:U$=CHR$11 130 DIM P%(13),D%(53),T%(8,20),B%(8),F%(8),A%(3):VDU5 140 : 150 REPEAT:PROCsetup 160 REPEAT:REPEAT:K%=GET 170 IF K%=136 OR K%=137 PROCmove 180 UNTIL K%=32 OR K%=65 OR K%=83 OR K%=67 OR K%=27 190 IF K%=65 PROCpickup 200 IF K%=32 PROCturnover 210 IF K%=83 PROCstack 220 IF K%=67 PROCcheat 230 *FX21,0 240 UNTIL K%=27 OR E%=52:GCOL0,0 250 REM IF E%=52 MOVE320,720:PRINT"** WELL DONE **":MOVE250,600:PRINT"You have finished it." 260 REM IF E%<>52 CLG 265 IF E%<>52 CLG ELSE MOVE320,720:PRINT"** WELL DONE **":MOVE250,600:PRINT"You have finished it." 270 MOVE200,500:PRINT"Do you want another go? Y/N":K$=GET$ 280 UNTIL K$="N" OR K$="n":*FX4,0 290 MODE7:END 300 : 310 DEFPROCback 320 MOVE FNx,FNy:PROCblank(3):GCOL0,1 330 PLOT0,20,-12:PRINT P$:ENDPROC 340 : 350 DEFPROCfront:PROCblank(3) 360 GCOL0,L%:PLOT0,8,-8:PRINT N$;F$; 370 IF N%=1 PROCace 380 IF N%=2 PROCtwo 390 IF N%=3 PROCthree 400 IF N%=4 PROCfour 410 IF N%=5 PROCfive 420 IF N%=6 PROCsix 430 IF N%=7 PROCseven 440 IF N%=8 PROCeight 450 IF N%=9 PROCnine 460 IF N%=10 PROCten 470 IF N%=11 PROCjack 480 IF N%=12 PROCqueen 490 IF N%=13 PROCking 500 ENDPROC 510 : 520 DEFPROCblank(C%):GCOL0,C% 530 PLOT0,132,0:PLOT81,0,180 540 PLOT81,-132,-180:PLOT81,0,180 550 IF C%=2 ENDPROC 560 GCOL0,0:PLOT1,132,0:PLOT1,0,-180 570 PLOT1,-132,0:PLOT1,0,180:ENDPROC 580 : 590 DEFPROCmove:PROCarrow(2) 600 IF K%=136 A%=A%-152:IF A%<0 A%=1184 610 IF K%=137 A%=A%+152:IF A%>1250 A%=116 620 PROCarrow(0):ENDPROC 630 : 640 DEFPROCarrow(C%):MOVE A%,35 650 GCOL0,C%:PRINT A$:ENDPROC 660 : 670 DEFPROCsuit(C%) 680 S%=C% DIV 13:N%=C% MOD 13 690 IF N%=0 N%=13:S%=S%-1 700 N$=STR$(N%) 710 IF N$="1" N$="A" 720 IF N$="11" N$="J" 730 IF N$="12" N$="Q" 740 IF N$="13" N$="K" 750 IF S%=0 F$=H$:L%=1 760 IF S%=1 F$=S$:L%=0 770 IF S%=2 F$=D$:L%=1 780 IF S%=3 F$=C$:L%=0 790 ENDPROC 800 : 810 DEFPROCturnover:PROCarrow(2) 820 A%=116:PROCarrow(0) 830 IF U%=H% U%=0 840 IF U%=0 AND H%<>0 X%=1:Y%=19:MOVE40,44:PROCblank(2):PROCback 850 IF H%=0 ENDPROC ELSE U%=U%+3 860 IF U%>H% U%=H% 870 IF U%=H% X%=1:Y%=19:MOVEFNx,FNy:PROCblank(2) 880 DEFPROCnext 890 PROCsuit(D%(U%)) 900 MOVE40,44:PROCfront 910 REPEAT:J%=J%+1:UNTIL J%>501 920 J%=0:ENDPROC 930 : 940 DEFPROCpickup:X%=FNc 950 IF H%<1 AND X%=0 ENDPROC 960 IF X%=0 PROCpacktotable:GOTO 1020 970 Y%=B%(X%)+F%(X%):IF Y%=0 ENDPROC 980 P%=0:T$="Y" 990 REPEAT:P%=P%+1:P%(P%)=T%(X%,Y%) 1000 PROCcover:UNTIL F%(X%)=0 1010 IF Y%>0 PROCback 1020 PROCsuit(P%(P%)) 1030 M%=L%:Q%=N%:Dp$="N" 1040 REPEAT:K%=GET 1050 IF K%=136 OR K%=137 PROCmove 1060 UNTIL K%=68 1070 V%=FNc:W%=B%(V%)+F%(V%) 1080 PROCsuit(T%(V%,W%)) 1090 IF Q%=13 AND W%=0 AND V%>0 Dp$="Y" 1100 IF M%<>L% AND (N%-Q%)=1 Dp$="Y" 1110 IF X%=V% Dp$="N" 1120 IF Dp$="N" AND T$="N" J%=501:PROCnext:ENDPROC 1130 IF Dp$="N" V%=X%:W%=Y% 1140 FOR I%=P%TO1 STEP-1 1150 PROCsuit(P%(I%)) 1160 MOVE V%*152+76,880-((W%+P%+1-I%)*44):PROCfront 1170 F%(V%)=F%(V%)+1 1180 T%(V%,(W%+P%+1-I%))=P%(I%):NEXT I% 1190 IF T$="N" PROCremove:ENDPROC 1200 IF Dp$="N" OR Y%=0 ENDPROC 1210 PROCsuit(T%(X%,Y%)) 1220 MOVE FNx,FNy:PROCfront 1230 F%(X%)=F%(X%)+1:B%(X%)=B%(X%)-1 1240 ENDPROC 1250 : 1260 DEFPROCstack:X%=FNc 1270 IF H%<1 AND X%=0 ENDPROC 1280 IF X%=0 PROCpacktostack:ENDPROC 1290 Y%=B%(X%)+F%(X%):IF Y%=0 ENDPROC 1300 PROCsuit(T%(X%,Y%)) 1310 IF (N%-A%(S%))<>1 ENDPROC 1320 PROCcover:PROCdrop:ENDPROC 1330 : 1340 DEFPROCcover:MOVE FNx,FNy 1350 PROCblank(2):T%(X%,Y%)=0 1360 F%(X%)=F%(X%)-1:Y%=Y%-1:ENDPROC 1370 : 1380 DEFPROCdrop 1390 MOVE40,192*(3-S%)+252:PROCfront 1400 A%(S%)=N%:E%=E%+1 1410 IF Y%=0 ENDPROC 1420 IF F%(X%)=0 B%(X%)=B%(X%)-1:F%(X%)=1 1430 PROCsuit(T%(X%,Y%)) 1440 MOVE FNx,FNy:PROCfront:ENDPROC 1450 : 1460 DEFPROCpacktostack 1470 Y%=0:PROCsuit(D%(U%)) 1480 IF N%-A%(S%)<>1 ENDPROC 1490 PROCdrop 1500 DEFPROCremove 1510 FOR J%=U%TOH% 1520 D%(J%)=D%(J%+1):NEXT J% 1530 H%=H%-1:U%=U%-1 1540 IF U%<1 MOVE40,44:PROCblank(2):ENDPROC 1550 PROCnext:ENDPROC 1560 : 1570 DEFPROCpacktotable 1580 P%=1:P%(1)=D%(U%):T$="N" 1590 MOVE40,44:PROCblank(3):ENDPROC 1600 : 1610 DEFPROCcheat 1620 P%=D%(1):FOR J%=1TOH%-1 1630 D%(J%)=D%(J%+1):NEXT J% 1640 D%(H%)=P%:U%=0 1650 J%=501:PROCturnover:ENDPROC 1660 : 1670 DEFFNc=(A%-65) DIV 150 1680 DEFFNx=X%*152+76 1690 DEFFNy=880-(Y%*44) 1700 : 1710 DEFPROCace:PLOT0,-20,-72 1720 PRINT F$:ENDPROC 1730 DEFPROCtwo:PLOT0,-20,-108 1740 PRINT F$+L$+U$+U$+F$:ENDPROC 1750 DEFPROCthree:PLOT0,-20,-108 1760 PRINT F$+L$+U$+F$+L$+U$+F$:ENDPROC 1770 DEFPROCfour:PLOT0,-52,-120 1780 PRINT F$+X$+F$+STRING$(3,L$)+U$+U$+F$+X$+F$;:ENDPROC 1790 DEFPROCfive:PROCfour 1800 PRINT L$+L$+Y$+F$:ENDPROC 1810 DEFPROCsix:PROCfour 1820 PRINT STRING$(3,CHR$8)+Y$+F$+X$+F$;:ENDPROC 1830 DEFPROCseven:PROCsix 1840 PLOT0,-64,16:PRINT F$;:ENDPROC 1850 DEFPROCeight:PROCseven 1860 PRINT L$+Y$+F$:ENDPROC 1870 DEFPROCnine:PLOT0,-52,-132 1880 B$=F$+X$+F$+STRING$(3,L$)+U$:PRINT STRING$(4,B$); 1890 PLOT0,32,-80:PRINT F$:ENDPROC 1900 DEFPROCten:PLOT0,-84,-132 1910 B$=F$+X$+F$+STRING$(3,L$)+U$:PRINT STRING$(4,B$); 1920 PLOT0,32,-112:PRINT F$+L$+U$+U$+F$:ENDPROC 1930 : 1940 DEFPROCjack 1950 B$=$BJ:R$=$RJ:G$=$GJ 1960 PROCpicture:ENDPROC 1970 DEFPROCqueen 1980 B$=$BQ:R$=$RQ:G$=$GQ 1990 PROCpicture:ENDPROC 2000 DEFPROCking 2010 B$=$BK:R$=$RK:G$=$GK 2020 PROCpicture:ENDPROC 2030 : 2040 DEFPROCpicture 2050 PLOT0,-68,-136 2060 GCOL0,0:PRINT B$; 2070 GCOL0,1:PRINT R$; 2080 GCOL0,2:PRINT G$ 2090 ENDPROC 2100 : 2110 DEFPROCsetup:Z%=RND(-TIME):H%=25 2120 CLG:GCOL0,0:MOVE300,550 2130 PRINT"SHUFFLING THE CARDS" 2140 FOR J%=0TO3:A%(J%)=0:NEXT J% 2150 FOR I%=1TO52:D%(I%)=I%:NEXTI% 2160 FOR Z%=1TO100:J%=RND(52) 2170 REPEAT:I%=RND(52):UNTIL I%<>J% 2180 N%=D%(J%):D%(J%)=D%(I%) 2190 D%(I%)=N%:NEXT Z% 2200 FOR J%=1TO7:FOR I%=J%TO7 2210 T%(I%,J%)=D%(H%):H%=H%+1 2220 NEXT I%,J%:H%=24:U%=0:CLG 2230 FOR X%=210TO1110 STEP 150 2240 MOVE X%,22:PRINT".":NEXT X% 2250 FOR Y%=1TO7:B%(Y%)=Y%-1 2260 FOR X%=Y%TO7:PROCback:NEXT X%,Y% 2270 FOR X%=1TO7:PROCsuit(T%(X%,X%)) 2280 Y%=X%:MOVE FNx,FNy:PROCfront 2290 F%(X%)=1:NEXT X%:J%=501:E%=0 2300 X%=1:Y%=19:PROCback 2310 A%=116:PROCarrow(0):ENDPROC