Pensieve header: Developing $\rho_d$.

Program

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

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

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

{(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, (Subscript[ca, 3,1])=0};

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

V@(Subscript[r, 1,s_])[i_,j_]:=(1/2) s (-1+((Subscript[p, i])-(Subscript[p, j])) (Subscript[x, i]) (2+(Subscript[p, j]) ((-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+(Subscript[p, j]) ((Subscript[x, i]) (3-9 T-2 (-1+T) (-2 (Subscript[p, i])+(3+T) (Subscript[p, j])) (Subscript[x, i]))+6 (3+(-(Subscript[p, i])+(1+T) (Subscript[p, j])) (Subscript[x, i])) (Subscript[x, j])-6 (Subscript[p, j]) (Subscript[x, j]^2)))

V@(Subscript[r, 2,-1])[i_,j_]:=-((((Subscript[p, i])-(Subscript[p, j])) (Subscript[x, i]) (6 (T^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])))))/(12 (T^2)))

V@(Subscript[r, 3,1])[i_,j_]:=(1/24) (Subscript[x, i]) ((Subscript[p, i]^3) (Subscript[p, j]) (Subscript[x, i]^2) (3 (-1+T) (Subscript[x, i])-4 (Subscript[x, j]))+(Subscript[p, i]^2) (Subscript[p, j]) (Subscript[x, i]) (-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])))+(Subscript[p, i]) (4+(Subscript[p, j]) ((Subscript[x, i]) (2 (5+7 T)+(Subscript[p, j]) (Subscript[x, i]) (-64+68 T+8 (T^2)+(-1+T) (13+T (22+T)) (Subscript[p, j]) (Subscript[x, i])))-4 (7+(Subscript[p, j]) (Subscript[x, i]) (27+6 T+(-6+T (17+T)) (Subscript[p, j]) (Subscript[x, i]))) (Subscript[x, j])+6 (Subscript[p, j]) (4+(10+T) (Subscript[p, j]) (Subscript[x, i])) (Subscript[x, j]^2)-4 (Subscript[p, j]^2) (Subscript[x, j]^3)))+(Subscript[p, j]) (-4+(Subscript[p, j]) ((Subscript[x, i]) (-2 (5+7 T)+(Subscript[p, j]) (Subscript[x, i]) (44-4 T (11+2 T)-(-1+T) (4+T (13+T)) (Subscript[p, j]) (Subscript[x, i])))+4 (7+(Subscript[p, j]) (Subscript[x, i]) (6 (3+T)+(-5+T (10+T)) (Subscript[p, j]) (Subscript[x, i]))) (Subscript[x, j])-6 (Subscript[p, j]) (4+(6+T) (Subscript[p, j]) (Subscript[x, i])) (Subscript[x, j]^2)+4 (Subscript[p, j]^2) (Subscript[x, j]^3))))

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

{(SuperStar[p]),(SuperStar[x]),(SuperStar[(OverBar[p])]),(SuperStar[(OverBar[x])])}={π,ξ,(OverBar[π]),(OverBar[ξ])};  (SuperStar[((Subscript[z_, i__]))]):=(Subscript[((SuperStar[z])), i]);

(Subscript[Zip, {}])[ℰ_]:=ℰ;
(Subscript[Zip, {z_,zs___}])[ℰ_] := (Collect[ℰ//(Subscript[Zip, {zs}]),z] /. f_.(z^(d_.)):>(D[f,{(SuperStar[z]),d}]))/.(SuperStar[z])->0

gPair[fs_,w_]:=gPair[fs,w]=(Subscript[PP, gPair])[
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},
(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}})))];
Δ=Factor[(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]];
G=Factor@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, PandS])@Expand[
ρd2/.F[fs_,es_]:>Expand[gPair[
Replace[fs,Thread[es->Range@Length@es],{2}],
Length@es
]/.(Subscript[g, α_,β_]):>G[[es[[α]],es[[β]]]]]
];
(Subscript[PP, Factor])@Collect[Expand@{Δ,ρd3/.(ϵ^(p_.))->p!(Δ^(2p))(ϵ^p)}/.{(T^(p_.))/;p>0:>(((((2+(z^2)-z (Sqrt[4+(z^2)]))/2)))^p),(T^(p_.))/;p<0:> (((((2+(z^2)+z (Sqrt[4+(z^2)]))/2)))^(-p))},ϵ,Expand]
];

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