home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.tar / ftp.whtech.com / club100 / gam / vpoker.ba < prev    next >
Text File  |  2006-10-19  |  5KB  |  54 lines
  1. 0 'VPOKER Hal Brown
  2. 1 'CLUB 100 Library - 415/939-1246 BBS,    937-5039 NEWSLETTER, 932-8856 VOICE
  3. 2 'NEC 8201A and Model 100 compatible
  4. 3 CLEAR200:SCREEN,0:ONERRORGOTO51:DEFINTA-Z:DIMC(9),V(14):Y=27:E$=CHR$(27):Y$=E$+"Y":T$=Y$+"!":L$=Y$+"%":CLS
  5. 4 B$="DRAW POKER":FORJ=1TO5:PRINTT$;CHR$(6*J+32);MID$(B$,J,1);:PRINTL$;CHR$(6*J+35);MID$(B$,J+5,1);:NEXT:FORJ=31TO177STEP36:LINE(J,5)-(J+32,49),1,B:LINE(J-1,6)-(J+33,48),1,B:NEXT
  6. 5 FORJ=1TO5:X=6+36*J:ONJGOSUB42,43,44,45,46:NEXT:PRINTY$"'-";CHR$(27)"p by Hal Brown "CHR$(27)"q";:LINE(79,55)-(160,55),1
  7. 6 PRINTY$;"'"+CHR$(34)"Any key";:PRINTY$"'?to play!";:GOSUB35:CLS:PRINTY$" !"CHR$(27)"p AWARD SCHEDULE "CHR$(27)"q  Any key to continue!"
  8. 7 PRINT:PRINT" Royal flush    150  Flush            8  Five of a kind  50  Straight         5  Straight flush  50  Three of a kind  3"
  9. 8 PRINT" Four of A kind  25  Two pair         2  Full house      10  Jacks or better  1":GOSUB35
  10. 9 CLS:PRINTY$+STRING$(2,34)"Want JOKER as wild card (Y/N)? ";
  11. 10 K$=INPUT$(1):K$=CHR$(ASC(K$)AND95):IFK$<>"Y"ANDK$<>"N"THEN10ELSEW=52-(K$="Y"):PRINTK$
  12. 11 PRINT:INPUT"  Number of credits to start";C
  13. 12 CLS:PRINTY$"#ACREDIT";:LINE(194,20)-(236,42),1,B:LINE(192,18)-(238,44),1,B:PRINTY$"$A";USING"#####";C;
  14. 13 PRINTY$;CHR$(34)+" ";SPACE$(15):FORI=10TO156STEP36:LINE(I,5)-(I+32,49),1,B:LINE(I-1,6)-(I+33,48),1,B:NEXT
  15. 14 PRINTY$"' "SPACE$(39);:IFC=0THENCLS:PRINTY$;"#!Out of credits! Play Again? ([Y]/N)? ";:K$=INPUT$(1):K$=CHR$(ASC(K$)AND95):IFK$="N"THENMENUELSE9
  16. 15 FORI=0TO9:C(I)=99:NEXT:GOSUB39:C=C-1
  17. 16 FORI=0TO4:GOSUB36:PRINTT$;CHR$(34+6*I)"  ";:PRINTL$;CHR$(37+6*I)"  ";:NEXT:FORI=1TO1000:NEXT
  18. 17 GOSUB37:SOUND15000,10:PRINTY$"$A";USING"#####";C;
  19. 18 PRINTY$"'!Key 1-5 to discard, ENTER to draw!";
  20. 19 GOSUB35:IFK$=CHR$(13)THENPRINTY$"'!"SPACE$(36);:GOTO22
  21. 20 I=VAL(K$)-1:IFI<0ORI>4THEN19ELSEX=C(I):C(I)=C(I+5):C(I+5)=X:GOSUB38:IFC(I)=99THENH$="  ":GOSUB36ELSEGOSUB41
  22. 21 PRINTT$;CHR$(34+6*I);H$;:PRINTL$;CHR$(39+6*I-LEN(H$));H$;:GOTO19
  23. 22 GOSUB39:GOSUB37:FORI=0TO14:V(I)=0:NEXT:FORI=0TO4:S(I)=0:NEXT
  24. 23 FORI=0TO4:N=C(I)\13:S(N)=S(N)+1:N=(C(I)MOD13)+1:V(N)=V(N)+1:NEXT:V(1)=V(1)-S(4):V(14)=V(1):FL=0:FORI=0TO3:FL=FL+(S(I)=5-S(4)):NEXT
  25. 24 ST=0:FORI=1TO10:N=0:FORK=ITOI+4:N=N-(V(K)>0):NEXT:ST=ST-(N=5-S(4)):NEXT:PRINTY$"'!";SPACE$(37);:PRINTY$"'#";
  26. 25 IFFLANDSTTHENIFV(9)=0ANDV(10)+V(11)>0THENPRINT"Royal flush!";:X=150:GOTO32ELSEPRINT"Straight flush!";:X=50:GOTO32
  27. 26 IFFLTHENPRINT"Flush!";:X=8:GOTO32ELSEIFSTTHENPRINT"Straight!";:X=5:GOTO32
  28. 27 PR=0:TR=0:FR=0:FV=0:FORI=1TO13:PR=PR+(V(I)=2):TR=TR+(V(I)=3-S(4)):FR=FR+(V(I)=4-S(4)):FV=FV-(V(I)=5-S(4)):NEXT
  29. 28 IFFVTHENPRINT"Five of a kind!";:X=50:GOTO32ELSEIFFRTHENPRINT"Four of a kind!";:X=25:GOTO32
  30. 29 IFTR=-2OR(TRANDPR+S(4))THENPRINT"Full house!";:X=10:GOTO32ELSEIFTRTHENPRINT"Three of a kind!";:X=3:GOTO32ELSEIFPR=-2THENPRINT"Two pair!";:X=2:GOTO32
  31. 30 IFS(4)+V(11)=2ORS(4)+V(12)=2ORS(4)+V(13)=2ORS(4)+V(14)=2THENPRINT"Pair, jacks or better!";:X=1:GOTO32
  32. 31 IFS(4)ORPRTHENPRINT"Pair!";:GOTO33ELSEPRINT"Nothing!";:GOTO33
  33. 32 PRINTY$"!@PAY:";:FORI=1TOX:C=C+1:PRINTY$"$A";USING"#####";C:BEEP:PRINTY$"!D";USING"###";I;:NEXT
  34. 33 PRINTY$"';Press ENTER!";
  35. 34 GOSUB35:IFK$<>CHR$(13)THEN34ELSEPRINTY$"!@";SPACE$(8);:GOTO14
  36. 35 N=RND(1):K$=INKEY$:IFK$=""THEN35ELSERETURN
  37. 36 FORM=0TO2:PRINTY$;CHR$(34+M)+CHR$(35+6*I)"   ";:NEXT:RETURN
  38. 37 FORI=0TO4:GOSUB38:GOSUB41:PRINTT$;CHR$(34+6*I);H$;:PRINTL$;CHR$(39+6*I-LEN(H$));H$;:NEXT:RETURN
  39. 38 IFC(I)=52THENH$="":RETURNELSEV=(C(I)MOD13)+1:IFV>1ANDV<11THENH$=RIGHT$(STR$(V),1-(V>9)):RETURNELSEH$=CHR$(65-9*(V>1)-7*(V>11)+6*(V>12)):RETURN
  40. 39 FORI=0TO4:IFC(I)<>99THENNEXT:RETURN
  41. 40 N=0:J=INT(RND(1)*W):FORK=0TO9:N=N+(J=C(K)):NEXT:IFNTHEN40ELSEC(I+5)=C(I):C(I)=J:NEXT:RETURN
  42. 41 X=21+36*I:ON(C(I)\13)GOTO43,44,45,46
  43. 42 GOSUB48:GOTO49
  44. 43 LINE(X+2,Y-5)-(X+3,Y-5),1:LINE(X+7,Y-5)-(X+8,Y-5),1:LINE(X+1,Y-4)-(X+9,Y-4),1:PRESET(X+5,Y-4):LINE(X,Y-3)-(X+10,Y-1),1,BF:GOTO50
  45. 44 GOSUB48:GOTO50
  46. 45 LINE(X+4,Y-5)-(X+6,Y-5),1:LINE(X+3,Y-4)-(X+7,Y-2),1,BF:LINE(X+1,Y-1)-(X+9,Y-1),1:GOTO49
  47. 46 LINE(X+5,Y-6)-(X+5,Y+1),1:LINE(X+4,Y-5)-(X+4,Y-4),1:LINE(X+6,Y-5)-(X+6,Y-4),1:LINE(X+4,Y-2)-(X+4,Y+5),1:LINE(X+6,Y-2)-(X+6,Y+5),1
  48. 47 LINE(X+3,Y-2)-(X+1,Y),1:LINE(X+7,Y-2)-(X+10,Y+1),1:LINE(X+3,Y-1)-(X+1,Y+1),1:LINE(X+7,Y-1)-(X+10,Y+2),1:LINE(X,Y-1)-(X,Y),1:PSET(X+3,Y+5):PSET(X+7,Y+5):RETURN
  49. 48 FORM=0TO4:LINE(X+5-M,Y-5+M)-(X+5+M,Y-5+M),1:NEXT:RETURN
  50. 49 LINE(X,Y)-(X+10,Y+2),1,BF:LINE(X+1,Y+3)-(X+9,Y+3),1:LINE(X+4,Y+4)-(X+6,Y+5),1,B:RETURN
  51. 50 FORM=0TO5:LINE(X+M,Y+M)-(X+10-M,Y+M),1:NEXT:RETURN
  52. 51 CLS:PRINT:IFERR=5THENPRINT" NEC 8201A must have LINE enabled.":END
  53. 52 PRINT" Error"ERR"in Line"ERL:END
  54.