Non Commutative Gaussian Elimination - Program 6

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 6 - this is just program 5, run on the "Brain Twist" puzzle.

The Annoying "Brain Twist"

n=12; $RecursionLimit = 2^16;
Feed[M[Range[n],__]]:={};
CycPerm[c___] := Range[n] /. Thread[{c} -> RotateRight[{c}]];

CycPerm[1,2,3]

gens = {
M[CycPerm[1,2,3], {row1}, 1],
M[CycPerm[4,5,6], {row2}, 1],
M[CycPerm[7,8,9], {row3}, 1],
M[CycPerm[10,11,12], {row4}, 1],
M[CycPerm[4,7,10], {col1}, 1],
M[CycPerm[1,8,11], {col2}, 1],
M[CycPerm[2,5,12], {col3}, 1],
M[CycPerm[3,6,9], {col4}, 1]
}

Program 5

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],__]]:={};
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[Inverse[ReplacePart[T[sij], {sij}, 2]]**M[a,{w},m]],
T[s[i,j]=++TC] = M[a,{w},m];
Feed[Inverse[M[a,{w},m]]**ReplacePart[T[sij], {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];
MoveCount[i_,i_] := 0;
MoveCount[i_,j_] := T[s[i,j]][[3]];
TMC[] := Sum[Total[MoveCount[i,#]& /@ Images[i]], {i, n}];
Optimize[] := Timing[
Do[
If[Head[sij=s[i,j]]==Integer, Do[
If[Head[skl=s[k,l]]==Integer,
Feed[ReplacePart[T[sij]**T[skl], {sij, skl}, 2]]
],{k,n},{l,n}]],
{i,n}, {j,n}];
TMC[]
];

g=0;
Print[Timing[
(++g; Feed[#]; Product[Length[Images[i]],{i,n}])& /@ gens
]];
Print[tmc=TMC[]];
While[
Last[opt= Optimize[]] ≠ tmc,
tmc=Last[opt];
Print[opt]
]

239500800/12!

The Worst Case Scenario

Sum[Max[MoveCount[i,#]& /@ Images[i]], {i, n}]