+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Poker hand evaluator (/showthread.php?tid=376)
Poker hand evaluator - Pete - 05-08-2022
I built a game called Pecos Pete Poker around a couple of decades ago. I recently updated it to play on QB64, and I also got together with TheBOB who offered his graphics playing cards if I wanted to make a graphics version. I've been working on that, and since I love reinventing the wheel, I came up with a completely new poker hand evaluator to go with it. This hand evaluation model is written in SCREEN 0 but can be converted to evaluate graphics hands, which I'll work on next week.
You need jacks or better to display a "Pair" with a payout. Other lesser pairs are marked in grey. Press Enter or any non-number key to draw the next hand. Since it takes awhile to get hands like 4 of a kind, and especially a royal flush, I put number buttons in a menu. Press 1 to wait on a royal flush, 2 for a straight flush, 3 for 4 of a kind, 4 for a full house, etc. Press esc if you get tired of waiting, it will go back to one at a time display.
Code: (Select All)
' Jacks or better poker evaluator demo.
' Use keys 1 - 9 to search for particular hands, Royal Flush, Full HOuse, etc.
sw% = 55
sh% = 17
WIDTH sw%, sh%
PALETTE 7, 63
COLOR 0, 7: CLS
fontpath$ = ENVIRON$("SYSTEMROOT") + "\fonts\lucon.ttf"
font& = _LOADFONT(fontpath$, 40, "monospace")
_FONT font&
_DELAY .25
_SCREENMOVE 0, 0
msg$ = "Poker Hand Evaluator"
LOCATE 1, (sw% / 2) - (LEN(msg$) / 2): PRINT msg$;
msg$ = "Any Key or 1=RF 2=SF 3=4K 4=FH 5=F 6=S 7=3K 8=2P 9=P"
LOCATE sh%, (sw% / 2) - (LEN(msg$) / 2): PRINT msg$;
VIEW PRINT 3 TO sh% - 2: LOCATE 4, 1
h = 1 ' Number of hands.
noc = 5 ' Number of card.
DO
REDIM cardID$(1, 5)
REDIM taken(5)
taken(3) = 13: taken(4) = 26: taken(5) = 39
FOR i = 1 TO noc
DO
card = INT(RND * 52) + 1
FOR j = 1 TO i
IF taken(j) = card THEN flag = -1: EXIT FOR
NEXT
IF flag = 0 THEN taken(i) = card: EXIT DO ELSE flag = 0
LOOP
cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
NEXT
IF POS(0) > 3 OR CSRLIN > 4 THEN PRINT: PRINT: PRINT: LOCATE CSRLIN - 1
LOCATE , 3
FOR j = 1 TO 5
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
x$ = LTRIM$(STR$(a1))
b = (a + 12) \ 13
suite$ = CHR$(2 + b)
REM PRINT x$; suite$; " ";
IF suite$ = CHR$(3) OR suite$ = CHR$(4) THEN COLOR 4 ELSE COLOR 0
SELECT CASE VAL(x$)
CASE 1: PRINT "A"; suite$; " ";
CASE 13: PRINT "K"; suite$; " ";
CASE 12: PRINT "Q"; suite$; " ";
CASE 11: PRINT "J"; suite$; " ";
CASE 10: PRINT "10"; suite$; " ";
CASE ELSE: PRINT LTRIM$(STR$(VAL(x$))); suite$; " ";
END SELECT
NEXT
GOSUB eval
COLOR 1
LOCATE , 28
IF hand$ = "Pair" THEN
IF highkind >= 11 THEN COLOR 1: PRINT hand$; " (Pay Out)"; ELSE COLOR 8: PRINT hand$;
ELSE
PRINT hand$;
END IF
COLOR 1
IF search$ = "" THEN GOSUB getkey ELSE IF INKEY$ = CHR$(27) THEN search$ = ""
IF LEN(search$) THEN
IF hand$ = search$ THEN SLEEP: search$ = ""
END IF
LOOP
END
eval:
hand$ = ""
DO
' Look for flush, same suit.
samesuit = 0
FOR j = 1 TO noc
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
b = (a + 12) \ 13
IF j > 1 AND b <> samesuit THEN flag = -1: EXIT FOR
samesuit = b
NEXT
IF flag = 0 THEN
' Flush or better.
hand$ = "Flush"
ELSE
flag = 0
END IF
' Look for staright, sequential order.
high = 0: low = 0: match$ = ""
FOR j = 1 TO noc
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
match$ = match$ + CHR$(a1 + 64)
NEXT
IF INSTR(match$, CHR$(1 + 64)) THEN
IF INSTR(match$, CHR$(13 + 64)) THEN high = 14 ' Ace high straight possible.
END IF
FOR j = 1 TO noc
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
IF j > 1 AND INSTR(match$, CHR$(a1 + 64)) <> j THEN match$ = "": EXIT FOR
IF low = 0 OR low > a1 THEN
IF a1 = 1 AND high = 14 THEN ELSE low = a1
END IF
IF high = 0 OR high < a1 THEN high = a1
NEXT
IF LEN(match$) AND high - low = noc - 1 THEN
IF hand$ = "Flush" THEN
IF high = 14 THEN
hand$ = "Royal Flush"
ELSE
hand$ = "Straight Flush": EXIT DO
END IF
ELSE
hand$ = "Straight": EXIT DO
END IF
END IF
' Look for number of kinds.
kinds = 1: highkind = -1
FOR j = 1 TO noc
kindcnt = 0
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
IF a1 = 1 THEN ' Convert ace high.
a1 = 14
'' cardID$(h, j) = MID$(cardID$(h, j), 1, INSTR(cardID$(h, j), "#")) + "14"
END IF
FOR k = 1 TO noc
IF j <> k THEN
IF a1 = (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 OR a1 = 14 AND (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 = 1 THEN
kindcnt = kindcnt + 1: IF highkind < a1 OR highkind = 0 THEN highkind = a1
END IF
END IF
IF kinds <= kindcnt THEN kinds = kindcnt + 1
NEXT k
NEXT j
IF kinds = 4 THEN hand$ = "Four of a Kind": EXIT DO
IF kinds = 3 THEN ' Look for full house.
kinds = 0
FOR j = 1 TO noc
kindcnt = 0
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
FOR k = 1 TO noc
IF j <> k AND a1 <> highkind THEN
IF a1 = (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 THEN
kindcnt = kindcnt + 1
END IF
END IF
NEXT k
IF kinds < kindcnt THEN kinds = kindcnt + 1
NEXT j
IF kinds = 2 THEN
hand$ = "Full House": EXIT DO
ELSE
hand$ = "Three of a Kind": EXIT DO
END IF
END IF
IF kinds = 2 THEN
' Look for two pair.
kinds = 0
FOR j = 1 TO noc
kindcnt = 0
a = VAL(MID$(cardID$(h, j), INSTR(cardID$(h, j), "#") + 1))
a1 = (a - 1) MOD 13 + 1
FOR k = 1 TO noc
IF j <> k AND a1 <> highkind THEN
IF a1 = 1 AND highkind = 14 THEN
' Checks for ace as 1 here after previous highkind converion to 14.
ELSE
IF a1 = (VAL(MID$(cardID$(h, k), INSTR(cardID$(h, k), "#") + 1)) - 1) MOD 13 + 1 THEN
kindcnt = kindcnt + 1
END IF
END IF
END IF
NEXT k
IF kinds < kindcnt THEN kinds = kindcnt + 1
NEXT j
IF kinds = 2 THEN
hand$ = "Two Pair": EXIT DO
ELSE
hand$ = "Pair": EXIT DO
END IF
END IF
EXIT DO
LOOP
RETURN
getkey:
DO
_LIMIT 30
b$ = INKEY$
IF LEN(b$) THEN
IF b$ = CHR$(27) THEN SYSTEM
IF b$ >= "1" AND b$ <= "9" THEN
SELECT CASE VAL(b$)
CASE 1: search$ = "Royal Flush"
CASE 2: search$ = "Straight Flush"
CASE 3: search$ = "Four of a Kind"
CASE 4: search$ = "Full House"
CASE 5: search$ = "Flush"
CASE 6: search$ = "Straight"
CASE 7: search$ = "Three of a Kind"
CASE 8: search$ = "Two Pair"
CASE 9: search$ = "Pair"
END SELECT
EXIT DO
END IF
EXIT DO
END IF
LOOP
RETURN
$IF THEN
---------Hearts
1=A
2
3
4
5
6
7
8
9
10
11=J
12=Q
13=K
---------Diamonds
14=A
15=2
16=3
17=4
18=5
19=6
20=7
21=8
22=9
23=10
24=J
25=Q
26=K
---------Clubs
27=A
28=2
29=3
30=4
31=5
32=6
33=7
34=8
35=9
36=10
37=J
38=Q
39=K
---------Spades
40=A
41=2
42=3
43=4
44=5
45=6
46=7
47=8
48=9
49=10
50=J
51=Q
52=K
--------------------Test
card = 13: i = 3: cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
card = 26: i = 4: cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
card = 39: i = 5: cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
card = 1: i = 1: cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
card = 14: i = 2: cardID$(h, i) = LTRIM$(STR$(y)) + "|" + LTRIM$(STR$(scol + (i - 1) * 120 + x)) + "#" + LTRIM$(STR$(card))
$END IFPete