Pensieve header: Implementing KH, day 4.

{,,, ({{"Nice dragon"}, {"curves, Lennart!"}})}

{,,, "Nice tori, Jesse!"}

{, "Nice foliation, Jonathan!"}

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.

Import["http://www.math.toronto.edu/~drorbn/papers/Categorification/QRG.png"]

Road map:
1. Produce all the info in a “cube of smoothings”.
2. Produce a commuting cube of vector spaces and maps between them.
3. Produce a complex.
4. Compute homology.
5. Package everything nicely (almost) for public consumption.

K[3,1]=Xm[1,4,2,5] Xm[3,6,4,1] Xm[5,2,6,3];
K[5,1]=Xm[1,6,2,7] Xm[3,8,4,9] Xm[5,10,6,1] Xm[7,2,8,3] Xm[9,4,10,5];
K[10,132]=Xm[5,12,6,13] Xm[9,16,10,17] Xm[11,6,12,7]Xm[13,20,14,1] Xm[15,18,16,19] Xm[17,10,18,11] Xm[19,14,20,15] Xp[2,8,3,7] Xp[4,2,5,1] Xp[8,4,9,3];

SetAttributes[{p,dx},Orderless];
S[K_] := Module[{α=0,ϵ,X,Z},
ϵ /: (ϵ^(_)) =0;
Z=Expand[
dx[]K/. {
(Xp|Xm)[i_,j_,k_,l_] :> (++α; 
p[i,j]p[k,l]+dx[α]p[i,l]p[j,k]+ϵ e[α]X[i,j,k,l])
} /. p[i_,j_] :> p[i,j][Min[i,j]]
] //. p[i_,j_][m_]p[j_,k_][n_] :> p[i,k][Min[m,n]] /. {
X[i_,j_,k_,l_]p[i_,j_][m_]p[k_,l_][n_] :>  (c[m]c[n]->c[Min[m,n]]),
X[i_,j_,k_,l_]p[i_,l_][m_]p[j_,k_][n_] :> (c[Min[m,n]]->c[m]c[n])
}/. 
((p[i_,j_][m_])^(_.)):>c[m] //. dx[i___]dx[j___]:> dx[i,j];
CoefficientList[Z,ϵ,{2}]
]

({S0,S1}=S[K[3,1]]) //Column

V0=List@@Expand[S0 /. c[i_] :> vp[i]+vm[i]]

sign[αs_List,β_Integer]:= Module[{s=1}, Do[
If[α<β, s*=-1],
{α, αs}
]; s]

sign[{1,2,5,8,11}, 7]

Count[{1,2,5,8,11}, 5]

Count[{1,2,5,8,11},7]

Count[{1,2,5,8,11}, x_ /; x<7]

Clear[sign]

sign[αs_List,β_Integer]:= (((-1))^(Count[αs, α_ /; α<β]))

sign[{1,2,5,8,11}, 7]

Clear[d]

d[dx[αs___]e[β_]cs_.(c[i_]c[j_]->c[k_])] := {s=sign[{αs},β];
dx[αs]vp[i]vp[j]->s dx[αs,β]vp[k],
dx[αs]vm[i]vp[j]->s dx[αs,β]vm[k],
dx[αs]vp[i]vm[j]->s dx[αs,β]vm[k],
dx[αs]vm[i]vm[j]->0,
dx[βs___] /; {βs}=!={αs} :> 0
};
d[dx[αs___]e[β_]cs_.(c[k_] -> c[i_]c[j_])] := {s=sign[{αs},β];
dx[αs]vp[k]->s dx[αs,β](vp[i]vm[j]+vm[i]vp[j]),
dx[αs]vm[k]->s dx[αs,β]vm[i]vm[j],
dx[βs___] /; {βs}=!={αs} :> 0
}

V0 /. d[dx[3] e[2] (c[1] c[2]->c[1])]

V0 /. d[dx[1,3] e[2] (c[1]->c[1] c[2])]

To do: 1. Signs. 2. Deg. 3. C0[r,d]. 4. d0[r]. 4.5. Verify d0//d0==0. 5. rankr=20[r,d]. 6. Put it all together!

V0

Dim[dx[αs___]rest_] := Length@{αs} ;
Deg[dx[αs___]rest_] := Length@{αs} + Count[rest, _vp,{0,1}] - Count[rest,_vm,{0,1}]

Deg /@ V0

Count[f[1,3,3,4], 3]

C0[r_,d_] := Select[V0, (Deg[#]==d∧Dim[#]==r)&]

C0[2,1]

Cases[{1,2,a,b,c}, _Symbol]

Cases[{1,2,a,b,c}, _Integer]

Clear[C0];C0[r_,d_] := Cases[V0, αs_dx rest_ /; Length@αs==r∧Deg[αs rest]==d];
C0[r_] := Cases[V0, αs_dx rest_ /; Length@αs==r];

C0[2,1]

r=2

Clear[d0];
d0[r_][expr_]:= Plus@@(expr /. (d/@Select[List@@S1, Dim[#]==r&]))

? /.

C0[1]

d0[1] /@ C0[1]

d0[2] /@ (d0[1] /@ C0[1])

d0[1] /@ (d0[0] /@ C0[0])

{1,2,3} /. {n_Integer :> (n^2), n_Integer :> (n^3)}

{1,2,3} /. {{n_Integer :> (n^2)}, {n_Integer :> (n^3)}}

Plus@@({1,2,3} /. {{n_Integer :> (n^2)}, {n_Integer :> (n^3)}})

Deg/@C0[2]

{r=2, deg=3}

Expand[d0[r] /@ C0[r,deg]]

C0[r+1,deg]