Non Commutative Gaussian Elimination - Program 2

By Dror Bar-Natan

Amended from a similar notebook by Dror Bar-Natan and Itai Bar-Natan. The original version is at http://www.math.toronto.edu/~drorbn/Misc/SchreierSimsRubik/.

Pensieve Header: NCGE Program 2 - replacing tricks with better ones when possible, non-recursively. The results are acceptible.

The Cube

The Generating Permutations

n=54; $RecursionLimit=2^16;
Generators = {
M[{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},
{BottomFace},1],
M[{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},
{TopFace}, 1],
M[{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},
{FrontFace},1],
M[{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},
{BackFace},1],
M[{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},
{LeftFace},1],
M[{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},
{RightFace},1]
};

Program 2

Clear[s, M, T];  TC=0;
M/:M[a1_,{w1___}, m1_]**M[a2_,{w2___}, m2_]:=M[a1[[a2]],{w1,w2}, m1+m2];
M /: Inverse[M[a_, w_, m_]] := M[Ordering[a], -Reverse[w], m];
Feed[M[Range[n],__]]:=Null;
Feed[M[a_,{w___}, m_]] := Module[
{i, j,sij,k,l,skl},
For[i=1, a[[i]]==i, ++i]; j=a[[i]];
If[Head[sij=s[i,j]]===Integer,
(* then *) If[m ≥ T[sij][[3]],
Feed[ReplacePart[Inverse[T[sij]]**M[a,{w},m],{-sij,w}, 2]],
T[s[i,j]=++TC] = M[a,{w},m];
Feed[ReplacePart[Inverse[M[a,{w},m]]**T[sij],-{w, -sij}, 2]]
],
(* else *) T[s[i,j]=++TC] = M[a,{w},m];
Do[
If[Head[skl=s[k,l]]==Integer,
Feed[ReplacePart[T[sij]**T[skl], {sij, skl}, 2]];
Feed[ReplacePart[T[skl]**T[sij], {skl, sij}, 2]]
],
{k,n},{l,n}
]
]
];
Images[i_] := Prepend[Select[Range[n], Head[s[i,#]]===Integer&], i]

The Order of the Group

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

The Worst Case Scenario

MoveCount[i_,i_] := 0;
MoveCount[i_,j_] := T[s[i,j]][[3]];
Sum[Max[MoveCount[i,#]& /@ Images[i]], {i, n}]

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

MoveCount[i_,i_] := 0;
MoveCount[i_,j_] := T[s[i,j]][[3]];
Sum[Max[MoveCount[i,#]& /@ Images[i]], {i, n}]

For the Patient : A Recipe for Solving the Cube

ColumnForm /@ {
Reap[
Do[If[Head[s[i,j]]===Integer, Sow[S[i,j] -> s[i,j]]], {i,n-1}, {j,i+1, n}]
][[2,1]],
(# -> Rest[T[#]])& /@ Range[1, TC, 100]
}