Pensieve header: Developing $\rho_d$.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Oaxaca-2210"];

Once[<<KnotTheory`; <<Rot.m];

<< "../../Projects/Profile/Profile.m"

CF[ℰ_]:=Module[{vs=Union[{ϵ},Cases[ℰ,(Subscript[(g|p|x), __]),∞]]},Total[
CoefficientRules[Expand@ℰ,vs]/.(ps_->c_):>Factor[c](Times@@(vs^ps))
]]

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

V@(Subscript[γ, d_,0])[j_]:=0; V@(Subscript[γ, 1,φ_])[k_]:=φ((1/2)-(Subscript[p, k]) (Subscript[x, k]));

V@(Subscript[r, 1,s_])[i_,j_]:=Expand[s(-(1/2)+(Subscript[p, i]) (Subscript[x, i])-(Subscript[p, j]) (Subscript[x, i])+(1/2) (-1+(T^s)) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]^2)+(1/2) (1-(T^s)) (Subscript[p, j]^2) (Subscript[x, i]^2)-(Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])+(Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j]))];

V@(Subscript[γ, 2,1])[k_]:=-(1/2) (Subscript[p, k]) (Subscript[x, k]); V@(Subscript[γ, 2,-1])[k_]:=-(1/2) (Subscript[p, k]) (Subscript[x, k]);

V@(Subscript[r, 2,1])[i_,j_]:=-(1/2) (Subscript[p, i]) (Subscript[x, i])+(((Subscript[p, j]) (Subscript[x, i]))/2)+(1/4) (1-3 T) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]^2)+(1/4) (-1+3 T) (Subscript[p, j]^2) (Subscript[x, i]^2)+(1/3) (-1+T) (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^3)-(1/6) (-1+T) (5+T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^3)+(1/6) (-1+T) (3+T) (Subscript[p, j]^3) (Subscript[x, i]^3)+(3/2) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])-(3/2) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j])-(1/2) (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^2) (Subscript[x, j])+(1/2) (2+T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^2) (Subscript[x, j])+(1/2) (-1-T) (Subscript[p, j]^3) (Subscript[x, i]^2) (Subscript[x, j])-(1/2) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j]^2)+(1/2) (Subscript[p, j]^3) (Subscript[x, i]) (Subscript[x, j]^2);

V@(Subscript[r, 2,-1])[i_,j_]:=-(1/2) (Subscript[p, i]) (Subscript[x, i])+(((Subscript[p, j]) (Subscript[x, i]))/2)+(((-3+T) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]^2))/(4 T))-(((-3+T) (Subscript[p, j]^2) (Subscript[x, i]^2))/(4 T))-(((-1+T) (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^3))/(3 T))+(((-1+T) (1+5 T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^3))/(6 (T^2)))-(((-1+T) (1+3 T) (Subscript[p, j]^3) (Subscript[x, i]^3))/(6 (T^2)))+(3/2) (Subscript[p, i]) (Subscript[p, j]) (Subscript[x, i]) (Subscript[x, j])-(3/2) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j])-(1/2) (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^2) (Subscript[x, j])+(((1+2 T) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]^2) (Subscript[x, j]))/(2 T))-(((1+T) (Subscript[p, j]^3) (Subscript[x, i]^2) (Subscript[x, j]))/(2 T))-(1/2) (Subscript[p, i]) (Subscript[p, j]^2) (Subscript[x, i]) (Subscript[x, j]^2)+(1/2) (Subscript[p, j]^3) (Subscript[x, i]) (Subscript[x, j]^2);

gPair[1]=1;
gPair[(ϵ^(d_.))Bs_]:=(ϵ^d)gPair[Bs];
gPair[c_?NumberQ*Bs_]:=c gPair[Bs];
gPair[ℰ_Plus]:=gPair/@ℰ;
gPair[(((Subscript[r, d_,s_])[i_,j_])^(p_.))]:= gPair[{(((Subscript[r, d,s])[i,j])^p)}];
gPair[(((Subscript[γ, d_,φ_])[k_])^(p_.))]:= gPair[{(((Subscript[γ, d,φ])[k])^p)}];
gPair[Bs_Times]:= gPair[List@@Bs];
gPair[Bs_List]:=Module[{es,BBs},
BBs=Bs/.((e_)^(p_)):>Sequence@@Table[e,{p}];
es=Union@@(List@@@BBs);
Do[ν@i=es[[i]],{i,Length@es}];
gpair[Replace[BBs,Thread[es->Range@Length@es],{2}]]/.(Subscript[g, α_,β_]):>(Subscript[g, ν@α,ν@β])
]

gpair[Bs_List]:=gpair[Bs]=Module[{es},
Print["At gpair with Bs=",Bs];
es=Union@@(List@@@Bs);
Simplify@(Subscript[Zip, Join@@Table[{(Subscript[p, 1,α]),(Subscript[p, 2,α]),(Subscript[x, 1,α]),(Subscript[x, 2,α])},{α,es}]])[Times[
Times@@(Bs/.{
(Subscript[r, d_,s_])[i_,j_]:>(V[(Subscript[r, d,s])[i,j]]/.{(Subscript[p, i])->(Subscript[p, 2,i]),(Subscript[p, j])->(Subscript[p, 2,j]),(Subscript[x, i])->(Subscript[x, 2,i]),(Subscript[x, j])->(Subscript[x, 2,j])}),
(Subscript[γ, d_,φ_])[k_]:>(V[(Subscript[γ, d,φ])[k]]/.{(Subscript[p, k])->(Subscript[p, 1,k]),(Subscript[x, k])->(Subscript[x, 1,k])})
}),
Exp[Sum[(Subscript[g, α,β])((Subscript[π, 1,α])+(Subscript[π, 2,α]))((Subscript[ξ, 1,β])+(Subscript[ξ, 2,β])),{α,es},{β,es}]-Sum[(Subscript[ξ, 1,α])(Subscript[π, 2,α]),{α,es}]]
]]
]

gPair[(Subscript[r, 1,-1])[3,4]]

gPair[(Subscript[r, 1,-1])[5,6]]

gPair[(Subscript[γ, 1,-1])[3]]

gPair[(Subscript[γ, 1,0])[6]]

gPair[(((Subscript[γ, 1,-1])[3])^2)]

gPair[(Subscript[r, 2,1])[3,4](Subscript[γ, 1,-1])[3]]

(Subscript[ρ, d_])[K_]:=(Subscript[PP, ρd])@Module[{Cs,φ,n,A,s,i,j,k,Δ,G,d1,ρd},
(Subscript[PP, "Green"])[
{Cs,φ}=Rot[K]; n=Length[Cs];
A=IdentityMatrix[2n+1];
Cases[Cs,{s_,i_,j_}:>(A[[{i,j},{i+1,j+1}]]+=(({{-(T^s), (T^s)-1}, {0, -1}})))];
Δ=(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A];
G=Inverse[A];
];
ρd=(Subscript[PP, Pairing])@gPair[Series[Exp[
Total[Cases[Cs,{s_,i_,j_}:>Sum[(ϵ^d1)(Subscript[r, d1,s])[i,j],{d1,d}]]]
+ Sum[(ϵ^d1)(Subscript[γ, d1,φ[[k]]])[k], {k,2n},{d1,d}]
],{ϵ,0,d}]//Normal//Expand];
(Subscript[PP, Renormalizing])[ρd=CoefficientList[Δ Normal[Series[ρd,{ϵ,0,d}]]/.ϵ->Δ ϵ,ϵ,d+1]];
(Subscript[PP, Substitution])@Factor[ρd/.(SuperPlus[α_]):>α+1/.(Subscript[g, α_,β_]):>G[[α,β]]]
];

(Subscript[ρ, 1])[Knot[3,1]]

Table[K->(Subscript[ρ, 1])[K], {K,AllKnots[{3,6}]}]

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

BeginProfile[]
Timing[z1=(Subscript[ρ, 2])[Knot[10,106]]]
PrintProfile[]

BeginProfile[]
Timing[z2=(Subscript[ρ, 2])[Knot[12, NonAlternating, 369]]]
PrintProfile[]

Simplify[Thread[z1==z2]]

GST48=EPD[(Subscript[X, 14,1]),(Subscript[(OverBar[X]), 2,29]),(Subscript[X, 3,40]),(Subscript[X, 43,4]),(Subscript[(OverBar[X]), 26,5]),(Subscript[X, 6,95]),(Subscript[X, 96,7]),(Subscript[X, 13,8]),(Subscript[(OverBar[X]), 9,28]),(Subscript[X, 10,41]),(Subscript[X, 42,11]),(Subscript[(OverBar[X]), 27,12]),(Subscript[X, 30,15]),(Subscript[(OverBar[X]), 16,61]),(Subscript[(OverBar[X]), 17,72]),(Subscript[(OverBar[X]), 18,83]),(Subscript[X, 19,34]),(Subscript[(OverBar[X]), 89,20]),(Subscript[(OverBar[X]), 21,92]),(Subscript[(OverBar[X]), 79,22]),(Subscript[(OverBar[X]), 68,23]),(Subscript[(OverBar[X]), 57,24]),(Subscript[(OverBar[X]), 25,56]),(Subscript[X, 62,31]),(Subscript[X, 73,32]),(Subscript[X, 84,33]),(Subscript[(OverBar[X]), 50,35]),(Subscript[X, 36,81]),(Subscript[X, 37,70]),(Subscript[X, 38,59]),(Subscript[(OverBar[X]), 39,54]),(Subscript[X, 44,55]),(Subscript[X, 58,45]),(Subscript[X, 69,46]),(Subscript[X, 80,47]),(Subscript[X, 48,91]),(Subscript[X, 90,49]),(Subscript[X, 51,82]),(Subscript[X, 52,71]),(Subscript[X, 53,60]),(Subscript[(OverBar[X]), 63,74]),(Subscript[(OverBar[X]), 64,85]),(Subscript[(OverBar[X]), 76,65]),(Subscript[(OverBar[X]), 87,66]),(Subscript[(OverBar[X]), 67,94]),(Subscript[(OverBar[X]), 75,86]),(Subscript[(OverBar[X]), 88,77]),(Subscript[(OverBar[X]), 78,93])];
BeginProfile[]
Timing[z3=(Subscript[ρ, 2])[GST48]]
PrintProfile[]