Dror Bar-Natan: Odds, Ends, Unfinished:

Solving Rubik's Cube using the Schreier-Sims Algorithm

By Dror Bar-Natan and Itai Bar-Natan

This Mathematica notebook contains some programs that we wrote the spring of 2007 to test our understanding of the Schreier-Sims algorithm by applying it to the Rubuk's Cube group of permutations. It is not easily readable and not meant for readership much beyond its own authors.

The .nb (original) version of this notebook is at http://www.math.toronto.edu/~drorbn/Misc/SchreierSimsRubik/SchreierSimsRubik.nb.

T1=Date[]

T0, the time stamp on the first version of this document, was {2007, 7, 1, 17, 4, 1.5781250}.

The Cube

The Generating Permutations

n=54;
Generators = {
BottomPer=P[{18, 27, 36,4,5,6,7,8,9,3,11,12,13,14,15,16,17,45,2,20,21,22,23,24,25,26,44,1,29,30,31,32,33,34,35,43,37,38,39,40,41,42,10,19,28,52,49,46,53,50,47,54,51,48},W[bttm]],
TopPer=P[{1,2,3,4,5,6,16,25,34,10,11,9,15,24,33,39,17,18,19,20,8,14,23,32,38,26,27,28,29,7,13,22,31,37,35,36,12,21,30,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54},W[top]],
FrontPer=P[{1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,31,32,33,34,35,36,48,47,46,39,42,45,38,41,44,37,40,43,30,29,28,49,50,51,52,53,54},W[frnt]],
BackPer=P[{3,6,9,2,5,8,1,4,7,54,53,52,10,11,12,13,14,15,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,18,17,16},W[back]],
LeftPer=P[{13,2,3,22,5,6,31,8,9,12,21,30,37,14,15,16,17,18,11,20,29,40,23,24,25,26,27,10,19,28,43,32,33,34,35,36,46,38,39,49,41,42,52,44,45,1,47,48,4,50,51,7,53,54},W[left]],
RightPer=P[{1,2,48,4,5,51,7,8,54,10,11,12,13,14,3,18,27,36,19,20,21,22,23,6,17,26,35,28,29,30,31,32,9,16,25,34,37,38,15,40,41,24,43,44,33,46,47,39,49,50,42,52,53,45},W[rite]]
};

The Program

$RecursionLimit=2^16;
Id=P[Range[n],W[]];
P/:P[a1_,W[w1___]]**P[a2_,W[w2___]]:=P[a1[[a2]],W[w1,w2]];
P /: Inv[P[a_, w_W]] := P[Ordering[a], Inv /@ Reverse[w]];
W[x___,Inv[Inv[y_]],z___]:=W[x,y,z];
Clear[s];
Feed[P[Range[n],_]]:=Null;
Feed[P[a_,w_W]] := Module[
{i, j},
For[i=1, a[[i]]==i, ++i];
j=a[[i]];
If[Head[s[i,j]]===P,
Feed[P[(Inv[s[i,j]]**P[a,w])[[1]],Prepend[w, Inv[S[i,j]]]]],
s[i,j]=P[a,w];
(* Print[S[i,j], " is ", If[Length[w]>1, NonCommutativeMultiply @@ w, w[[1]]]]; *)
Do[
If[Head[s[k,l]]==P,
Feed[P[(s[i,j]**s[k,l])[[1]],W[S[i,j],S[k,l]]]];
Feed[ReplacePart[s[k,l]**s[i,j], W[S[k,l], S[i,j]], 2]]
],
{k,n},{l,n}
]
]
];
Images[i_] := Prepend[Select[Range[n], Head[s[i,#]]===P&], i]

Running the Program

The Order of the Group

(Feed[#]; Product[Length[Images[i]],{i,n}])& /@ Generators

It is lovely to note that the number computed right above, the order of the Rubik's cube group according to our computer, agrees with the number that appears in the literature, for example, in Wikipedia. Note also that according to our computation the last generator of the group was actually not necessary.

For the Patient : A Recipe for Solving the Cube

tricks={};
Do[If[Head[s[i,j]]===P, AppendTo[tricks, S[i,j] -> s[i,j][[2]]]], {i,n-1}, {j,i+1, n}];
tricks