Euler Problem 62

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

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

Posted in Uncategorized

9 thoughts on “Euler Problem 62

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

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

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


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

Leave a Reply

Your email address will not be published.