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

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

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

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

gPair[fs_,w_]:=gPair[fs,w]=(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[ρ, d_])[K_]:=Module[{Cs,φ,n,A,s,i,j,k,Δ,G,d1,ρd1,ρd2,ρd3},
{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=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=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=ρd2/.F[fs_,es_]:>(gPair[
Replace[fs,Thread[es->Range@Length@es],{2}],Length@es
]/.(Subscript[g, α_,β_]):>(Subscript[g, es[[α]],es[[β]]]));
Collect[
{Δ,ρd3/.ϵ->ϵ (Δ^2)}/.{(Subscript[g, α_,β_]):>G[[α,β]],Δ->(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]},
ϵ,Factor]
];

{K=Knot[3,1],d=2}

{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=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=Expand[Normal@Series[ρd1,{ϵ,0,d}]]

ρd2=Expand[F[{},{}]×Normal@Series[ρd1,{ϵ,0,d}]]

ρd2=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}]

gPair[fs_,w_]:=gPair[fs,w]=(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}]]]

ρd3=ρd2/.F[fs_,es_]:>(gPair[
Replace[fs,Thread[es->Range@Length@es],{2}],Length@es
]/.(Subscript[g, α_,β_]):>(Subscript[g, es[[α]],es[[β]]]))

?gPair

Collect[
{Δ,ρd3/.ϵ->ϵ (Δ^2)}/.{(Subscript[g, α_,β_]):>G[[α,β]],Δ->(T^((-Total[φ]-Total[Cs[[All,1]]])/2))Det[A]},
ϵ,Factor]