Pensieve header: The naive Kh Program - aborted attempt to remove np/nm.

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

Sign[X[i_,j_,k_,l_]]/;j-l==1∨l-j>1 ^:= 1;
Sign[X[i_,j_,k_,l_]]/;l-j==1∨j-l>1 ^:= -1;
w[pd_]:=Plus@@(Sign/@pd);

Sign/@pd

w[pd]

SetAttributes[p,Orderless]

m_⋄n_:=Min[m,n];
S[pd_PD,a_List]:=Times@@({List@@pd,a}\[Transpose]/.{
{x:X[i_,j_,k_,l_],0}:>(q^((3/2)Sign[x]-(1/2)))(t^((1/2)Sign[x]-(1/2)))(Subscript[p[i,j], i⋄j])(Subscript[p[k,l], k⋄l]),
{x:X[i_,j_,k_,l_],1}:>(q^((3/2)Sign[x]+(1/2)))(t^((1/2)Sign[x]+(1/2)))(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}]
}

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

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

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

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

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

{V[pd, {0,0,0,1,0}] , d[pd, {0,0,★,1,0}]}

CC[pd_PD,r_,deg_]:=Select[Union@@((v@@#) V[pd,#,deg]&/@Tuples[{0,1},Length@pd]), Exponent[#,t]==r&]

CC[pd,-4,-9]

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]

{r,(w[pd]-Length[pd])/2,(w[pd]+Length[pd])/2}

Plus@@V[pd,Table[0,Length@pd]]

{deg,Exponent[Plus@@V[pd,Table[0,Length@pd]],q,Min], Exponent[Plus@@V[pd,Table[1,Length@pd]],q,Max]}

Kh1[pd_PD]:=Sum[(t^r)(q^deg)Betti[pd,r,deg],
{r,-Length@pd,Length@pd},
{deg,Exponent[Plus@@V[pd,Table[0,Length@pd]],q,Min], Exponent[Plus@@V[pd,Table[1,Length@pd]],q,Max],2}
]

Kh1[pd_PD]:=Sum[(t^r)(q^deg)Betti[pd,r,deg],
{r,-Length@pd,Length@pd},
{deg,-3Length@pd,3Length@pd,1}
]

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