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};

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

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

V@(Subscript[r, 1,s_])[i_,j_]:=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[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, α]),(Subscript[(OverBar[p]), α]),(Subscript[x, α]),(Subscript[(OverBar[x]), α])},{α,es}]])[Times[
Times@@(Bs/.{
(Subscript[r, d_,s_])[i_,j_]:>V[(Subscript[r, d,s])[i,j]], (Subscript[γ, d_,φ_])[k_]:>V[(Subscript[γ, d,φ])[k]]
}),
Exp[Sum[(Subscript[g, α,β])((Subscript[π, α])+(Subscript[(OverBar[π]), α]))((Subscript[ξ, β])+(Subscript[(OverBar[ξ]), β])),{α,es},{β,es}]-Sum[(Subscript[(OverBar[ξ]), α])(Subscript[π, α]),{α,es}]]
]]
]

(Subscript[ρ, d_])[K_]:=(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=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])@Table[Expand@SeriesCoefficient[ρd1,{ϵ,0,d1}],{d1,d}];
ρd3=(Subscript[PP, Pairing])[gPair/@ρd2];
ρd4=(Subscript[PP, Substitution])@Factor[Join[{Δ},ρd3*(Δ^(2Range[d]))]/.{(Subscript[g, α_,β_]):>G[[α,β]],Δ->(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]}]
];

Testing

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

According to C:\drorbn\AcademicPensieve\Projects\SL2Invariant\k=2\12XingStats.nb, expect 2893 below:

BeginProfile[]
Monitor[{NumberOfKnots[{3,12}],
Length@Union@Table[(Subscript[ρ, 2])[K],{K,AllKnots[{3,12}]}],
Length@Union@Table[{HOMFLYPT[K], Kh[K]},{K,AllKnots[{3,12}]}]},
K]
PrintProfile[]

Table[K->(Subscript[ρ, 2])[K],{K,AllKnots[{3,12}]}] >> Rho2Data.m