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