home *** CD-ROM | disk | FTP | other *** search
/ Loadstar 189 / 189.d81 / euchre.bas (.txt) < prev    next >
Commodore BASIC  |  2022-08-26  |  27KB  |  982 lines
  1. 1 rem euchre 2000.02.13
  2. 2 poke53371,0:gosub3002
  3. 3 gosub12:onqgoto4002,4,3,3
  4. 4 gosub302
  5. 5 gosub502:onqgoto4002,4:ifsb=-1then4
  6. 6 gosub1002:onqgoto4002,4:ifng%(t)<3then4
  7. 7 goto3
  8. 10 :
  9. 12 : rem game screen input
  10. 14 :
  11. 16 ifqrthenqr=0:q=qs:goto36
  12. 18 pokesv+39,1:qs=q:ifmn>0then24
  13. 20 sysml+9:on3+(cr%>0)+(cr%>4)goto34,32:ifr2%=1thenqr=-1:q=4:goto34
  14. 22 sysml+60,k$:cr%=i%:on2+(cr%>0)goto32:on2+fnht(p)goto20,34
  15. 24 pokemv+2,4:poke646,c2
  16. 26 fori=0tomn:sysml+183,1+fnme(i):sysml+12,xm%,ym%+i,left$(w$+"   ",10):next
  17. 28 sysml+33,xm%+128,xm%+9,ym%,ym%+mn,c2,c3,m$:ifsl%<128thengosub186:goto34
  18. 30 cr%=sl%and127:ifsl%=133thenqr=-1:q=4:gosub186:goto34
  19. 32 oncr%gosub2086,2002,2030,2074:onqgoto34,34:ifq=qsthenon2+(mn=0)goto20,24
  20. 34 pokesv+39,7
  21. 36 return
  22. 100 :
  23. 102 : rem cards in play
  24. 104 :
  25. 106 b=pd:forj=0to4:fori=0to3:b=a1%(b):r=r%(b,j):s=s%(b,j):ifj=tc%(b)then112
  26. 108 ifb=0thenx=xh%(j):y=yh%:gosub120:goto114
  27. 110 x=xc%(b-1)-j*2*(b=2):y=yc%(b-1)+j*3*(b-2):gosub144:goto114
  28. 112 x=xp%(b):y=yp%(b):gosub120
  29. 114 next:next
  30. 116 return
  31. 118 :
  32. 120 : rem display big card
  33. 122 :
  34. 124 ifr=-1ors=-1then140
  35. 126 v=r+(r-2)*(mb%=0andr>5):w=s+(s-a2%(s))*(mb%=0andr=6)
  36. 128 poke646,cs%(w)
  37. 130 sysml+12,x,y+0,r$(v)+"  "
  38. 132 sysml+12,x,y+1,s$(w)+"  "
  39. 134 sysml+12,x,y+2,"  "+s$(w)
  40. 136 sysml+12,x,y+3,"  "+r$(v)
  41. 138 poke646,c0
  42. 140 return
  43. 142 :
  44. 144 : rem display small card
  45. 146 :
  46. 148 ifr=-1ors=-1then162
  47. 150 ifhp%thenv=8:w=4:goto154
  48. 152 v=r+(r-2)*(mb%=0andr>5):w=s+(s-a2%(s))*(mb%=0andr=6)
  49. 154 poke646,cs%(w)
  50. 156 sysml+12,x,y+0,r$(v)
  51. 158 sysml+12,x,y+1,s$(w)
  52. 160 poke646,c0
  53. 162 return
  54. 164 :
  55. 166 : rem clear big card
  56. 168 :
  57. 170 sysml+30,x,x+2,y,y+3,160,c0
  58. 172 return
  59. 174 :
  60. 176 : rem display prompt - human              n=text string #
  61. 178 :
  62. 180 sysml+183,n:x=xu%-len(w$)/2+2:y=yh%-2:poke199,1:sysml+186,x,y,n:poke199,0
  63. 182 return
  64. 184 :
  65. 186 : rem clear menu
  66. 188 :
  67. 190 sysml+30,xm%,xm%+9,ym%,ym%+mn,160,c0:poke646,c0:mn=0:pokemv+2,9
  68. 192 return
  69. 194 :
  70. 196 : rem clear small card
  71. 198 :
  72. 200 x=xc%(p-1)-c*2*(p=2):y=yc%(p-1)+c*3*(p-2):sysml+30,x,x,y,y+1,160,c0
  73. 202 return
  74. 204 :
  75. 206 : rem clear center
  76. 208 :
  77. 210 sysml+30,xc%(0)+2,xc%(2)-2,yc%(1)+2,yh%-2,160,c0
  78. 212 return
  79. 214 :
  80. 216 : rem results block
  81. 218 :
  82. 220 sysml+30,xh%(3),xh%(3)+10,yc%(1),yc%(1)+1,160,c1
  83. 222 return
  84. 224 :
  85. 226 : rem clear results block
  86. 228 :
  87. 230 sysml+30,xh%(3),xh%(3)+10,yc%(1),yc%(1)+1,160,c0
  88. 232 return
  89. 234 :
  90. 236 : rem display results text                n=string text #; t=team #
  91. 238 :
  92. 240 poke646,ct%(t):sysml+12,xh%(3),yc%(1),t$(t):poke646,c0:sysml+183,n
  93. 242 sysml+12,xh%(3)+4,yc%(1),mid$(w$,5,7):sysml+12,xh%(3),yc%(1)+1,mid$(w$,12)
  94. 244 return
  95. 300 :
  96. 302 : rem *** deal
  97. 304 :
  98. 306 ifq=2then314
  99. 308 sysml+30,xd%(pd,0),xd%(pd,1),yd%(pd,0),yd%(pd,1),160,c1
  100. 310 sysml+30,xb%(pb,0),xb%(pb,1),yb%(pb,0),yb%(pb,1),160,c1
  101. 312 pd=a1%(pd)
  102. 314 q=4-hp%
  103. 316 gosub332:sysml+48,xd%(pd,0),xd%(pd,1),yd%(pd,0),yd%(pd,1),a(2+(pdand253))
  104. 318 gosub346
  105. 320 v=0:forj=0to4:fori=0to3:w=peek(rv+v)-1:s%(i,j)=fncs(w):r%(i,j)=fncr(w)
  106. 322 v=v+1:next:next:w=peek(rv+v)-1:su=fncs(w):ru=fncr(w):sp=su
  107. 324 fori=0to2:v=v+1:dh%(i)=peek(rv+v)-1:next
  108. 326 gosub102:y=yu%:x=xu%:r=ru:s=su:gosub120
  109. 328 return
  110. 330 :
  111. 332 : rem initialize hand
  112. 334 :
  113. 336 y=yn%(0):fori=0to1:x=xn%+4+7*i:nt%(i)=0:n=0:poke646,ct%(i):gosub356:next
  114. 338 y=yn%(1):fori=0to1:x=xn%+4+7*i:n=np%(i):poke646,ct%(i):gosub356:next
  115. 340 poke646,c0:fori=0to3:tc%(i)=-1:forj=0to3:cp%(i,j)=0:next:next
  116. 342 return
  117. 344 :
  118. 346 : rem shuffle
  119. 348 :
  120. 350 poke176,0:poke177,hr:poke178,24:sysrl
  121. 352 return
  122. 354 :
  123. 356 : rem display big number                  n=big #
  124. 358 :
  125. 360 w=int(n/10):ifw>0thenfork=0to1:sysml+12,x-1,y+k,mid$(n$(k),w+1,1):next
  126. 362 w=n-w*10:fork=0to1:sysml+12,x,y+k,mid$(n$(k),w+1,1):next
  127. 364 return
  128. 500 :
  129. 502 : rem *** bid
  130. 504 :
  131. 506 pb=0:px=-1:sb=-1:p=a1%(pd)
  132. 508 rem --- order up trump
  133. 510 iffnht(p)thengosub824:onqgoto588,588,514
  134. 512 gosub592:gosub688:gosub12:ifq<3then588
  135. 514 n=2+(sb=-1):gosub898:ifsb<>-1thenpb=p:goto556
  136. 516 p=a1%(p):ifp<>pdthen510
  137. 518 rem --- pick up trump
  138. 520 iffnht(p)thengosub834:onqgoto588,588,524
  139. 522 gosub592:gosub688:gosub12:ifq<3then588
  140. 524 n=4+(sb=-1):gosub898:ifsb=-1thengosub888:goto544
  141. 526 rem --- discard
  142. 528 pb=p:gosub632:ifmb%thenr=ru:s=su:y=yu%:x=xu%:gosub120:gosub102
  143. 530 iffnht(p)thengosub844:onqgoto588,588,534
  144. 532 gosub708:gosub12:ifq<3then588
  145. 534 s=s%(p,c):r=r%(p,c):cp%(p,s)=cp%(p,s)orrb%(r)
  146. 535 iflv%<2thenso%(p,s)=so%(p,s)-1:goto540
  147. 536 forj=0to3:cp%(j,s)=cp%(j,s)orrb%(r):so%(j,s)=so%(j,s)-1:next
  148. 540 gosub206:r%(p,c)=ru:s%(p,c)=su:gosub876
  149. 542 goto564
  150. 544 rem --- name trump
  151. 546 p=a1%(p):iffnht(p)thengosub856:onqgoto588,588,550:gosub592
  152. 548 gosub676:gosub12:ifq<3then588
  153. 550 n=6+sb:gosub898:ifsb<>-1thenpb=p:goto556
  154. 552 ifp=pdthen581
  155. 554 goto546
  156. 556 rem --- updates for order up & name
  157. 558 gosub632:ifmb%thenr=ru:s=su:x=xu%:y=yu%:gosub120:gosub102
  158. 560 fori=0to3:cp%(i,su)=cp%(i,su)orrb%(ru):so%(i,su)=so%(i,su)-1:next
  159. 562 gosub206
  160. 564 rem --- suit count
  161. 566 fori=0to3:forj=0to3:sn%(i,j)=0:next
  162. 568 fork=0to4:sn%(i,s%(i,k))=sn%(i,s%(i,k))+1:next:next
  163. 570 rem --- lone hand
  164. 572 p=pb:iffnht(p)thengosub866:onqgoto588,588,576
  165. 574 gosub752:gosub12:ifq<3then588
  166. 576 n=11+(px=-1):gosub898:ifpx=-1then580
  167. 577 onpx+1gosub784,794,804,814:iflv%<2then580
  168. 578 fork=0to4:s=s%(px,k):cp%(p,s)=cp%(p,s)orrb%(r%(px,k)):so%(p,s)=so%(p,s)-1
  169. 579 next
  170. 580 gosub206:goto586
  171. 581 rem --- no bids
  172. 582 gosub216:sysml+186,xh%(3),yc%(1),20:sysml+24,100:gosub226
  173. 584 gosub784:gosub794:gosub804:gosub814:gosub206
  174. 586 rem ---
  175. 588 return
  176. 590 :
  177. 592 : rem suit count/points
  178. 594 :
  179. 596 fori=0to3:sn%(p,i)=0:sp%(p,i)=0:next
  180. 598 fori=0to4:s=s%(p,i):ks=fnks(r%(p,i)):gosub608
  181. 600 ifr%(p,i)=2thens=a2%(s):ks=5:gosub608
  182. 602 next:ifp=pdthens=su:ks=fnks(ru):gosub608:ifsn%(p,s)=6thensn%(p,s)=5
  183. 604 return
  184. 606 :
  185. 608 : rem suit count/points sub
  186. 610 :
  187. 612 ifp<>pdands=suthenks=ks-(ks<fnks(ru))
  188. 614 ifru=2ands=a2%(su)thenks=ks-(ks<fnks(5))
  189. 616 iflv%<2then624
  190. 618 fork=0to2:v=fncs(dh%(k)):w=fncr(dh%(k)):ifv=sthenks=ks-(ks<fnks(w)):goto622
  191. 620 ifw=2thenifv=a2%(s)thenks=ks-(ks<5)
  192. 622 next
  193. 624 sn%(p,s)=sn%(p,s)+1:sp%(p,s)=sp%(p,s)+ks%(ks)
  194. 626 ifks=4thenforj=0to3:sp%(p,j)=sp%(p,j)-ks%(3)*(j<>s):next
  195. 628 return
  196. 630 :
  197. 632 : rem update for trump
  198. 634 :
  199. 636 rem --- bidder
  200. 638 poke646,cs%(sb)
  201. 640 sysml+12,xb%(pb,0),yb%(pb,0),s$(sb):sysml+12,xb%(pb,1),yb%(pb,1),s$(sb)
  202. 642 ifpb<>pdthensysml+48,xd%(pb,0),xd%(pb,1),yd%(pb,0),yd%(pb,1),a(4+(pband253))
  203. 644 poke646,c0
  204. 646 rem --- bowers
  205. 648 v=a2%(sb):fori=0to3:cp%(i,sb)=cp%(i,sb)orrb%(2):cp%(i,v)=cp%(i,v)orrb%(2)
  206. 650 forj=0to3:ifj<>sbthencp%(i,j)=cp%(i,j)orrb%(6)orrb%(7)
  207. 652 next
  208. 654 forj=0to4:ifr%(i,j)<>2then660
  209. 656 ifs%(i,j)=sbthenr%(i,j)=7:goto660
  210. 658 ifs%(i,j)=vthenr%(i,j)=6:s%(i,j)=sb
  211. 660 next:next
  212. 662 ifru<>2then668
  213. 664 ifsu=sbthenru=7:goto668
  214. 666 ifsu=vthenru=6:su=sb
  215. 668 rem --- suit out count
  216. 670 forj=0to3:so%(0,j)=6-(j=sb)+(j=v):fori=1to3:so%(i,j)=so%(0,j):next:next
  217. 672 return
  218. 674 :
  219. 676 : rem name trump - computer
  220. 678 :
  221. 680 w=0:fori=0to3:ifi<>suthenifsp%(p,i)>wthensp=i:w=sp%(p,i)
  222. 682 next:ifw>0thengosub688
  223. 684 return
  224. 686 :
  225. 688 : rem bid - computer                      used for order up, pick up & name
  226. 690 :
  227. 692 ifsn%(p,sp)<2then704
  228. 694 ifsn%(p,sp)>3then702
  229. 696 v=ks%(3)*(h%(lv%)+(np%(a1%(p)and253)=9)+(p=pdora1%(p)=pd))
  230. 698 v=v+ks%(6)+ks%(5)+ks%(3)*(sn%(p,sp)>2)
  231. 700 ifsp%(p,sp)<vthen704
  232. 702 sb=sp
  233. 704 return
  234. 706 :
  235. 708 : rem discard - computer
  236. 710 :
  237. 712 fori=0to3:sn%(p,i)=0:next:fori=0to4:sn%(p,s%(p,i))=sn%(p,s%(p,i))+1:next
  238. 714 ifsn%(p,sb)=5thensp=sb:goto738
  239. 716 on5-sn%(p,sb)goto718,722,728,728
  240. 718 rem --- only non-trump singleton
  241. 720 fori=0to4:c=i:i=i+(i-4)*(s%(p,i)<>sb):next:goto742
  242. 722 rem --- lowest rank non-trump
  243. 724 r=8:fori=0to4:ifs%(p,i)<>sbthenifr%(p,i)<rthenr=r%(p,i):c=i
  244. 726 next:goto742
  245. 728 rem --- keep strong suit(s)
  246. 730 fori=0to3:sp%(p,i)=0:next
  247. 732 fori=0to4:sp%(p,s%(p,i))=sp%(p,s%(p,i))+rb%(r%(p,i)):next:w=99
  248. 734 fori=0to4:s=s%(p,i):ifs<>sbthenifsp%(p,s)>0andsp%(p,s)<wthenw=sp%(p,s):sp=s
  249. 736 next
  250. 738 rem --- lowest card in suit
  251. 740 gosub1512
  252. 742 rem --- clear
  253. 744 ifp>0thengosub196:goto748
  254. 746 y=yh%:x=xh%(c):gosub166
  255. 748 return
  256. 750 :
  257. 752 : rem lone hand - computer
  258. 754 :
  259. 756 ifsn%(p,sb)<3ornp%(pand253)=9then780
  260. 758 sp=sb:gosub1500:ifr%(p,c)<>7+(pb<>pdandsb=suandru=7)then780
  261. 759 ifsn%(p,sb)=5then772
  262. 760 j=rb%(sb):fork=1to3:sp=a1%(sp):ifsn%