Comments on: Euler Problem 54

By: keepITcool

keepITcool — Sun, 01 Feb 2009 22:25:00 +0000

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.

By: Hans Schraven

Hans Schraven — Sun, 01 Feb 2009 17:26:00 +0000

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)

By: keepITcool

keepITcool — Sat, 31 Jan 2009 21:44:00 +0000

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.

By: Hans Schraven

Hans Schraven — Sat, 31 Jan 2009 14:22:00 +0000

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

By: keepITcool

keepITcool — Sat, 31 Jan 2009 05:59:00 +0000

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"

By: Hans Schraven

Hans Schraven — Fri, 30 Jan 2009 15:12:00 +0000

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

By: keepITcool

keepITcool — Fri, 30 Jan 2009 04:50:00 +0000

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) & 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

By: keepITcool

keepITcool — Fri, 30 Jan 2009 01:33:00 +0000

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

By: Michael

Michael — Thu, 29 Jan 2009 23:39:00 +0000

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

By: keepITcool

keepITcool — Thu, 29 Jan 2009 21:54:00 +0000

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, "

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