Pensieve Header: Computing $\rho_2$ efficiently.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\KnotTheoryCongress-2502"];
<< KnotTheory`
<< Rot.m

T2z[p_]:=Module[{q=Expand[p],n,c},
If[q===0,0,c=Coefficient[q,T,n=Exponent[q,T]];c (z^(2n))+T2z[q-c((((T^(1/2))-(T^(-1/2))))^(2n))]]];

Pre-computing the Feynman Diagrams

CF[ℰ_] := Expand@Collect[ℰ,(Subscript[g, __]),F]/.F->Factor;

{(SuperStar[p]),(SuperStar[x]),(SuperStar[π]),(SuperStar[ξ])}={π,ξ,p,x};  (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);

(Subscript[Zip, {}])[ℰ_]:=ℰ;
(Subscript[Zip, {ζ_,ζs___}])[ℰ_] := (Collect[ℰ//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>(D[f,{(SuperStar[ζ]),d}]))/.(SuperStar[ζ])->0

px2g[ℰ_]:=CF@Module[{ps,xs,Q,α,β},
ps=Union[Cases[ℰ,(Subscript[p, __]),∞]]; xs=Union[Cases[ℰ,(Subscript[x, __]),∞]];
Q=Sum[(SuperStar[p0]) (SuperStar[x0]) (Subscript[g, p0[[2]],x0[[2]]]),{p0,ps},{x0,xs}];
Expand[(Subscript[Zip, ps⋃xs])[ℰ (E^Q)]]
]

px2g[(s/2)((Subscript[x, i])((Subscript[p, i])-(Subscript[p, j]))(((T^s)-1)(Subscript[x, i])(Subscript[p, j])+2(1-(Subscript[p, j])(Subscript[x, j])))-1)]

From AcademicPensieve/Talks/Beijing-2407/More.nb:

q[s_,i_,j_]:=(Subscript[x, i]) ((Subscript[p, i+1])-(Subscript[p, i]))+(Subscript[x, j]) ((Subscript[p, j+1])-(Subscript[p, j]))+((T^s)-1)(Subscript[x, i])((Subscript[p, i+1])-(Subscript[p, j+1]));
(Subscript[r, 1])[s_,i_,j_]:=(s/2)((Subscript[x, i])((Subscript[p, i])-(Subscript[p, j]))(((T^s)-1)(Subscript[x, i])(Subscript[p, j])+2(1-(Subscript[p, j])(Subscript[x, j])))-1);
(Subscript[r, 2])[1,i_,j_]:=(-6 (Subscript[p, i]) (Subscript[x, i])+6 (Subscript[p, j]) (Subscript[x, i])-3 (-1+3 T) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]^2)+3 (-1+3 T) (Subscript[p, j]^2) (Subscript[x, i]^2)+4 (-1+T) (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^3)-2 (-1+T) (5+T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^3)+2 (-1+T) (3+T) (Subscript[p, j]^3) (Subscript[x, i]^3)+18 (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])-18 (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j])-6 (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^2) (Subscript[x, j])+6 (2+T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^2) (Subscript[x, j])-6 (1+T) (Subscript[p, j]^3) (Subscript[x, i]^2) (Subscript[x, j])-6 (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j]^2)+6 (Subscript[p, j]^3) (Subscript[x, i]) (Subscript[x, j]^2))/12;
(Subscript[r, 2])[-1,i_,j_]:=(-6 (T^2) (Subscript[p, i]) (Subscript[x, i])+6 (T^2) (Subscript[p, j]) (Subscript[x, i])+3 (-3+T) T (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]^2)-3 (-3+T) T (Subscript[p, j]^2) (Subscript[x, i]^2)-4 (-1+T) T (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^3)+2 (-1+T) (1+5 T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^3)-2 (-1+T) (1+3 T) (Subscript[p, j]^3) (Subscript[x, i]^3)+18 (T^2) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])-18 (T^2) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j])-6 (T^2) (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^2) (Subscript[x, j])+6 T (1+2 T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^2) (Subscript[x, j])-6 T (1+T) (Subscript[p, j]^3) (Subscript[x, i]^2) (Subscript[x, j])-6 (T^2) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j]^2)+6 (T^2) (Subscript[p, j]^3) (Subscript[x, i]) (Subscript[x, j]^2))/(12(T^2));
(Subscript[γ, 1])[φ_,k_]:=φ(1/2-(Subscript[x, k])(Subscript[p, k]));
(Subscript[γ, 2])[φ_,k_]:=-(φ^2)(Subscript[p, k])(Subscript[x, k])/2;
ℒ[(Subscript[X, i_,j_])[s_]]:=(T^(s/2))𝔼[q[s,i,j]+ϵ (Subscript[r, 1])[s,i,j]+(ϵ^2)(Subscript[r, 2])[s,i,j]+((O[ϵ])^3)];
ℒ[(Subscript[C, k_])[φ_]]:=(T^(φ/2))𝔼[-(Subscript[x, k])((Subscript[p, k])-(Subscript[p, k+1]))+ϵ (Subscript[γ, 1])[φ,k]+(ϵ^2)(Subscript[γ, 2])[φ,k]+((O[ϵ])^3)];
ℒ[K_]:=(((2π))^(-Features[K][[1]]))CF[ℒ/@Features[K][[2]]];
vs[K_] := Union@@Table[{(Subscript[p, i]),(Subscript[x, i])},{i,Features[K][[1]]}]

F[(Subscript[X, i_,j_])[1]]=px2g[(Subscript[r, 2])[1,i,j]+((((Subscript[r, 1])[1,i,j])^2)/2)]

F[(Subscript[X, i_,j_])[-1]]=px2g[(Subscript[r, 2])[-1,i,j]+((((Subscript[r, 1])[-1,i,j])^2)/2)]

Short[F[(Subscript[X, i0_,j0_])[1](Subscript[X, i1_,j1_])[1]]=px2g[(Subscript[r, 1])[1,i0,j0](Subscript[r, 1])[1,i1,j1]]]

Short[F[(Subscript[X, i0_,j0_])[1](Subscript[X, i1_,j1_])[-1]]=px2g[(Subscript[r, 1])[1,i0,j0](Subscript[r, 1])[-1,i1,j1]]]

Short[F[(Subscript[X, i0_,j0_])[-1](Subscript[X, i1_,j1_])[-1]]=px2g[(Subscript[r, 1])[-1,i0,j0](Subscript[r, 1])[-1,i1,j1]]]

F[(Subscript[C, k_])[1]]=px2g[(Subscript[γ, 2])[1,k]+((((Subscript[γ, 1])[1,k])^2)/2)]

F[(Subscript[C, k_])[-1]]=px2g[(Subscript[γ, 2])[-1,k]+((((Subscript[γ, 1])[-1,k])^2)/2)]

F[(Subscript[X, i_,j_])[1](Subscript[C, k_])[1]]=px2g[(Subscript[r, 1])[1,i,j](Subscript[γ, 1])[1,k]]

F[(Subscript[X, i_,j_])[1](Subscript[C, k_])[-1]]=px2g[(Subscript[r, 1])[1,i,j](Subscript[γ, 1])[-1,k]]

F[(Subscript[X, i_,j_])[-1](Subscript[C, k_])[1]]=px2g[(Subscript[r, 1])[-1,i,j](Subscript[γ, 1])[1,k]]

F[(Subscript[X, i_,j_])[-1](Subscript[C, k_])[-1]]=px2g[(Subscript[r, 1])[-1,i,j](Subscript[γ, 1])[-1,k]]

F[(Subscript[C, k0_])[1](Subscript[C, k1_])[1]]=px2g[(Subscript[γ, 1])[1,k0](Subscript[γ, 1])[1,k1]]

F[(Subscript[C, k0_])[1](Subscript[C, k1_])[-1]]=px2g[(Subscript[γ, 1])[1,k0](Subscript[γ, 1])[-1,k1]]

F[(Subscript[C, k0_])[-1](Subscript[C, k1_])[-1]]=px2g[(Subscript[γ, 1])[-1,k0](Subscript[γ, 1])[-1,k1]]

A line-by-line computation of (Subscript[ρ, 2])

K=Knot[6,3]

{n,Fs}=List@@Features[K]; {++n, Xs=Cases[Fs,(Subscript[X, __])[_]], Cs=Cases[Fs,(Subscript[C, _])[_]]}

A=IdentityMatrix[n]; w=φ=0;
Xs/.(Subscript[X, i_,j_])[s_]:>(w+=s; A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})));
Cs/.(Subscript[C, k_])[ϕ_]:>(φ+=ϕ; A[[k,k+1]]+=-1);

{A//MatrixForm,w,φ}

Δ=(T^(-(φ+w)/2))Det[A]

G=Inverse[A];

{MatrixForm[G],MatrixForm[G]/.T->1}

Subsets[Fs,{1,2}]

Factor[(F/@Subsets[Fs,{1,2}])/.(Subscript[g, α_,β_]):>G[[α,β]]]

out=Factor[2(Δ^4)Total[(F/@Subsets[Fs,{1,2}])/.(Subscript[g, α_,β_]):>G[[α,β]]]]

T2z[out]

A (Subscript[ρ, 2]) program

(Subscript[ρ, 2])[K_]:=Module[{n,Fs,Xs,Cs,A,w,φ,Δ,G},
{n,Fs}=List@@Features[K]; {++n, Xs=Cases[Fs,(Subscript[X, __])[_]], Cs=Cases[Fs,(Subscript[C, _])[_]]};
A=IdentityMatrix[n]; w=φ=0;
Xs/.(Subscript[X, i_,j_])[s_]:>(w+=s; A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})));
Cs/.(Subscript[C, k_])[ϕ_]:>(φ+=ϕ; A[[k,k+1]]+=-1);
Δ=(T^(-(φ+w)/2))Det[A];
G=Inverse[A];
Factor[2(Δ^4)Total@Factor[(F/@Subsets[Fs,{1,2}])/.(Subscript[g, α_,β_]):>G[[α,β]]]]
]

(Subscript[ρ, 2])[Knot[3,1]]//T2z

(Subscript[ρ, 2])/@{"K11n34","K11n42"}

DunfieldKnots=ReadList["../../People/Dunfield/nmd_random_knots"]/.k_Integer:>k+1;
DK[n_]:=DunfieldKnots[[n-2]];

(Subscript[ρ, 2])[DK[3]]//T2z

AbsoluteTiming[(Subscript[ρ, 2])[DK[10]]//T2z]

AbsoluteTiming[(Subscript[ρ, 2])[DK[20]]//T2z]

AbsoluteTiming[(Subscript[ρ, 2])[DK[30]]//T2z]

AbsoluteTiming[(Subscript[ρ, 2])[DK[100]]//T2z]

AbsoluteTiming[(Subscript[ρ, 2])[DK[150]]//T2z]