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

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

Once[<<KnotTheory`]

PD[Knot[10,132]]

Alexander[Knot[10,132]][t]

pd=PD[Knot[4,1]]

DrawPD[pd]

Count[{1,2,3,3,2,4,3,2,1},2]

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

{0,1,1,0,1}

"010001"

Characters["Yusuke"]

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

S[pd, "01*0"]

m_⋄n_:=Min[m,n];

a={0,1,0,0}

{List@@pd,a}//MatrixForm

{List@@pd,a}\[Transpose]

{List@@pd,a}\[Transpose]

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

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

a={0,1,★,0};
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])
}

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,{1,0,0,0}]

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

a={0,1,0,0}

S[pd,a]

S[pd,a]/.(Subscript[c, x_]):>((Subscript[vp, x])+(Subscript[vm, x]))

Expand[S[pd,a]/.(Subscript[c, x_]):>((Subscript[vp, x])+(Subscript[vm, x]))]

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"]}//Column

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

Exponent[(q^7),q]

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

udeg[(Subscript[vm, 1]) (Subscript[vm, 2]) (Subscript[vp, 3])]

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

Table[0,3]

Table[1,2]

Table[0,3]~Join~Table[1,2]

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

Permutations[{1,2,3,4}]//Length

Permutations[Table[i,{i,11}]]//Length

11!

Permutations[Table[0,3]~Join~Table[1,2]]

With[{r=1},
Permutations[Table[0,(SubPlus[n])[pd]-r]~Join~Table[1,r+(SubMinus[n])[pd]]]
]

f[x_]:=(x^2)

f[3]

f/@{1,2,3,4,5}

(((#)^2)+#)& /@{1,2,3,4,5}

With[{r=1},
((((Subscript[v, #])) V[pd,#])&/@Permutations[Table[0,(SubPlus[n])[pd]-r]~Join~Table[1,r+(SubMinus[n])[pd]]])
]

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]

KC[pd,0,1]//Length

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]

Kh1[PD[Knot[8,17]]]

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

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

Kh2[Knot[4,1]]

Kh2[Knot[8,17]]

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

{DrawPD[Knot[5,1]],DrawPD[Knot[10,132]]}

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

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

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