home *** CD-ROM | disk | FTP | other *** search
/ Loadstar 4 / 004.d81 / spectrum (.txt) < prev    next >
Commodore BASIC  |  2022-08-26  |  12KB  |  345 lines
  1. 10 rem *** spectrum by donna k. woody  7-18-84 ***
  2. 15 poke783,peek(783)and254:f=54272:pokef+24,8:pokef+6,0:pokef+1,255:pokef+4,8
  3. 20 gosub40000:gosub20000
  4. 30 gosub20200:goto9000
  5. 98 :
  6. 99 rem *** update source & drop piles ***
  7. 100 cd=cd-1:c$(sp,0,0)=str$(cd):rem remove card from source pile
  8. 110 lf=lf+1:rem inc drop pile
  9. 120 c$(dp,0,0)=str$(lf):c$(dp,lf,0)=c$(sp,cd+1,0):return:rem transfer card
  10. 148 :
  11. 149 rem *** print source card ***
  12. 150 ifqf=1thenreturn
  13. 155 xp=sp:xc=cd:gosub200:q$=ca$:gosub5000
  14. 160 q=q+1:w=w+1:q$=c$(sp,cd,0):gosub5000:gosub300:return
  15. 198 :
  16. 199 rem *** get position to update card ***
  17. 200 q1=val(p$(xp,1)):w1=val(p$(xp,0)):rem read q & w start positions
  18. 210 q2=val(p$(xp,3)):w2=val(p$(xp,2)):rem read q & w offset values
  19. 220 mx=val(p$(xp,4)):c2=xc:rem value of max # cards in pile
  20. 230 ifxc>mxthenifmx<>0thenc2=mx
  21. 233 c2=c2-1
  22. 240 q=q1+(q2*c2):w=w1+(w2*c2):return
  23. 298 :
  24. 299 rem *** sound routine ***
  25. 300 pokef+24,6:pokef+5,128:pokef+4,129:fori=1to50:next:pokef+4,128:pokef+5,0
  26. 310 pokef+24,0:pokef+24,15:pokef+4,129:pokef+4,128:return
  27. 798 :
  28. 799 rem *** drop on same suit ***
  29. 800 flag=1:lc$=c$(sp,cd,0):ss$=right$(lc$,1)
  30. 810 lf=val(c$(dp,0,0)):lf$=c$(dp,lf,0):ds$=right$(lf$,1)
  31. 820 ifss$=ds$thenflag=1:return
  32. 830 flag=-1:return
  33. 998 :
  34. 999 rem *** drop on correct increment ***
  35. 1000 flag=1:cj=val(p$(dp,7)):cj$=p$(dp,8):ifcj$="0"thenflag=-1:return
  36. 1010 ifcj$="-"thencj=-1*cj
  37. 1020 rp$=mid$(c$(sp,cd,0),2,1):gosub5100:rs=rp
  38. 1030 rp$=mid$(c$(dp,lf,0),2,1):gosub5100:rd=rp
  39. 1040 ifrd=rs+cjthengoto1070
  40. 1050 ifrd=13thenifrs=1thengoto1056
  41. 1052 ifrd=1thenifrs=13thengoto1060
  42. 1054 goto1072
  43. 1056 if(dp=1ordp=2ordp=3ordp=4)thengoto1070
  44. 1058 goto1072
  45. 1060 if(dp=1ordp=2ordp=3ordp=4)thengoto1072
  46. 1062 goto1070
  47. 1070 flag=1:return
  48. 1072 flag=-1:return
  49. 1098 :
  50. 1099 rem *** drop on opposite color ***
  51. 1100 flag=1:ifleft$(c$(sp,cd,0),1)<>left$(c$(dp,lf,0),1)thenflag=1:return
  52. 1110 flag=-1:return
  53. 4998 :
  54. 4999 rem *** print string ***
  55. 5000 poke781,q:poke782,w:sys65520:printq$:return
  56. 5098 :
  57. 5099 rem *** get rank and value ***
  58. 5100 ifrp$="1"thenrp$="10":rp=val(rp$):return
  59. 5110 ifrp$="j"thenrp$="11":rp=val(rp$):return
  60. 5120 ifrp$="q"thenrp$="12":rp=val(rp$):return
  61. 5130 ifrp$="k"thenrp$="13":rp=val(rp$):return
  62. 5140 ifrp$="a"thenrp$="1":rp=val(rp$):return
  63. 5141 rp=val(rp$):return
  64. 5148 :
  65. 5149 rem *** keyboard movement ***
  66. 5150 ifval(c$(10,0,0))=0andval(c$(11,0,0))=0then5170
  67. 5155 poke1820,30:poke56092,0:gosub5300:ifqf=1thenreturn
  68. 5157 ifa<>32anda<>13then5150
  69. 5158 poke1820,32:ifa=13thenpi=11:return
  70. 5160 poke1540,30:poke55812,0:gosub5300:ifqf=1thenreturn
  71. 5162 ifa<>32anda<>13then5160
  72. 5165 poke1540,32:ifa=13thenpi=10:return
  73. 5170 ifval(c$(5,0,0))=0then5180
  74. 5172 poke1426,30:poke55698,0:gosub5300:ifqf=1thenreturn
  75. 5174 ifa<>32anda<>13then5170
  76. 5175 poke1426,32:ifa=13then pi=5:return
  77. 5180 poke1833,30:poke56105,0:gosub5300:ifqf=1thenreturn
  78. 5182 ifa<>32anda<>13then5180
  79. 5185 poke1833,32:ifa=13then pi=6:return
  80. 5190 poke1840,30:poke56112,0:gosub5300:ifqf=1thenreturn
  81. 5192 ifa<>32anda<>13then5190
  82. 5195 poke1840,32:ifa=13then pi=7:return
  83. 5200 poke1847,30:poke56119,0:gosub5300:ifqf=1thenreturn
  84. 5202 ifa<>32anda<>13then5200
  85. 5205 poke1847,32:ifa=13then pi=8:return
  86. 5210 poke1854,30:poke56126,0:gosub5300:ifqf=1thenreturn
  87. 5212 ifa<>32anda<>13then5210:
  88. 5215 poke1854,32:ifa=13then pi=9:return
  89. 5220 poke1116,31:poke55388,0:gosub5300:ifqf=1thenreturn
  90. 5222 ifa<>32anda<>13then5220
  91. 5225 poke1116,32:ifa=13then pi=1:return
  92. 5230 poke1123,31:poke55395,0:gosub5300:ifqf=1thenreturn
  93. 5232 ifa<>32anda<>13then5230
  94. 5235 poke1123,32:ifa=13then pi=2:return
  95. 5240 poke1130,31:poke55402,0:gosub5300:ifqf=1thenreturn
  96. 5242 ifa<>32anda<>13then5240
  97. 5245 poke1130,32:ifa=13then pi=3:return
  98. 5250 poke1137,31:poke55409,0:gosub5300:ifqf=1thenreturn
  99. 5252 ifa<>32anda<>13then5250
  100. 5255 poke1137,32:ifa=13then pi=4:return
  101. 5260 goto5150
  102. 5298 :
  103. 5299 rem *** get key press ***
  104. 5300 ifqf=1thenreturn
  105. 5310 poke198,0:wait198,1:geta$:a=asc(a$)
  106. 5320 ifa=42andch=-1then5310
  107. 5340 ifa=42thengosub9400:goto5300
  108. 5350 return
  109. 5398 :
  110. 5399 rem *** drop card on foundations ***
  111. 5400 lf=val(c$(dp,0,0)):iflf>0then5410
  112. 5405 ifp$(dp,5)=mid$(c$(sp,cd,0),2,1)then5430
  113. 5410 gosub800:ifflag=-1thengosub150:return
  114. 5420 gosub1000:ifflag=-1thengosub150:return
  115. 5430 q=val(p$(dp,1)):w=val(p$(dp,0)):q$=ca$:gosub5000
  116. 5440 q=q+1:w=w+1:q$=c$(sp,cd,0):gosub5000:gosub300
  117. 5450 gosub100:xp=sp:xc=cd:gosub200
  118. 5460 ifcd=0thenreturn
  119. 5470 q$=ca$:gosub5000:q=q+1:w=w+1:q$=c$(sp,cd,0):gosub5000:gosub300:return
  120. 5498 :
  121. 5499 rem *** pick up card ***
  122. 5500 cd=val(c$(sp,0,0)):xc=cd:xp=sp:gosub200
  123. 5510 q$=er$:gosub5000:ifcd=1thenreturn
  124. 5520 if(sp=5orsp=10)then5535
  125. 5525 xc=cd-1:xp=sp:gosub200:q$=ca$:gosub5000:q$=c$(sp,cd-1,0)
  126. 5530 q=q+1:w=w+1:gosub5000:gosub300:return
  127. 5535 q$=ca$:gosub5000:q$=bl$:xc=cd:xp=sp:gosub200:gosub5000:return
  128. 5598 :
  129. 5599 rem *** drop card on building pile ***
  130. 5600 lf=val(c$(dp,0,0)):iflf=0then5660
  131. 5620 gosub1100:ifflag=-1thengosub150:return
  132. 5630 gosub1000:ifflag=-1thengosub150:return
  133. 5640 xp=dp:xc=lf+1:gosub200:q$=ca$:gosub5000:q=q+1:w=w+1:q$=c$(sp,cd,0)
  134. 5650 gosub5000:gosub300:goto5680
  135. 5660 q=val(p$(dp,1)):w=val(p$(dp,0)):q$=ca$:gosub5000:q=val(p$(dp,1))
  136. 5670 w=val(p$(dp,0)):q$=c$(sp,cd,0):q=q+1:w=w+1:gosub5000:gosub300
  137. 5680 gosub100
  138. 5690 ifcd=0thenreturn
  139. 5700 ifsp=5orsp=10thenxp=sp:gosub150:return
  140. 5710 xp=sp:xc=cd:gosub200:q$=c$(sp,cd,0):q=q+1:w=w+1:gosub5000:gosub300:return
  141. 5798 :
  142. 5799 rem *** pick up card from hand & drop on waste pile ***
  143. 5800 cd=val(c$(sp,0,0)):dp=10:lf=val(c$(dp,0,0))
  144. 5802 ifcd=0andlf=0thenreturn
  145. 5804 ifcd=0andd2=1thengosub6000:return
  146. 5805 ifcd=0thend2=d2+1:gosub5900
  147. 5810 q=val(p$(dp,1)):w=val(p$(dp,0)):q$=ca$:gosub5000
  148. 5820 q=q+1:w=w+1:q$=c$(sp,cd,0):gosub5000:gosub300
  149. 5830 gosub100:ifcd=0thenq=val(p$(sp,1)):w=val(p$(sp,0)):q$=er$:gosub5000
  150. 5840 return
  151. 5898 :
  152. 5899 rem *** redeal ***
  153. 5900 c$(11,0,0)=str$(lf):c$(10,0,0)=str$(cd):forx=1to40:c$(11,x,0)="":next
  154. 5920 forx=lfto1step-1:c$(11,x,0)=c$(10,lf-x+1,0):next:cd=lf:lf=0
  155. 5930 q=val(p$(10,1)):w=val(p$(10,0)):q$=bl$:gosub5000
  156. 5940 q=val(p$(11,1)):w=val(p$(11,0)):q$=ca$:gosub5000:q$=ba$:gosub5000:gosub300
  157. 5950 return
  158. 5998 :
  159. 5999 rem *** no more redeals ***
  160. 6000 q=22:w=0:q$=sp$+sp$:gosub5000
  161. 6010 q=22:w=0:q$="no more re-deals allowed.  you must use the cards you have."
  162. 6020 q$=q$+"       -- * to quit":gosub5000:return
  163. 8888 :
  164. 8889 rem *** initial set up ***
  165. 9000 printchr$(147):flag=1:ch=1:w=val(p$(1,0)):q=val(p$(1,1)):q$=ca$:gosub5000
  166. 9005 q=q+1:w=w+1:q$=c$(1,1,0):gosub5000:gosub300
  167. 9010 w=val(p$(5,0)):q=val(p$(5,1)):q$=ca$:gosub5000
  168. 9015 q=q+1:w=w+1:q$=c$(5,7,0):gosub5000:gosub300
  169. 9020 forx=6to9:w=val(p$(x,0)):q=val(p$(x,1)):q$=ca$:gosub5000
  170. 9022 q=q+1:w=w+1:q$=c$(x,1,0):gosub5000:gosub300:next
  171. 9030 w=val(p$(11,0)):q=val(p$(11,1)):q$=ca$:gosub5000:q$=ba$:gosub5000:gosub300
  172. 9040 q=22:w=0
  173. 9045 q$="[144]move arrow with space bar - use return  to pick up or drop card"
  174. 9050 q$=q$+"   - * to quit":gosub5000
  175. 9052 d$=p$(1,5):ifd$="1"thend$="10"
  176. 9055 q=1:w=0:q$="[156]base[157][157][157][157]card[157][157][157][157]is "+d$:gosub5000
  177. 9060 ifqf=1thengoto30
  178. 9063 ifval(c$(1,0,0))<>13then9068
  179. 9064 ifval(c$(2,0,0))<>13then9068
  180. 9065 ifval(c$(3,0,0))<>13then9068
  181. 9066 ifval(c$(4,0,0))<>13then9068
  182. 9067 goto9300
  183. 9068 ifch=1thenq=12:w=0:q$="pick up[157][157][157][157][157][157][157]card":gosub5000:gosub5150:sp=pi
  184. 9069 ifpi=99thengoto9060
  185. 9072 ifch=-1thenq=12:w=0:q$="[129]drop   [157][157][157][157][157][157][157]card":gosub5000:gosub5180:dp=pi
  186. 9073 ifpi=99thengoto9060
  187. 9075 if(pi=1orpi=2orpi=3orpi=4)andch=1then9060
  188. 9080 if(pi=1orpi=2orpi=3orpi=4)andch=-1thengosub5400:ch=1:goto9060
  189. 9085 ifpi=5andch=1andval(c$(sp,0,0))=0then9060
  190. 9090 ifpi=5andch=1thengosub5500:ch=-1:goto9060
  191. 9100 ifpi=5andch=-1thengosub150:ch=1:goto9060
  192. 9105 if(pi=6orpi=7orpi=8orpi=9)andch=1andval(c$(sp,0,0))=0then9060
  193. 9110 if(pi=6orpi=7orpi=8orpi=9)andch=1thengosub5500:ch=-1:goto9060
  194. 9120 if(pi=6orpi=7orpi=8orpi=9)andch=-1thengosub5600:ch=1:goto9060
  195. 9125 ifpi=10andch=1andval(c$(sp,0,0))=0then9060
  196. 9130 ifpi=10andch=1thengosub5500:ch=-1:goto9060
  197. 9140 ifpi=10andch=-1thengosub150:ch=1:goto9060
  198. 9150 ifpi=11andch=1thengosub5800:ch=1:goto9060
  199. 9160 ifpi=11andch=-1thengosub150:ch=1:goto9060
  200. 9170 goto9060
  201. 9298 :
  202. 9299 rem *** win game ***
  203. 9300 printchr$(147):forx=1to30:print"[144]c