Pensieve header: Khovanov Homology, Day 5.

Topics (in no particular order). Whatever you may suggest; whatever comes to my mind; the Fibonacci numbers; the Catalan 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; some Peano curves; braid closures and Vogel’s algorithm; the insolubility of the quintic; phase portraits; the Mandelbrot set; shadows of the Cantor square; quilt plots; some image transformations; De Bruijn graphs; the Riemann series theorem; finite type invariants and the Willerton fish; the Towers of Hanoi; Hochschild homology of (some) coalgebras; convolutions and image improvements; the 8-5-3 milk jug problem; a cow problem, a permutations package.

One further class meeting on Thursday at 10 at Bahen 6180!

Outstanding Challenges

The last day to submit projects for marks will be the last day of the UofT examination period, December 20 2017 at midnight.

Update the NCGE program to contain “backtracking information”. Use it to find how to turn the lower face of a Rubik’s cube by turning all but the lower face of that cube.

Complete the package perm, with documentation and all. For Perm[5,2,3,1,4], etc, your package should know σ∘τ, (σ^(-1)), σ[[i]], Pivot[σ], PermutationQ[σ], IdentityPermutation[n], it should interact well with Cycles, and its internals should be hidden. It should live in a file “Perm.m”.

Write a sophisticated Mathematica package that implements QuiltPlot and DoubleQuiltPlot with many bells and whistles, as explained on November 20th.

Draw approximations of the Cantor square (C^2). Then rotate (C^2) by an angle θ and project the rotation vertically, draw that projection (while explaining why it is what you think it is), and compute its measure. Perhaps also use Manipulate[..., {θ,0,π/2}]?

Everybody knows that the length of a smooth curve is the supremum of the lengths of its polygonal approximations. Everybody should know that the same is not true for smooth surfaces. Can you draw a smooth surface in (ℝ^3) along with a triangulated approximation thereof whose area is vastly more? An appropriate animation may be even more convincing.

Make the best picture of the Hopf fibration the world has even seen.

Khovanov Homology

Challenge: Implement Khovanov Homology as it is defined in the handout. Your implementation should fit in one page and should be good enough to show that Kh((Subscript[5, 1]))≠Kh((Subscript[10, 132])).

K=K31=PD[X[3,1,4,6],X[1,5,2,4], X[5,3,6,2]];
K51=PD[X[1,6,2,7],X[3,8,4,9],X[5,10,6,1],X[7,2,8,3],X[9,4,10,5]];
K10132 = PD[X[4,2,5,1],X[8,4,9,3],X[5,12,6,13],X[15,18,16,19],X[9,16,10,17],X[17,10,18,11],X[13,20,14,1],X[19,14,20,15],X[11,6,12,7],X[2,8,3,7]];

SetAttributes[{B,P}, Orderless]; t=0;
VerticesAndCycles=Expand[
Times@@(K /. X[i_,j_,k_,l_] :> (++t; P[i,j]P[k,l]+B[t] P[i,l]P[j,k]))
] //. B[i__]B[j__]:> B[i,j] /.P[a_,b_] :> P[a,b][Min[a,b]]//. P[a_,b_][m1_]P[b_,c_][m2_] :> P[a,c][Min[m1,m2]] /. {P[i_, i_][m_] :> c[m], ((P[_,_][m_])^2):> c[m]}

K

Times@@K

FullBasis=List@@Expand[VerticesAndCycles /. c[m_] :> vp[m]+vm[m]]

Next Task. Produce a “generating function for the edges”.

?Coefficient

n=2;
G=Expand[Product[(Subscript[a, i])+(Subscript[b, i])+ϵ (Subscript[e, i]),{i,n}]];
{VV=List@@Coefficient[G, ϵ,0], EE=List@@Coefficient[G, ϵ,1]}

n=5;
G=Expand[Product[(Subscript[a, i])+(Subscript[b, i])+ϵ (Subscript[e, i]),{i,n}]];
{VV=List@@Coefficient[G, ϵ,0], EE=List@@Coefficient[G, ϵ,1]};
Graph[VV, Table[(ζ/.e->a)->(ζ/.e->b), {ζ,EE}]]

SetAttributes[{B,P}, Orderless]; t=0;
ϵ /: (ϵ^(p_))/;p>1:=0;
VerticesAndCycles=Expand[
Times@@(K /. X[i_,j_,k_,l_] :> (++t; P[i,j]P[k,l]+B[t] P[i,l]P[j,k]))
] //. B[i__]B[j__]:> B[i,j] /.P[a_,b_] :> P[a,b][Min[a,b]]//. P[a_,b_][m1_]P[b_,c_][m2_] :> P[a,c][Min[m1,m2]] /. {P[i_, i_][m_] :> c[m], ((P[_,_][m_])^2):> c[m]}

SetAttributes[{B,P}, Orderless]; t=0; ϵ /: (ϵ^(p_))/;p>1:=0;
Expand[
Times@@(K /. X[i_,j_,k_,l_] :> (++t; P[i,j]P[k,l]+B[t] P[i,l]P[j,k]+ϵ S[t]X[i,j,k,l]))
] //. B[i__]B[j__]:> B[i,j] /.P[a_,b_] :> P[a,b][Min[a,b]]//. P[a_,b_][m1_]P[b_,c_][m2_] :> P[a,c][Min[m1,m2]] /. {P[i_, i_][m_] :> c[m], ((P[_,_][m_])^2):> c[m]}

ϵ B[1,3] c[3] S[2] X[1,5,2,4] P[1,4][1] P[2,5][2] /. X[i_,j_,k_,l_]P[i,j][m1_]P[k,l][m2_] :> (...)