# Euler Problem 54

‘In the card game poker, a hand consists of five cards and are ranked,
‘from lowest to highest, in the following way:

‘    * High Card: Highest value card.
‘    * One Pair: Two cards of the same value.
‘    * Two Pairs: Two different pairs.
‘    * Three of a Kind: Three cards of the same value.
‘    * Straight: All cards are consecutive values.
‘    * Flush: All cards of the same suit.
‘    * Full House: Three of a kind and a pair.
‘    * Four of a Kind: Four cards of the same value.
‘    * Straight Flush: All cards are consecutive values of same suit.
‘    * Royal Flush: Ten, Jack, Queen, King, Ace, in same suit.

‘The cards are valued in the order:
‘2, 3, 4, 5, 6, 7, 8, 9, 10, Jack, Queen, King, Ace.

‘If two players have the same ranked hands then the rank made up of the
‘highest value wins; for example, a pair of eights beats a pair of fives
‘(see example 1 below). But if two ranks tie, for example, both players
‘have a pair of queens, then highest cards in each hand are compared
‘(see example 4 below); if the highest cards tie then the next highest
‘cards are compared, and so on.

‘Consider the following five hands dealt to two players:
‘Hand  Player 1            Player 2             Winner
‘1     5H 5C 6S 7S KD      2C 3S 8S 8D TD
‘      Pair of Fives       Pair of Eights       Player 2
‘2     5D 8C 9S JS AC      2C 5C 7D 8S QH
‘      Highest card Ace    Highest card Queen   Player 1
‘3     2D 9C AS AH AC      3D 6D 7D TD QD
‘      Three Aces          Flush with Diamonds  Player 2
‘4     4D 6S 9H QH QC      3D 6D 7H QD QS
‘      Pair of Queens      Pair of Queens
‘      Highest card Nine   Highest card Seven   Player 1
‘5     2H 2D 4C 4D 4S      3C 3D 3S 9S 9D
‘      Full House          Full House
‘      With Three Fours    with Three Threes    Player 1

‘The file, poker.txt, contains one-thousand random hands dealt to
‘two players. Each line of the file contains ten cards (separated
‘by a single space): the first five are Player 1’s cards and the last
‘five are Player 2’s cards. You can assume that all hands are valid
‘(no invalid characters or repeated cards), each player’s hand is in
‘no specific order, and in each hand there is a clear winner.

‘How many hands does Player 1 win?

I saw the problem as six tasks:

1. Open the file
2. Populate the hands
3. Populate the cards and assign values
4. Sort the cards to recognize the patterns
5. Score the hands
6. Compare scores and keep a running total for Player 1

I set up a User-defined Type of Card, and then a User-defined Type of Hand, which holds, natually, 5 cards, the string (display) that it came in as, plus a value to compare against the other hand. User-defined Types nicely work with the With…End With syntax construction.

Euler provides the hands as a line of the file containing both hands. I parsed the file into cards, and picked off the cards’ value and suit. I gave a Jack 11, Queen 12, King 13 and Ace 14. I sorted the cards for the purpose of scoring the hand. A Royal Flush got the absolute max of 9. The values went down by 1 until a single high card was zero, with each card of the hand getting evaluated also, to break ties. The most important card’s value was multiplied by 10^-2, the second by 10^-4, the third by 10^-6, the fourth by 10^-8, and the fifth by 10^-10. The most important card is not the highest card, but the one that makes the hand. A King-high straight flush (KQJT9) would score 8.1312111009, while 3 treys plus A2 for three-of-a-kind gets 3.0303031402. Tie breaking is built-in. My dad, who won the rent money back from the landlord playing poker, would have asked how come a Royal Flush (AKQJT and also a straight flush) isn’t 8.1413121110 (could have been) and I’d say, “Well, Dad, it just isn’t.” With that as the scoring system in mind, I passed the hand down the possible fits until it matched, and then set a GoFarther flag to false to stop work, so to speak. Finally, I compared Player One’s hand against Player 2’s, and kept tally.

The lowest possible score is 0.0705040302. That’s the worst hand (75432 of different suits) you can get. In poker, suits only count for flushes, and are never a tie breaker. Tie’s are broken by a highcard comparison, and some ties can be imagined that remain tied down through all the cards (JJ998 for example). When that happenes, the pot is split. You can’t have 4-of-a-kind, 3-of-a-kind, or fullhouse ties. Many a fullboat loses to a higher fullboat’s trio.

It ends up that Euler didn’t include any 5-high straights (Ace as low) but I put it in. The code runs in 46ms on my machine. I used LT for the left angle bracket, and GT for the right angle bracket. It is by far the longest problem by far in lines of code, attested to by many who solved it before, and it was made longer by me in time because I forgot a pattern.

Option Explicit
Option Base 1

Public Type Card
Face        As String * 2
Value       As Byte
Suit        As String * 1
End Type

Public Type Hand
Display     As String * 14
Cards(1 To 5)    As Card
Value       As Double
End Type

Sub Problem_054()
Const T     As Byte = 10
Const J     As Byte = 11
Const Q     As Byte = 12
Const K     As Byte = 13
Const A     As Byte = 14
Dim Hands(1000, 2) As Hand
Dim h       As Long   ‘for number of hands
Dim c       As Long   ‘for number of cards
Dim p       As Long   ‘for number of players
Dim i As Long, Line As String, secs As Single
Dim IsFlush As Boolean, IsRoyal As Boolean, IsStraight As Boolean
Dim Is4kind As Boolean, Is3Kind As Boolean, GoFarther As Boolean

secs = Timer

h = 1
Open text For Input As #1   ‘1000 hands or lines as: p1 p1 p1 p1 p1 p2 p2 p2 p2 p2
Do While Not EOF(1)
Line Input #1, Line
Hands(h, 1).Display = Left(Line, 14)
Hands(h, 2).Display = Right(Line, 14)
h = h + 1
Loop
Close #1

For h = 1 To 1000   ‘number of hands
For p = 1 To 2   ‘number of players
i = 1
For c = 1 To 5   ‘number of cards
With Hands(h, p)
.Cards(c).Face = Trim(Mid(.Display, i, 3))
i = i + 3
.Cards(c).Suit = Right(.Cards(c).Face, 1)
Select Case Left(.Cards(c).Face, 1)
Case Is &lt; = 9
.Cards(c).Value = CLng(Left(.Cards(c).Face, 1))
Case “T”
.Cards(c).Value = T
Case “J”
.Cards(c).Value = J
Case “Q”
.Cards(c).Value = Q
Case “K”
.Cards(c).Value = K
Case “A”
.Cards(c).Value = A
End Select
End With
Next c
Next p
Next h

For h = 1 To 1000
For p = 1 To 2
For c = 1 To 4
For i = c + 1 To 5
With Hands(h, p)
If .Cards(c).Value LT .Cards(i).Value Then   ‘5-card decending sort
TEMP = .Cards(i)
.Cards(i) = .Cards(c)
.Cards(c) = TEMP
End If
End With
Next i
Next c
Next p
Next h

For h = 1 To 1000
For p = 1 To 2
IsFlush = False
IsRoyal = False
IsStraight = False
Is4kind = False
Is3Kind = False
GoFarther = True
With Hands(h, p)
.Value = 0

For c = 1 To 5   ‘Royal (AKQJT)
If .Cards(c).Value = 15 – c Then
IsRoyal = True   ‘also straight
Else
IsRoyal = False
Exit For
End If
Next c

For c = 1 To 4   ‘Flushes
If .Cards(c).Suit = .Cards(c + 1).Suit Then
IsFlush = True
Else
IsFlush = False
Exit For
End If
Next c

If IsFlush And IsRoyal Then
.Value = 9   ‘absolute max – The Royal Flush (AKQJT)
GoFarther = False
End If

If GoFarther And IsFlush Then    ‘Straight Flushes
For c = 1 To 4   ‘to King-high straight flush (KQJT9)
If .Cards(c).Value – 1 = .Cards(c + 1).Value Then
IsStraight = True
.Value = 8 + Adder   ‘max 8.1312111009
GoFarther = False
Else
IsStraight = False
GoFarther = True
Exit For
End If
Next c
If IsStraight Then .Value = .Value + (.Cards(5).Value * (10 ^ -10))
End If

If GoFarther And IsFlush Then   ‘Ace-low straight flushes
If .Cards(1).Value = 14 Then
Adder = 1 * (10 ^ -10)
For c = 2 To 5   ‘5-high straight flush (5432A)
If .Cards(c).Value = 7 – c Then
IsStraight = True
Adder = Adder + (.Cards(c).Value * 10 ^ (-2 * (c – 1)))
.Value = 8 + Adder   ‘max 8.0504030201
GoFarther = False
Else
IsStraight = False
GoFarther = True
Exit For
End If
Next c
End If
End If

If GoFarther Then
For c = 1 To 3   ‘4 of a Kind – 4 cards High (AAAAK)
If .Cards(c).Value = .Cards(c + 1).Value Then
Is4kind = True
.Value = 7 + Adder   ‘max 7.1414141413
GoFarther = False
Else
Is4kind = False
GoFarther = True
Exit For
End If
Next c
If Is4kind Then .Value = .Value + (.Cards(4).Value * (10 ^ -8))
If Is4kind Then .Value = .Value + (.Cards(5).Value * (10 ^ -10))
End If

If GoFarther Then
For c = 2 To 4   ‘4 of a kind – 4 cards low (AKKKK)
If .Cards(c).Value = .Cards(c + 1).Value Then
Is4kind = True
Adder = Adder + (.Cards(c).Value * 10 ^ (-2 * (c – 1)))
.Value = 7 + Adder   ‘max 7.1313131314
GoFarther = False
Else
Is4kind = False
GoFarther = True
Exit For
End If
Next c
If Is4kind Then .Value = .Value + (.Cards(5).Value * (10 ^ -8))
If Is4kind Then .Value = .Value + (.Cards(1).Value * (10 ^ -10))
End If

If GoFarther Then   ‘Full House tie goes to higher trio
If .Cards(1).Value = .Cards(2).Value And .Cards(2).Value = .Cards(3).Value Then
If .Cards(4).Value = .Cards(5).Value Then
.Value = 6 + (.Cards(1).Value * (10 ^ -2))   ‘max 6.14 (AAAKK)
GoFarther = False
End If
ElseIf .Cards(3).Value = .Cards(4).Value And .Cards(4).Value = .Cards(5).Value Then
If .Cards(1).Value = .Cards(2).Value Then
.Value = 6 + (.Cards(3).Value * (10 ^ -2))   ‘max 6.13 (AAKKK)
GoFarther = False
End If
End If
End If

If GoFarther And IsFlush Then   ‘Flushes (AKQJ9)
For c = 1 To 5
.Value = 5 + Adder   ‘max 5.1413121109
Next c
GoFarther = False
End If

If GoFarther Then     ‘Straights
For c = 1 To 4   ‘to Ace-high straight (AKQJT)
If .Cards(c).Value – 1 = .Cards(c + 1).Value Then
IsStraight = True
.Value = 4 + Adder   ‘max 4.1413121110
GoFarther = False
Else
IsStraight = False
GoFarther = True
Exit For
End If

Posted in Uncategorized

## 22 thoughts on “Euler Problem 54”

1. fzz says:

No need for VBA. This can be solved in Excel itself.

Open poker.txt in Excel, parsing into columns, so the text file starts off filling A1:J1000. Insert blank rows in rows 1 and 2, so the cards now fill A3:J1002.

Enter the following labels.

S1: High Card
R1: Pairs
Q1: 3oaK
P1: Straight
O1: Flush
N1: Full House
M1: 4oaK
L1: Straight Flush

Note that royal flushes are just a special case of straight flushes.

Enter the following formulas.

S3 [high card]:
{=SUM(LARGE(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”),{1;2;3;4;5})*0.01^{1;2;3;4;5})}

R3 [pairs – 1 or 2]:
{=S3*100^SUMPRODUCT((FREQUENCY(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”),
{1;2;3;4;5;6;7;8;9;10;11;12;13})=2))}

Q3 [3oaK]:
{=S3*IF(OR(FREQUENCY(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”),
{1;2;3;4;5;6;7;8;9;10;11;12;13})=3),100^3,1)}

P3 [Straight]:
{=S3*IF(VAR(FIND(LEFT(\$A3:\$E3,1),”A23456789TJQKA”))=2.5,100^4,1)}

O3 [Flush]:
=S3*IF(OR(COUNTIF(\$A3:\$E3,{“?S”;”?H”;”?D”;”?C”})=5),100^5,1)

N3 [Full House]:
=S3*IF(AND(Q3>1,R3>1),100^6,1)

M3 [4oaK]:
{=S3*IF(OR(FREQUENCY(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”),
{1;2;3;4;5;6;7;8;9;10;11;12;13})=4),100^7,1)}

L3 [Straight Flush]:
=S3*IF(AND(O3>1,P3>1),100^8,1)

Note that the string “A23456789TJQKA” for straights is intentional since many places will allow ace-low (A-2-3-4-5) straights. When this isn’t allowed, change the string to “23456789TJQKA”.

Fill L3:S3 into L4:S1002. Copy L3:S3 into U3:AB3. With U3:AB3 selected, Edit-Replace \$A3:\$E3 with \$F3:\$J3. Fill U3:AB3 into U4:AB1002.

Enter the following formula.

=SIGN(MAX(L3:S3)-MAX(U3:AB3))

2. fzz says:

Screwed up the straights formula. If ace-low straights are allowed, need a separate test for ace-high straights.

P3 [Straight]:
{=S3*IF(OR(VAR(FIND(LEFT(\$A3:\$E3,1),”A23456789TJQK”))=2.5,
VAR(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”))=2.5),100^4,1)}

3. Michael says:

fzz –

It’s there…above the Ace-low test. Test high straights first, if found, GoFather is false, otherwise next test is for A5432.

…mrt

4. Doug Jenkins says:

Michael – yes I meant this one, not 53.

This is the first one where I have seen someone admit to using Excel in the discussion, without feeling the need to apologise for it. Also I note that this has a comparatively low number of correct responses posted.

I think it’s an ideal application for a combined UDF and spreadsheet approach.

I wrote a UDF to evaluate each hand (see below), then copied the function down, and counted the number of rows where 1 had the higher value.

The basis of the evaluation was:

2-14High Card: Highest value card.
22-34One Pair: Two cards of the same value.
42-54Two Pairs: Two different pairs.
62-74Three of a Kind: Three cards of the same value.
82-94Straight: All cards are consecutive values.
102-114Flush: All cards of the same suit.
122-134Full House: Three of a kind and a pair.
142-154Four of a Kind: Four cards of the same value.
162-174Straight Flush: All cards are consecutive values of same suit.

To separate ties I added the maximum card value divided by 20 to this value.

I didn’t allow low ace straights; the problem said that the ace was the highest ranking card, so I took that literally, and it gave the right answer.

It takes about 5 seconds to evaluate the 2000 UDFs in XL2007. Earlier versions would probably be quicker. It would be much quicker to do the whole thing in VBA, working on an imported array of the whole data set, rather than importing one line at a time, but doing it as I did made de-bugging much easier.

Here’s the code:

``` Function HandVal(Hand As Variant) As Variant Dim HandA(1 To 14, 1 To 4) As Long, i As Long, Card As String, Val As String, Suit As String Dim Scount(1 To 4) As Long, Vcount(1 To 14) As Long, Seq As Long, SSeq(1 To 4) As Long Dim SumProd As Long, MaxVcount As Long, MaxVcount2 As Long, MaxScount As Long Dim j As Long, MaxVal As Long, MaxSeq As Long, MaxVVAl As Long, MaxVVal2 As Long```

``` Hand = Hand.Value For i = 1 To 5 Card = Hand(1, i) Val = Left(Card, 1) Suit = Right(Card, 1) Select Case Val Case Is = "T" Val = 10 Case Is = "J" Val = 11 Case Is = "Q" Val = 12 Case Is = "K" Val = 13 Case Is = "A" Val = 14 End Select Select Case Suit Case Is = "C" Suit = 1 Case Is = "D" Suit = 2 Case Is = "H" Suit = 3 Case Is = "S" Suit = 4 End Select HandA(Val, Suit) = 1 Next i For i = 2 To 14 For j = 1 To 4 Vcount(i) = Vcount(i) + HandA(i, j) Next j If Vcount(i) >= MaxVcount Then MaxVcount2 = MaxVcount MaxVVal2 = MaxVVAl MaxVcount = Vcount(i) MaxVVAl = i End If If Vcount(i) > 0 Then MaxVal = i Next i For i = 1 To 4 For j = 2 To 14 Scount(i) = Scount(i) + HandA(j, i) Next j If Scount(i) > MaxScount Then MaxScount = Scount(i) End If Next i Seq = 0 For i = 2 To 14 If Vcount(i) > 0 Then Seq = Seq + 1 If Seq > MaxSeq Then MaxSeq = Seq Else Seq = 0 End If Next i If MaxScount = 5 And MaxSeq = 5 Then HandVal = 160 + MaxVal ElseIf MaxVcount = 4 Then HandVal = 140 + MaxVVAl + MaxVal / 20 ElseIf MaxVcount = 3 And MaxVcount2 = 2 Then HandVal = 120 + MaxVVAl + MaxVal / 20 ElseIf MaxScount = 5 Then HandVal = 100 + MaxVal ElseIf MaxSeq = 5 Then HandVal = 80 + MaxVal ElseIf MaxVcount = 3 Then HandVal = 60 + MaxVVAl + MaxVal / 20 ElseIf MaxVcount = 2 And MaxVcount2 = 2 Then HandVal = 40 + MaxVVAl + MaxVal / 20 ElseIf MaxVcount = 2 Then HandVal = 20 + MaxVVAl + MaxVal / 20 Else: HandVal = MaxVal End If End Function [VB] ```

5. Doug Jenkins says:

I just re-wrote the UDF to operate on all 1000 rows, and return an array with a valuation of each hand. It’s now almost instantaneous.

6. fzz says:

My first reply is still awaiting moderation. It’s fairly long.

I broke down and came up with a VBA solution as well.

Sub euler54fzz()
Const VALUES As String = ” 23456789TJQKA 2345A”
Const SUITS As String = “SSSSS HHHHH DDDDD CCCCC”
Const FACTOR As Double = 16#

Dim h(1 To 2) As Variant, hv(1 To 2) As Double
Dim t As String, ts As String, tv As String
Dim i As Long, j As Long, k As Long, p As Long
Dim res As Long, dt As Double

dt = Timer

h(1) = Worksheets(“euler54”).Range(“A3:E1002”).Value2
h(2) = Worksheets(“euler54”).Range(“F3:J1002”).Value2

For i = 1 To 1000
For p = 1 To 2

‘collect ordered card values and suits
ts = “”
tv = “”

For j = 1 To 5
t = h(p)(i, j)
ts = ts &amp; Right\$(t, 1)

t = Chr(InStr(1, VALUES, Left\$(t, 1)))

‘bubble sort card values
For k = 1 To j – 1
If Mid(tv, k, 1) &gt; t Then
If k = 1 Then
tv = t &amp; tv
Else
tv = Left\$(tv, k – 1) &amp; t &amp; Mid\$(tv, k)
End If

t = “”
Exit For
End If
Next k

tv = tv &amp; t

Next j

‘calc total hand values and transform tv (only for debugging and ace-low straights)
hv(p) = 0
For j = 1 To 5
hv(p) = (hv(p) + Asc(Mid\$(tv, j, 1))) / FACTOR
Mid\$(tv, j, 1) = Mid(VALUES, Asc(Mid\$(tv, j, 1)), 1)
Next j

‘check hand type
k = 0

If InStr(1, SUITS, ts) &gt; 0 Then ‘flush at least
k = IIf(InStr(1, VALUES, tv) &gt; 0, 8, 5)  ‘straight/not

ElseIf InStr(1, VALUES, tv) &gt; 0 Then ‘straight
k = 4

‘special handling for ace-low straights
If tv = “2345A” Then hv(p) = hv(p) – 13 / FACTOR

ElseIf Mid\$(tv, 1, 1) = Mid\$(tv, 4, 1) _
Or Mid\$(tv, 2, 1) = Mid\$(tv, 5, 1) Then ‘four of a kind
k = 7

Else ‘check full house, 3 of a kind, pairs
For j = 1 To 3
If Mid\$(tv, j, 1) = Mid\$(tv, j + 2, 1) Then
k = IIf(k &gt; 0, 6, 3) ‘full house/3 of a kind
j = j + 2

ElseIf Mid\$(tv, j, 1) = Mid\$(tv, j + 1, 1) Then
k = IIf(k = 3, 6, k + 1) ‘full house/pair
j = j + 1

End If
Next j

If j = 4 And Mid\$(tv, 4, 1) = Mid\$(tv, 5, 1) Then _
k = IIf(k = 3, 6, k + 1) ‘full house/pair

End If

hv(p) = hv(p) * FACTOR ^ k

Next p

If hv(1) &gt; hv(2) Then res = res + 1
Next i

Debug.Print res; Timer – dt

End Sub

7. fzz says:

Now I have two replies awaiting moderation. The first shows a complete formulas-only approach, the second a VBA macro.

Tangential: it’s always a good idea in draw poker to draw for a flush when dealt 4 cards in the same suit. Better odds than drawing for an outside straight. One of the wonderful quirks of draw poker.

8. Michael says:

fzz –

Now I better understand you comment at the top which showed up first…

I never knew that tangential topic, though I bet my Dad did. He was orders better the poker player than me. Certainly not what you’d think, there being 9 cards that complete the flush, and 16 that complete the straight (top or bottom fill). However, straights being more likely than flushes, near straights are I guess more likely than near flushes, and so there are more of them in the competition. So those 16 cards get eaten up… And you’re sitting there with the near flush…

It’s still not going to make me a great poker player ;-)

…mrt

9. Harry says:

Michael:
in your code, specifically the Card type, why do you use Value as a byte, rather than an integer?

thanks,

Harry

10. fzz says:

There are only *8* cards that fill an outside straight. If you had 6, 7, 8 and 9, there are only four 5s and only four 10s that fill the straight.

Anyway, my formulas don’t work. They ranked cards in face value order all the time rather than promoting the values of pairs, 3oaks, 4oaks. So 2H 2C 4D 5S AS would rank higher than 10C JC QH KH KS.

I’ve fixed that. The following single formula ranks the hand in A3:E3.

=SUM(INT(LARGE(LOOKUP(FREQUENCY(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”),
{1;2;3;4;5;6;7;8;9;10;11;12;13}),{1,2,3,4,5}-1,16^{-5,0,1,2,6})*
1;2;3;4;5;6;7;8;9;10;11;12;13;0},{1,2,3,4,5}))*16^(5-{1,2,3,4,5}))
*IF(AND(LARGE(FREQUENCY(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”),
{1;2;3;4;5;6;7;8;9;10;11;12;13}),{1,2})={3,2}),16^3+N(“full house”),1)
*IF(OR(COUNTIF(\$A3:\$E3,{“?S”,”?H”,”?D”,”?C”})=5),16^4+N(“flush”),1)
*IF(OR(VAR(FIND(LEFT(\$A3:\$E3,1),”23456789TJQKA”))=2.5,
VAR(FIND(LEFT(\$A3:\$E3,1),”A23456789TJQK”))=2.5),16^3+N(“straight”),1)

And if you define the following names

Cards =”23456789TJQKA”
CardsA ={1;2;3;4;5;6;7;8;9;10;11;12;13}
CardsB ={1;2;3;4;5;6;7;8;9;10;11;12;13;0}
Hand ={1,2,3,4,5}

you could shorten the formula to

=SUM(INT(LARGE(LOOKUP(FREQUENCY(FIND(LEFT(\$A3:\$E3,1),Cards),CardsA),
Hand-1,16^{-5,0,1,2,6})*CardsB,Hand))*16^(5-Hand))
*IF(AND(LARGE(FREQUENCY(FIND(LEFT(\$A3:\$E3,1),Cards),CardsA),{1,2})={3,2}),
16^3+N(“full house”),1)
*IF(OR(COUNTIF(\$A3:\$E3,{“?S”,”?H”,”?D”,”?C”})=5),16^4+N(“flush”),1)
*IF(OR(VAR(FIND(LEFT(\$A3:\$E3,1),Cards))=2.5,
VAR(FIND(LEFT(\$A3:\$E3,1),”A”&Cards))=2.5),16^3+N(“straight”),1)

My macro was also wrong since it duplicated the functionality of my original formulas. I may or may not fix it.

11. Michael says:

Hi Harry – basically because I knew the card’s value would fit in a byte, and I knew I would have 5 cards per hand, 1000 hands per player, and two players. That’s 10,000 card values, and I wanted to be frugal. That’s probably a false concern, because the spreadsheet solutions certainly don’t worry about filling up 10000 cells. But that was my thoughtto save memory storage.

I’ve stopped use type integer for variables. There’s research out there, and here in DDoE, that using longs are faster than integers because of under-the-hood machinations that Excel does to make int’s out of longs to start with. I don’t know where bytes fall on the speed curve.

…mrt

12. Michael says:

fzz – four at the top and four at the bottom, that’s four-squared, and that’s 16 :-) or at least it was yesterday.

Case in point of why I let Excel do the math, and I lose money at poker.

…mrt

13. keepITcool says:

Convert ID’s (AS QH etc) to (long) integers.
The LoByte contains a prime from 2 to 41 to represent the rank.
The HiByte (of Loword) is a mask for the suit of the card.
The HiWord can be used for a mask of the rank, but I found it confusing.
xxxAKQJT98765432 xxxxDHSDxxPPPPPP = long(4bytes)

First prep a dictionary for all 6175 possible products 4888 Combinations (score>0) and 1287 Uniques (score aRes(1) Then win = win + 1
Next h
Next x
t = Timer – t
Debug.Print win, t, “<Num”

End Sub
Sub ScoreNums(res&, n0&, n1&, n2&, n3&, n4&)
Dim p&
p = (n0 And Not &HFF00) * (n1 And Not &HFF00) * (n2 And Not &HFF00) * (n3 And Not &HFF00) * (n4 And Not &HFF00)
res = dProd(p)
If res < 0 Then
If n0 And n1 And n2 And n3 And n4 And &HF00 Then
If -res h Then
k = h
h = i(n)
End If
Next
HighKick = h * 100 + k
End Function

14. Michael says:

kIc – looks like the the HTML bug has bitten you. If you have a paired set of angle brackets in your text- left angle followed by right angle, no matter how separated, the software parses that as an HTML tag, and doesn’t display it.

We’ve gotten used to such workarounds as LT or LTE or GT or GTE and some others to convey the thought.

I’ve never used a dictionary, VB-wise at least ;-), and want to see how that goes.

…mrt

15. keepITcool says:

Code to complex and Me too lazy for rewrite and ten trial posts. Whay can’t I post some PRE formatted code?
Just for the sake of some fancy highlighting. If interested drop me mail. keepITcool AT chello DOT nl

16. keepITcool says:

removed type declaration chars and hex codes.cleaned up code.inserted GT’s LT’s and NOTEQUAL
pressed [submit] and hope for the best.

Option Explicit

Const kSF  As Long = 80000    ‘StraightFlush
Const k4K  As Long = 70000    ‘FourKind
Const kFH  As Long = 60000    ‘FullHouse
Const kFL  As Long = 50000    ‘Flush
Const kST  As Long = 40000    ‘Straight
Const k3K  As Long = 30000    ‘ThreeKind
Const k2P  As Long = 20000    ‘TwoPair
Const k2K  As Long = 10000    ‘OnePair
Const k1K  As Long = 0

Const HFF   As Long = 255     ‘0000 0000 1111 1111: 255
Const HFF00 As Long = 65280   ‘1111 1111 0000 0000: 65535-255=65280
Const SUITS As String = “CDHS”
Const RANKS As String = “23456789TJQKA”

‘Reference nneded for Microsoft Scripting Runtime
Dim mNums As Dictionary
Dim mProd As Dictionary

Sub euler54_kic()
Dim list As Variant
Dim cube(999, 1, 4) As Long
Dim rslt(1) As Long, wins As Long
Dim h As Long, p As Long, c As Long
Dim t As Single, x As Long

t = Timer

‘Prepare Cache
PrepScores
list = [p54!cardsIDS]

‘Convert id’s to numbers
For h = 0 To UBound(cube, 1)
For p = 0 To UBound(cube, 2)
For c = 0 To 4
cube(h, p, c) = mNums(list(h + 1, p * 5 + c + 1))
Next
Next p
Next h

‘Score numbers (1000 loops for effective timing)
For x = 0 To 999
wins = 0
For h = 0 To UBound(cube, 1)
For p = 0 To UBound(cube, 2)
ScoreNums rslt(p), cube(h, p, 0), cube(h, p, 1), cube(h, p, 2), cube(h, p, 3), cube(h, p, 4)
Next p
If rslt(0) GT rslt(1) Then wins = wins + 1
Next h
Next x
t = Timer – t
Debug.Print wins, t, “Euler54”

End Sub
Sub ScoreNums(rslt As Long, n0 As Long, n1 As Long, n2 As Long, n3 As Long, n4 As Long)
Dim p As Long
‘Product of numbers (use LoByte=Prime)
p = (n0 And HFF) * (n1 And HFF) * (n2 And HFF) * (n3 And HFF) * (n4 And HFF)
‘Find in dictionary
rslt = mProd(p)
If rslt LT 0 Then
‘Flush?
If n0 And n1 And n2 And n3 And n4 And HFF00 Then
‘Yes! MixUps become Flushes and Straights become StraightFlushes
If -rslt LT kST Then rslt = kFL – rslt Else rslt = kSF – kST – rslt
Else
‘No. Highcard is all
rslt = -rslt
End If
End If
End Sub

Sub PrepScores()
Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long
Dim s As Long, r As Long

Dim bits As Long, prod As Long, rslt As Long
Dim rank(0 To 12) As Long
Dim sums(1 To 4) As Long
Dim high(1 To 4) As Long
Dim kick(1 To 4) As Long
Dim prim As Variant
Dim dBits As Dictionary

prim = Array(2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41)

Set mNums = New Dictionary
For s = 0 To 3
For r = 0 To 12
mNums.add Mid\$(RANKS, r + 1, 1) &amp; Mid\$(SUITS, s + 1, 1), (2 ^ s) * 256 + prim(r)
Next
Next

‘All single suit combinations
Set dBits = New Dictionary
For i1 = 0 To 12
For i2 = i1 + 1 To 12
For i3 = i2 + 1 To 12
For i4 = i3 + 1 To 12
For i5 = i4 + 1 To 12
bits = 2 ^ i1 + 2 ^ i2 + 2 ^ i3 + 2 ^ i4 + 2 ^ i5
Select Case bits
Case 4111: rslt = kST + 300    ‘Wheel
Case 31: rslt = kST + 400
Case 62: rslt = kST + 500
Case 124: rslt = kST + 600
Case 248: rslt = kST + 700
Case 496: rslt = kST + 800
Case 992: rslt = kST + 900
Case 1984: rslt = kST + 1000
Case 3968: rslt = kST + 1100
Case 7936: rslt = kST + 1200
Case Else: rslt = k1K + HighKick(i1, i2, i3, i4, i5)
End Select
Next: Next: Next: Next: Next

‘All other hands
Set mProd = New Dictionary
For i1 = 0 To 12
For i2 = i1 To 12
For i3 = i2 To 12
For i4 = i3 To 12
For i5 = i4 To 12

If i5 NOTEQUAL i1 Then
bits = 2 ^ i1 + 2 ^ i2 + 2 ^ i3 + 2 ^ i4 + 2 ^ i5
prod = prim(i1) * prim(i2) * prim(i3) * prim(i4) * prim(i5)

If dBits.Exists(bits) Then

Else
‘How many of each rank
Erase rank, sums, high, kick
rank(i1) = rank(i1) + 1
rank(i2) = rank(i2) + 1
rank(i3) = rank(i3) + 1
rank(i4) = rank(i4) + 1
rank(i5) = rank(i5) + 1
For r = 0 To 12
‘Nifty calculating!
If rank(r) Then
sums(rank(r)) = sums(rank(r)) + 1
kick(rank(r)) = high(rank(r))
high(rank(r)) = r
End If
Next
Select Case True
Case sums(4) = 1 And sums(1) = 1: rslt = k4K + high(4) * 100 + high(1)
Case sums(3) = 1 And sums(2) = 1: rslt = kFH + high(3) * 100 + high(2)
Case sums(3) = 1 And sums(1) = 2: rslt = k3K + high(3) * 100 + high(1)
Case sums(2) = 2 And sums(1) = 1: rslt = k2P + high(2) * 100 + kick(2)
Case sums(2) = 1 And sums(1) = 3: rslt = k2K + high(2) * 100 + high(1)
End Select

End If

End If

Next: Next: Next: Next: Next

End Sub

Function HighKick(ParamArray i()) As Long
‘Finds high card and kicker
Dim h As Long, k As Long, n As Long
For n = 0 To 4
If i(n) GT h Then
k = h
h = i(n)
End If
Next
HighKick = h * 100 + k
End Function

17. Hans Schraven says:

Maybe some compacter code will do as well (at least it generates the correct answer).

Sub euler54()
Dim x As Long, j As Long, jj As Long, c5 As Long

Open “E:OFpoker.txt” For Input As #1
sb = Filter(Split(Replace(Replace(Replace(Replace(Replace(Input(LOF(1), #1), “T”, “10”), “J”, “11”), “Q”, “12”), “K”, “13”), “A”, “14”), vbCr &amp; Chr(10)), ” “)
Close #1

For j = 0 To UBound(sb)
ReDim sp(15)                                   ‘   first hand matrix
ReDim sr(15)                                   ‘   second hand matrix

st = Split(sb(j))
For jj = 0 To 4                                ‘       sort and count per cardvalue
sp(15) = IIf(jj = 0, Right(st(jj), 1), IIf(sp(15) = Right(st(jj), 1), sp(15), “”))  ‘  same kind
x = Val(st(jj))
sp(x) = (sp(x) 100 + 1) * (100 + x) + Choose(sp(x) 100 + 1, 0, 0, 100, 0, 300)   ‘ first hand sort and count
sr(15) = IIf(jj = 0, Right(st(jj + 5), 1), IIf(sr(15) = Right(st(jj + 5), 1), sr(15), “”))
n = Val(st(jj + 5))
sr(n) = (sr(n) 100 + 1) * (100 + n) + Choose(sr(n) 100 + 1, 0, 0, 100, 0, 300)   ‘  second hand sort and count
st(jj) = 0
Next

For jj = 1 To 2                                                         ‘  scoring first and second hand
c2 = WorksheetFunction.Max(Choose(jj, sp, sr))
c3 = Format(Val(Join(Choose(jj, sp, sr), “”)))
c4 = Len(c3)

If InStr(Trim(Left(Join(Choose(jj, sp, sr)), Len(Join(Choose(jj, sp, sr))) – 1)), ”  “) = 0 And c4 = 15 Then st(jj) = 500 + (c2 Mod 100)    ‘     straight (5 consecutive)
If c2 100 = 2 And c4 = 9 Then st(jj) = 300 + (c2 Mod 100)   ‘       2 pairs
If c2 100 = 4 And c4 = 6 Then st(jj) = 700 + (c2 Mod 100)     ‘       full house
If Choose(jj, sp(15), sr(15)) ISNOT. “” Then st(jj) = 600 + (c2 Mod 100) + IIf(st(jj) 100 = 5, 300, 0) + IIf(InStr(c3, “110111112113114”) GT. 0, 100, 0)  ‘ flush, straight flush and royal flush
If st(jj) = 0 Then st(jj) = c2                                   ‘  high card, 1 pair, three of a kind and flush
Next
Do While st(1) = st(2) And Replace(Join(sp, “”), st(1), “”) ISNOT. “”  ‘      solve ties
st(1) = UBound(Split(RTrim(Replace(Join(sp), st(1), “”))))
st(2) = UBound(Split(RTrim(Replace(Join(sr), st(2), “”))))
Loop
If Val(st(1)) GT. Val(st(2)) Then c5 = c5 + 1
Next
End Sub

18. keepITcool says:

Hans, I grant you it’s compact, but too slow for my liking. My goal was speed: 1000 loops in 1,5 secs (yours takes 1,5 minutes)
P.S. I’ve modified my code to solve “ties”

19. Hans Schraven says:

KeepITcool

You must be kidding. The responses I get vary between 1,39 and 2,4 seconds. Your computer must be to cool, because these values were obtained on a Pentium II, 350Mhz system.
I made some improvements (see below)

Sub euler54()
Dim t As Long, n As Long, j As Long, jj As Long, c0 As String, c5 As Long, c2 As Long

t = Timer
Open “E:OFpoker.txt” For Input As #1
c0 = Input(LOF(1), #1)
Close #1
sb = Split(“T|J|Q|K|A|10|11|12|13|14”, “|”)
For j = 0 To 4
c0 = Replace(c0, sb(j), sb(j + 5))
Next
sb = Filter(Split(c0, vbCr &amp; Chr(10)), ” “)

For j = 0 To UBound(sb)
ReDim sp(15)                                   ‘   first hand matrix
ReDim sr(15)                                   ‘   second hand matrix

st = Split(sb(j))
For jj = 0 To 4                                               ‘       sort and count per cardvalue
sp(15) = IIf(jj = 0, Right(st(jj), 1), IIf(sp(15) = Right(st(jj), 1), sp(15), “”))
x = Val(st(jj))
sp(x) = (sp(x) 100 + 1) * (100 + x) + Choose(sp(x) 100 + 1, 0, 0, 100, 0, 300)
sr(15) = IIf(jj = 0, Right(st(jj + 5), 1), IIf(sr(15) = Right(st(jj + 5), 1), sr(15), “”))
n = Val(st(jj + 5))
sr(n) = (sr(n) 100 + 1) * (100 + n) + Choose(sr(n) 100 + 1, 0, 0, 100, 0, 300)
st(jj) = 0
Next

For jj = 1 To 2                                       ‘  scoring first and second hand
c2 = WorksheetFunction.Max(Choose(jj, sp, sr))

Select Case Len(Format(Val(Join(Choose(jj, sp, sr), “”))))
Case 6
If c2 100 = 4 Then st(jj) = 700 + (c2 Mod 100)
Case 9
If c2 100 = 2 Then st(jj) = 300 + (c2 Mod 100)
Case 15
If InStr(Trim(Left(Join(Choose(jj, sp, sr)), Len(Join(Choose(jj, sp, sr))) – 1)), ”  “) = 0 Then st(jj) = 500 + (c2 Mod 100)
End Select

If Choose(jj, sp(15), sr(15)) .ISNOT. “” Then st(jj) = 600 + (c2 Mod 100) + IIf(st(jj) 100 = 5, 300 + IIf(Choose(jj, sp(14), sr(14)) = “114”, 100, 0), 0) ‘ flush, straight flush and royal flush
If st(jj) = 0 Then st(jj) = c2                         ‘  high card, 1 pair, three of a kind and flush
Next

Do While st(1) = st(2) And Replace(Join(sp, “”), st(1), “”) .ISNOT. “”            ‘      solve ties
st(1) = UBound(Split(RTrim(Replace(Join(sp), st(1), “”))))
st(2) = UBound(Split(RTrim(Replace(Join(sr), st(2), “”))))
Loop
If Val(st(1)) .GT. Val(st(2)) Then c5 = c5 + 1
Next
End Sub

20. keepITcool says:

Be sure to dim T as single!.. Your Proc as is: 0,09375secs. ReadOnce then run 1000×1000×2=> 87secs.
I’ve got my code down to 1.08secs. So you’ve still a factor 80 to go :-)
IIf and Choose are compact but (very) slow… Plus all the string stuff (Join/Split/Replace) requires time.
With strings I really noticed a change when I bought my PC 2 years ago. DuoCore 2.6GHz 2GB DDR2@400Mhz)

My next step is evaluate hands during games of Hold’m… mucho more complex.

21. Hans Schraven says:

KeepITkool: I have to disappoint you. Your code gives the wrong answer and is, tested on the same system as my code, 10 to 15 times slower (22 seconds) than mine (1,4 seconds).
Besides I wouldn’t rely on your arithmetic ‘1000×1000×2=> 87secs’, because it only runs 1000 times; that’s all. I’d say: let the timer do the counting.
So there is still a long way to go compressing the code (220 lines compared to 40) and speeding up the code (from 22 seconds to 1,4)

22. keepITcool says:

Hans.. LOL. When finetuning code I just loop it 1000 times so I can get a reliable timing. Why do you think x goes from 0 to 999? It’s because timer can’t handle anything faster than 1/64th of a second. Try my code for x= 0 to 0. Even on PIII it’ll take < 0.0625 (4/64)secs.

Posting code? Use <pre> tags for VBA and <code> tags for inline.