Pensieve header:  Profile with encapsulation of Zip3-Inner; CCF is traced. Time to K31@$k=3: 8039.11.

Startup

Date[]
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\FullDoPeGDO"];
Once[<<KnotTheory`];
Once[Get@"../Profile/Profile.m"];
$k=1;
<<Objects.m
<<KT.m

Engine

Canonical Forms:

mlc=0;
CCF[ℰ_] := (Subscript[PP, CCF])@Module[{nℰ}, (*Coefficient Canonical Form *)
nℰ=ExpandDenominator@ExpandNumerator@Together[ℰ];
If[LeafCount[nℰ]>mlc,mlc=LeafCount[nℰ]; EchoLabel["With LeafCount=="<>ToString[mlc]<>", nℰ is"][nℰ]];
nℰ];
CF[ℰ_] := (Subscript[PP, CF])@Module[
{vs=Cases[ℰ,(Subscript[(y|a|x|η|β|τ|ξ), _]),∞]⋃{y,a,x,η,β,τ,ξ}},
Total[(CCF[#[[2]]](Times@@(vs^(#[[1]]))))& /@ CoefficientRules[ℰ, vs]]
];
CF[ℰ_𝔼]:=CF/@ℰ; 
CF[ℰ_List]:=CF/@ℰ; 
CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];

Variables and their duals:

{(SuperStar[t]),(SuperStar[b]),(SuperStar[y]),(SuperStar[a]),(SuperStar[x]),(SuperStar[z]),(SuperStar[τ]),(SuperStar[β]),(SuperStar[η]),(SuperStar[α]),(SuperStar[ξ]),(SuperStar[ζ])}={τ,β,η,α,ξ,ζ,t,b,y,a,x,z}; 
(SuperStar[(vs_List)]):=(v|->(SuperStar[v]))/@vs;
(SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

Weights:

Clear[Wt];
Evaluate[Wt/@{y,b,t,a,x,η,β,τ,α,ξ}]={1,0,0,2,1,1,2,2,0,1};
Wt[(Subscript[u_, i_])]:=Wt[u];

The maximal weight $n, i.e. the n of gl(n). Initially and for a long while this will not be tested beyond $n==2.

$n=2;

Upper to lower and lower to Upper:

U2l[ℰ_]:=ℰ/.{(Subscript[B, i_]^(p_.)):>(E^(-p ℏ (Subscript[b, i]))),(B^(p_.)):>(E^(-p ℏ b)), (Subscript[T, i_]^(p_.)):>(E^(p ℏ (Subscript[t, i]))),(T^(p_.)):>(E^(p ℏ t)),(Subscript[𝒜, i_]^(p_.)):>(E^(p (Subscript[α, i]))),(𝒜^(p_.)):>(E^(p α))}; 
l2U[ℰ_]:=ℰ//.{(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c/ℏ))(E^d),(E^(c_.b+d_.)):>(B^(-c/ℏ))(E^d),(E^(c_.(Subscript[t, i_])+d_.)):>(Subscript[T, i]^(c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^c)(E^d),(E^(c_.α+d_.)):>(𝒜^c)(E^d),(E^(𝒳_)):>(E^(Expand@𝒳))};
l2U[r_Rule]:=Module[{U=r[[1]]/.{b->B,t->T,α->𝒜}},U->l2U[U2l[U]/.r]];
AlsoUpper[rs_List] := rs⋃(l2U/@rs);

Derivatives in the presence of exponentiated variables:

(Subscript[D, b])[f_]:=(∂_b)f-ℏ B(∂_B)f; (Subscript[D, (Subscript[b, i_])])[f_]:=(∂_(Subscript[b, i]))f-ℏ (Subscript[B, i])(∂_(Subscript[B, i]))f;
(Subscript[D, t])[f_]:=(∂_t)f+ℏ T(∂_T)f; (Subscript[D, (Subscript[t, i_])])[f_]:=(∂_(Subscript[t, i]))f+ℏ (Subscript[T, i])(∂_(Subscript[T, i]))f; 
(Subscript[D, α])[f_]:=(∂_α)f+𝒜 (∂_𝒜)f; (Subscript[D, (Subscript[α, i_])])[f_]:=(∂_(Subscript[α, i]))f+(Subscript[𝒜, i]) (∂_(Subscript[𝒜, i]))f;
(Subscript[D, v_])[f_]:=(∂_v)f;

𝔼 operations:

ℰ_𝔼[$]:=Length[ℰ]-1; (Subscript[𝔼, _])[ℰs___][$]:=𝔼[ℰs][$];ℰ_𝔼[k_Integer]:=ℰ[[k+1]]; (Subscript[𝔼, _])[ℰs___][k_Integer]:={ℰs}[[k+1]];
𝔼/:ℰ1_𝔼≡ℰ2_𝔼:=Inner[CF@#1==CF@#2&, ℰ1,ℰ2,And];
(Subscript[𝔼, d1_->r1_])[ℰ1s___]≡(Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (d1==d2)∧(r1==r2)∧(𝔼[ℰ1s]≡𝔼[ℰ2s]);
𝔼/:ℰ1_𝔼*ℰ2_𝔼:=𝔼@@Table[CF[ℰ1[kk]+ℰ2[kk]],{kk,0,Min[ℰ1[$],ℰ2[$]]}];
(Subscript[𝔼, d1_->r1_])[ℰ1s___](Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[ℰ1s]𝔼[ℰ2s]);

(Subscript[𝔼, d1_->r1_])[ℰ1s___]//(Subscript[𝔼, d2_->r2_])[ℰ2s___] :=Module[{is=r1⋂d2,lvs},
lvs=Flatten@Table[{(Subscript[y, $@i]),(Subscript[b, $@i]),(Subscript[t, $@i]),(Subscript[a, $@i]),(Subscript[x, $@i])},{i,is}];
(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@((Subscript[Zip, lvs⋃(SuperStar[lvs])])[{(SuperStar[lvs]).lvs,Times[
𝔼[ℰ1s]/.Table[(Subscript[(v:b|B|t|T|a|x|y), i])->(Subscript[v, $@i]),{i,is}],
𝔼[ℰ2s]/.Table[(Subscript[(v:β|τ|α|𝒜|ξ|η), i])->(Subscript[v, $@i]),{i,is}]
]}])
]

(Subscript[Λ2𝔼, d_->r_])[Λ_]:=Module[{k},(Subscript[𝔼, d->r])@@l2U@Table[SeriesCoefficient[Λ,{ϵ,0,k}],{k,0,$k}]];

Zipping! Lemmas 2 and 3 are combined, yet they must be applied first to the middle weight variables and then to the heavy and light variables.

(Subscript[Zip, vs_])[{ℱ_,ℰ_}]:={ℱ,ℰ}//(Subscript[Zip1, vs])//(Subscript[Zip2, Select[vs,(0<Wt[#]<$n)&]])//(Subscript[EZip3, Select[vs,(0<Wt[#]<$n)&]])//(Subscript[Zip2, Select[vs,(Wt[#]==0∨Wt[#]==$n)&]])//(Subscript[Zip3, Select[vs,(Wt[#]==0∨Wt[#]==$n)&]])//Last;

Getting rid of the quadratic.

(Subscript[Zip1, {}])=Identity;
(Subscript[Zip1, vs_])@{ℱ_,𝔼[Q_,P___]} := (Subscript[PP, Zip1])@Module[{ℐ,F,G,u,v},
ℐ=IdentityMatrix@Length@vs;
F=Table[If[Wt[u]+Wt[v]==$n,(∂_((SuperStar[u]),(SuperStar[v])))ℱ,0],{u,vs},{v,vs}];
G=Table[If[Wt[u]+Wt[v]==$n,(∂_(u,v))Q,0],{u,vs},{v,vs}];
{CF[(SuperStar[vs]).(F.Inverse[ℐ-G.F]).(SuperStar[vs])/2], 𝔼[CF[Q-Log[Det[ℐ- G.F]]/2-vs.G.vs/2],P]}
]

Getting rid of linear terms.

(Subscript[Zip2, {}])=Identity;
(Subscript[Zip2, vs_])@{ℱ_,𝔼[Q_,P___]} := (Subscript[PP, Zip2])@Module[{F,Y,u,v},
F=Table[If[Wt[u]+Wt[v]==$n,(∂_((SuperStar[u]),(SuperStar[v])))ℱ,0],{u,vs},{v,vs}];
Y=Table[(∂_v)Q,{v,vs}]/.AlsoUpper@Table[v->0,{v,vs}];
CF/@({ℱ, 𝔼[Q-Y.vs+Y.F.Y/2, P]}/.AlsoUpper@Thread[vs->vs+F.Y])
]

Dealing with Feynman diagrams.

Note that the power m of λ is at most k-1+((2k+2)/2)=2k. We write (Subscript[Z, λ])=∑Z[m](λ^m).

(Subscript[Zip3, vs_])@{ℱ_,ℰ_𝔼} := (Subscript[PP, Zip3])@Module[{F,u,v,Z,$k,kk,jj,$m=0,m,n},
$k=Length[ℰ]-1;
Do[Z[0,kk]=ℰ[[kk+1]],{kk,0,$k}];
F[u_,v_]:=F[u,v]=CF@If[Wt[u]+Wt[v]==$n,(∂_((SuperStar[u]),(SuperStar[v])))ℱ,0];
Z[m_,kk_,u_]:=Z[m,kk,u]=(Subscript[D, u])[Z[m,kk]];
Z[m_,kk_,u_,v_]:=Z[m,kk,u,v]=(Subscript[D, v])[Z[m,kk,u]];
For[m=0,m≤2$m,++m,For[kk=0,kk≤$k,++kk,
Z[m+1,kk]=CF@Sum[
If[F[u,v]===0,0,((F[u,v])/(2(m+1)))(Z[m,kk,u,v]+Sum[Z[n,jj,u]*Z[m-n,kk-jj,v],{n,0,m},{jj,0,kk}])],
{u,vs},{v,vs}];
If[Z[m+1,kk]=!=0, $m=m+1]
]];
CF/@({
ℱ-Sum[F[u,v](SuperStar[u])(SuperStar[v])/2,{u,vs},{v,vs}],
𝔼@@Table[Sum[Z[m,kk],{m,0,$m}],{kk,0,$k}]
}/.AlsoUpper@Table[v->0,{v,vs}])
]

Encapsulation.

(Subscript[EZip3, vs_])@{ℱ_,ℰ_𝔼} := (Subscript[PP, EZip3])@Module[
{nℰ,nℱ,rc,ps,rr={(*release rules*)}},
rc=0; nℰ=Total[
CoefficientRules[#, vs] /. (ps_->c_) :> (AppendTo[rr,cℰ[++rc]->c]; cℰ[rc](Times@@(vs^ps)))
]& /@ ℰ;
rc=0; nℱ=Total[CoefficientRules[ℱ, (SuperStar[vs])] /. (ps_->c_) :> (AppendTo[rr,cℱ[++rc]->c]; cℱ[rc](Times@@((((SuperStar[vs])))^ps)))];
CF[Expand[{nℱ,nℰ}//(Subscript[Zip3, vs])]/.rr]
]

Profiling

BeginProfile[];

Timing@Block[{$k=1},Z[Knot[3,1]]]

PrintProfile[]

Timing@Block[{$k=1},Z[Knot[8,17]]]

PrintProfile[]

Timing@Block[{$k=2},Z[Knot[3,1]]]

PrintProfile[]

Timing@Block[{$k=2},Z[Knot[8,17]]]

PrintProfile[]

Timing@Block[{$k=3},Z[Knot[3,1]]]

PrintProfile[]

Timing@Block[{$k=3},Z[Knot[8,17]]]

PrintProfile[]