Pensieve header: MandelTime and Non-Commutative Gaussian Elimination, Day 3.

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; the Mamdelbrot set.

The Mandelbrot Set

$MandelTimeBound=100;
MandelTime[c_]:=Module[{z=0,n=0},
While[n<$MandelTimeBound∧Abs[z]<3, ++n; z=(z^2)+c];
n
];

Plot[Sin[x],{x,0,2π}, ImageSize->50]

Plot[Sin[x],{x,0,2π}, ImageSize->50] // Rasterize

{x0,y0}={-0.5,0};
a=2;
DensityPlot[-MandelTime[x+I y], {x,x0-a,x0+a},{y,y0-a,y0+a},
PlotPoints->100, ColorFunction->"SunsetColors", PlotRange->All
] // Rasterize

{{"-0.09909","0.9826"}}

ToExpression["1+1"]

{x0,y0}=ToExpression/@(Last@{{"-0.3726","0.6575"}});
a=0.02;
DensityPlot[-MandelTime[x+I y], {x,x0-a,x0+a},{y,y0-a,y0+a}, ColorFunction->"SunsetColors",PlotPoints -> 50] // Rasterize

Non Commutative Gaussian Elimination

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}}];

σ_∘τ_ := PermutationProduct[τ, σ];
Feed[Cycles[{}]]:=1+1;
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])=τ;Pause[0.5];
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 -> 720
] // 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 turn the program into a “package”?
2. Can you make the porgram doubly efficient?
3. Can you keep track of the actual “tricks”?
4. Can you find the true lengths of the “tricks”?
5. Can you fix these sad results?
6. Can you actually solve cubes?

The Mathematica Package “Permutations”

Goal: Re-implement permutations, using “permutation lists” as the basic data type, rather than “cycle decompositions”.

?Cycles

?PermutationList

?PermutationCycles

?PermutationProduct

?InversePermutation

?PermutationSupport

?PermutationReplace

Finer Goal: Make a useful package implementing PL, PC, PP, IP, PS, and PR, to the point that we can re-write “Feed” so that it works on the following (Subscript[γ, α])'s:

Table[(Subscript[γ, α])=PermutationList[(Subscript[g, α]),n],{α,6}] // MatrixForm

?Permutation