Find the smallest cube for which exactly five permutations of its digits are cubes.
Rem: Runtime heavily dependent of solution's concept.
Source  disclosed later.
Thanks for the remark about runtimes: it made me think: going through all permutations of all cubes would be horrendous. Much better to list all the cubes of a given number of digits and check pairs for being anagrams.
The first found is the 12digit 127035954683, which has four other permutations that are cubes: 352045367981 = 7061^3, 373559126408 = 7202^3, 569310543872 = 8288^3 and 589323567104 = 8384^3.
The next set of 5 is 140283769536, 536178930624, 613258407936, 913237656408 and 936302451687.
If we want a cube with five other permutations that are cubes, it would be the 13digit 1000600120008, which has permutations 1006012008000, 1061208000000, 8001200060001, 8012006001000 and 8120601000000. Next would be the set 1426487591593, 1432197595648, 3496581419752, 4275981654391, 4813967954125 and 7591941538264.
The above were all found within a runtime of less than one minute. It took only a minute or two more to check the rest of the 13digit cubes, which included only three other sets of five:
1961574655832 2981631556457 5657831164259 8631525145697 9625537115648
2097643558401 2501609484375 2595641083407 6140550947328 9083540714625
2546097986375 2567976059384 5429503678976 6587579024936 7736546098952
DefDbl AZ
Dim crlf$, cube(20000) As String, hit(10) As String
Private Sub Form_Load()
Form1.Visible = True
Text1.Text = ""
crlf = Chr$(13) + Chr$(10)
For digs = 2 To 13
DoEvents
lower = Int(10 ^ ((digs  1) / 3))
upper = Int((10 ^ digs  1) ^ (1 / 3))
Text1.Text = Text1.Text & digs & Str(lower) & Str(upper) & Str(upper  lower + 1) & crlf
cubect = 0
For cr = lower To upper
cubect = cubect + 1
cube(cubect) = LTrim(Str(cr * cr * cr))
Next
For i = 1 To cubect
DoEvents
hitct = 0
For j = i + 1 To cubect
If isPerm(cube(i), cube(j)) Then hitct = hitct + 1: hit(hitct) = cube(j)
Next
If hitct >= 4 Then
Text1.Text = Text1.Text & cube(i)
For j = 1 To hitct
Text1.Text = Text1.Text & " " & hit(j)
Next
Text1.Text = Text1.Text & crlf
End If
Next i
Text1.Text = Text1.Text & crlf
Next
Text1.Text = Text1.Text & crlf & " done"
End Sub
Function isPerm(a$, b$)
x$ = a$
good = 1
If Len(a$) <> Len(b$) Then isPerm = 0: Exit Function
For i = 1 To Len(b$)
ix = InStr(x, Mid(b, i, 1))
If ix = 0 Then good = 0: Exit For
x = Left(x, ix  1) + Mid(x, ix + 1)
Next
isPerm = good
End Function

Posted by Charlie
on 20160126 15:29:18 