Pensieve header: A development notebook for $\rho_k$.

Preliminaries

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Oaxaca-2210"];
Once[<<KnotTheory`; <<Rot.m];

The Old Program

(Subscript[R, 1])[s_,i_,j_]:=s((Subscript[g, j,i])((Subscript[g, (SuperPlus[j]),j])+(Subscript[g, j,(SuperPlus[j])])-(Subscript[g, i,j]))-(Subscript[g, i,i])((Subscript[g, j,(SuperPlus[j])])-1)-1/2);
ρ[K_]:=ρ[K]=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,ρ1},
{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];
ρ1=(∑_(k=1)^n)(Subscript[R, 1])@@Cs[[k]] - (∑_(k=1)^(2n))φ[[k]]((Subscript[g, k,k])-1/2);
Factor@{Δ,(Δ^2)ρ1/.(SuperPlus[α_]):>α+1/.(Subscript[g, α_,β_]):>G[[α,β]]}];

The g-Rules

(Subscript[δ, i_,j_]):=If[i===j,1,0];
(Subscript[gRules, s_,i_,j_]):={(Subscript[g, i,β_]):>(Subscript[δ, i,β])+(T^s)(Subscript[g, (SuperPlus[i]),β])+(1-(T^s))(Subscript[g, (SuperPlus[j]),β]),(Subscript[g, j,β_]):>(Subscript[δ, j,β])+(Subscript[g, (SuperPlus[j]),β]),
(Subscript[g, α_,i]):>(T^(-s))((Subscript[g, α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, α_,j]):>(Subscript[g, α,(SuperPlus[j])])-(1-(T^s))(Subscript[g, α,i])-(Subscript[δ, α,(SuperPlus[j])])}
(SuperPlus[((SuperPlus[α_]))]):=(α^("++"));    (* this is for cosmetic reasons only *)

CF

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

g2px and px2g

g2px[ℰ_]:=Module[{λ},Expand[ℰ/.(Subscript[g, α_,β_]):>λ (Subscript[p, α])(Subscript[x, β])]/.(λ^(k_.)):>1/k!]

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

px2g[ℰ_]:=Module[{ps,xs,Q},
ps=Union[Cases[ℰ,(Subscript[p, α_]),∞]];
xs=Union[Cases[ℰ,(Subscript[x, α_]),∞]];
Q=Sum[(SuperStar[p0]) (SuperStar[x0]) (Subscript[g, p0[[2]],x0[[2]]]),{p0,ps},{x0,xs}];
(Subscript[Zip, ps⋃xs])[ℰ (E^Q)]//Expand
]

(Subscript[R, 1])[1,i,j]//Expand

(Subscript[R, 1])[1,i,j]//g2px

(Subscript[R, 1])[1,i,j]//g2px//px2g

(Subscript[R, 1])[1,i,j]//g2px//px2g//g2px

(((1+((Subscript[p, 1])+(Subscript[p, 2]))((Subscript[x, 1])+(Subscript[x, 2]))))^3)//px2g

(((1+((Subscript[p, 1])+(Subscript[p, 2]))((Subscript[x, 1])+(Subscript[x, 2]))))^4)//px2g//g2px//FullSimplify

(Subscript[R, 1])[1,i,j](Subscript[R, 1])[1,k,l]//g2px//px2g//FullSimplify//Short

((Subscript[R, 1])[1,1,3](Subscript[R, 1])[1,5,7]//.(Subscript[gRules, 1,1,3])⋃(Subscript[gRules, 1,5,7]))//g2px//px2g//FullSimplify//Short

Generic Perturbations

Module[{i,j,k},
AllMonomials[{},0]={1};
AllMonomials[{},d_Integer] /; d>0 := {};
AllMonomials[{v_,vs___},d_Integer] := Join@@Table[(v^(d-k))AllMonomials[{vs},k],{k,0,d}];
AllMonomials[vs_List, {d_}] := Join@@Table[AllMonomials[vs,k],{k,0,d}];
Basis[js_List,m_]:=Flatten@Outer[Times,AllMonomials[Table[(Subscript[p, j]),{j,js}],m],AllMonomials[Table[(Subscript[x, j]),{j,js}],m]];
Basis[js_List,{m_}]:=Flatten@Table[Basis[js,k],{k,0,m}];
GenericCombination[bas_,c_]:=bas.Table[(Subscript[c, j]),{j,Length@bas}];
GenericCombination[bas_,(Subscript[c_, k_])]:=bas.Table[(Subscript[c, k,j]),{j,Length@bas}];
]

Module[{k},
(Subscript[r, d_])[i_,j_]:=Expand@Together@Sum[(ϵ^k)GenericCombination[Basis[{i,j},{k+1}],(Subscript[c, k])],{k,d}]
];

(Subscript[r, 2])[j,k]

Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]

Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]/.(Subscript[c, 1,_])->0

Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])},λ,λs},
λs=(Subscript[λ, #])&/@Range[d-1];
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]+Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β])+(Subscript[g, β,α])(Subscript[π, β])(Subscript[ξ, α]),{α,es},{β,λs}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]

Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])},λ,λs},
λs=(Subscript[λ, #])&/@Range[d-1];
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]+Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β])+(Subscript[g, β,α])(Subscript[π, β])(Subscript[ξ, α]),{α,es},{β,λs}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]/.(Subscript[c, 1,_])->0

Non-Universally Solving at d=1

Short[lhs=Expand[Module[{d=1,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])]]

Short[rhs=Expand[Module[{d=1,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[i,j]+(Subscript[r, d])[(SuperPlus[i]),k]+(Subscript[r, d])[(SuperPlus[j]),(SuperPlus[k])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])]]

Exponent[lhs-rhs,T,Min]

vars=Cases[Variables[lhs-rhs], (Subscript[c, __])]

covars=DeleteCases[Variables[lhs-rhs],T| (Subscript[c, __])]

Short[eqns=(#==0)&/@Union[Last /@ CoefficientRules[Expand[(T^4)(lhs-rhs)], covars]]]

{sol}=Solve[eqns,vars]

sol/.Rule->Set

lhs=CF[((Subscript[r, 1])[i,j]//px2g)//.(Subscript[gRules, 1,i,j])/.{ϵ->1,(Subscript[c, 1,1])->-(1/2),(Subscript[c, 1,2])->1,(Subscript[c, 1,4])->-1,(Subscript[c, 1,9])->(1/2)(T-1),(Subscript[c, 1,10])->-1}]
lhs==CF[(Subscript[R, 1])[1,i,j]//.(Subscript[gRules, 1,i,j])]

Solving at d=1

lhs=Expand[Module[{d=1,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])},λs},
λs=(Subscript[λ, #])&/@Range[d+1];
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]+Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β])+(Subscript[g, β,α])(Subscript[π, β])(Subscript[ξ, α]),{α,es},{β,λs}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])]

rhs=Expand[Module[{d=1,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])},λs},
λs=(Subscript[λ, #])&/@Range[d+1];
Times[
Normal@Series[Exp[(Subscript[r, d])[i,j]+(Subscript[r, d])[(SuperPlus[i]),k]+(Subscript[r, d])[(SuperPlus[j]),(SuperPlus[k])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]+Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β])+(Subscript[g, β,α])(Subscript[π, β])(Subscript[ξ, α]),{α,es},{β,λs}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])]

lhs-rhs

Exponent[lhs-rhs,T,Min]

vars=Cases[Variables[lhs-rhs], (Subscript[c, __])]

covars=DeleteCases[Variables[lhs-rhs],T| (Subscript[c, __])]

Short[eqns=(#==0)&/@Union[Last /@ CoefficientRules[Expand[(T^4)(lhs-rhs)], covars]]]

{sol}=Solve[eqns,vars]

sol/.Rule->Set

Simplify[(Subscript[r, 1])[j,k]/.{(Subscript[c, 1,1|2|4])->0,(Subscript[c, 1,9])->1,(Subscript[c, 1,13])->-1}]

(Subscript[c, 1,1])=(Subscript[c, 1,2])=(Subscript[c, 1,4])=0; (Subscript[c, 1,9])=1; (Subscript[c, 1,13])=-1;
(Subscript[r, 1])[j,k]

Non-Universally Solving at d=2

Short[lhs=Expand[Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])]]

Short[rhs=Expand[Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[i,j]+(Subscript[r, d])[(SuperPlus[i]),k]+(Subscript[r, d])[(SuperPlus[j]),(SuperPlus[k])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])]]

Exponent[lhs-rhs,T,Min]

vars=Cases[Variables[lhs-rhs], (Subscript[c, __])]

covars=DeleteCases[Variables[lhs-rhs],T| (Subscript[c, __])]

Short[eqns=(#==0)&/@Union[Last /@ CoefficientRules[Expand[(T^6)(lhs-rhs)], covars]]]

{sol}=Solve[eqns,vars]

sol/.Rule->Set

(Subscript[r, 2])[j,k]

Solving at d=2

(Subscript[r, 2])[j,k]

lhs=Expand[Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])},λs},
λs=(Subscript[λ, #])&/@Range[d+1];
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]+Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β])+(Subscript[g, β,α])(Subscript[π, β])(Subscript[ξ, α]),{α,es},{β,λs}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])]

rhs=Expand[Module[{d=2,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])},λs},
λs=(Subscript[λ, #])&/@Range[d+1];
Times[
Normal@Series[Exp[(Subscript[r, d])[i,j]+(Subscript[r, d])[(SuperPlus[i]),k]+(Subscript[r, d])[(SuperPlus[j]),(SuperPlus[k])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]+Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β])+(Subscript[g, β,α])(Subscript[π, β])(Subscript[ξ, α]),{α,es},{β,λs}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])]

Exponent[lhs-rhs,T,Min]

vars=Cases[Variables[lhs-rhs], (Subscript[c, __])]

covars=DeleteCases[Variables[lhs-rhs],T| (Subscript[c, __])]

Short[eqns=(#==0)&/@Union[Last /@ CoefficientRules[Expand[(T^6)(lhs-rhs)], covars]]]

Simplify[eqns]

Non-Universally Solving at d=3

Short[lhs=Expand[Module[{d=3,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[j,k]+(Subscript[r, d])[i,(SuperPlus[k])]+(Subscript[r, d])[(SuperPlus[i]),(SuperPlus[j])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,j,k])⋃(Subscript[gRules, 1,i,(SuperPlus[k])])⋃(Subscript[gRules, 1,(SuperPlus[i]),(SuperPlus[j])])]]

Short[rhs=Expand[Module[{d=3,es={i,j,k,(SuperPlus[i]),(SuperPlus[j]),(SuperPlus[k])}},
Times[
Normal@Series[Exp[(Subscript[r, d])[i,j]+(Subscript[r, d])[(SuperPlus[i]),k]+(Subscript[r, d])[(SuperPlus[j]),(SuperPlus[k])]], {ϵ,0,d}],
Exp[Sum[(Subscript[g, α,β])(Subscript[π, α])(Subscript[ξ, β]),{α,es},{β,es}]]
]//(Subscript[Zip, ((Subscript[p, #])&/@es)⋃((Subscript[x, #])&/@es)])//Expand
]//.(Subscript[gRules, 1,i,j])⋃(Subscript[gRules, 1,(SuperPlus[i]),k])⋃(Subscript[gRules, 1,(SuperPlus[j]),(SuperPlus[k])])]]

Exponent[lhs-rhs,T,Min]

vars=Cases[Variables[lhs-rhs], (Subscript[c, __])]

covars=DeleteCases[Variables[lhs-rhs],T| (Subscript[c, __])]

Short[eqns=(#==0)&/@Union@Simplify[Last /@ CoefficientRules[Expand[(T^10)(lhs-rhs)], covars]]]

{sol3}=Solve[eqns,vars]

sol3/.Rule->Set

(Subscript[r, 3])[j,k]