Pensieve header: Non-Commutative Gaussian Elimination, Day 2.

From http://www.math.toronto.edu/drorbn/classes/16-1750-ShamelessMathematica/About.html: Possible Topics (in no particular order). Whatever you may suggest, and the Fibonacci numbers; the Jones polynomial; a more efficient Jones algorithm; a riddle on spheres; Khovanov homology; Γ-calculus; the Hopf fibration; Hilbert’s 13th problem; non-commutative Gaussian elimination; free Lie algebras; the Baker-Campbell-Hausdorff formula; wacky numbers; an order 4 torus; the Schwarz Lantern; knot colourings; the Temperley-Lieb pairing; the dodecahedral link; sound experiments; barycentric subdivisions; a Peano curve; braid closures and Vogel’s algorithm; the insolubility of the quintic, phase portraits.

?Cycles

n=54; 
(Subscript[g, 1])=Cycles[{{1,18,45,28},{2,27,44,19},{3,36,43,10},{46,52,54,48},{47,49,53,51}}];
(Subscript[g, 2])=Cycles[{{7,16,39,30},{8,25,38,21},{9,34,37,12},{13,15,33,31},{14,24,32,22}}];
(Subscript[g, 3])=Cycles[{{28,31,34,48},{29,32,35,47},{30,33,36,46},{37,39,45,43},{38,42,44,40}}];
(Subscript[g, 4])=Cycles[{{1,3,9,7},{2,6,8,4},{10,54,16,13},{11,53,17,14},{12,52,18,15}}];
(Subscript[g, 5])=Cycles[{{1,13,37,46},{4,22,40,49},{7,31,43,52},{10,12,30,28},{11,21,29,19}}];
(Subscript[g, 6])=Cycles[{{3,48,39,15},{6,51,42,24},{9,54,45,33},{16,18,36,34},{17,27,35,25}}];

?PermutationList

?PermutationCycles

?PermutationProduct

a_∘b_ := PermutationProduct[a,b]

?InversePermutation

?PermutationSupport

?PermutationReplace

σ_∘τ_ := PermutationProduct[τ, σ];
Feed[Cycles[{}]]:=Null;
Feed[τ_]:=Module[{i,j,k,l},
i=Min[PermutationSupport[τ]];
j=PermutationReplace[i, τ];
If[Head[(Subscript[σ, i,j])]===Cycles,
Feed[InversePermutation[(Subscript[σ, i,j])]∘τ],
(*Else*) (Subscript[σ, i,j])=τ;
For[k=1, k<n, ++k,
For[l=k+1, l≤n, ++l,
If[Head[(Subscript[σ, k,l])]===Cycles,
Feed[(Subscript[σ, i,j])∘(Subscript[σ, k,l])]; Feed[(Subscript[σ, k,l])∘(Subscript[σ, i,j])]]
]]
]];
$RecursionLimit=∞;

Table[Feed[(Subscript[g, α])];(∏_(i=1)^n)(1+Count[Range[n], j_ /; Head[(Subscript[σ, i,j])]==Cycles]), {α, 6}] // Timing

ArrayPlot[
Table[
Which[
Head[(Subscript[σ, i,j])]===Cycles∨i==j, Red,i<j, Yellow,i>j, White],
{j,n},{i,n}],
Mesh -> True, Frame -> True, FrameTicks ->Range@n, AspectRatio -> 9/16, ImageSize -> 960
] // Rasterize

Math Questions.
1. Why are there so many yellow cells in column 1?
2. Why are there so many yellow cells in column 2?
3. Why are there “new” yellow cells in column 3?
4. Why are there “new” yellow cells in column 4?
5. Why is column 5 entirely yellow?
6. Why’s the big yellow gap between colulmn 10 and 18?

Mathematica Challanges.
1. Can you make the porgram doubly efficient?
2. Can you keep track of the actual “tricks”?
3. Can you find the true lengths of the “tricks”?
4. Can you fix these sad results?
5. Can you actually solve cubes?