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