Pensieve header: Improving KnotTheory`’s ColouredJones by using the built in QPochhammer / QBinomial, following Stavros.

<< KnotTheory`

?ColouredJones

{K=Knot[8,17], n=4}

(j1=ColouredJones[K, n, Program->"Braid"][q]) // Timing

False && (j2=ColouredJones[K//PD, n][q]) // Timing

j1==j2

Changes below, relative to current program:
* Remove qExpand.
* Remove qPochhammer[___], replace by FunctionExpand[QPochhammer[___]] in two places.
* Same for qBinomial.

(* qQBin[n_,k_Integer,q_]/;k≥0:=qQBin[n,k,q]=FunctionExpand[QPochhammer[q^(n-k+1),q,k]/QPochhammer[q,q,k]];
qQBin[n_,k_Integer,q_]/;k<0:=qQBin[n,k,q]=0;*)
qQBin[n_,k_,q_] := If[0≤k≤n, QBinomial[n,k,q],0];

Summand[K_,n_]/;Head[K]=!=BR:=Summand[BR[K],n]
Summand[BR[s_,l_List],n_]:=Module[{i,eqns,v,vars,sol,nulls,a=Range[s],m=s,j,B,summand},B=Times[Times@@(l/.{j_Integer/;j>0:>Xp[a[[j]],a[[j+1]],a[[j]]=++m,a[[j+1]]=++m],j_Integer/;j<0:>Xm[a[[-j]],a[[1-j]],a[[-j]]=++m,a[[1-j]]=++m]}),Product[cl[a[[j]],j],{j,2,s}],bt[1]*tp[a[[1]]]];
i=0;
eqns=Flatten[(List@@B)/.{Xp[a_,b_,c_,d_]:>{v[a]-k[++i]==v[d],v[b]+k[i]==v[c]},Xm[a_,b_,c_,d_]:>{v[a]+k[++i]==v[d],v[b]-k[i]==v[c]},cl[a_,b_]:>{v[a]==v[b]},(bt|tp)[a_]:>{v[a]==0}}];
vars=v/@(Union@@Apply[List,List@@B,{1}]);
sol=First@Solve[eqns,vars];
nulls=Union[Cases[Cases[Last/@sol,HoldPattern[Times[-1,_]|Plus[Times[-1,_]..]]],_k,Infinity]];
i=0;
summand=B/.{Xp[a_,b_,_,_]:>(++i;
q^(n/2)*q^(v[b](k[i]-v[a]))*qQBin[v[a],k[i],1/q]*q^(v[b]*n)*QPochhammer[q^(n-v[b]),1/q,k[i]]),Xm[a_,b_,_,_]:>(++i;
q^(-n/2)*q^(-v[a](k[i]-v[b]))*qQBin[v[b],k[i],q]*q^(-v[a]*n)*QPochhammer[q^(-n+v[a]),q,k[i]]),cl[a_,b_]:>q^((2v[a]-n)/2),(_bt)|(_tp):>1}/.sol/.((#->0)&/@nulls);
vars=Union[Cases[summand,_k,Infinity]];
{summand/.q->CJ`q,vars}/.Thread[Rule[vars,Array[CJ`k,Length[vars]]]]]

CJStavros[b_BR,n_Integer,opts___]:=Module[{compute=Compute/.{opts}/.Options[ColouredJones],s1,vars1,s2,vars2,s,vars,rule,nv,out=0,jj},If[!compute,NotAvailable,{s1,vars1}=Summand[b,n];
{s2,vars2}=Summand[Mirror[b],n];
If[Length[vars1]≤Length[vars2],{vars,s}={vars1,s1};rule={CJ`q->#},{vars,s}={vars2,s2};rule={CJ`q->1/#}];
s=Together[FunctionExpand[s]]//Expand;
nv=Length[vars];
Do[out+=Expand[FunctionExpand[s/.Thread[Rule[vars,IntegerDigits[jj,n+1,nv]]]]],{jj,(n+1)^nv}];
Function@@{Expand[Simplify[out/.rule]]}]]

(j3=CJStavros[K//BR, n][q]) // Timing

j1==j3

(j4=ColouredJones[K, n, Program -> "Braid"][q]) // Timing