10 REM PROGRAM PYR
   20 REM AUTHOR L.J.Fowl.
   30 ON ERROR MODE7:VDU7:REPORT:PRINT;" at line ";ERL:END
   40 DIM cx%(30),cy%(30),p%(30),cv$(30)
   50 DIM ip$(2),cval%(2),pi%(22),du%(22)
   60 DIM rl$(6):game%=0
   70 PROCpeter
   80 CLS:FOR Y%=12 TO 13:PRINTTAB(11,Y%);CHR$141+CHR$134+"Shuffling..":NEXT
   90 PROCinit:PROCshuffle
  100 IF SH% PROCshuffle
  110 temp$=apex$+f$
  120 VDU22,129:PROCtable
  130 PROCtableu:temp$="":PROCdeal
  140 PROCplay:CLS
  150 IF kflag GOTO 180
  160 PROCremovecard(c%,d%)
  170 IF st AND wa temp$=""
  180 PROCremovecard(A%,B%)
  190 IF st tflag=TRUE:PROCdeal
  200 IF wa PROCupdatewaste:VDU4
  210 PROCcheckwin
  220 IF win=FALSE GOTO140
  230 END
  240 :
  250 DEF PROCtableu:r=0
  260 REPEAT X%=X%-88:Y%=Y%-96:x=X%:y=Y%
  270 FORx=x TO X%+step%*r STEP step%:c%=c%+1
  280 cx%(c%)=x:cy%(c%)=y:p%(c%)=c%
  290 PROCbrdr(x,y):GCOL0,3
  300 VDU5:MOVEx,y:PLOT97,120,step%
  310 PROCdisplay(x,y,temp$,c%)
  320 temp$=RIGHT$(temp$,LEN(temp$)-2)
  330 NEXT:r=r+1:UNTIL r=7:card$=""
  340 ENDPROC
  350 :
  360 DEF PROCbrdr(x,y):GCOL0,0
  370 MOVEx-2,y-2:PLOT29,x-2,y+180
  380 PLOT29,x+124,y+180:PLOT29,x+124,y-2
  390 PLOT29,x-2,y-2:ENDPROC
  400 :
  410 DEF PROCtable:VDU5
  420 VDU28,0,31,39,29,24,0;100;1279;1023;
  430 VDU19,2,2,0,0,0:GCOL0,130:CLG
  440 CLS:GCOL0,0:N=64
  450 MOVE524,1008:PRINT"PYRAMID"
  460 MOVE508,968:PRINT"PATIENCE"
  470 FOR x=104 TO 1228 STEP 88:N=N+1
  480 MOVE x,140:PRINT;CHR$(N):NEXT
  490 N=0:FOR y=756 TO 276 STEP-96
  500 N=N+1:MOVE8,y:PRINT;N:MOVE1244,y:PRINT;N:NEXT
  510 MOVE8,1016:DRAW184,1016:DRAW184,768:DRAW8,768:DRAW8,1016:MOVE16,1008:VDU5:PRINT"Waste"
  520 MOVE894,1016:DRAW1270,1016:DRAW1270,768:DRAW894,768:DRAW894,1016:MOVE986,1008:PRINT"Stock"
  530 MOVE216,1008:PRINT"Game ";game%
  540 ENDPROC
  550 :
  560 DEF PROCsuits(card$)
  570 IF RIGHT$(card$,1)="H"THEN suit$=H$:suit2$=H2$:GCOL0,1
  580 IF RIGHT$(card$,1)="D"THEN suit$=D$:suit2$=D2$:GCOL0,1
  590 IF RIGHT$(card$,1)="C"THEN suit$=C$:suit2$=C2$:GCOL0,0
  600 IF RIGHT$(card$,1)="S"THEN suit$=S$:suit2$=S2$:GCOL0,0
  610 ENDPROC
  620 :
  630 DEF PROCdisplay(x,y,c$,c%)
  640 card$="":card$=LEFT$(c$,2)
  650 cv$(c%)=card$
  660 pip$=LEFT$(cv$(c%),1)
  670 DEF PROCdisplay1(card$)
  680 IF card$="" ENDPROC
  690 PROCsuits(card$)
  700 MOVEx+2,y+172:PRINTpip$
  710 MOVEx+2,y+140:PRINTsuit$
  720 MOVEx+32,y+132:PRINTsuit2$
  730 MOVEx+88,y+64:PRINTpip$
  740 MOVEx+88,y+32:PRINTsuit$
  750 SOUND0,-10,4,1:ENDPROC
  760 :
  770 DEF PROCstock(x,y):GCOL0,3
  780 IF S%=0 tflag=FALSE:ENDPROC
  790 MOVEx,y:MOVEx,y-172
  800 PLOT85,x+120,y
  810 MOVEx+120,y-172:PLOT85,x,y-172
  820 VDU5:MOVE1124,958:GCOL0,1:PRINTSB$
  830 PROCbrdr(x,y-176):ENDPROC
  840 :
  850 DEF PROCshuffle
  860 f$="":D%=51:FORI%=1TO51
  870 A%=INT(RND(RND(1))*D%+1)
  880 f$=f$+MID$(temp$,2*A%-1,2)
  890 L$=LEFT$(temp$,(A%-1)*2)
  900 R$=RIGHT$(temp$,(LEN(temp$)/2-A%)*2)
  910 temp$=L$+R$:D%=D%-1
  920 NEXT I%:temp$=f$
  930 stock$=RIGHT$(temp$,48)
  940 IF PP%=FALSE ENDPROC
  950 FOR I%=1 TO LEN(stock$)-1 STEP 2
  960 IF MID$(stock$,I%,1)=MID$(stock$,I%+2,1) THEN stock$=stock$+MID$(stock$,I%+2,2):stock$=LEFT$(stock$,I%+1)+MID$(stock$,I%+4,LEN(stock$)-(I%+2))
  970 NEXT ELSE NEXT
  980 ENDPROC
  990 :
 1000 DEF PROCinit
 1010 S%=25:W%=0:tflag=FALSE:game%=game%+1
 1020 cx%(0)=1112:cy%(0)=790
 1030 cx%(29)=32:cy%(29)=790
 1040 cx%(30)=920:cy%(30)=790
 1050 pack$="A23456789TJQK":waste$="":W$=""
 1060 key$="ABCDEFGHIJKLMWS@TQ":stock$=""
 1070 suit$="HCDS":X%=668:Y%=832:step%=176
 1080 C$="":apex$="":temp$="":waste2$=""
 1090 rl$(1)="FH":rl$(2)="EGI"
 1100 rl$(3)="DFHJ":rl$(4)="CEGIK"
 1110 rl$(5)="BDFHJL":rl$(6)="ACEGIKM"
 1120 count%=28:r%=0:c%=0:SH%=TRUE:PP%=TRUE
 1130 FOR I%=1 TO 13:FOR J%=1 TO 4
 1140 temp$=temp$+MID$(pack$,I%,1)+MID$(suit$,J%,1)
 1150 NEXT J%:NEXT I%
 1160 apex$=RIGHT$(pack$,1)+(MID$(suit$,INT(RND(4)),1))
 1170 FOR k%=1 TO LEN(temp$) STEP2
 1180 IF MID$(temp$,k%,2)=apex$ THEN NEXT ELSE C$=C$+MID$(temp$,k%,2):NEXT
 1190 C$=apex$+C$:temp$="":temp$=RIGHT$(C$,LEN(C$)-2)
 1200 D$=CHR$(231):H$=CHR$(232)
 1210 C$=CHR$(233):S$=CHR$(234)
 1220 nl$=CHR$(8)+CHR$(8)+CHR$(10)
 1230 D2$=CHR$(235)+CHR$(236)+nl$+CHR$(237)+CHR$(238)
 1240 H2$=CHR$(239)+CHR$(240)+nl$+CHR$(241)+CHR$(242)
 1250 C2$=CHR$(243)+CHR$(244)+nl$+CHR$(245)+CHR$(246)
 1260 S2$=CHR$(247)+CHR$(248)+nl$+CHR$(249)+CHR$(250)
 1270 SB$="":sb$=CHR$230+CHR$230+CHR$230+CHR$8+CHR$8+CHR$8+CHR$10
 1280 FOR I%=1TO5:SB$=SB$+sb$:NEXT
 1290 RESTORE
 1300 FOR I%=1TO22:READN,T
 1310 pi%(I%)=N:du%(I%)=T:NEXT
 1320 DATA117,5,129,5,129,10,117,5,109,5
 1330 DATA101,10,109,5,117,5,129,5,117,5
 1340 DATA109,20,117,5,129,5,129,10,117,5
 1350 DATA109,5,101,10,109,5,117,5,109,5,101,5,101,20
 1360 ENDPROC
 1370 :
 1380 DEF PROCplay
 1390 CLS:C%=0:I%=0:*FX15,1
 1400 wa=FALSE:st=FALSE:kflag=FALSE
 1410 FOR I%=1TO2
 1420 PRINT"Enter card #";I%;:IF (S%<2 AND I%<2) PRINT;" or Q to quit";
 1430 INPUT" "ip$(I%)
 1440 C%=INSTR(key$,RIGHT$(ip$(I%),1))
 1450 IF C%=0 PROCerr(2):I%=2:NEXT:GOTO1390
 1460 IF C%=16 PROCdeal:I%=2:NEXT:GOTO1390
 1470 IF C%=17 PROCerr(7):I%=2:NEXT:GOTO1390
 1480 IF C%=18 I%=2:NEXT:PROCquit:ENDPROC
 1490 IF C%=14 B%=29:A%=0:wa=TRUE:GOTO1590
 1500 IF C%=15 B%=30:A%=0:st=TRUE:GOTO1590
 1510 A%=VAL(LEFT$(ip$(I%),1))
 1520 row%=FNconvert(A%)
 1530 IF row%=0 PROCerr(1):GOTO1390
 1540 IF NOT FNrl(ip$(I%)) THEN PROCerr(8):I%=2:NEXT:GOTO1390
 1550 B%=ASC(RIGHT$(ip$(I%),1))/2-row%
 1560 IF (p%(B%)=0 AND cv$(B%)="")PROCerr(3):CLS:GOTO 1390
 1570 IF A%<6:IF (p%(B%+(2+A%))<>0 OR p%(B%+(A%+1))<>0) PROCerr(4):GOTO1390
 1580 IF C%>13 AND C%<16 cv$(B%)=temp$
 1590 cval%(I%)=FNval(LEFT$(cv$(B%),1))
 1600 IF cval%(I%)=13 THEN kflag=TRUE:I%=2:NEXT:ENDPROC
 1610 IF I%=1 c%=A%:d%=B%
 1620 NEXT I%
 1630 IF cval%(1)+cval%(2)<>13 PROCerr(5):GOTO1390
 1640 ENDPROC
 1650 :
 1660 DEF FNconvert(A%)
 1670 IF (A%<1 OR A%>6):=FALSE
 1680 IF A%=1:=33 ELSE IF A%=2:=30
 1690 IF A%=3:=27 ELSE IF A%=4:=22
 1700 IF A%=5:=17 ELSE IF A%=6:=10
 1710 :
 1720 DEF FNval(V$)
 1730 IF V$="A":=1 ELSE IF V$="T":=10
 1740 IF V$="J":=11 ELSE IF V$="Q":=12
 1750 IF V$="K":=13 ELSE =VAL(V$)
 1760 :
 1770 DEF FNrl(ip$(I%))
 1780 r=VAL(LEFT$(ip$(I%),1))
 1790 c$=RIGHT$(ip$(I%),1)
 1800 IF INSTR(rl$(r),c$) THEN =TRUE ELSE =FALSE
 1810 :
 1820 DEF PROCremovecard(a%,b%)
 1830 GCOL0,2
 1840 MOVEcx%(b%)-2,cy%(b%)-2
 1850 PLOT97,126,182
 1860 cv$(b%)="":p%(b%)=0
 1870 IF C%>13 AND S%>0 tflag=TRUE
 1880 IF a%=0 THEN ENDPROC
 1890 SOUND0,-10,4,1
 1900 PROCcheck(a%,b%)
 1910 PROCrepair(a%,b%)
 1920 ENDPROC
 1930 :
 1940 DEF PROCrepair(A%,B%)
 1950 I%=(B%-(A%+1))
 1960 IF NOT p%(I%) GOTO2040
 1970 GCOL0,3:MOVEcx%(I%)+86,cy%(I%)
 1980 PLOT97,34,84
 1990 MOVEcx%(I%)+86,cy%(I%)-2:GCOL0,0
 2000 PLOT29,cx%(I%)+124,cy%(I%)-2
 2010 PLOT29,cx%(I%)+124,cy%(I%)+88
 2020 IF p%(I%)<>0 THEN p%(I%)=I%
 2030 PROCdisplay2(I%)
 2040 I%=(B%-A%):GCOL0,3
 2050 IF NOT p%(I%) ENDPROC
 2060 MOVEcx%(I%),cy%(I%):PLOT97,38,86
 2070 GCOL0,0:MOVEcx%(I%)-2,cy%(I%)+88
 2080 PLOT29,cx%(I%)-2,cy%(I%)-2
 2090 PLOT29,cx%(I%)+40,cy%(I%)-2
 2100 IF p%(I%)<>0 THEN p%(I%)=I%
 2110 ENDPROC
 2120 :
 2130 DEF PROCcheck(A%,B%)
 2140 IF (B%=2 OR B%=4 OR B%=7 OR B%=11 OR B%=16 OR B%=22) THEN p%(B%-A%)=TRUE:ENDPROC
 2150 IF (B%=3 OR B%=6 OR B%=10 OR B%=15 OR B%=21 OR B%=28) THEN p%(B%-(A%+1))=TRUE:ENDPROC
 2160 IF p%(B%-A%)<>0 THEN p%(B%-A%)=TRUE
 2170 IF p%(B%-(A%+1))<>0 THEN p%(B%-(A%+1))=TRUE
 2180 ENDPROC
 2190 :
 2200 DEF PROCdisplay2(I%)
 2210 pip$=LEFT$(cv$(I%),1)
 2220 card$=cv$(I%):PROCsuits(card$)
 2230 MOVEcx%(I%)+88,cy%(I%)+64
 2240 VDU5:PRINTpip$
 2250 MOVEcx%(I%)+88,cy%(I%)+32
 2260 PRINTsuit$:VDU4:ENDPROC
 2270 :
 2280 DEF PROCerr(e%):COLOUR1:*FX15,1
 2290 SOUND1,-15,20,5:CLS:PRINT
 2300 IF e%=1 PRINT"row number incorrect ";
 2310 IF e%=2 PRINT;"Invalid entry.";
 2320 IF e%=3 PRINT;ip$(I%);" Has already been removed.";
 2330 IF e%=4 PRINT;ip$(I%);" Not yet available.";
 2340 IF e%=5 PRINT;ip$(1);"+";ip$(2);" Do NOT total 13.";
 2350 IF e%=6 PRINT;"Stock exhausted.";
 2360 IF e%=7 PRINT;"Cards remaining :"''"Waste=";W%;"  Stock=";S%;" ";
 2370 IF e%=8 PRINT"Col to Row input mis-match";
 2380 COLOUR2:PRINT" HIT SPACE"
 2390 REPEAT UNTIL GET=32:CLS
 2400 COLOUR3:CLS:e%=0:ENDPROC
 2410 :
 2420 DEF PROCdeal
 2430 IF (S%=1 AND C%=16) THEN S%=1:PROCerr(6):ENDPROC
 2440 S%=S%-1
 2450 IF S%<=0 S%=0:PROCerr(6):ENDPROC
 2460 IF S%=1 PROCremovecard(0,0):GOTO2480
 2470 PROCstock(1112,966)
 2480 IF (S%>=0 AND S%<=23 AND W%>=0 AND C%=16) tflag=FALSE
 2490 IF tflag temp$=""
 2500 IF W%<=0 W%=0
 2510 W$=W$+temp$
 2520 IF S%>0 AND S%<24 AND NOT tflag W%=W%+1
 2530 temp$=LEFT$(stock$,2):cv$(30)=temp$
 2540 x=920:y=790:GCOL0,3
 2550 MOVEx,y:MOVEx+120,y
 2560 PLOT85,x,y+176:MOVEx+120,y+176
 2570 PLOT85,x+120,y:PROCbrdr(x,y)
 2580 pip$=LEFT$(temp$,1):VDU5
 2590 PROCdisplay1(temp$):SOUND0,-10,4,1
 2600 stock$=RIGHT$(stock$,LEN(stock$)-2)
 2610 PROCdispwaste(W$)
 2620 tflag=FALSE:VDU4:ENDPROC
 2630 :
 2640 DEF PROCdispwaste(W$)
 2650 waste$=RIGHT$(W$,2)
 2660 IF waste$="" OR waste$=waste2$ ENDPROC
 2670 cv$(29)=waste$
 2680 x=32:y=790:GCOL0,3
 2690 MOVEx,y:MOVEx+120,y:PLOT85,x,y+176
 2700 MOVEx+120,y+176:PLOT85,x+120,y
 2710 PROCbrdr(x,y)
 2720 pip$=LEFT$(waste$,1):VDU5
 2730 PROCdisplay1(waste$):tflag=FALSE
 2740 waste2$=waste$
 2750 ENDPROC
 2760 :
 2770 DEF PROCupdatewaste
 2780 W%=W%-1:IF W%<0 W%=0
 2790 W$=LEFT$(W$,LEN(W$)-2)
 2800 PROCdispwaste(W$):ENDPROC
 2810 :
 2820 DEF PROCcheckwin
 2830 LOCAL I%:win=TRUE:count%=28
 2840 FOR I%=28 TO 2 STEP-1
 2850 IF p%(I%)>0 win=FALSE:I%=2:NEXT:ENDPROC ELSE NEXT
 2860 IF W%>0 OR S%>0 win=FALSE:I%=2:ENDPROC
 2870 GCOL0,0:VDU5
 2880 MOVE186,200:PLOT97,914,400
 2890 GCOL0,3:MOVE400,564:PRINT"CONGRATULATIONS"
 2900 MOVE 352,460:PRINT"You have achieved"
 2910 MOVE 316,424:PRINT"The almost imposible"
 2920 FOR I%=1 TO 22
 2930 SOUND1,-15,pi%(I%),du%(I%)
 2940 SOUND1,0,0,1:NEXT
 2950 MOVE 196,324:PRINT"Would you like to play again"
 2960 MOVE 512,264:PRINT"(Y/N)";
 2970 PROCyn:ENDPROC
 2980 :
 2990 DEF PROCquit:LOCAL I%
 3000 FOR I%=28 TO1 STEP-1
 3010 IF p%(I%)=0 count%=count%-1
 3020 NEXT:VDU22,7,7
 3030 PRINT'''"Bad Luck...."'"You have been unable to complete"'"Game ";game%:PRINT''"There are ";W%;" cards left in the waste."
 3040 PRINTTAB(10);S%;" cards left in stock."
 3050 PRINTTAB(6)"and ";count%;" cards left in the pyramid."
 3060 PRINT''"Better luck next time."''"Play again ?  (Y/N)";
 3070 PROCyn:ENDPROC
 3080 :
 3090 DEF PROCyn
 3100 REPEAT G=INSTR("YyNn",GET$):UNTILG>0 AND G<5
 3110 IF G<3 VDU22,7:GOTO70 ELSE VDU22,7
 3120 FOR Y%=3 TO 4:X%=0
 3130 PRINTTAB(X%,Y%);CHR$131CHR$141"Thank you for playing":NEXT
 3140 FOR Y%=6 TO 7
 3150 PRINTTAB(X%,Y%);CHR$133CHR$141"Pyramid Patience.":NEXT:END
 3160 :
 3170 DEF PROCpeter
 3180 CLS:X%=7:FOR Y%=1TO2
 3190 PRINTTAB(X%,Y%)CHR$134CHR$141"Pyramid  Patience":NEXT
 3200 FOR Y%=4TO5:X%=8
 3210 PRINTTAB(X%,Y%)CHR$131CHR$141"Shuffle Options":NEXT
 3220 PRINT''CHR$131"1)  Straight Shuffle only."
 3230 PRINT'CHR$131"2)  Shuffle + pairs separation."
 3240 PRINT'CHR$131"3)  Double Shuffle only."
 3250 PRINT'CHR$131"4)  Double Shuffle + pairs separation."
 3260 PRINT'"Pairs separation applies to stock only."
 3270 PRINT'''CHR$130"Enter option number :";
 3280 REPEAT:G%=GET-48:UNTIL G%>0 AND G%<5
 3290 IF G%=1 SH%=FALSE:PP%=FALSE
 3300 IF G%=2 SH%=FALSE:PP%=TRUE
 3310 IF G%=3 SH%=TRUE:PP%=FALSE
 3320 IF G%=4 SH%=TRUE:PP%=TRUE
 3330 CLS:ENDPROC