1
$\begingroup$

Problem 599 of the Project-Euler is described as follows:

The well-known Rubik's Cube puzzle has many fascinating mathematical properties. The 2×2×2 variant has 8 cubelets with a total of 24 visible faces, each with a coloured sticker. Successively turning faces will rearrange the cubelets, although not all arrangements of cubelets are reachable without dismantling the puzzle.

Suppose that we wish to apply new stickers to a 2×2×2 Rubik's cube in a non-standard colouring. Specifically, we have n different colours available (with an unlimited supply of stickers of each colour), and we place one sticker on each of the 24 faces in any arrangement that we please. We are not required to use all the colours, and if desired the same colour may appear in more than one face of a single cubelet.

We say that two such colourings c1,c2 are essentially distinct if a cube coloured according to c1 cannot be made to match a cube coloured according to c2 by performing mechanically possible Rubik's Cube moves.

For example, with two colours available, there are 183 essentially distinct colourings.

How many essentially distinct colourings are there with 10 different colours available?

I can get the right result with two colors (Refer to the code in this post):

rot1 = System`Cycles[{{1, 2, 4, 3}, {5, 24, 9, 7}, {6, 23, 10, 8}}];
rot2 = System`Cycles[{{21, 22, 24, 23}, {1, 11, 20, 10}, {2, 5, 19, 
     16}}];
rot3 = System`Cycles[{{11, 5, 6, 12}, {1, 7, 17, 21}, {3, 13, 19, 
     23}}];
rot4 = System`Cycles[{{7, 8, 14, 13}, {3, 9, 18, 12}, {4, 15, 17, 6}}];
rot5 = System`Cycles[{{10, 16, 15, 9}, {2, 22, 18, 8}, {4, 24, 20, 
     14}}];
rot6 = System`Cycles[{{20, 19, 17, 18}, {16, 21, 12, 14}, {15, 22, 11,
      13}}];
RubikGroup2x2x2 = 
  PermutationGroup[{rot1, rot2, rot3, rot4, rot5, rot6}];
GroupOrder[RubikGroup2x2x2]
poly = CycleIndexPolynomial[RubikGroup2x2x2, 
   Array[Subscript[a, ##] &, 24]];
c2poly = poly /. Subscript[a, i_] -> Total[(Array[colour, 2]^i)] // 
   Expand;
CoefficientList[c2poly, Array[colour, 2]] // Flatten // Total

But when I extended the above method to 10 colors, the memory crashed:

c10poly = 
  poly /. Subscript[a, i_] -> Total[(Array[colour, 10]^i)] // Expand;
CoefficientList[c10poly, Array[colour, 10]] // Flatten // Total

How can I get the right answer of this question?

$\endgroup$
1
$\begingroup$

An answer written by MuthuVeerappanR in the forum of Project-Euler:

Clear["Global`*"];
Tp = Cycles[{{9, 5, 17, 13}, {10, 6, 18, 14}, {1, 2, 4, 3}}];
Rt = Cycles[{{13, 14, 16, 15}, {10, 2, 19, 22}, {12, 4, 17, 24}}];
Fr = Cycles[{{9, 10, 12, 11}, {3, 13, 22, 8}, {4, 15, 21, 6}}];
Dn = Cycles[{{21, 22, 24, 23}, {11, 15, 19, 7}, {12, 16, 20, 8}}];
Lt = Cycles[{{5, 6, 8, 7}, {3, 11, 23, 18}, {1, 9, 21, 20}}];
Bk = Cycles[{{17, 18, 20, 19}, {1, 7, 24, 14}, {2, 5, 23, 16}}];
RubikGroup = PermutationGroup[{Tp, Rt, Fr, Dn, Lt, Bk}];
GroupOrder[RubikGroup]
CycleIndexPolynomial[RubikGroup, ConstantArray[10, 24]]
| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.