Dror Bar-Natan: Papers: Categorification:

Explaining the "Categorification.m" Program

The purpose of this document, written on September 17 2008 along with Jana Archibald, Zsuzsanna Dancso, Iva Halacheva, Louis Leung and Krzysztof Putyra is play around a bit with Dror's old "categorification.m" mathematica program, which computes Khovanov homology. Hopefully, Krzysztof will use this knowledge to produce a program to compute his variant of "odd" Khovanov homology. The original program is available at http://www.math.toronto.edu/~drorbn/papers/Categorification/Categorification.m. It is reproduced here in (mostly) red, with minor modifications to make it compliant with KnotTheory` conventions.

This Mathematica notebook is available at http://www.math.toronto.edu/~drorbn/papers/Categorification/CategorificationProgramExplained.nb.

First, let us load KnotTheory` :

<< KnotTheory`

PD conventions are explained at http://katlas.org/wiki/Planar_Diagrams.

pd=PD[Knot[5,2]]

First, for degree reasons, we need to count the positive and negative crossings in pd :

np[L_PD]:=Count[L,X[i_,j_,k_,l_]/;j-l==1||l-j>1];
nm[L_PD]:=Count[L,X[i_,j_,k_,l_]/;l-j==1||j-l>1];

?Count

{Count[pd, _Putyra], Count[pd, _X], Count[pd, X[i_, j_, k_]], Count[pd, X[i_, j_, k_, l_] /; l>j]}

{np[pd], nm[pd]}

Let' s implement the smoothing rules : X[i, j, k, l] -> either p[i, j] p[k, l] or p[i, l] p[j, k] . First. "p" must be "commutative" or ""Orderless":

SetAttributes[p,Orderless]

SetAttributes[p2, Orderless]

{p1[3,4,1,2], p2[3,4,1,2]}

We now go into the definition of "S", which stands for "Smoothing" : it gets an input which is a PD and either a list {0, 0, 1, 0} of zeros and ones or a string "0010".

S[L_PD,s_String]:=S[L,Characters[s]/.{"0"->0,"1"->1}]

Characters["Krzysztof"] // FullForm

Characters["Krzysztof"] /. {"K" -> 7, "f" -> 9}

S0[L_PD,s_String]:=S0[L,Characters[s]/.{"0"->0,"1"->1}]

S0[pd, "00110"]

Constructing the vertices of the Khovanov cube

First, a simple variant:

S1[L_PD, a_List] := {L,a};
S1[pd, {0,0,1,1,0}]

Thread[{{10,11,12},{1,2,3}}]

List @@ pd

S2[L_PD, a_List] := Thread[{List @@L,a}];
t1=S2[pd, {0,0,1,1,0}]

t2=t1 /. {
{X[i_,j_,k_,l_],0}:>p[i,j] p[k,l],
{X[i_,j_,k_,l_],1} :> p[i,l]p[j,k]
}

Times[2,3]

Times @@{1,2,3,4,5,6,7}

t3=Times @@ t2

t3 /. {p[i_,j_]p[j_,k_] :> p[i,k]} /. {p[i_,j_]p[j_,k_] :> p[i,k]}

t4=t3 //. {p[i_,j_]p[j_,k_] :> p[i,k]}

So our smoothing has 3 cycles!

t4 /. p[i_,j_]^2 :> c

"p[i,j][m]" means "a path from i to j, named m; by convention, a path is named after the minimal edge inside it.

S3[L_PD,a_List]:=Times@@(Thread[{List@@L,a}]/.{
{X[i_,j_,k_,l_],0}:>p[i,j][Min[i,j]] p[k,l][Min[k,l]],{X[i_,j_,k_,l_],1}:>p[i,l][Min[i,l]] p[j,k][Min[j,k]]
})

S3[pd, {0,0,1,1,0}]

S4[L_PD,a_List]:=Times@@(Thread[{List@@L,a}]/.{
{X[i_,j_,k_,l_],0}:>p[i,j][Min[i,j]] p[k,l][Min[k,l]],{X[i_,j_,k_,l_],1}:>p[i,l][Min[i,l]] p[j,k][Min[j,k]]
}) //.p[i_,j_][m_] p[j_,k_][n_]:>p[i,k][Min[m,n]];
S4[pd, {0,0,1,1,0}]

S5[L_PD,a_List]:=Times@@(Thread[{List@@L,a}]/.{
{X[i_,j_,k_,l_],0}:>p[i,j][Min[i,j]] p[k,l][Min[k,l]],{X[i_,j_,k_,l_],1}:>p[i,l][Min[i,l]] p[j,k][Min[j,k]]
}) //.p[i_,j_][m_] p[j_,k_][n_]:>p[i,k][Min[m,n]] /. p[_,_][m_]^_.:>c[m];
S5[pd, {0,0,1,1,0}]

{
S5[PD[Mirror[Knot[3,1]]], {0,0,0}],
S5[PD[Mirror[Knot[3,1]]], {0,1,0}],
S5[PD[Mirror[Knot[3,1]]], {0,1,1}]
}

Yet, we want S to also understand "*" s!

S[L_PD,a_List]:=Times@@(Thread[{List@@L,a}]/.{
{X[i_,j_,k_,l_],0}:>p[i,j][Min[i,j]] p[k,l][Min[k,l]],{X[i_,j_,k_,l_],1}:>p[i,l][Min[i,l]] p[j,k][Min[j,k]],
{x_X,"*"}:>x})//.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[_,_][m_]^_.:>c[m]

{
S[PD[Mirror[Knot[3,1]]], {0,0,0}],
S[PD[Mirror[Knot[3,1]]], {0,1,0}],
S[PD[Mirror[Knot[3,1]]], {0,"*",0}]
}

{
S[PD[Mirror[Knot[5,2]]], "00010"],
S[PD[Mirror[Knot[5,2]]], "00110"],
S[PD[Mirror[Knot[5,2]]], "00*10"]
}

S6[L_PD,a_List]:=Times@@(Thread[{List@@L,a}]/.{
{X[i_,j_,k_,l_],0}:>p[i,j][Min[i,j]] p[k,l][Min[k,l]],{X[i_,j_,k_,l_],1}:>p[i,l][Min[i,l]] p[j,k][Min[j,k]],
{x_X,"*"}:>x})//.p[i_,j_][m_] p[j_,k_][n_]:>p[i,k][Min[m,n]]

S6[PD[Mirror[Knot[5,2]]], Characters["00*10"]/.{"0"->0,"1"->1}]

S6[PD[Mirror[Knot[5,2]]], Characters["00*10"]/.{"0"->0,"1"->1}] /. X[i_,j_,k_,l_] p[i_,j_][m_] p[k_,l_][n_]:>(c[m] c[n]->c[Min[m,n]])

Permutations[{1,2,3,3}]

Permutations[{0,0,0,1,"*"}]

f/@{1,2,3}

S/@Permutations[{0,0,0,1,"*"}]

S7[a_] := S[pd, a];
S7/@Permutations[{0,0,0,1,"*"}]

Define the degree of an arbitrary combination of v_ + and v_ - ' s :

Deg[expr_]:=Count[expr,_vp,{0,1}]-Count[expr,_vm,{0,1}]

{Deg[vp[6]vp[7]], Deg[vp[6]vm[7]]}

t5=vp[6]vp[7]

Head[t5]

t5[[1]]

Head[t5[[1]]]

t5[[1]][[1]]

t5[[1,1]]

V[L, a] is the vector space sitting at a for L, V[L, a, deg] will be the degree deg part of V[L, a]:

V[L_PD,s_String,deg___]:=V[L,Characters[s]/.{"0"->0,"1"->1},deg]
V[L_PD,a_List]:=List@@Expand[S[L,a]/.x_c:>((vp@@x)+(vm@@x))]
V[L_PD,a_List,deg_Integer]:=Select[V[L,a],(deg==Deg[#]+(Plus@@a))&]

S[pd,"00010"]

t6=S[pd,"00010"]/.x_c:>((vp@@x)+(vm@@x))

t7=Expand[t6]

t8=List @@ t7

Select[t8, #==vm[1]vm[3]&]

Select[t8, Deg[#]==0&]

Defining the edge morphisms :

d[L_PD,s_String]:=d[L,Characters[s]/.{"0"->0,"1"->1}]
d[L_PD,a_List]:=S[L,a]/.{(c[x_]c[y_]->c[z_])*_.:>{vp@x vp@y->vp@z,vp@x vm@y->vm@z,vm@x vp@y->vm@z,vm@x vm@y->0},(c[z_]->c[x_]c[y_])*_.:>{vp@z->vp@x vm@y+vm@x vp@y,vm@z->vm@x vm@y}}

d[pd, #]& /@Permutations[{0,0,0,1,"*"}]

{V[pd, "00010"] , d[pd, "00*10"]}

Expand[V[pd, "00010"] /. d[pd, "00*10"]]

The "column" direct sums :

KhBracket[L_PD,r_Integer,deg___]:=If[r<0||r>Length[L],{0},Join@@(((v@@#) V[L,#,deg])&/@Permutations[Join[Table[0,{Length[L]-r}],Table[1,{r}]]])]

CC[L_PD,r_Integer,deg_Integer]:=KhBracket[L,r+nm[L],deg-np[L]+2nm[L]]

KhBracket[pd,1]

The differential

d[L_PD][expr_]:=Expand[expr]/.s_*a_v:>Expand[sign=1;Sum[
If[a[[i]]==0,sign*ReplacePart[a,1,i]*s/.d[L,List@@ReplacePart[a,"*",i]],sign*=-1;0],{i,Length[a]}
]]

t9=d[pd][v[0,0,1,0,0] vm[3] vp[1]]

d[pd][t9]

Options[Betti]={Modulus->Infinity}
Rank[L_PD,r_Integer,deg_Integer,opts___]:=Rank[L,r,deg,opts]=(
modulus=(Modulus/.{opts}/.Options[Betti]);
Off[Solve::svars];
b0=CC[L,r,deg];
l1=Length[b1=CC[L,r+1,deg]];
eqs=(#==0)&/@d[L][b0]/.MapThread[Rule,{b1,vars=Array[b,l1]}];
rk=Which[
b0=={}||l1==0,
0,modulus===Infinity,Length[First[Solve[eqs,vars]]],
True,Length[First[Solve[Append[eqs,Modulus==modulus],vars,Mode->Modular]]]-1
];
On[Solve::svars];
rk
)
Betti[L_PD,r_Integer,deg_Integer,opts___]:=Betti[L,r,deg,opts]=(b=Length[CC[L,r,deg]]-Rank[L,r,deg,opts]-Rank[L,r-1,deg,opts];
Print[StringForm["Betti[``,``] = ``",r,deg,b]];b)

qBetti[L_PD,r_Integer,opts___]:=(degs=Union[Deg/@KhBracket[L,r+nm[L]]]+np[L]-nm[L]+r;
(Betti[L,r,#,opts]&/@degs).q^degs)

Kh1[L_PD,opts___]:=Kh1[L,opts]=Expand[Sum[t^r*qBetti[L,r,opts],{r,-nm[L],Length[L]-nm[L]}]]

Kh1[PD[Knot[3,1]]]