Non Commutative Gaussian Elimination - Program 0

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 0 - as on handout + a printout of the filling table. See more at Dror Bar-Natan: Academic Pensieve: 2009-07.

Program 0

gs={purple=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],white=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],green=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],blue=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],red=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],yellow=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]};

($RecursionLimit=2^16;
n=54;
P/:p_P**P[a___]:=p[[{a}]];
Inv[p_P]:=P@@Ordering[p];
Feed[P@@Range[n]]:=Null;
Feed[p_P]:=Module[{i,j},
For[i=1,p[[i]]==i,++i]; j=p[[i]];
If[Head[s[i,j]]===P,
Feed[Inv[s[i,j]]**p],
(*Else*)s[i,j]=p;
Do[If[Head[s[k,l]]==P,
Feed[s[i,j]**s[k,l]];
Feed[s[k,l]**s[i,j]]
],
{k,n},{l,n}]
]]
);

(Feed[#];Product[1+Length[Select[Range[n],Head[s[i,#]]===P&]],{i,n}])&/@gs

Images[i_] := {i}~Join~Select[Range[n],Head[s[i,#]]===P&];
ListPlot[
Join@@Table[{i, #}& /@ Images[i], {i,n}],
AspectRatio ->1
]

43252003274489856000/(8!*3^8*12!*2^12)