home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Loadstar 5
/
005.d81
/
solataire
(
.txt
)
< prev
next >
Wrap
Commodore BASIC
|
2022-08-26
|
10KB
|
284 lines
10 rem card game
20 rem by donna k. woody
25 printchr$(147):s=54272:pokes+24,8:pokes+6,0:pokes+1,255:pokes+4,8
30 poke783,peek(783)and254:poke53281,1:rem clear plot flag
40 gosub4999:rem initialize deck
50 gosub6000:rem title page
60 gosub5300:rem shuffle deck
70 gosub5400:rem print out movement info
80 printchr$(19):rem home but don't clear
90 h=0:v=2:z=0:pi=0:co=0:qq=0:forx=1to8:pa$(x)="":next
94 t=1:rem print out numbers for piles
95 forx=1to8:printtab(t);x;
96 t=t+5
97 next
100 forco=1to52:rem deal cards
104 pi=pi+1:ifpi>8thenpi=8:goto260
105 qq=52-co:q=23:w=25-(len(str$(qq))-1)
106 q$=" "+right$(str$(qq),len(str$(qq))-1):gosub200
107 rem line 105 & 106 prints # of cards left in deck
108 pa$(pi)=d$(co)
110 q=v:w=h:q$=ca$:gosub200:rem print card
120 q=v+1:w=h+1:q$=pa$(pi):gosub200:gosub340:rem print rank
122 q=v+5:w=11:q$=wa$:gosub200:rem get choice
123 gosub500:ifk>0thenk=o:goto600:rem ck to see if valid moves if not quit
124 gosub220:rem get key press
125 if(a$=chr$(34)ora$=chr$(19)ora$=chr$(147))then124
126 q=v+5:w=27:q$=a$:gosub200:rem print keypress
127 ifa$="n"then145:rem get next card
128 ifa$="e"thengosub900:rem end game
130 ifasc(a$)>48andasc(a$)<58then1000:rem if number pickup card
140 goto124
145 h=h+5
146 ifco=53then122
170 nextco:rem deal next card
175 gosub500:ifk>0thenk=o:goto600:rem ck to see if valid moves if not quit
180 ifpi=1andco=0then300:rem you won
181 goto122
198 :
199 ren *** print card ***
200 poke781,q:poke782,w:sys65520:printq$;
210 return
218 :
219 rem *** get character from keyboard ***
220 a$="":poke198,0:wait198,1:geta$
230 return
240 :
250 rem *** try to have more than 8 piles ***
260 q=16:w=0:q$="you are limited to 8 piles. ":gosub200
270 q=18:w=0:q$="play on the piles you already have.":gosub200:goto122
298 :
299 rem *** you won ***
300 printchr$(147)
310 forx=1to100:print"*** you won!!![160]***";:next
320 goto950
329 :
330 rem *** sound effects ***
340 pokes+24,6:pokes+5,128:pokes+4,129:fori=1to50:next:pokes+4,128:pokes+5,.
350 pokes+24,.:pokes+24,15:pokes+4,129:pokes+4,128:return
398 :
399 rem *** you lost ***
400 q=12:w=0:q$="that's too bad. ":gosub200
410 q=14:w=0:q$="you lost this game. ":gosub200
415 print:print:print" [145][145][145]"
420 ifpi>1thenprint:print:print"you had "pi" piles left. ":goto430
425 print:print:print" "
430 goto950
498 :
499 rem *** check to see if you can move ***
500 ifpa$(8)=""thenk=o:return
505 k=0
510 for lc = 1 to 4
520 if right$(pa$(lc),1)=right$(pa$(lc+4),1) then k=k+1:rem check suit
530 next
540 if k <4 thenk=0:return
550 for pc=1to7
560 forlc = pc+1 to pc+3
570 if mid$(pa$(pc),2,1)=mid$(pa$(lc),2,1) then k=0 :pc=5:lc=pc+3
575 next
580 next
590 return
598 :
599 rem *** no valid moves - end? ***
600 q=16:w=0:q$="there are no legal plays left.":gosub200
610 q=18:w=0:q$="press space bar to continue. ":gosub200:gosub220
620 goto410:rem print out score
698 :
699 rem *** invalid move ***
700 q=16:w=0:q$="you can only move to an adjacent pile ":gosub200
710 q=18:w=0:q$="or jump one or two piles. ":gosub200
720 goto1170
898 :
899 rem *** end game or another ***
900 q=16:w=0:q$="do you want to end this game (y/n)? ":gosub200
910 q=18:w=0:q$=" ":gosub200
920 gosub220:ifa$="y"then 400
930 ifa$="n"thenq=16:w=0:q$=" ":gosub200:return
940 goto920
950 q=18:w=0:q$="do you want to play again (y/n)? ":gosub200
960 gosub220:ifa$="y"thengoto60
970 ifa$="n"then 990
980 goto960
990 print"[147]load"chr$(34)"payload"chr$(34)",8":print"run"
992 poke631,13:poke632,13:poke198,2:end
998 :
999 rem *** pick up card ***
1000 a=val(a$):rem 'a' is card to pick up
1005 ifa=1then124
1020 ifa<=pithen1050:rem check for valid pile
1030 goto124:rem not valid pile
1039 :
1040 rem *** blank out card ***
1050 h1=5*(a-1):rem horizontal location
1060 q=v:w=h1:q$=ba$:gosub200
1070 :
1080 rem *** drop card ***
1090 q=v+5:w=11:q$=wc$:gosub200:rem drop where
1100 gosub220:q=v+5:w=30:q$=a$:gosub200:rem print keypress
1105 b=val(a$):rem b is where to drop card
1110 ifb<=pithen1122:rem check for valid pile
1120 goto1090:rem not valid pile
1122 lz=a-b:iflz<1then700:rem not valid move
1123 iflz>3then700:rem not valid move
1129 :
1130 rem *** does suit or rank match ***
1140 ifright$(pa$(a),1)=right$(pa$(b),1)then1205:rem suit match
1150 ifmid$(pa$(a),2,1)=mid$(pa$(b),2,1)then1205:rem rank match
1159 :
1160 rem *** illegal play ***
1170 q=v:w=h1:q$=bl$:gosub200:rem white out background
1180 q=v+1:w=h1+1:q$=pa$(a):gosub200:rem print rank
1190 goto122:rem go back to get another choice
1199 :
1200 rem *** legal play drop card ***
1205 h2=5*(b-1):rem horizontal location
1210 q=v+1:w=h2+1:iflen(pa$(a))=4thenq$=pa$(a):gosub200:gosub340:goto1240
1220 q$=pa$(a)+" ":gosub200:gosub340:rem print suit
1229 :
1230 rem *** erase picked up card ***
1240 q=v:w=h1:q$=er$:gosub200:rem erase card
1242 pa$(b)=pa$(a):pa$(a)="":rem erase value for card
1249 :
1250 rem *** was 'a' last card in line ***
1260 ifa=pithenpi=pi-1:z=z-1:h=h-5:goto122:rem no blank spaces
1269 :
1270 rem *** fill in blank spaces ***
1280 fore=b+1topi-1:rem from card moved +1to last pile
1290 ifpa$(e)<>""then 1370
1300 pa$(e)=pa$(e+1):rem move card down
1310 h=5*(e-1):rem horizontal location for card
1320 q=v:w=h:q$=ca$:gosub200:rem print card
1330 q=v+1:w=h+1:q$=pa$(e):gosub200:gosub340:rem print rank
1340 h=h+5:rem erase e+1 card location
1350 q=v:w=h:q$=er$:gosub200:rem erase card
1360 pa$(e+1)=""
1370 nexte
1379 :
1380 rem *** return to get another choice
1390 h=h-5:pi=pi-1:z=z-1:goto122
4996 :
4997 rem *** set up card arrays ***
4999 dimd$(52),pa$(24)
5000 forx=1to13:x$=str$(x):d$(x)=right$(x$,len(x$)-1):next
5010 forx=14to26:x$=str$(x-13):d$(x)=right$(x$,len(x$)-1):next
5020 forx=27to39:x$=str$(x-26):d$(x)=right$(x$,len(x$)-1):next
5030 forx=40to52:x$=str$(x-39):d$(x)=right$(x$,len(x$)-1):next
5040 d$(1)="a":d$(11)="j":d$(12)="q":d$(13)="k":d$(24)="j":d$(25)="q":d$(26)="k"
5050 d$(37)="j":d$(38)="q":d$(39)="k":d$(50)="j":d$(51)="q":d$(52)="k"
5060 d$(14)="a":d$(27)="a":d$(40)="a"
5070 forx=1to13:d$(x)=""+d$(x)+"[211]":next
5080 forx=14to26:d$(x)="[144]"+d$(x)+"[193]":next
5090 forx=27to39:d$(x)=""+d$(x)+"[218]":next
5100 forx=40to52:d$(x)="[144]"+d$(x)+"[216]":next
5198 :
5199 rem *** card shape ***
5200 ca$="[144][176][195][195][195][174][157][157][157][157][157][194] [194][157][157][157][157][157][194] [194][157][157][157][157][157][194] [194][157][157][157][157][157][173][195][195][195][189]"
5210 ba$="[159][166][166][166][157][157][157][157][157][166][166][166][157][157][157][157][157][166][166][166][157][157][157][157][157]"
5220 bl$=" [157][157][157][157][157] [157][157][157][157][157] [157][157][157][157][157][146]"
5230 er$="[146] [157][157][157][157][157] [157][157][157][157][157] [157][157][157][157][157] [157][157][157][157][157] [146]"
5240 wa$="[144]which (1-8,e,n)? [157][157][157][157][157]"
5250 wc$="[144]drop on which pile?[160]"
5290 return
5298 :
5299 rem *** shuffle deck ***
5300 printchr$(147):q=22:w=13:q$="shuffling deck":gosub200
5310 forco=1to52:rem rnd deck & print * while waiting
5320 c%=(rnd(q9)*52)+1
5330 t$=d$(co):d$(co)=d$(c%):d$(c%)=t$:rem interchange cards - shuffle
5340 a%=(rnd(q9)*20)+1:b%=(rnd(q9)*39)+1:rem rnd points for star
5350 poke781,a%:poke782,b%:sys65520:print"*"
5360 next
5370 return
5398 :
5399 rem *** print out movement info ***
5400 printchr$(147):rem clear home
5410 poke781,22:poke782,0:sys65520
5420 print"[144]<1-8> - pick up card <n> - next card"
5430 print"[144]<e> - exit game - cards left"
5440 return
5998 :
5999 rem *** title page ***
6000 printchr$(147);chr$(142);chr$(8):rem clear home
6010 forx=1to30:rem print cards for title page
6020 h%=(rnd(1)*34)+1:rem rnd horizontal position
6030 v%=(rnd(1)*15)+1:rem rnd vertical position
6040 c%=(rnd(1)*52)+1:rem rnd card
6050 q=v%:w=h%:q$=ca$:gosub200:rem print card
6060 q=v%+1:w=h%+1:q$=d$(c%):gosub200:gosub340:rem print rank
6070 n