Pensieve header: Developing $\rho_d$.

Program

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

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

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

{(SuperStar[p]),(SuperStar[x]),(SuperStar[π]),(SuperStar[ξ]),(SuperStar[(OverBar[p])]),(SuperStar[(OverBar[x])]),(SuperStar[(OverBar[π])]),(SuperStar[(OverBar[ξ])])}={π,ξ,p,x,(OverBar[π]),(OverBar[ξ]),(OverBar[p]),(OverBar[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

{(Subscript[ca, 1,2])=1,(Subscript[ca, 1,10])=-1,(Subscript[ca, 2,1])=0,(Subscript[cb, 2,10])=3/2,(Subscript[cb, 3,10])=(7-12(Subscript[ca, 3,1]))/6};

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

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

V@(Subscript[γ, 3,φ_])[k_]:=-(1/6) (Δ^5) φ ((Subscript[(OverBar[p]), k]) (Subscript[(OverBar[x]), k]) (1-12 (Subscript[ca, 3,1]))+6 Δ (Subscript[ca, 3,1]));

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

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

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

V@(Subscript[r, 3,1])[i_,j_]:=(1/24) (Δ^2) ((Subscript[p, i]^3) (Subscript[p, j]) (Subscript[x, i]^3) (3 (-1+T) (Subscript[x, i])-4 (Subscript[x, j]))+4 Δ (Subscript[p, j]^3) (Subscript[x, i]) ((11-T (11+2 T)) (Subscript[x, i]^2)+6 (3+T) (Subscript[x, i]) (Subscript[x, j])-6 (Subscript[x, j]^2))+(Subscript[p, j]^4) (Subscript[x, i]) (-((-1+T) (4+T (13+T)) (Subscript[x, i]^3))+4 (-5+T (10+T)) (Subscript[x, i]^2) (Subscript[x, j])-6 (6+T) (Subscript[x, i]) (Subscript[x, j]^2)+4 (Subscript[x, j]^3))+(Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^2) (-3 (-4+T+3 (T^2)) (Subscript[p, j]) (Subscript[x, i]^2)+12 (Subscript[x, j]) (3 Δ-2 (Subscript[p, j]) (Subscript[x, j]))+4 (Subscript[x, i]) (5 Δ-6 T Δ+7 T (Subscript[p, j]) (Subscript[x, j])))+24 (Δ^4) (Subscript[ca, 3,1])+4 (Δ^3) (Subscript[p, j]) (Subscript[x, i]) (-1+12 (Subscript[ca, 3,1]))+2 (Δ^2) (Subscript[p, j]^2) (Subscript[x, i]) (2 (Subscript[x, j]) (7-12 (Subscript[ca, 3,1]))+(Subscript[x, i]) (-5-7 T+12 (-1+T) (Subscript[ca, 3,1])))+(Subscript[p, i]) (Subscript[x, i]) (4 Δ (Subscript[p, j]^2) ((-16+T (17+2 T)) (Subscript[x, i]^2)-3 (9+2 T) (Subscript[x, i]) (Subscript[x, j])+6 (Subscript[x, j]^2))+(Subscript[p, j]^3) ((-1+T) (13+T (22+T)) (Subscript[x, i]^3)-4 (-6+T (17+T)) (Subscript[x, i]^2) (Subscript[x, j])+6 (10+T) (Subscript[x, i]) (Subscript[x, j]^2)-4 (Subscript[x, j]^3))+4 (Δ^3) (1-12 (Subscript[ca, 3,1]))+2 (Δ^2) (Subscript[p, j]) (2 (Subscript[x, j]) (-7+12 (Subscript[ca, 3,1]))+(Subscript[x, i]) (5+7 T-12 (-1+T) (Subscript[ca, 3,1])))));

V@(Subscript[r, 3,-1])[i_,j_]:=-(1/(24 (T^3)))(Δ^2) ((T^2) (Subscript[p, i]^3) (Subscript[p, j]) (Subscript[x, i]^3) (-3 (-1+T) (Subscript[x, i])-4 T (Subscript[x, j]))+4 T Δ (Subscript[p, j]^3) (Subscript[x, i]) ((-2+11 (-1+T) T) (Subscript[x, i]^2)+6 T (1+3 T) (Subscript[x, i]) (Subscript[x, j])-6 (T^2) (Subscript[x, j]^2))+(Subscript[p, j]^4) (Subscript[x, i]) ((-1+T) (1+T (13+4 T)) (Subscript[x, i]^3)+4 T (1-5 (-2+T) T) (Subscript[x, i]^2) (Subscript[x, j])-6 (T^2) (1+6 T) (Subscript[x, i]) (Subscript[x, j]^2)+4 (T^3) (Subscript[x, j]^3))+T (Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]^2) (3 (-1+T) (3+4 T) (Subscript[p, j]) (Subscript[x, i]^2)+12 (T^2) (Subscript[x, j]) (3 Δ-2 (Subscript[p, j]) (Subscript[x, j]))+4 T (Subscript[x, i]) (-6 Δ+5 T Δ+7 (Subscript[p, j]) (Subscript[x, j])))+24 (T^3) (Δ^4) (Subscript[ca, 3,1])+4 (T^3) (Δ^3) (Subscript[p, j]) (Subscript[x, i]) (-1+12 (Subscript[ca, 3,1]))-2 (T^2) (Δ^2) (Subscript[p, j]^2) (Subscript[x, i]) (2 T (Subscript[x, j]) (-7+12 (Subscript[ca, 3,1]))+(Subscript[x, i]) (7+5 T+12 (-1+T) (Subscript[ca, 3,1])))+(Subscript[p, i]) (Subscript[x, i]) (4 T Δ (Subscript[p, j]^2) ((2+(17-16 T) T) (Subscript[x, i]^2)-3 T (2+9 T) (Subscript[x, i]) (Subscript[x, j])+6 (T^2) (Subscript[x, j]^2))+(Subscript[p, j]^3) (-((-1+T) (1+T (22+13 T)) (Subscript[x, i]^3))+4 T (-1+T (-17+6 T)) (Subscript[x, i]^2) (Subscript[x, j])+6 (T^2) (1+10 T) (Subscript[x, i]) (Subscript[x, j]^2)-4 (T^3) (Subscript[x, j]^3))+4 (T^3) (Δ^3) (1-12 (Subscript[ca, 3,1]))+2 (T^2) (Δ^2) (Subscript[p, j]) (2 T (Subscript[x, j]) (-7+12 (Subscript[ca, 3,1]))+(Subscript[x, i]) (7+5 T+12 (-1+T) (Subscript[ca, 3,1])))));

gPair[fs_,w_]:=gPair[fs,w]=(
Print["Running gPair[",fs,",",w,"]..."];
Collect[(Subscript[Zip, Join@@Table[{(Subscript[p, α]),(Subscript[(OverBar[p]), α]),(Subscript[x, α]),(Subscript[(OverBar[x]), α])},{α,w}]])[(Times@@(V/@fs))Exp[Sum[(Subscript[g, α,β])((Subscript[π, α])+(Subscript[(OverBar[π]), α]))((Subscript[ξ, β])+(Subscript[(OverBar[ξ]), β])),{α,w},{β,w}]-Sum[Δ(Subscript[(OverBar[ξ]), α])(Subscript[π, α]),{α,w}]]],
(Subscript[g, __]),Factor]
)

(Subscript[ρ, d_])[K_]:=(Subscript[PP, ρd])@Module[{Cs,φ,n,A,s,i,j,k,G,d1,ρd1,ρd2,ρd3,ρd4},
(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}})))];
G=Factor[(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]Inverse[A]];
];
ρd1=(Subscript[PP, Mold])@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}]];
ρd2=(Subscript[PP, ExpandedMold])[
Expand[F[{},{}]×Normal@Series[ρd1,{ϵ,0,d}]]//.F[fs_,{es___}]×(((f:(Subscript[(r|γ), ps__])[is__]))^(p_.)):>F[Join[fs,Table[f,p]],DeleteDuplicates@{es,is}]
];
ρd3=(Subscript[PP, Pairing])[
ρd2/.F[fs_,es_]:>(gPair[
Replace[fs,Thread[es->Range@Length@es],{2}],
Length@es
]/.(Subscript[g, α_,β_]):>(Subscript[g, es[[α]],es[[β]]]))
];
ρd4=(Subscript[PP, Substitution])@Collect[
{Δ,ρd3}/.{(Subscript[g, α_,β_]):>G[[α,β]],Δ->(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]},
ϵ,Factor]
];

Testing

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

TableForm[Table[Join[{(Subscript[K[[1]], K[[2]]])},(Subscript[ρ, 1])[K]], {K,AllKnots[{3,6}]}], TableAlignments->Center]

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

TableForm[Table[Join[{(Subscript[K[[1]], K[[2]]])},(Subscript[ρ, 2])[K]], {K,AllKnots[{3,7}]}], TableAlignments->Center]

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[]

BeginProfile[]
Timing[(Subscript[ρ, 3])[Knot[3,1]]]
PrintProfile[]

BeginProfile[]
Timing[(Subscript[ρ, 3])[Knot[4,1]]]
PrintProfile[]

TableForm[Table[Echo@Join[{(Subscript[K[[1]], K[[2]]])},(Subscript[ρ, 3])[K]], {K,AllKnots[{3,6}]}], TableAlignments->Center]

BeginProfile[]
Timing[z1=(Subscript[ρ, 3])[Knot[11,NonAlternating,34]]]
PrintProfile[]

BeginProfile[]
Timing[z2=(Subscript[ρ, 3])[Knot[11,NonAlternating,42]]]
PrintProfile[]

z1-z2

BeginProfile[]
Timing[(Subscript[ρ, 3])[GST48]]
PrintProfile[]