Posts: 3,885
Threads: 174
Joined: Apr 2022
Reputation:
202
Code: (Select All) ' Poker.bas 2022-10-10 b+ try ranking hands
Dim Shared Order$
Order$ = " A 2 3 4 5 6 7 8 910 J Q K"
Dim Shared Deck$(52), rankCount(10)
makeDeck
'For i = 1 To 52
' Print i, Deck$(i)
'Next
'end
shuffle
'For i = 1 To 52
' Print i, Deck$(i)
'Next
'end
'make sure we detect rare occurances
h$ = " AC10C JC QC KC"
Print h$; " = "; RankName$(Rank(h$))
h$ = " KS10S JS QS AS"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AC 3C JC QC KC"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AC 2C 3C 4C 5C"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AS 2C 3C 4C 5C"
Print h$; " = "; RankName$(Rank(h$))
Cls
tests = 10000000
While fini = 0
For k = 0 To 9
h$ = ""
For i = 1 To 5
h$ = h$ + Deck$(k * 5 + i)
Next
r = Rank(h$)
rankCount(r) = rankCount(r) + 1
Next
hands = hands + 10
If hands >= tests Then fini = 1 Else shuffle
'input "Quit? ";a$
'if a$ = "y" then fini = 1 else shuffle
Wend
For i = 1 To 10
Print rankCount(i); ", "; Int(rankCount(i) / tests * 100); "%, "; RankName$(i)
Next
Function RankName$ (RNumber)
Select Case RNumber
Case 1: RankName$ = "Royal Flush"
Case 2: RankName$ = "Straight Flush"
Case 3: RankName$ = "Four of a Kind"
Case 4: RankName$ = "Full House"
Case 5: RankName$ = "Flush"
Case 6: RankName$ = "Straight"
Case 7: RankName$ = "Three of a Kind"
Case 8: RankName$ = "Two Pair"
Case 9: RankName$ = "Pair"
Case 10: RankName$ = "High Card"
End Select
End Function
Function Rank (hand$)
Dim arrange(13)
For i = 1 To 5
v$ = Mid$(hand$, i * 3 - 2, 2)
f = (InStr(Order$, v$) + 1) / 2
arrange(f) = arrange(f) + 1
Next
For i = 1 To 13
Select Case arrange(i)
Case 2: pair = pair + 1
Case 3: three = 1
Case 4: four = 1
End Select
Next
If four = 1 Then Rank = 3: Exit Function
If three = 1 And pair = 1 Then Rank = 4: Exit Function
If three = 1 Then Rank = 7: Exit Function
If pair = 2 Then Rank = 8: Exit Function
If pair = 1 Then
Rank = 9: Exit Function
Else ' check flush and straight
suit$ = Mid$(hand$, 3, 1): flush = 1
For i = 2 To 5
If Mid$(hand$, i * 3, 1) <> suit$ Then flush = 0: Exit For
Next
i = 1: straight = 1 ' find lowest card i
While arrange(i) = 0
i = i + 1
Wend
If i = 1 Then
If arrange(10) = 1 And arrange(11) = 1 And arrange(12) = 1 And arrange(13) = 1 Then
straight = 1: royal = 1: GoTo FinishRank
End If
End If
If i >= 10 Then
straight = 0
Else
straight = 1
For j = i + 1 To i + 4 ' check next 4 cards in sequence
If arrange(j) <> 1 Then straight = 0: Exit For
Next
End If
FinishRank:
If (straight = 1) And (flush = 1) And (royal = 1) Then Rank = 1: Exit Function
If (straight = 1) And (flush = 1) Then Rank = 2: Exit Function
If (flush = 1) Then Rank = 5: Exit Function
If (straight = 1) Then
Rank = 6
Else
Rank = 10
End If
End If
End Function
Sub shuffle
For i = 52 To 2 Step -1
r = Int(Rnd * i) + 1
t$ = Deck$(i)
Deck$(i) = Deck$(r)
Deck$(r) = t$
Next
End Sub
Sub makeDeck
suit$ = "CDHS"
For s = 1 To 4
For i = 1 To 13
Deck$((s - 1) * 13 + i) = Mid$(Order$, (i - 1) * 2 + 1, 2) + Mid$(suit$, s, 1)
Next
Next
End Sub
' rank name calc % calc odds
'1data " Royal Flush", 0.000154, 649740
'2data " Straight Flush", 0.00139 , 72193.33
'3data " Four of a Kind", 0.0240 , 4165
'4data " Full House", 0.144 , 694.17
'5data " Flush", 0.197 , 508.8
'6data " Straight", 0.392 , 254.8
'7data "Three of a Kind", 2.11 , 47.3
'8data " Two Pair", 4.75 , 21.03
'9data " Pair", 42.3 , 2.36
'10 data " High Card", 50.1 , 1.995
b = b + ...
Posts: 634
Threads: 93
Joined: Apr 2022
Reputation:
22
(10-11-2022, 05:52 AM)bplus Wrote: Code: (Select All) ' Poker.bas 2022-10-10 b+ try ranking hands
Dim Shared Order$
Order$ = " A 2 3 4 5 6 7 8 910 J Q K"
Dim Shared Deck$(52), rankCount(10)
makeDeck
'For i = 1 To 52
' Print i, Deck$(i)
'Next
'end
shuffle
'For i = 1 To 52
' Print i, Deck$(i)
'Next
'end
'make sure we detect rare occurances
h$ = " AC10C JC QC KC"
Print h$; " = "; RankName$(Rank(h$))
h$ = " KS10S JS QS AS"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AC 3C JC QC KC"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AC 2C 3C 4C 5C"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AS 2C 3C 4C 5C"
Print h$; " = "; RankName$(Rank(h$))
Cls
tests = 10000000
While fini = 0
For k = 0 To 9
h$ = ""
For i = 1 To 5
h$ = h$ + Deck$(k * 5 + i)
Next
r = Rank(h$)
rankCount(r) = rankCount(r) + 1
Next
hands = hands + 10
If hands >= tests Then fini = 1 Else shuffle
'input "Quit? ";a$
'if a$ = "y" then fini = 1 else shuffle
Wend
For i = 1 To 10
Print rankCount(i); ", "; Int(rankCount(i) / tests * 100); "%, "; RankName$(i)
Next
Function RankName$ (RNumber)
Select Case RNumber
Case 1: RankName$ = "Royal Flush"
Case 2: RankName$ = "Straight Flush"
Case 3: RankName$ = "Four of a Kind"
Case 4: RankName$ = "Full House"
Case 5: RankName$ = "Flush"
Case 6: RankName$ = "Straight"
Case 7: RankName$ = "Three of a Kind"
Case 8: RankName$ = "Two Pair"
Case 9: RankName$ = "Pair"
Case 10: RankName$ = "High Card"
End Select
End Function
Function Rank (hand$)
Dim arrange(13)
For i = 1 To 5
v$ = Mid$(hand$, i * 3 - 2, 2)
f = (InStr(Order$, v$) + 1) / 2
arrange(f) = arrange(f) + 1
Next
For i = 1 To 13
Select Case arrange(i)
Case 2: pair = pair + 1
Case 3: three = 1
Case 4: four = 1
End Select
Next
If four = 1 Then Rank = 3: Exit Function
If three = 1 And pair = 1 Then Rank = 4: Exit Function
If three = 1 Then Rank = 7: Exit Function
If pair = 2 Then Rank = 8: Exit Function
If pair = 1 Then
Rank = 9: Exit Function
Else ' check flush and straight
suit$ = Mid$(hand$, 3, 1): flush = 1
For i = 2 To 5
If Mid$(hand$, i * 3, 1) <> suit$ Then flush = 0: Exit For
Next
i = 1: straight = 1 ' find lowest card i
While arrange(i) = 0
i = i + 1
Wend
If i = 1 Then
If arrange(10) = 1 And arrange(11) = 1 And arrange(12) = 1 And arrange(13) = 1 Then
straight = 1: royal = 1: GoTo FinishRank
End If
End If
If i >= 10 Then
straight = 0
Else
straight = 1
For j = i + 1 To i + 4 ' check next 4 cards in sequence
If arrange(j) <> 1 Then straight = 0: Exit For
Next
End If
FinishRank:
If (straight = 1) And (flush = 1) And (royal = 1) Then Rank = 1: Exit Function
If (straight = 1) And (flush = 1) Then Rank = 2: Exit Function
If (flush = 1) Then Rank = 5: Exit Function
If (straight = 1) Then
Rank = 6
Else
Rank = 10
End If
End If
End Function
Sub shuffle
For i = 52 To 2 Step -1
r = Int(Rnd * i) + 1
t$ = Deck$(i)
Deck$(i) = Deck$(r)
Deck$(r) = t$
Next
End Sub
Sub makeDeck
suit$ = "CDHS"
For s = 1 To 4
For i = 1 To 13
Deck$((s - 1) * 13 + i) = Mid$(Order$, (i - 1) * 2 + 1, 2) + Mid$(suit$, s, 1)
Next
Next
End Sub
' rank name calc % calc odds
'1data " Royal Flush", 0.000154, 649740
'2data " Straight Flush", 0.00139 , 72193.33
'3data " Four of a Kind", 0.0240 , 4165
'4data " Full House", 0.144 , 694.17
'5data " Flush", 0.197 , 508.8
'6data " Straight", 0.392 , 254.8
'7data "Three of a Kind", 2.11 , 47.3
'8data " Two Pair", 4.75 , 21.03
'9data " Pair", 42.3 , 2.36
'10 data " High Card", 50.1 , 1.995
I'm in the middle (or at least I've started) writing a game based on a similar algorithm.
I use this for shuffling:
for a=1 to 52
swop=int (rnd*52)+1
swap deck$(a),deck$(swop)
next
Posts: 2,123
Threads: 217
Joined: Apr 2022
Reputation:
100
I made one of those for Pecos Pete Poker.
The evaluator demo...
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)
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 IF
Pete
Posts: 3,885
Threads: 174
Joined: Apr 2022
Reputation:
202
10-11-2022, 01:15 PM
(This post was last modified: 10-11-2022, 01:26 PM by bplus.)
(10-11-2022, 07:00 AM)PhilOfPerth Wrote: (10-11-2022, 05:52 AM)bplus Wrote: Code: (Select All) ' Poker.bas 2022-10-10 b+ try ranking hands
Dim Shared Order$
Order$ = " A 2 3 4 5 6 7 8 910 J Q K"
Dim Shared Deck$(52), rankCount(10)
makeDeck
'For i = 1 To 52
' Print i, Deck$(i)
'Next
'end
shuffle
'For i = 1 To 52
' Print i, Deck$(i)
'Next
'end
'make sure we detect rare occurances
h$ = " AC10C JC QC KC"
Print h$; " = "; RankName$(Rank(h$))
h$ = " KS10S JS QS AS"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AC 3C JC QC KC"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AC 2C 3C 4C 5C"
Print h$; " = "; RankName$(Rank(h$))
h$ = " AS 2C 3C 4C 5C"
Print h$; " = "; RankName$(Rank(h$))
Cls
tests = 10000000
While fini = 0
For k = 0 To 9
h$ = ""
For i = 1 To 5
h$ = h$ + Deck$(k * 5 + i)
Next
r = Rank(h$)
rankCount(r) = rankCount(r) + 1
Next
hands = hands + 10
If hands >= tests Then fini = 1 Else shuffle
'input "Quit? ";a$
'if a$ = "y" then fini = 1 else shuffle
Wend
For i = 1 To 10
Print rankCount(i); ", "; Int(rankCount(i) / tests * 100); "%, "; RankName$(i)
Next
Function RankName$ (RNumber)
Select Case RNumber
Case 1: RankName$ = "Royal Flush"
Case 2: RankName$ = "Straight Flush"
Case 3: RankName$ = "Four of a Kind"
Case 4: RankName$ = "Full House"
Case 5: RankName$ = "Flush"
Case 6: RankName$ = "Straight"
Case 7: RankName$ = "Three of a Kind"
Case 8: RankName$ = "Two Pair"
Case 9: RankName$ = "Pair"
Case 10: RankName$ = "High Card"
End Select
End Function
Function Rank (hand$)
Dim arrange(13)
For i = 1 To 5
v$ = Mid$(hand$, i * 3 - 2, 2)
f = (InStr(Order$, v$) + 1) / 2
arrange(f) = arrange(f) + 1
Next
For i = 1 To 13
Select Case arrange(i)
Case 2: pair = pair + 1
Case 3: three = 1
Case 4: four = 1
End Select
Next
If four = 1 Then Rank = 3: Exit Function
If three = 1 And pair = 1 Then Rank = 4: Exit Function
If three = 1 Then Rank = 7: Exit Function
If pair = 2 Then Rank = 8: Exit Function
If pair = 1 Then
Rank = 9: Exit Function
Else ' check flush and straight
suit$ = Mid$(hand$, 3, 1): flush = 1
For i = 2 To 5
If Mid$(hand$, i * 3, 1) <> suit$ Then flush = 0: Exit For
Next
i = 1: straight = 1 ' find lowest card i
While arrange(i) = 0
i = i + 1
Wend
If i = 1 Then
If arrange(10) = 1 And arrange(11) = 1 And arrange(12) = 1 And arrange(13) = 1 Then
straight = 1: royal = 1: GoTo FinishRank
End If
End If
If i >= 10 Then
straight = 0
Else
straight = 1
For j = i + 1 To i + 4 ' check next 4 cards in sequence
If arrange(j) <> 1 Then straight = 0: Exit For
Next
End If
FinishRank:
If (straight = 1) And (flush = 1) And (royal = 1) Then Rank = 1: Exit Function
If (straight = 1) And (flush = 1) Then Rank = 2: Exit Function
If (flush = 1) Then Rank = 5: Exit Function
If (straight = 1) Then
Rank = 6
Else
Rank = 10
End If
End If
End Function
Sub shuffle
For i = 52 To 2 Step -1
r = Int(Rnd * i) + 1
t$ = Deck$(i)
Deck$(i) = Deck$(r)
Deck$(r) = t$
Next
End Sub
Sub makeDeck
suit$ = "CDHS"
For s = 1 To 4
For i = 1 To 13
Deck$((s - 1) * 13 + i) = Mid$(Order$, (i - 1) * 2 + 1, 2) + Mid$(suit$, s, 1)
Next
Next
End Sub
' rank name calc % calc odds
'1data " Royal Flush", 0.000154, 649740
'2data " Straight Flush", 0.00139 , 72193.33
'3data " Four of a Kind", 0.0240 , 4165
'4data " Full House", 0.144 , 694.17
'5data " Flush", 0.197 , 508.8
'6data " Straight", 0.392 , 254.8
'7data "Three of a Kind", 2.11 , 47.3
'8data " Two Pair", 4.75 , 21.03
'9data " Pair", 42.3 , 2.36
'10 data " High Card", 50.1 , 1.995
I'm in the middle (or at least I've started) writing a game based on a similar algorithm.
I use this for shuffling:
for a=1 to 52
swop=int (rnd*52)+1
swap deck$(a),deck$(swop)
next
Ha, didn't know we were racing but I have been with Basic Forums since 2014 that might be an advantage.
Your shuffle is allot better than my first shuffle routine that I thought the cat's meow when i posted my first at JB forum way back 2015 maybe? Then tsh73, Russian Computer Science teacher, showed me Fisher Yates Shuffle the most efficient known to computer scientists wow! so yours is really close https://en.wikipedia.org/wiki/Fisher–Yates_shuffle
The one I use in Ranking is directly from JB and they don't have swap so you need to hold a value in temp variable for swap.
Code: (Select All) Sub shuffle
For i = 52 To 2 Step -1
r = Int(Rnd * i) + 1
t$ = Deck$(i)
Deck$(i) = Deck$(r)
Deck$(r) = t$
Next
End Sub
For QB64pe mod to
Code: (Select All) Sub shuffle ' for 1 to 52 cards as string in Shared Deck$
For i = 52 To 2 Step -1
Swap Deck$(i), Deck$(Int(Rnd * i) + 1) ' random from 1 to i inclusive,
' Steve showed me to do random directly without variable assignment
Next
End Sub
Hope to pass tsh73 and Steve advice along to you all 
Thumbs up to Phil for giving me that opportunity.
b = b + ...
Posts: 3,885
Threads: 174
Joined: Apr 2022
Reputation:
202
10-11-2022, 01:21 PM
(This post was last modified: 10-11-2022, 01:27 PM by bplus.)
(10-11-2022, 08:54 AM)Pete Wrote: I made one of those for Pecos Pete Poker.
The evaluator demo...
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)
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 IF
Pete
Hope to study this now that I've done one myself first, pickup some tips from an experienced Poker coder!
Thumbs up to you in advance because I am that sure there will be at least one thing in there I could use.
b = b + ...
Posts: 1,277
Threads: 120
Joined: Apr 2022
Reputation:
100
I've always wanted to create a clone of the late 1980's/early 1990's video poker machines found in Vegas at the time. Thanks for posting this code. I've been looking for a project to add to the tutorial that walks the user from start to finish creating a working game. Perhaps a video poker machine would be a good project.
Posts: 3,885
Threads: 174
Joined: Apr 2022
Reputation:
202
10-11-2022, 02:20 PM
(This post was last modified: 10-11-2022, 03:04 PM by bplus.)
This ranking system is nice start but when pairs are 42% of hands, you need to sort out the better eg, 2 players have a pair of 2's and an Ace high card? Who wins? Or both players have an Ace high card, do you look at suit of Ace or next highest card?
Comment on Terry's: If I did a Poker Machine, I think I would like to play against 3 or 4 AI's. Yeah since slots was Pete's...
Oh, maybe make a game with Plug-In-And-Play AI's to represent yourself at table, so everyone can try out their own AI.
Update: Just realized you only need an AI for Draw Poker with option to swap up to 3 cards with deck. And just being good at that makes world class poker players?
b = b + ...
Posts: 2,123
Threads: 217
Joined: Apr 2022
Reputation:
100
(10-11-2022, 02:11 PM)TerryRitchie Wrote: I've always wanted to create a clone of the late 1980's/early 1990's video poker machines found in Vegas at the time. Thanks for posting this code. I've been looking for a project to add to the tutorial that walks the user from start to finish creating a working game. Perhaps a video poker machine would be a good project.
@TerryRitchie,
I forgot I also had the poker slots game posted here: https://qb64phoenix.com/forum/showthread...66#pid2466
You are welcome to add it to your tutorial site, if you like.
Can you believe Bob hand designed those playing cards as bitmaps? The man's a real talent, well, for someone who doesn't program in SCREEN 0, that is.
Pete
Posts: 1,277
Threads: 120
Joined: Apr 2022
Reputation:
100
(10-12-2022, 09:03 AM)Pete Wrote: (10-11-2022, 02:11 PM)TerryRitchie Wrote: I've always wanted to create a clone of the late 1980's/early 1990's video poker machines found in Vegas at the time. Thanks for posting this code. I've been looking for a project to add to the tutorial that walks the user from start to finish creating a working game. Perhaps a video poker machine would be a good project.
@TerryRitchie,
I forgot I also had the poker slots game posted here: https://qb64phoenix.com/forum/showthread...66#pid2466
You are welcome to add it to your tutorial site, if you like.
Can you believe Bob hand designed those playing cards as bitmaps? The man's a real talent, well, for someone who doesn't program in SCREEN 0, that is.
Pete
Added it a few days ago.
https://www.qb64tutorial.com/games#h.6a3o4uul50i
Same game correct?
Terry
Posts: 3,885
Threads: 174
Joined: Apr 2022
Reputation:
202
10-12-2022, 03:05 PM
(This post was last modified: 10-12-2022, 03:08 PM by bplus.)
Yeah I was wondering if Pete was having a senior moment?
And @Pete I was wondering about this:
Code: (Select All) $IF THEN
---------Hearts
1=A
2
3
4
5
6
7
8
9
10
11=J
12=Q
... at the end of your code
As a way to code a comment without a ' block? If not, what is that doing?
b = b + ...
|
