Pensieve header: Two Peano curves and Non-Commutative Gaussian Elimination, Day 4.

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.

A Peano Curve

Peano[0] = DLine[{{0,0},{1,1}}];
Peano[n_] := Peano[n-1] /. DLine[{{x0_,y0_},{x1_,y1_}}] :> {
dx=x1-x0; dy=y1-y0;
DLine[{{x0,y0}, {x0+1/2 dx, y0+1/2 dy}}],
Line[{{x0+1/2 dx, y0+1/2 dy}, {x0+1/2 dx, y0}}],
DLine[{{x0+1/2 dx, y0}, {x0+dx, y0+1/2 dy}}],
Line[{{x0+dx, y0+1/2 dy}, {x0, y0+1/2 dy}}],
DLine[{{x0, y0+1/2 dy}, {x0+1/2 dx, y0+dy}}],
Line[{{x0+1/2 dx, y0+dy}, {x0+1/2 dx, y0+1/2 dy}}],
DLine[{ {x0+1/2 dx, y0+1/2 dy},  {x0+dx, y0+dy}}]
};
GraphicsRow@Table[Graphics[Peano[n] /. DLine -> Line], {n, 0, 3}]

AlmostPeano[0] = DLine[{{0,0},{1,1}}];
AlmostPeano[n_] := AlmostPeano[n-1] /. DLine[{{x0_,y0_},{x1_,y1_}}] :> {
dx=x1-x0; dy=y1-y0;
DLine[{{x0,y0}, {x0+0.45 dx, y0+0.45 dy}}],
Line[{{x0+0.45 dx, y0+0.45 dy}, {x0+0.55 dx, y0}}],
DLine[{{x0+0.55 dx, y0}, {x0+dx, y0+0.45 dy}}],
Line[{{x0+dx, y0+0.45 dy}, {x0, y0+0.55 dy}}],
DLine[{{x0, y0+0.55 dy}, {x0+0.45 dx, y0+dy}}],
Line[{{x0+0.45 dx, y0+dy}, {x0+0.55 dx, y0+0.55 dy}}],
DLine[{ {x0+0.55 dx, y0+0.55 dy},  {x0+dx, y0+dy}}]
};
GraphicsRow@Table[Graphics[AlmostPeano[n] /. DLine -> Line], {n, 0, 3}]

Graphics[AlmostPeano[5] /. DLine -> Line]

A Better Peano Curve

t=RandomChoice[{0,1},20]

2t

2t.(((1/3))^(Range@20))//N

2t.(((1/3))^(Range@20))

FromDigits[{2t,0},3]

t

Partition[t,2]

Partition[t,2]//Transpose

Prepend[
FromDigits[{#,0},2]& /@ Transpose[Partition[t,2]],
FromDigits[{2t,0},3]
]

γ[t_List] := Prepend[
FromDigits[{#,0},2]& /@ Transpose[Partition[t,2]],
FromDigits[{2t,0},3]
];
Graphics3D[
Line[γ /@ Tuples[{0,1},14]],
ViewPoint->{-370.06,733.124,570.6},ViewVertical->{0.1792,0.789508,-0.599889}
]//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])=τ;
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

Mathematica Challanges.
1. Can you find the true lengths of the “tricks”? Done!
2. Can you fix these sad results? Done, but can you do better?
3. Can you turn the program into a “package”?
4. Can you make the porgram doubly efficient?
5. Can you keep track of the actual “tricks”?
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