Euler Problem 62 asks:
The cube, 41063625 (345^3), can be permuted to produce two other cubes: 56623104 (384^3) and 66430125 (405^3). In fact, 41063625 is the smallest cube which has exactly three permutations of its digits which are also cube.
Find the smallest cube for which exactly five permutations of its digits are cube.
Having discovered how to find out if an item is in, or not in, a collection, I have been using collections more and more in the Euler problems. I do this in preference over an array, which requires a loop to find if you have membership, and presents size issues if you really don’t know how many elements you will have. Collections are open ended. All that said, in this problem, I used both. I used a collection of cubes with a key of the sorted string of item (i-cubed), and in the parallel array I kept a counter. Every time the sorted string came around again, indicating a permutation, I retrieved the first occurrence by using that key, and incremented the array counter (at item^(1/3)) associated with that first occurrence. In the end, I just looped through the array, looking for a count of 5. The cube of that index is the answer. I used two functions, IsIn() and SortString(), and guessed at the bounds for the cubes of interest as being between 1000 and 10000. I used currency to be able to hold (10^4)^3)).
Dim i As Long
Dim Answer As Currency, T As Single
Dim Cubes As New Collection
Dim Cube(1000 To 10000) As Long
Dim Item As Currency, Key As String
T = Timer
For i = 1000 To 10000 ‘ a guess
Key = SortString(CStr(i ^ 3), False)
If Not IsIn(Cubes, Key) Then ‘ add it
Item = i ^ 3
Cubes.Add Item:=Item, Key:=Key
Cube(i) = 1 ‘ add counter
Else ‘ retrieve it
Item = Cubes.Item(Key)
Cube(Item ^ (1 / 3)) = Cube(Item ^ (1 / 3)) + 1 ‘ increment counter
End If
Next i
For i = 1000 To 10000
If Cube(i) = 5 Then
Answer = i ^ 3
Exit For
End If
Next i
Debug.Print Answer; ” Time:”; Timer – T
End Sub
Function IsIn(Col As Collection, Key As String) As Boolean
Dim errNum As Long, TEMP As Variant
errNum = 0
Err.Clear
On Error Resume Next
TEMP = Col.Item(Key)
errNum = CLng(Err.Number)
On Error GoTo 0
If errNum = 5 Then ‘IsIn = False
Exit Function
End If
IsIn = True ‘errNums 0 , 438
End Function
Function SortString(ByVal str, Optional Up) As String
Dim i As Long
Dim j As Long
Dim TEMP As String * 1
If IsMissing(Up) Then Up = True
j = 1
For i = Len(str) – 1 To 1 Step -1
str = Left(str, 2 * j – 1) & Chr(32) & Right(str, i)
j = j + 1
Next i
str = Split(str)
If Up Then ‘Ascending
For i = LBound(str) To UBound(str) – 1
For j = i + 1 To UBound(str)
If str(i) > str(j) Then
TEMP = str(j)
str(j) = str(i)
str(i) = TEMP
End If
Next j
Next i
Else ‘Descending
For i = LBound(str) To UBound(str) – 1
For j = i + 1 To UBound(str)
If str(i) < str(j) Then
TEMP = str(j)
str(j) = str(i)
str(i) = TEMP
End If
Next j
Next i
End If
For i = LBound(str) To UBound(str)
SortString = SortString & str(i)
Next i
End Function
The code runs in under .6 seconds. There are the usual angle bracket substitutions above.
…mrt
Another approach is to take each cube and count the number of occurrences of each digit, 0 to 9, returning the result as a string, first character is the count of zeros, second for the ones etc. Then store the digit keys in an array along with the roots. My solution uses the worksheet sort to order array members by the digit count key and then returns the sorted values to the array. A simple search then locates runs of 5 identical keys, keeping track of the smallest root. It all runs in just under 0.47 seconds.
Dim Cubes As Variant
Dim i As Long
Dim val As String
Dim k As Integer
Dim T As Single
Dim minCube As Long
Dim minCubeIndex As Integer
Dim count As Integer
T = Timer
ReDim Cubes(1000 To 10000, 1 To 2)
For i = 1000 To 10000
Cubes(i, 1) = i
Cubes(i, 2) = DigCountCubes(i)
Next i
Sheets(1).Range(“A1:B9001”).Value = Cubes
ActiveWorkbook.Worksheets(“Sheet1”).Sort.SortFields.Add Key:=Range(“B1:B9001” _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(“Sheet1”).Sort
.SetRange Range(“A1:B9001”)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Cubes = Sheets(1).Range(“A1:B9001”).Value ‘Resets indexing of Cubes to 1 to 9001
count = 0
minCube = 10000
For i = 2 To 9001
If Cubes(i, 2) = Cubes(i – 1, 2) Then
count = count + 1
Else: count = 0
End If
If count = 4 Then ‘sequence of 5 cubes identical
If Cubes(i – 4, 1) < minCube Then ‘sort sets first of the five cube roots to be smallest number
minCube = Cubes(i – 4, 1)
minCubeIndex = i – 4
End If
End If
Next i
For k = 0 To 4
Sheets(1).Cells(k + 1, 3).Value = Cubes(minCubeIndex + k, 1)
Next k
Debug.Print ” Time:”; Timer – T
End Sub
Function DigCountCubes(x As Long) As String ‘Accepts a long as argument and returns a string where the first character
‘is a count of the number of zeros in the long, the second is the count of the number of ones, etc
‘counts greater than 10 are returned as letters
Dim Cube As Currency
Dim cubeStr As String
Dim i, k, count As Integer
Dim temp As String
Dim dig As String
Cube = x ^ 3
cubeStr = CStr(Cube)
temp = “”
For k = 0 To 9
dig = CStr(k)
count = 0
For i = 1 To Len(cubeStr)
If Mid(cubeStr, i, 1) = dig Then
count = count + 1
End If
Next i
If count < 10 Then
temp = temp + CStr(count)
Else ‘in case a digit count is over 9
Select Case count
Case 10
temp = temp + “a”
Case 11
temp = temp + “b”
Case 12
temp = temp + “c” ‘e.g. 10000^3 has 12 zeros
End Select
End If
Next k
DigCountCubes = temp
End Function
I followed much the same result as David, but I stored my digit count as a double (too big for a long), and used a fast VBA sorting routine that I found on my hard disk (source not known, apologies to the author, whoever they might be). Time about 0.18 seconds:
Note that the sort routine was written for a 1 dimensional of longs, and I’ve modified it for a 2 column array of doubles.
Dim V As Long, Cubea() As Double, Vlen As Long, CubCount As Long
Dim Vcub As Double, i As Long, Digval As Double, Dig As Long, Cubmin As Long
Dim Resa(1 To 1, 1 To 2) As Double
ReDim Cubea(Vmin To Vmax, 1 To 2)
Resa(1, 2) = Timer
For V = Vmin To Vmax
Vcub = V ^ 3
Vlen = Len(Trim(Vcub))
For i = 1 To Vlen
Dig = Mid(Vcub, i, 1)
Digval = Digval + 10 ^ (9 – Dig)
Next i
Cubea(V, 1) = Digval
Cubea(V, 2) = V
Digval = 0
Next V
CombSort Cubea
CubCount = 1
For V = Vmin + 1 To Vmax
If Cubea(V, 1) = Cubea(V – 1, 1) Then
CubCount = CubCount + 1
If Cubea(V, 2) .LT. Cubmin Then Cubmin = Cubea(V, 2)
If CubCount = NumCub Then
Resa(1, 1) = Cubmin
Resa(1, 2) = Timer – Resa(1, 2)
P_62 = Resa
Exit Function
End If
Else
CubCount = 1
Cubmin = Cubea(V, 2)
End If
Next V
P_62 = Cubea
End Function
Public Sub CombSort(ByRef dblArray() As Double)
Dim iSpacing As Long
Dim iOuter As Long
Dim iInner As Long
Dim iTemp As Double
Dim iLBound As Long
Dim iUBound As Long
Dim iArrSize As Long
Dim iFinished As Long
iLBound = LBound(dblArray)
iUBound = UBound(dblArray)
‘Initialise comb width
iSpacing = iUBound – iLBound
Do
If iSpacing > 1 Then
iSpacing = Int(iSpacing / 1.3)
If iSpacing = 0 Then
iSpacing = 1 ‘Dont go lower than 1
ElseIf iSpacing > 8 And iSpacing dblArray(iInner, 1) Then
‘Swap
iTemp = dblArray(iOuter, 1)
dblArray(iOuter, 1) = dblArray(iInner, 1)
dblArray(iInner, 1) = iTemp
iTemp = dblArray(iOuter, 2)
dblArray(iOuter, 2) = dblArray(iInner, 2)
dblArray(iInner, 2) = iTemp
‘Not finished
iFinished = 0
End If
Next iOuter
Loop Until iFinished
End Sub
This seems to be the source for the combsort routine:
http://www.xtremevbtalk.com/showpost.php?postid=388009&postcount=10
The angle bracket formatting bug has bitten Doug. A less-then angle bracket immediately follows iSpacing, and a greater-than angle bracket immediately precedes dblArray(iInner,1). The result is that all in the middle between the brackets was treated as an HTML tag and ignored/hidden/deleted. The link Doug provided has these aggravating deletions completely included, but I believe it goes like this for here:
…ElseIf iSpacing > 8 And iSpacing dblArray(iInner) then
‘Swap …
This is a frustrating bug that only appears between the VB tags.
…mrt
Belay my last. The bug appears in posts, too. Trying again, using LT and GT surrogates for angle brackets.
…ElseIf iSpacing GT 8 And iSpacing LT 11 Then
iSpacing = 11 ‘This is a special number, goes faster than 9 and 10
End If
End If
‘Always go down to 1 before attempting to exit
If iSpacing = 1 Then iFinished = 1
‘Combing pass
For iOuter = iLBound To iUBound – iSpacing
iInner = iOuter + iSpacing
If dblArray(iOuter) GT dblArray(iInner) then
‘Swap …
Glad to have this sort tool in my expanding tool box. Thank you, Doug.
…mrt
…mrt
Oops. I should know to do a search and replace for those symbols by now.
Here’s the complete combsort code again, with .GT. and .LT. in place of the offending symbols. I’m going to re-write this as a function, and make it more flexible; any number of columns, mult-level sorts, and use variants rather than longs or doubles. It should appear on my blog in a few days.
Dim iSpacing As Long
Dim iOuter As Long
Dim iInner As Long
Dim iTemp As Double
Dim iLBound As Long
Dim iUBound As Long
Dim iArrSize As Long
Dim iFinished As Long
iLBound = LBound(dblArray)
iUBound = UBound(dblArray)
‘Initialise comb width
iSpacing = iUBound – iLBound
Do
If iSpacing .GT. 1 Then
iSpacing = Int(iSpacing / 1.3)
If iSpacing = 0 Then
iSpacing = 1 ‘Dont go lower than 1
ElseIf iSpacing .GT. 8 And iSpacing .LT. 11 Then
iSpacing = 11 ‘This is a special number, goes faster than 9 and 10
End If
End If
‘Always go down to 1 before attempting to exit
If iSpacing = 1 Then iFinished = 1
‘Combing pass
For iOuter = iLBound To iUBound – iSpacing
iInner = iOuter + iSpacing
If dblArray(iOuter, 1) .GT. dblArray(iInner, 1) Then
‘Swap
iTemp = dblArray(iOuter, 1)
dblArray(iOuter, 1) = dblArray(iInner, 1)
dblArray(iInner, 1) = iTemp
iTemp = dblArray(iOuter, 2)
dblArray(iOuter, 2) = dblArray(iInner, 2)
dblArray(iInner, 2) = iTemp
‘Not finished
iFinished = 0
End If
Next iOuter
Loop Until iFinished
End Sub
I’ve just noticed that the code I posted doesn’t give the right answer. I did some adjustments after getting the correct solution, and messed it up. I should have checked that the first group of five palindromic cubes contains the lowest value with five palindromic cubes (it doesn’t). Corrected code below. For some reason I don’t understand the execution time has now reduced to 0.12 seconds.
Dim V As Long, Cubea() As Double, Vlen As Long, CubCount As Long, CubMinV As Long
Dim Vcub As Double, i As Long, Digval As Double, Dig As Long, Cubmin As Long
Dim Resa(1 To 1, 1 To 2) As Double
ReDim Cubea(Vmin To Vmax, 1 To 2)
Resa(1, 2) = Timer
CubMinV = Vmax
For V = Vmin To Vmax
Vcub = V ^ 3
Vlen = Len(Trim(Vcub))
For i = 1 To Vlen
Dig = Mid(Vcub, i, 1)
Digval = Digval + 10 ^ (9 – Dig)
Next i
Cubea(V, 1) = Digval
Cubea(V, 2) = V
Digval = 0
Next V
CombSort Cubea
CubCount = 1
For V = Vmin + 1 To Vmax
If Cubea(V, 1) = Cubea(V – 1, 1) Then
If CubCount = 1 Then Cubmin = Cubea(V – 1, 2)
CubCount = CubCount + 1
If Cubea(V, 2) .LT. Cubmin Then Cubmin = Cubea(V, 2)
If CubCount = NumCub Then
If Cubmin .LT. CubMinV Then CubMinV = Cubmin
End If
Else
CubCount = 1
End If
Next V
Resa(1, 1) = CubMinV ^ 3
Resa(1, 2) = Timer – Resa(1, 2)
P_62 = Resa
End Function
For yet another Project Euler solution that uses no VB(A) see
Project Euler – Problem 62
http://www.tushar-mehta.com/misc_tutorials/project_euler/euler062.html
As mentioned above, I have modified the comb sort function, which can be downloaded from http://newtonexcelbach.wordpress.com/2009/03/23/a-sort-function/.
It can now be used as a VBA function or UDF, and will accept mixed arrays of numbers and strings (but it doesn’t do multi-level sorts yet).