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_]:=φ(((Subscript[ca, 1,2])/2)+(Subscript[p, k]) (Subscript[x, k]) (Subscript[ca, 1,10]))/.v:p|x:>(OverBar[v]);

V@(Subscript[γ, 2,1])[k_]:=-(Subscript[ca, 2,1])+(Subscript[p, k]) (Subscript[x, k]) (-(Subscript[ca, 1,2]) (Subscript[ca, 1,10])-(Subscript[cb, 2,10]))/.v:p|x:>(OverBar[v]);
V@(Subscript[γ, 2,-1])[k_]:=(Subscript[ca, 2,1])+(Subscript[p, k]) (Subscript[x, k]) ((Subscript[ca, 1,2]) (Subscript[ca, 1,10])-(Subscript[ca, 1,10]^2)+(Subscript[cb, 2,10]))/.v:p|x:>(OverBar[v]);

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

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

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

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

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[ca, 1,10])=-(Subscript[ca, 1,2]);

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

(Subscript[ca, 1,2])=1;

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

z1=Factor@(Subscript[ρ, 2])[Knot[3,1]]

PolynomialRemainder[(1/(2 (T^4)))(1-T-5 (T^2)+18 (T^3)-30 (T^4)+42 (T^5)-35 (T^6)+17 (T^7)-5 (T^8)-4 (Subscript[ca, 2,1])+12 T (Subscript[ca, 2,1])-20 (T^2) (Subscript[ca, 2,1])+16 (T^3) (Subscript[ca, 2,1])-16 (T^5) (Subscript[ca, 2,1])+20 (T^6) (Subscript[ca, 2,1])-12 (T^7) (Subscript[ca, 2,1])+4 (T^8) (Subscript[ca, 2,1])-2 T (Subscript[cb, 2,10])+8 (T^2) (Subscript[cb, 2,10])-20 (T^3) (Subscript[cb, 2,10])+32 (T^4) (Subscript[cb, 2,10])-36 (T^5) (Subscript[cb, 2,10])+28 (T^6) (Subscript[cb, 2,10])-14 (T^7) (Subscript[cb, 2,10])+4 (T^8) (Subscript[cb, 2,10])),1-T+(T^2),T]

Simplify[z1[[3]]-(z1[[3]]/.T->(T^(-1)))]

z2=Factor@(Subscript[ρ, 2])[Knot[4,1]]

Simplify[z2[[3]]-(z2[[3]]/.T->(T^(-1)))]

(Subscript[cb, 2,10])=((3-4(Subscript[ca, 2,1]))/2)

z3=Factor@(Subscript[ρ, 2])[Knot[8,17]]

Simplify[z3[[3]]-(z3[[3]]/.T->(T^(-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[Factor@Join[{(Subscript[K[[1]], K[[2]]])},z=(Subscript[ρ, 2])[K],{((Coefficient[z[[3]],(Subscript[ca, 2,1])])/(z[[2]])),z[[1]],PolynomialRemainder[z[[3]],z[[1]],T]}], {K,AllKnots[{3,7}]}], TableAlignments->Center]

OverbayP2Data=Get["C:\\drorbn\\AcademicPensieve\\People\\Overbay\\OverbayP2Data.m"];
P2[K_]:=K/.OverbayP2Data;

TableForm[Table[Factor@Join[{(Subscript[K[[1]], K[[2]]])},z=(Subscript[ρ, 2])[K],{P2[K],((Coefficient[z[[3]],(Subscript[ca, 2,1])])/(z[[2]])),z[[1]],PolynomialRemainder[z[[3]],z[[1]],T]}], {K,AllKnots[{3,7}]}], TableAlignments->Center]

(Subscript[𝔼[L_,Q_,P_], $k_]):=𝔼[L,Q,Series[Normal@P,{ϵ,0,$k}]];
(Subscript[(Subscript[𝔼, d_->r_])[L_,Q_,P_], $k_]):=(Subscript[𝔼, d->r])@@(Subscript[𝔼[L,Q,P], $k]);
𝔼3@𝔼[ω_,L_,Q_,Ps_]:=Factor/@(Subscript[𝔼[L,(ω^(-1)) Q,(ω^(-1))((((ω^(-4))ϵ))^(-1+Range@Length@Ps)).Ps], $k]);
𝔼4@𝔼[L_,Q_,P_]:=Module[
{ω=((Normal[P])^(-1))/.ϵ->0,Ps=CoefficientList[P,ϵ]},
Factor/@𝔼[ω,L,ω Q,(ω^(-3+4Range@Length@Ps))Ps]];
𝔼3@(Subscript[𝔼, sp___])[as___]:=𝔼3@𝔼[as]/.𝔼->(Subscript[𝔼, sp]);
𝔼4@(Subscript[𝔼, sp___])[as___]:=𝔼4@𝔼[as]/.𝔼->(Subscript[𝔼, sp]);

$k=2;
Clear[QP,ω];
QP[Knot[n_,k_]] := QP[Knot[n,k]]=Collect[Module[{fname},
fname="../../Projects/PG/Data/"<>ToString[n]<>"_"<>ToString[k]<>".m";
Collect[𝔼3[Get[fname][[2,2]]][[3]] // Normal, ϵ, Simplify]
], ϵ, Factor];
ω[K_Knot]:=ω[K]=Factor[(((QP@K/.ϵ->0))^(-1))];
(Subscript[c, k_,d_])[K_Knot]:=Factor[SeriesCoefficient[QP[K],{y,0,0}, {ϵ,0,k},{a,0,d}]((ω[K])^(1+2k-d))]

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

Clear[ρ1,ρ2];
ρ1[K_Knot]:=ρ1[K]=Factor[((T(-(Subscript[c, 1,0])[K]+ω[K]T(∂_T)ω[K]))/(((T-1))^2))];
ρ2[K_Knot]:=ρ2[K]=Factor[-2(Subscript[c, 2,0])[K]+ω[K](Subscript[c, 2,1])[K]];
plus[ℰ_]:=Expand[ℰ]/. (T^(n_.))/; n<0 :> 0;

TableForm[Table[Factor@Join[{(Subscript[K[[1]], K[[2]]]),ρ1[K],ρ2[K]},z=(Subscript[ρ, 2])[K]/.(Subscript[ca, 2,1])->0;{((z[[2]])/((((T-1))^2)/T)),z[[3]]}], {K,AllKnots[{3,7}]}], TableAlignments->Center]

MatrixForm[tab=Table[z=(Subscript[ρ, 2])[K];Ω=z[[1]];
Factor@Join[{ρ1[K],ρ2[K]},{ P2[K],Ω((T^2)/((T^2)-1))(∂_T)ρ1[K],((T^2)/((T^2)-1))(∂_T)Ω,Ω ((T^2)/((T^2)-1))(∂_T)Ω,(Ω^2)((T^2)/((T^2)-1))(∂_T)Ω,(Ω^3) Factor[((T^2)/((T^2)-1))(∂_T)Ω],(Ω^2)(((((T^2)/((T^2)-1))(∂_T)Ω))^2),Ω Factor[((T^2)/((T^2)-1))(∂_T)Ω]ρ1[K],(Ω^3)Factor[(((T(∂_T)(T(∂_T)Ω))-T(((T^2)+1)/((T^2)-1))(∂_T)Ω)/((2 (((-1+T))^2) (((1+T))^2))/(T^2)))],ρ1[K]Ω,(Ω^3),((z[[2]])/((((T-1))^2)/T)),z[[3]]/.(Subscript[ca, 2,1])->0,Coefficient[z[[3]],(Subscript[ca, 2,1])]}], {K,AllKnots[{3,7}]}]]
NullSpace[tab/.T->100]

Factor[tab-(tab/.T->(T^(-1)))]

MatrixForm[tab=Table[z=(Subscript[ρ, 2])[K];Ω=z[[1]];
Factor@Join[{ρ2[K]},{(Ω^3) Factor[((T^2)/((T^2)-1))(∂_T)Ω],(Ω^2)(((((T^2)/((T^2)-1))(∂_T)Ω))^2),(Ω^3)Factor[(((T(∂_T)(T(∂_T)Ω))-T(((T^2)+1)/((T^2)-1))(∂_T)Ω)/((2 (((-1+T))^2) (((1+T))^2))/(T^2)))],z[[3]]/.(Subscript[ca, 2,1])->0}], {K,AllKnots[{3,7}]}]]
NullSpace[tab]

MatrixForm[tab=Table[z=(Subscript[ρ, 2])[K];Ω=z[[1]];
Factor@Join[{ρ2[K]},{(Ω^3) Factor[((T^2)/((T^2)-1))(∂_T)Ω],(Ω^2)(((((T^2)/((T^2)-1))(∂_T)Ω))^2),(Ω^3)Factor[(((T(∂_T)(T(∂_T)Ω))-T(((T^2)+1)/((T^2)-1))(∂_T)Ω)/((2 (((-1+T))^2) (((1+T))^2))/(T^2)))],z[[3]]/.(Subscript[ca, 2,1])->0}], {K,AllKnots[{3,8}]}]]
NullSpace[tab]

Factor[tab-(tab/.T->(T^(-1)))]