Pensieve header: The naive Kh Program - a variant of the program I first wrote in Kyoto in September 2001.

\documentclass[11pt,notitlepage]{article}
\usepackage{dbnsymb, amsmath, amssymb, multicol, stmaryrd, pifont,
  amscd, colortbl, mathtools, wasysym, needspace, import, longtable,
  overpic, bbm, pdfpages, array, blkarray, setspace, graphicx, tensor}
\usepackage{txfonts}	% for the likes of \coloneqq.
\usepackage[usenames,dvipsnames]{xcolor}
\usepackage[textwidth=8in,textheight=10.5in,centering]{geometry}
\usepackage[setpagesize=false]{hyperref} % Following http://tex.stackexchange.com/a/847/22475
\hypersetup{colorlinks, linkcolor={blue!50!black}, citecolor={blue!50!black}, urlcolor={blue!50!black}}
\usepackage[export]{adjustbox}

\def\nbpdfInput#1{\vskip 1mm\par\noindent\includegraphics[max width=\linewidth]{#1}}
\def\nbpdfEcho#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfPrint#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfText#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfMessage#1{}
\def\nbpdfOutput#1{\vskip 1mm\par\noindent\includegraphics[max width=\linewidth]{#1}}
\def\nbpdfSubsection#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfSubsubsection#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfgraphInput#1{\vskip 1mm\par\noindent\includegraphics{#1}}
\def\nbpdfgraphOutput#1{\vskip 1mm\par\noindent\includegraphics[width=1.5in]{#1}}

\pagestyle{empty} \parindent 0in
\begin{document}
\setlength{\abovedisplayskip}{0.5ex} \setlength{\belowdisplayskip}{0.5ex}
\setlength{\abovedisplayshortskip}{0ex} \setlength{\belowdisplayshortskip}{0ex}

\def\myurl{http://www.math.toronto.edu/~drorbn}
\href{\myurl}{Dror Bar-Natan}:
\href{\myurl/classes}{Classes}:
\href{\myurl/classes/\#2223}{2022-23}:
\href{\myurl/classes/23-FastComputations}{Fast Computations in Knot Theory}:
{\bf A Naive Khovanov Homology Program}

\begin{multicols*}{2}

We load a knot theory package only for pre-loaded PD data and for comparisons with known KH results:

Once[<<KnotTheory`]

pd=PD[Knot[4,1]]

(SubPlus[n])[pd_PD]:=Count[pd,X[i_,j_,k_,l_]/;j-l==1∨l-j>1];
(SubMinus[n])[pd_PD]:=Count[pd,X[i_,j_,k_,l_]/;l-j==1∨j-l>1];

{(SubPlus[n])[pd], (SubMinus[n])[pd]}

SetAttributes[p,Orderless]

S[pd_PD,s_String]:=S[pd,Characters[s]/.{"0"->0,"1"->1, "*"->★}]

S[pd, "01*0"]

m_⋄n_:=Min[m,n];
S[pd_PD,a_List]:=Times@@({List@@pd,a}\[Transpose]/.{
{X[i_,j_,k_,l_],0}:>(Subscript[p[i,j], i⋄j])(Subscript[p[k,l], k⋄l]),
{X[i_,j_,k_,l_],1}:>(Subscript[p[i,l], i⋄l])(Subscript[p[j,k], j⋄k]),
{x_X,★}:>x}
)//.{
(Subscript[p[i_,j_], m_])(Subscript[p[j_,k_], n_]):>(Subscript[p[i,k], m⋄n])
}//.{
X[i_,j_,k_,l_] (Subscript[p[i_,j_], m_])(Subscript[p[k_,l_], n_]):>((Subscript[c, m])(Subscript[c, n])->(Subscript[c, m⋄n])),X[i_,j_,k_,l_] (Subscript[p[i_,l_], m_])(Subscript[p[j_,k_], n_]):>((Subscript[c, m⋄n])->(Subscript[c, m])(Subscript[c, n]))
}//.(Subscript[p[__], m_]^(_.)):>(Subscript[c, m])

{S[pd,"0100"],S[pd,"0110"],S[pd,"01*0"]}

{S[pd,"0000"],S[pd,"1000"],S[pd,"*000"]}

{S[pd,"1100"],S[pd,"1110"],S[pd,"11*0"]}

V[pd_PD,a_]:=List@@Expand[S[pd,a]/.(Subscript[c, x_]):>((Subscript[vp, x])+(Subscript[vm, x]))]

V[pd,"0100"]

d[pd_PD,a_]:=S[pd,a]/.{
((Subscript[c, x_])(Subscript[c, y_])->(Subscript[c, z_]))*_.:>{(Subscript[vp, x]) (Subscript[vp, y])->(Subscript[vp, z]),(Subscript[vp, x]) (Subscript[vm, y])->(Subscript[vm, z]),(Subscript[vm, x]) (Subscript[vp, y])->(Subscript[vm, z]),(Subscript[vm, x]) (Subscript[vm, y])->0},((Subscript[c, z_])->(Subscript[c, x_])(Subscript[c, y_]))*_.:>{(Subscript[vp, z])->(Subscript[vp, x]) (Subscript[vm, y])+(Subscript[vm, x]) (Subscript[vp, y]),(Subscript[vm, z])->(Subscript[vm, x]) (Subscript[vm, y])}
}

{S[pd, "01*0"],d[pd,"01*0"]}

{S[pd,"*000"], d[pd,"*000"]}

{S[pd,"11*0"], d[pd,"11*0"]}

{S[pd, "*000"] ,V[pd, "0000"], d[pd, "*000"]}

{V[pd, "0000"],V[pd, "0000"]/.d[pd, "*000"]}

udeg[P_]:=Exponent[P/.{(Subscript[v, a_]):>(q^(Total[a])),(Subscript[vp, _])->q,(Subscript[vm, _])->(q^(-1))},q]

udeg[(Subscript[v, {0,0,0,1,1}]) (Subscript[vm, 1])]

KC[pd_PD,r_]:=If[r<-(SubMinus[n])[pd]||r>(SubPlus[n])[pd],{},
Join@@((((Subscript[v, #])) V[pd,#])&/@Permutations[Table[0,(SubPlus[n])[pd]-r]~Join~Table[1,r+(SubMinus[n])[pd]]])
];
KC[pd_PD,r_,deg_]:=Cases[KC[pd,r],u_ /;udeg[u]-2(SubMinus[n])[pd]+(SubPlus[n])[pd]==deg]

KC[pd,1]

KC[pd,1,1]

dd[pd_PD][expr_]:=Expand[expr]/.s_*(Subscript[v, a_]):>Expand[σ=1;
Sum[
If[a[[i]]==0,σ*(Subscript[v, ReplacePart[a,1,i]])*s/.d[pd,List@@ReplacePart[a,★,i]],σ*=-1;0],{i,Length[a]}
]
]

KC[pd,0,1]//dd[pd]

KC[pd,0,1]//dd[pd]//dd[pd]

Rank[pd_PD,r_,deg_]:=(
B0=KC[pd,r,deg];
B1=KC[pd,r+1,deg];
If[B0=={}∨B1=={}, 0,
dB0=dd[pd][B0];
MatrixRank[Table[Coefficient[db0,b1],{db0,dB0},{b1,B1}]]
]
);

Rank[pd,1,1]

Betti[pd_PD,r_,deg_]:=Length[KC[pd,r,deg]]-Rank[pd,r,deg]-Rank[pd,r-1,deg]

Betti[pd,1,1]

Kh1[pd_PD]:=Sum[
(t^r)(q^deg)Betti[pd,r,deg],
{r,-(SubMinus[n])[pd],(SubPlus[n])[pd]},
{deg,Union[udeg/@KC[pd,r]]-2(SubMinus[n])[pd]+(SubPlus[n])[pd]}
]

Kh1[pd]

Timing@Table[
K->Kh[K][q,t]==Kh1[PD@K],
{K, AllKnots[{3,6}]}
]

\end{multicols*}

nb2tex$PDFWidth=8.5;

m_⋄n_:=Min[m,n];
Kh2[K_]:=Module[{pd,np,nm,p,S,a,★,c,V,vp,vm,d,udeg,KC,v,dd,σ,Rank,B0,B1,dB0,db0,b1,Betti},
pd=PD[K];
np=Count[pd,X[i_,j_,k_,l_]/;j-l==1∨l-j>1];
nm=Count[pd,X[i_,j_,k_,l_]/;l-j==1∨j-l>1];
SetAttributes[p,Orderless];
S[a_List]:=S[a]=Times@@({List@@pd,a}\[Transpose]/.{
{X[i_,j_,k_,l_],0}:>(Subscript[p[i,j], i⋄j])(Subscript[p[k,l], k⋄l]),
{X[i_,j_,k_,l_],1}:>(Subscript[p[i,l], i⋄l])(Subscript[p[j,k], j⋄k]),
{x_X,★}:>x}
)//.{
(Subscript[p[i_,j_], m_])(Subscript[p[j_,k_], n_]):>(Subscript[p[i,k], m⋄n])
}//.{
X[i_,j_,k_,l_] (Subscript[p[i_,j_], m_])(Subscript[p[k_,l_], n_]):>((Subscript[c, m])(Subscript[c, n])->(Subscript[c, m⋄n])),
X[i_,j_,k_,l_] (Subscript[p[i_,l_], m_])(Subscript[p[j_,k_], n_]):>((Subscript[c, m⋄n])->(Subscript[c, m])(Subscript[c, n]))
}//.(Subscript[p[__], m_]^(_.)):>(Subscript[c, m]);
V[a_]:=V[a]=List@@Expand[S[a]/.(Subscript[c, x_]):>((Subscript[vp, x])+(Subscript[vm, x]))];
d[a_]:=d[a]=S[a]/.{
((Subscript[c, x_])(Subscript[c, y_])->(Subscript[c, z_]))*_.:>{(Subscript[vp, x]) (Subscript[vp, y])->(Subscript[vp, z]),(Subscript[vp, x]) (Subscript[vm, y])->(Subscript[vm, z]),(Subscript[vm, x]) (Subscript[vp, y])->(Subscript[vm, z]),(Subscript[vm, x]) (Subscript[vm, y])->0},((Subscript[c, z_])->(Subscript[c, x_])(Subscript[c, y_]))*_.:>{(Subscript[vp, z])->(Subscript[vp, x]) (Subscript[vm, y])+(Subscript[vm, x]) (Subscript[vp, y]),(Subscript[vm, z])->(Subscript[vm, x]) (Subscript[vm, y])}
};
udeg[P_]:=Exponent[P/.{(Subscript[v, a_]):>(q^(Total[a])),(Subscript[vp, _])->q,(Subscript[vm, _])->(q^(-1))},q];
KC[r_]:=KC[r]=If[r<-nm||r>np,{},
Join@@((((Subscript[v, #])) V[#])&/@Permutations[Table[0,np-r]~Join~Table[1,r+nm]])
];
KC[r_,deg_]:=KC[r,deg]=Cases[KC[r],u_ /;udeg[u]-2nm+np==deg];
dd[expr_]:=Expand[expr]/.s_*(Subscript[v, a_]):>Expand[σ=1;
Sum[
If[a[[i]]==0,σ*(Subscript[v, ReplacePart[a,1,i]])*s/.d[List@@ReplacePart[a,★,i]],σ*=-1;0],{i,Length[a]}
]
];
Rank[r_,deg_]:=Rank[r,deg]=(
B0=KC[r,deg];
B1=KC[r+1,deg];
If[B0=={}∨B1=={}, 0,
dB0=dd[B0];
MatrixRank[Table[Coefficient[db0,b1],{db0,dB0},{b1,B1}]]
]
);
Betti[r_,deg_]:=Length[KC[r,deg]]-Rank[r,deg]-Rank[r-1,deg];
Sum[
(t^r)(q^deg)Betti[r,deg],
{r,-nm,np},
{deg,Union[udeg/@KC[r]]-2nm+np}
]
]

nb2tex$PDFWidth=4.5;

\begin{multicols*}{2}

Kh2[Knot[4,1]]

Timing@Table[
K->Kh[K][q,t]==Kh2[K],
{K, AllKnots[{3,6}]}
]

Timing[kh12={Kh2[Knot[5,1]], Kh2[Knot[10,132]]}]

Expand@Cancel[((kh12/.t->-1)/(q+(q^(-1))))]

{Jones[Knot[5,1]][(q^2)], Jones[Knot[10,132]][(q^2)]}

\end{multicols*}
\end{document} \endinput