# Euler Problem 62

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

Sub Problem_062()
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
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
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) &amp; Chr(32) &amp; 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) &gt; 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) &lt; 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 &amp; str(i)
Next i

End Function

The code runs in under .6 seconds. There are the usual angle bracket substitutions above.

…mrt

Posted in Uncategorized

## 9 thoughts on “Euler Problem 62”

1. David says:

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.

Sub Problem_062A()
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
), 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) &lt; 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 &lt; 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

2. Doug Jenkins says:

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.

Function P_62(Vmin As Long, Vmax As Long, NumCub As Long) As Variant
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 &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  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

3. Michael says:

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

4. Michael says:

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

5. Doug Jenkins says:

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.

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

6. Doug Jenkins says:

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.

Function P_62(Vmin As Long, Vmax As Long, NumCub As Long) As Variant
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

7. Doug Jenkins says:

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

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