Pensieve header: A concise implementation of the FastKh algorithm.

{DateString[],CFKh[Knot[10,165]]} // Timing

{DateString[], Plus @@ (CFKh[#]==Kh[#][q,t]& /@ AllKnots[{3,10}])} // Timing

K=TorusKnot[9,5]; {TubePlot[K, ImageSize -> 80]//Rasterize, KhPoly[K]} // Timing

<< KnotTheory`

SetAttributes[{P,S}, Orderless];
dot /: ((dot[_])^(k_)) := 0;
(σ_S)[i_] := σ[i] = First@Cases[σ, P[i,j_] :> j];

ECP[λ_List] := Module[{ρ, ec}, (* "Equivalence Class Projection" *)
ec=Fold[
(ρ = First /@ Position[#1, #2];
Append[Delete[#1, List /@ ρ], Union@@(#1[[ρ]])])&,
λ, Union @@ λ
] // SortBy[#, First]&;
Union@@Replace[ec, c_ :> ((# -> First[c])& /@ c), {1}]];
ECP[λ__S] := ECP[Join[λ] /. S|P->List];
ECR[λ__] := Union[Last /@ ECP[λ]]  (* "Equiv. Class Representatives" *);

VCLaw[β_S, μ_S, τ_S] := VCLaw[β,μ,τ]=Module[
{p, ins1, ins2, outs, χs, h, law1, law2, dec} ,
p=ECP[β,μ,τ];
ins1=ECR[β,μ]; ins2=ECR[μ,τ]; outs=ECR[β,τ];
χs = ((Times @@ (h/@ Join[ins1, ins2, outs] /. p))/( PowerExpand[(((Times @@ (h /@ (Last /@ p))))^(1/2))]));
dec = χs /. ((h[i_])^(χ_.)) :> (((2dot[i]))^((2-χ)/2));
dec *= Times @@ MapThread[If[#1==#2, 1, dot[#1]+dot[#2]]&,
{outs, outs/.p}];
law1=Table[dot[i]->dot[i/.p], {i,ins1}];
law2=Table[dot[i]->dot[i/.p], {i,ins2}];
{law1, law2, Expand[dec]}];
VC[Cob[β_S, μ_S, dots1_], Cob[μ_S, τ_S, dots2_]] := Module[
{law1, law2, dec}, {law1, law2, dec} = VCLaw[β,μ,τ];
Expand[dec*(dots1/.law1)(dots2/.law2)] ];

m0[i_,j_][σ_S] := m0[i,j][σ] = Which[
σ[i]≠j, Append[DeleteCases[σ, P[i,_]|P[_,j]], P[σ[i],σ[j]]],
σ[i]==j, DeleteCases[σ, P[i,j]]];
m[i_,j_][σ_S] := m0[i,j][σ]*If[σ[i]≠j, {1}, {q,(q^(-1))}];
m[i_,j_][(q^(k_.))σ_S] := (q^k)m[i,j][σ];

m[i_,j_][Cob[β_S, τ_S, dots_]] := Module[{p, ijdot, ndots, x},
p=ECP[β,τ]; ijdot=dot[Min[i,j]];
ndots = Which[
β[i]≠j && τ[i]≠j, {{If[(i/.p)≠(j/.p), 1, dot[β[i]]+dot[τ[i]]]}},
β[i]==j && τ[i]≠j, {{1, ijdot}},
β[i]≠j && τ[i]==j, {{ijdot},{1}},
β[i]==j && τ[i]==j, (({{ijdot, 0}, {1, ijdot}}))];
ndots=Expand[dots*ndots] /. dot[k_] :> dot[k /. {i->β[i], j->β[j]} /. {i->τ[i], j->τ[j]} /. ECP[m0[i,j][β],m0[i,j][τ]] ];
If[β[i]==j && τ[i]==j, Coefficient[ndots /. ijdot -> x, x], ndots]];

m[i_,j_][Kom[Ω_, d_]] := Kom[
Flatten /@ Map[m[i,j], Ω, {2}],
Table[
If[Length[Ω[[k]]]==0 || Length[Ω[[k+1]]]==0, 0,
Table[
m[i,j][Cob[Ω[[k,b]]/. q -> 1, Ω[[k+1, a]] /. q -> 1, d[[k,a,b]]]],
{a, Length[Ω[[k+1]]]}, {b, Length[Ω[[k]]]}
] // ArrayFlatten  ],
{k,Length[d]}]  ];

Kom /: (Kom[Ω_, d_]*Cob[(q^(p1_.))β_, (q^(p2_.))τ_, 1]) := Module[{L, ρ, δ, k},
L=Length[Ω]; (Subscript[ρ, k_]) := (Subscript[ρ, k])=Length[Ω[[k]]]; (Subscript[ρ, 0])=(Subscript[ρ, L+1])=0;
Kom[
MapThread[Join, List @@@ {
Append[Ω /. σ_S :> (q^p1)Join[β,σ], {}],
Prepend[Ω /. σ_S :> (q^p2)Join[τ,σ], {}] }],
Table[
If[(Subscript[ρ, k])+(Subscript[ρ, k-1])==0 || (Subscript[ρ, k+1])+(Subscript[ρ, k])==0, 0,
δ=Table[0, {(Subscript[ρ, k+1])+(Subscript[ρ, k])}, {(Subscript[ρ, k])+(Subscript[ρ, k-1])}];
If[(Subscript[ρ, k])(Subscript[ρ, k+1])≠0, δ[[1;;(Subscript[ρ, k+1]), 1;;(Subscript[ρ, k])]]=d[[k]]];
If[(Subscript[ρ, k])≠0, δ[[(Subscript[ρ, k+1])+1;;(Subscript[ρ, k+1])+(Subscript[ρ, k]), 1;;(Subscript[ρ, k])]]=(((-1))^k)IdentityMatrix[(Subscript[ρ, k])]];
If[(Subscript[ρ, k-1])(Subscript[ρ, k])≠0, δ[[(Subscript[ρ, k+1])+1;;(Subscript[ρ, k+1])+(Subscript[ρ, k]), (Subscript[ρ, k])+1;;(Subscript[ρ, k])+(Subscript[ρ, k-1])]]=d[[k-1]]];
δ
], {k,L}   ] ] ]

Contract[kom_Kom] := Module[{cs, ds, L, ρ, k, done, a, b, ϕ, γδ},
{cs, ds} = List @@ kom; L=Length[ds]; ρ[k_] := Length[cs[[k]]];
For[k=1, k≤L, ++k,
done=False; While[!done, done=True;
For[a=1, a≤ρ[k+1], ++a, For[b=1, b≤ρ[k], ++b,
If[NumberQ[ϕ=ds[[k,a,b]]] && ϕ≠0 && cs[[k+1,a]]==cs[[k,b]],
done=False;
If[ρ[k]>1 && ρ[k+1]>1,
γδ = Table[
VC[Cob[cs[[k,d]], cs[[k+1,a]], ds[[k,a,d]]] /. q -> 1,
Cob[cs[[k,b]], cs[[k+1,c]], ds[[k,c,b]]] /. q -> 1],
{c, ρ[k+1]}, {d, ρ[k]} ];
ds[[k]] = Expand[Drop[ds[[k]]-(ϕ^(-1))γδ, {a}, {b}]],
(* else *) ds[[k]]=0 ];
cs[[k]]=Drop[cs[[k]], {b}]; cs[[k+1]]=Drop[cs[[k+1]], {a}];
If[k>1,ds[[k-1]]=If[ds[[k-1]]===0, 0, Drop[ds[[k-1]], {b}]]];
If[k<L, ds[[k+1]] = If[ds[[k+1]]===0, 0, Drop[ds[[k+1]], {}, {a}]]];
If[a≤Length[cs[[k+1]]], --a]; b=Length[cs[[k]]]; ]  ]] ] ];
Kom[cs, ds]];

CFKh[L_] := Module[
{pd=PD[L], kom=Kom[{{S[]}},{}], inside={}, tp=0, pos},
While[Length[pd]>0,
pos = Last[Ordering[(Length[(List @@ #)⋂inside])& /@ pd]];
kom=kom*(pd[[pos]] /. {
X[i_,j_,k_,l_]/;(j-l==1||l-j>1) :>
Cob[q S[P[-i,j],P[k,-l]], (q^2)S[P[-i,-l],P[j,k]],1],
X[i_,j_,k_,l_]/;(l-j==1||j-l>1) :>
(--tp; Cob[(q^(-2))S[P[-i,-j],P[k,l]], (q^(-1))S[P[-i,l],P[-j,k]], 1])
});
(kom = Contract[kom // m[#, -#]])& /@ ((List@@pd[[pos]])⋂inside);
inside = inside⋃(List @@ pd[[pos]]); pd=Drop[pd, {pos}] ];
Expand[(t^(tp-1+Range[Length[First[kom]]])).(List @@ Plus @@@ First @ kom) /. S[] -> 1] ]