Euler Problem 54

Posted on by Michael

Euler Problem 54 asks:

‘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 Answer As Long, Adder As Double, TEMP As Card
    Dim IsFlush As Boolean, IsRoyal As Boolean, IsStraight As Boolean
    Dim Is4kind As Boolean, Is3Kind As Boolean, GoFarther As Boolean
    Const text  As String = “D:/Downloads/Euler/Poker.txt”
 
    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 < = 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
            Adder = 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
               Adder = 0
               For c = 1 To 4   ‘to King-high straight flush (KQJT9)
                  If .Cards(c).Value – 1 = .Cards(c + 1).Value Then
                     IsStraight = True
                     Adder = Adder + (.Cards(c).Value * 10 ^ (-2 * c))
                     .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
               Adder = 0
               For c = 1 To 3   ‘4 of a Kind – 4 cards High (AAAAK)
                  If .Cards(c).Value = .Cards(c + 1).Value Then
                     Is4kind = True
                     Adder = Adder + (.Cards(c).Value * 10 ^ (-2 * c))
                     .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
               Adder = 0
               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
                  Adder = Adder + (.Cards(c).Value * 10 ^ (-2 * c))
                  .Value = 5 + Adder   ‘max 5.1413121109
               Next c
               GoFarther = False
            End If
 
            If GoFarther Then     ‘Straights
               Adder = 0
               For c = 1 To 4   ‘to Ace-high straight (AKQJT)
                  If .Cards(c).Value – 1 = .Cards(c + 1).Value Then
                     IsStraight = True
                     Adder = Adder + (.Cards(c).Value * 10 ^ (-2 * c))
                     .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. 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.

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

    Fill AD3 into AD4:AD1002.

    The number of hands Player 1 won is given by =COUNTIF(AD3:AD1002,”1?).

  2. 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. 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. 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]

  6. 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

      ‘poker.txt already loaded into worksheet
      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 & 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) > t Then
                If k = 1 Then
                  tv = t & tv
                Else
                  tv = Left$(tv, k – 1) & t & Mid$(tv, k)
                End If

                t = “”
                Exit For
              End If
            Next k

            tv = tv & 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) > 0 Then ‘flush at least
            k = IIf(InStr(1, VALUES, tv) > 0, 8, 5)  ‘straight/not

          ElseIf InStr(1, VALUES, tv) > 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 > 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) > hv(2) Then res = res + 1
      Next i

      Debug.Print res; Timer – dt

    End Sub

  7. 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. 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. Michael:
    in your code, specifically the Card type, why do you use Value as a byte, rather than an integer?

    thanks,

    Harry

  10. 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. 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.

    Thanks for asking.
    …mrt

  12. 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. 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. 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. 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. 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
      ‘Read Id’s (separate cells)
      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
        dBits.add bits, rslt
      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

            mProd.add prod, -dBits(bits)

          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

            mProd.add prod, rslt

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

Leave a Reply

Your email address will not be published.