Liren Large Software Subsidy 5

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 5 / 05.iso / a / a044 / 3.ddi / POKER / POKER.PRG < prev

Wrap

Text File | 1993-08-31 | 12.3 KB | 595 lines

************************************************************************ * Poker.PRG * * Casino-Style Draw Poker * * Copyright 1992 Computer Associates * All rights reserved. * ************************************************************************ set procedure to poker #DEFINE WINNING_AMT 100000 declare HandString[10] declare Payoff[10] declare counts[13] declare suits[4] declare groups[4] declare PDeck[52] declare flipped[5] HandString[1] = "nothing" Payoff[1] = -1 HandString[2] = "Jacks or better 2 to 1" Payoff[2] = 2 HandString[3] = "Two pair 3 to 1" Payoff[3] = 3 HandString[4] = "three of a kind 5 to 1" Payoff[4] = 5 HandString[5] = "Straight 10 to 1" Payoff[5] = 10 HandString[6] = "Flush 20 to 1" Payoff[6] = 20 HandString[7] = "Full house 50 to 1" Payoff[7] = 50 HandString[8] = "Four of a kind 100 to 1" Payoff[8] = 100 HandString[9] = "Straight flush 200 to 1" Payoff[9] = 200 HandString[10] = "Royal flush 500 to 1" Payoff[10] = 500 CFlag = 0 score = 1000 bet = 10 sBet = '10' lastTitle = 0 PokerMode = 1 card1 = '' card2 = '' card3 = '' card4 = '' card5 = '' cardback = '' afill(@flipped, 0) for i = 10 to 12 Random(seconds()/(9*i*day(date()))) next create window "DrawPoker" from 1,1 to 24,78 set window title to "Draw Poker" ********************** * set up color display ********************** store sayvideo() to savsay, svsav store bitand(savsay,240) to bascolor store bascolor + 4 to color | Red set say video to color center("dBFast Casino -- Draw Poker",0,0,78,11) set say video to svsav do DrawTitles create Button " Quit " at 21,63 create button " Deal " at 21,6 create control editbox "BET" at 21,40 size 1,8 save to sBet @ 21,20 say "Cash: $ " + str(score, 7, 0) declare cards[5] declare cardname[52] ********************** * Load card bmps ********************** for i = 1 to 52 cardname[i] = "card" + alltrim(str(i)) + ".bmp" next load bitmap back.bmp into cardback sAction = '?' DO while .not. empty(sAction) nEvent = GetEvent() sAction = TranslateEvent(nEvent) DO CASE CASE sAction = ' Deal ' If OKBet() DO playhand endif CASE sAction = ' Draw ' if OKBet() DO ProcessMode2 with 1 endif CASE sAction = ' Quit ' *: Set sAction to empty to EXIT the program sAction = '' CASE sAction = '1st' IF PokerMode = 1 do ProcessMode1 with 11 ELSE do ProcessMode2 with 11 ENDIF CASE sAction = '2nd' IF PokerMode = 1 do ProcessMode1 with 12 ELSE do ProcessMode2 with 12 ENDIF CASE sAction = '3rd' IF PokerMode = 1 do ProcessMode1 with 13 ELSE do ProcessMode2 with 13 ENDIF CASE sAction = '4th' IF PokerMode = 1 do ProcessMode1 with 14 ELSE do ProcessMode2 with 14 ENDIF CASE sAction = '5th' IF PokerMode = 1 do ProcessMode1 with 15 ELSE do ProcessMode2 with 15 ENDIF OTHERWISE sAction = 'unknown' ENDCASE ENDDO release all clear gets ERASE RETURN ************************ FUNCTION GetEvent() * Get event from Windows ************************ PRIVATE nTheEvent nTheEvent = -1 DO WHILE nTheEvent = -1 nTheEvent = CHKEVENT() ENDDO *: nTheMenu = HMENU() nTheOption = VMENU() nTheKey = LASTKEY() sTheWindow = WINDOW() sTheButton = BUTTON() RETURN(nTheEvent) ********************************************** FUNCTION TranslateEvent() * Translate event number and set return code * see POKER.INC for event number definition ********************************************** PARAMETER nTheEvent PRIVATE sTheAction DO CASE CASE nTheEvent = eKybd nTheKey = LASTKEY() DO CASE CASE nTheKey = 1553 | Ctrl+F4 sTheAction = 'Exit' otherwise If OKBet() do PlayHand PokerMode = 2 endif sTheAction = '?' ENDCASE CASE nTheEvent = eButton sTheAction = button() CASE nTheEvent = eMClick |Mouse clicked on the screen row = MROW() col = MCOL() sTheAction = '?' if col < 15 .AND. col > 5 .AND. row > 11 .AND. row < 18 sTheAction = '1st' endif if col < 29 .AND. col > 19 .AND. row > 11 .AND. row < 18 sTheAction = '2nd' endif if col < 43 .AND. col > 33 .AND. row > 11 .AND. row < 18 sTheAction = '3rd' endif if col < 57 .AND. col > 47 .AND. row > 11 .AND. row < 18 sTheAction = '4th' endif if col < 71 .AND. col > 61 .AND. row > 11 .AND. row < 18 sTheAction = '5th' endif OTHERWISE sTheAction = "" ENDCASE RETURN(sTheAction) ********************************************** Function HandCompute ********************************************** private i, straight, flush, retv, ai private suits, counts, groups, high1, low1, high2, low2 declare counts[13] declare suits[4] declare groups[4] afill(@counts, 0) afill(@suits, 0) afill(@groups, 0) low1 = 15 high1 = 0 low2 = 15 high2 = 0 highpair = 0 straight = 0 ai = 0 i = 0 FOR i = 1 to 5 val = int(mod((cards[i] - 1), 13)) + 1 suit = int((cards[i] - 1)/13) + 1 counts[val] = counts[val] + 1 suits[suit] = suits[suit] + 1 low1 = Min(low1, val) high1 = Max(high1, val) IF val = 1 ai = 14 else ai = val endif low2 = Min(low2, ai) high2 = Max(high2, ai) NEXT ai = 0 FOR i = 1 to 13 val = counts[i] IF val > 0 groups[val] = groups[val] + 1 IF val = 2 if i = 1 ai = 14 else ai = i endif highpair = Max(highpair, ai) ENDIF endif NEXT if ((high1 - low1) = 4) .AND. (groups[1] = 5) straight = 1 endif if ((high2 - low2) = 4) .AND. (groups[1] = 5) straight = 1 endif flush = 0 retv = 1 FOR i = 1 to 4 IF suits[i] = 5 flush = 1 ENDIF NEXT IF straight = 1 .AND. flush = 1 IF low2 = 10 RETV = 10 ELSE RETV = 9 ENDIF ENDIF IF groups[4] = 1 RETV = 8 ENDIF IF groups[3] = 1 RETV = 4 ENDIF IF groups[2] = 1 .AND. highpair > 10 RETV = 2 ENDIF IF groups[3] = 1 .AND. groups[2] = 1 RETV = 7 ENDIF IF flush = 1 RETV = 6 ENDIF IF straight = 1 RETV = 5 ENDIF IF groups[2] = 2 RETV = 3 ENDIF RETURN RETV ********************************************** Procedure ResetCards ********************************************** afill(@PDeck, 0) afill(@flipped, 0) IF CFlag = -1 PDeck[1] = 49 PDeck[2] = 52 PDeck[3] = 15 PDeck[4] = 33 PDeck[5] = 50 PDeck[6] = 40 PDeck[7] = 51 PDeck[8] = 19 PDeck[9] = 37 PDeck[10] = 8 CFlag = 1 ENDIF Return ********************************************** Function RandomCard ********************************************** private i, stop IF CFlag > 0 CFlag = CFlag + 1 RETURN PDeck[CFlag - 1] ENDIF stop = .t. do while stop i = int(seconds()*Random() / 32726 * 52) i=mod(i,52)+1 IF PDeck[i] = 0 PDeck[i] = 1 stop = .f. ENDIF ENDDO RETURN i ********************************************** Procedure DrawCard ********************************************** parameter i cardmap = cardname[cards[i]] if i = 1 load bitmap &cardmap into card1 @ 12,6 say card1 endif if i = 2 load bitmap &cardmap into card2 @ 12,20 say card2 endif if i = 3 load bitmap &cardmap into card3 @ 12,34 say card3 endif if i = 4 load bitmap &cardmap into card4 @ 12,48 say card4 endif if i = 5 load bitmap &cardmap into card5 @ 12,62 say card5 endif Return ********************************************** Procedure DrawCardBack ********************************************** parameter i @ 12,14*i-8 say cardback Return ********************************************** Procedure UpdateTitles ********************************************** parameter n IF n = LastTitle return ENDIF * Set title to black IF LastTitle > 1 set say video to svsav @ LastTitle + 3 - int((LastTitle-1)/6)*5, 6 + int((LastTitle-1)/6)*37 say Handstring[LastTitle] ENDIF * Set winning title to Red IF n > 1 store bascolor + 4 to color | Red set say video to color @ n + 3 - int((n-1)/6)*5, 6 + int((n-1)/6)*37 say Handstring[n] set say video to svsav ENDIF LastTitle = n Return ********************************************** Procedure DrawTitles ********************************************** for i = 2 to 10 @ i + 3 - int((i-1)/6)*5, 6 + int((i-1)/6)*37 say Handstring[i] next Return ********************************************** Procedure PlayHand ********************************************** private i, sel, c, h do UpdateTitles with 0 FOR i = 1 to 5 do DrawCardBack with i NEXT do ResetCards @ 12,6 clear to 17,76 FOR i = 1 to 5 cards[i] = RandomCard() do DrawCard with i NEXT h = HandCompute() do UpdateTitles with h close button " Deal " create button " Draw " at 21,6 DISABLE CONTROL "BET" @ 2,30 clear to 3,50 && for win/lose message pokerMode = 2 Return ********************************************** Procedure ProcessMode2 ********************************************** parameter sel private i, c, h DO CASE CASE sel = 1 |Draw FOR i = 1 to 5 IF flipped[i] = 1 cards[i] = RandomCard() do DrawCard with i ENDIF NEXT i h = HandCompute() do UpdateTitles with h afill(@PDeck, 0) score = score + Payoff[h] * val(sBet) store sayvideo() to SaveSay If Payoff[h]=-1 set say video to 15*16+12 @ 2,30 say "You Lose" font 15 else set say video to 15*16+2 @ 2,30 say "You Win" font 15 endif set say video to SaveSay @ 21,20 clear to 21,27 @ 21,20 say "Cash: $ " + str(score, 7, 0) If WinOrLose() quit endif close button " Draw " create button " Deal " at 21,6 ENABLE CONTROL "BET" IF CFlag > 1 CFlag = 0 ENDIF PokerMode = 1 CASE sel > 10 .and. sel < 16 | Cards c = sel - 10 IF flipped[c] = 1 do DrawCard with c flipped[c] = 0 ELSE do DrawCardBack with c flipped[c] = 1 ENDIF ENDCASE Return ********************************************** Procedure ProcessMode1 ********************************************** parameter sel DO CASE CASE sel = 1 |Deal IF OKBet() do PlayHand PokerMode=2 endif ENDCASE Return ************** Function OKBet ************** If val(sBet)>score warning("ERROR","You cannot bet more than you have.",384+1) SELECT CONTROL "BET" return(.f.) elseif val(sBet)<1 warning("ERROR","You must bet at least 1 coin.",384+1) SELECT CONTROL "BET" return(.f.) endif return(.t.) ****************** Function WinOrLose ****************** If Score <=0 warning("YOU LOSE","You have lost all of your money. Better luck next time.",384+1) return(.t.) elseif Score>=WINNING_AMT warning("YOU WIN!!!","Congratulations! You have broken the bank!",384+3) return(.t.) endif return(.f.)