************************************************************************
*  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.)
