10-11-2022, 05:52 AM
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 + ...