Pensieve header: Implementing KH, day 6 (Alt kernel).

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.

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[4,1]=Xm[2,7,3,8] Xm[6,3,7,4] Xp[4,2,5,1] Xp[8,6,1,5];
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[6,1]=Xm[1,4,2,5] Xm[5,12,6,1] Xm[7,10,8,11] Xm[11,6,12,7] Xp[3,9,4,8] Xp[9,3,10,2];
K[7,4]=Xp[2,12,3,11] Xp[4,10,5,9] Xp[6,2,7,1] Xp[8,14,9,13] Xp[10,4,11,3] Xp[12,6,13,5] Xp[14,8,1,7];
K[8,17]=Xm[2,13,3,14] Xm[4,9,5,10] Xm[8,3,9,4] Xm[12,5,13,6] Xp[6,2,7,1] Xp[10,16,11,15] Xp[14,8,15,7] Xp[16,12,1,11];
K[9,42]=Xm[1,4,2,5] Xm[5,10,6,11] Xm[6,15,7,16] Xm[14,7,15,8] Xp[3,9,4,8] Xp[9,3,10,2] Xp[12,18,13,17] Xp[16,12,17,11] Xp[18,14,1,13];
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];

Kh[K_] := Module[
{p,dx,e,α,ϵ,X,Z,c,S0,S1,vm,vp,V0,sign,d,s,Deg,C0,Dim,d0,d0rule,r0,im,bas1,mat,β0,Kh0},
SetAttributes[{p,dx},Orderless];
ϵ /: (ϵ^(_)) =0;
α=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];
{S0,S1} = CoefficientList[Z,ϵ,{2}];
V0=List@@Expand[S0 /. c[i_] :> vp[i]+vm[i]];
sign[αs_List,β_Integer]:= (((-1))^(Count[αs, α_ /; α<β]));
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
};
Deg[dx[αs___]rest_] := Length@{αs} + Count[rest, _vp,{0,1}] - Count[rest,_vm,{0,1}];
C0[r_,deg_] := Cases[V0, αs_dx rest_ /; Length@αs==r∧Deg[αs rest]==deg];
Dim[dx[αs___]rest_] := Length@{αs};
d0rule[r_] := d0rule[r] = d/@Select[List@@S1, Dim[#]==r&];
d0[r_][expr_]:= Plus@@(expr /. d0rule[r]);
r0[r_,deg_] := r0[r,deg]=(
im=Expand[d0[r] /@ C0[r,deg]];
bas1=C0[r+1,deg];
If[im=={}∨bas1=={}, 0,
mat=Table[
Coefficient[x,y],
{x,im}, {y,bas1}
];
MatrixRank[mat]
]
);
β0[r_,deg_]:=Length@C0[r,deg] - r0[r,deg]-r0[r-1,deg];
Kh0=Sum[(t^r)(q^deg)β0[r,deg],
{r,0,Length[K]},{deg,Union[Deg /@ V0]}
];
np=Count[K,_Xp]; nm=Count[K,_Xm];
Expand[(t^(-nm))(q^(np-2nm))Kh0]
]

Kh[K[3,1]]

Kh[K[5,1]] // Timing

Kh[K[6,1]] // Timing

Kh[K[7,4]] // Timing

Kh[K[8,17]] // Timing

Kh[K[10,132]] // Timing

(1/(q^5))+(1/(q^3))+(1/((q^15) (t^5)))+(1/((q^11) (t^4)))+(1/((q^11) (t^3)))+(1/((q^7) (t^2))) == (1/(q^3))+(1/q)+(1/((q^15) (t^7)))+(1/((q^11) (t^6)))+(1/((q^11) (t^5)))+(1/((q^9) (t^4)))+(1/((q^7) (t^4)))+(1/((q^9) (t^3)))+(1/((q^5) (t^3)))+(2/((q^5) (t^2)))+(1/(q t)) /. t->-1

The “Timing” is pathetic! Ideas:
1. Compute r0 only once.
2. Avoid re-computing d0[r][x].
3. Avoid re-computing d0[r].
4. Use SparseArray.