Pensieve header: The naive Kh Program.

\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}}

\def\nbpdfInput#1{\vskip 1mm\par\noindent\includegraphics{#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}

\begin{multicols*}{2}

SetDirectory["C:\\drorbn\\AcademicPensieve\\Classes\\23-FastComputations"];
Once[<<KnotTheory`]

pd=PD[Knot[5,2]]

np[pd_PD]:=Count[pd,X[i_,j_,k_,l_]/;j-l==1∨l-j>1];
nm[pd_PD]:=Count[pd,X[i_,j_,k_,l_]/;l-j==1∨j-l>1];

{np[pd], nm[pd]}

SetAttributes[p,Orderless]

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

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[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"]
}

Deg[P_]:=Count[P,(Subscript[vp, _]),{0,1}]-Count[P,(Subscript[vm, _]),{0,1}]

{Deg[(Subscript[vp, 6])(Subscript[vp, 7])], Deg[(Subscript[vp, 6])(Subscript[vm, 7])]}

V[pd_PD,a_]:=List@@Expand[S[pd,a]/.(Subscript[c, x_]):>((Subscript[vp, x])+(Subscript[vm, x]))]
V[pd_PD,a_,deg_]:=Select[V[pd,a],(deg==Deg[#]+(Plus@@a))&]

V[pd,{0,0,0,0,0}]

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])}}

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

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

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

KhBracket[pd_PD,r_,deg___]:=If[r<0||r>Length[pd],{},Join@@(((v@@#) V[pd,#,deg])&/@Permutations[Join[Table[0,Length@pd-r],Table[1,r]]])]
CC[pd_PD,r_,deg_]:=KhBracket[pd,r+nm[pd],deg-np[pd]+2nm[pd]]

KhBracket[pd,2]

d[pd_PD][expr_]:=Expand[expr]/.s_*a_v:>Expand[sign=1;Sum[
If[a[[i]]==0,sign*ReplacePart[a,1,i]*s/.d[pd,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]

Rank[pd_PD,r_,deg_]:=(*Rank[pd,r,deg]=*)Module[{b0,b1,db0,ds0,s1},
b0=CC[pd,r,deg]; b1=CC[pd,r+1,deg];
If[b0=={}∨b1=={}, 0,
db0=d[pd][b0];
MatrixRank[Table[Coefficient[ds0,s1],{ds0,db0},{s1,b1}]]
]
];

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

qBetti[pd_PD,r_]:=(degs=Union[Deg/@KhBracket[pd,r+nm[pd]]]+np[pd]-nm[pd]+r;
(Betti[pd,r,#]&/@degs).(q^degs))

Kh1[pd_PD]:=Expand[Sum[(t^r)qBetti[pd,r],{r,-nm[pd],Length[pd]-nm[pd]}]]

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

(1/(q^3))+(1/q)+(1/((q^9) (t^3)))+(1/((q^5) (t^2)))

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

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