Pensieve header: The 3-Heisenberg Formalism for $\Theta$. Engine modified from pensieve://Projects/BabyDoPeGDO/Solving_to_k=3.nb, $px$ formulas modified from pensieve://Talks/Bonn-2505/. Last version before the transition to the $xp$ order.

𝔼[ω,Q,P_ϵSeries] represents ω (e^(Q+P)), where ω is a scalar, Q is an ϵ-free quadratic, and P=(∑_(k=0)^$k)P[[k]](ϵ^k) is a perturbation (it is ill-advised to include ω in P because then it will have log terms).

Scheme: (Subscript[𝔼, _])[_]//(Subscript[𝔼, _])[_] calls FZip or Zip, which are functionally the same. Zip works by handling the quadratic part and calling PZip for the perturbation-only part. PZip works by iteratively solving the synthesis equation. FZip works by encapsulating coefficients, calling Zip, and back-substituting.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Talks\\Banff-2607"];
Once[<<KnotTheory`];

$k=1;

Minor utilities

CCF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[ℰ]; (*CoefficientCanonical Form *)
CCF[ℰ_] := Factor[ℰ]; (*CoefficientCanonical Form *)
CF[ℰ_List]:=CF/@ℰ;
CF[ℰ_ϵSeries]:=CF/@Take[ℰ,$k+1];
CF[ℰ_] :=Module[{F},Expand@Collect[ℰ,(Subscript[(p|x|π|ξ|g), __]),F]/.F->CCF];
(*CF[ℰ_] := Module[
{vs=Cases[ℰ,(Subscript[(p|x|π|ξ), __]),∞]},
Total[(CCF[#[[2]]](Times@@(vs^(#[[1]]))))& /@ CoefficientRules[Expand[ℰ], vs]]
];*)
CF[ℰ_𝔼]:=CF/@ℰ; 
CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];

ϵSeries/: S1_ϵSeries≡S2_ϵSeries:=Length[S1]==Length[S2]∧Inner[CF[#1]==CF[#2]&,S1,S2,And];
ϵSeries[]:=ϵSeries@@Table[0,$k+1];
ϵSeries/: Plus[ss___ϵSeries]:=Module[{l=Min[Length/@{ss}]},
ϵSeries@@Total[Take[List@@#,l]&/@{ss}]
];
(*ϵSeries/: S1_ϵSeries+S2_ϵSeries := ϵSeries@@Table[S1[[k]]+S2[[k]],{k,Min[Length@S1,Length@S2]}];*)
ϵSeries/: S1_ϵSeries*S2_ϵSeries := ϵSeries@@Table[Sum[S1[[j+1]]*S2[[k-j+1]], {j,0,k}],{k,0,Min[Length@S1,Length@S2]-1}];
ϵSeries /:c_*S_ϵSeries:=(c#)& /@ S;
ϵSeries/:(∂_(vs___))S_ϵSeries:=(s|->(∂_vs)s)/@S;

The Main Program

Variables and their duals:

{(SuperStar[p]),(SuperStar[x]),(SuperStar[π]),(SuperStar[ξ])}={π,ξ,p,x}; 
(SuperStar[(vs_List)]):=(v|->(SuperStar[v]))/@vs;
(SuperStar[((Subscript[u_, νi__]))]):=(Subscript[((SuperStar[u])), νi]);

𝔼 operations:

𝔼/:𝔼[ω1_,Q1_,P1_]≡𝔼[ω2_,Q2_,P2_]:=CF[ω1==ω2]∧CF[Q1==Q2]∧(P1≡P2);
𝔼/:𝔼[ω1_,Q1_,P1_]𝔼[ω2_,Q2_,P2_]:=𝔼[ω1 ω2,Q1+Q2,P1+P2];
(Subscript[𝔼, d1_->r1_])[ℰ1s___]≡(Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (d1==d2)∧(r1==r2)∧(𝔼[ℰ1s]≡𝔼[ℰ2s]);
(Subscript[𝔼, d1_->r1_])[ℰ1s___](Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[ℰ1s]𝔼[ℰ2s]);
(Subscript[(Subscript[𝔼, dr_])[ℰs___], $k_]):=(Subscript[𝔼, dr])@@(Subscript[𝔼[ℰs], $k]);

(Subscript[𝔼, d1_->r1_])[ℰ1s___]//(Subscript[𝔼, d2_->r2_])[ℰ2s___] :=Module[{is=r1⋂d2,lvs},
lvs=Flatten@Table[{(Subscript[x, ν,$@i]),(Subscript[p, ν,$@i])},{ν,3},{i,is}];
(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@((Subscript[Zip, lvs⋃(SuperStar[lvs])])[(SuperStar[lvs]).lvs,Times[
𝔼[ℰ1s]/.Table[(Subscript[(u:(x|p)), ν_,i])->(Subscript[u, ν,$@i]),{i,is}],
𝔼[ℰ2s]/.Table[(Subscript[(u:(ξ|π)), ν_,i])->(Subscript[u, ν,$@i]),{i,is}]
]])
]

(Subscript[Zip, vs_])[ℱ_,ℰ_]:=((*EchoLabel["EZip called with {vs,ℱ,ℰ} = "][{vs,ℱ,ℰ}];*) ⟨ℱ,ℰ⟩//(Subscript[Zip1, vs])//(Subscript[EZip23, vs]));
(Subscript[Zip, vs_])[ℱ_,ℰ_]:=((*EchoLabel["EZip called with {vs,ℱ,ℰ} = "][{vs,ℱ,ℰ}];*)⟨ℱ,ℰ⟩//(Subscript[Zip1, vs])//(Subscript[Zip2, vs])//(Subscript[Zip3, vs]));

Getting rid of the quadratic.

(Subscript[Zip1, {}])=Identity;
(Subscript[Zip1, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := Module[{ℐ,F,G,u,v},
(*EchoLabel["EZip1 called with {vs,ℱ,ω,Q,P} = "][{vs,ℱ,ω,Q,P}];*)
ℐ=IdentityMatrix@Length@vs;
F=Table[(∂_(u,v))ℱ,{u,(SuperStar[vs])},{v,(SuperStar[vs])}];
G=Table[(∂_(u,v))Q,{u,vs},{v,vs}];
⟨CF[(SuperStar[vs]).F.Inverse[ℐ-G.F].(SuperStar[vs])/2], 𝔼[CF@PowerExpand@Factor[ω  ((Det[ℐ- G.F])^(-1/2))],CF[Q-vs.G.vs/2],P]⟩
]

Getting rid of linear terms.

(Subscript[Zip2, {}])=Identity;
(Subscript[Zip2, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := Module[{F,Y,u,v},
(*EchoLabel["EZip2 called with {vs,ℱ,ω,Q,P} = "][{vs,ℱ,ω,Q,P}];*)
F=Table[(∂_(u,v))ℱ,{u,(SuperStar[vs])},{v,(SuperStar[vs])}];
Y=Table[(∂_v)Q,{v,vs}];
CF/@⟨ℱ, 𝔼[ω,Q-Y.vs+Y.F.Y/2, P/.Thread[vs->vs+F.Y]]⟩
]

Dealing with Feynman diagrams.

Note that the power m of λ is at most k-1+((2k+2)/2)=2k. We write (Subscript[Z, λ])=∑Z[m](λ^m).

(Subscript[Zip3, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := Module[{Z,u,v,m,j},
(*EchoLabel["Zip3 called with {vs,ℱ,ω,Q,P} = "][{vs,ℱ,ω,Q,P}];*)
Z[0]=P;
For[m=0,m<2$k+3,++m,
Z[m+1]=CF[(1/(2(m+1)))Sum[(∂_((SuperStar[u]),(SuperStar[v])))ℱ((∂_(u,v))Z[m]+Sum[((∂_u)Z[j])((∂_v)Z[m-j]),{j,0,m}]),{u,vs},{v,vs}]]
];
𝔼[ω,Q,CF[Sum[Z[m],{m,0,2$k+3}]/.Table[v->0,{v,vs}]]]
]

(Subscript[EZip23, vs_])@⟨ℱ_,𝔼[ω_,Q_,P_]⟩ := Module[
{nP,nℱ,nQ,j=0,ps,c,t,rr={(*release rules*)}},
nP=Total[
CoefficientRules[#, vs] /. (ps_->c_) :> (AppendTo[rr,t[++j]->CF@c]; t[j](Times@@(vs^ps)))
]& /@ P;
nQ=Total[CoefficientRules[Q, vs] /. (ps_->c_) :> (AppendTo[rr,t[++j]->CF@c]; t[j](Times@@(vs^ps)))];
nℱ=Total[CoefficientRules[ℱ, (SuperStar[vs])] /. (ps_->c_) :> (AppendTo[rr,t[++j]->CF@c]; t[j](Times@@((((SuperStar[vs])))^ps)))];
CF[Expand[⟨nℱ,𝔼[ω,nQ,nP]⟩//(Subscript[Zip2, vs])//(Subscript[Zip3, vs])]/.rr]
]

(Subscript[m, i_,j_->k_]):=(Subscript[𝔼, {i,j}->{k}])[1,(∑_(ν=1)^3)(-(Subscript[ξ, ν,i])(Subscript[π, ν,j])+((Subscript[π, ν,i])+(Subscript[π, ν,j]))(Subscript[p, ν,k])+((Subscript[ξ, ν,i])+(Subscript[ξ, ν,j]))(Subscript[x, ν,k])),ϵSeries[]]

(Subscript[m, a,b->c])

g2px and px2g

From pensieve://Talks/Geneva-2408/DataConversions.nb

g2px[ℰ_]:=CF@Module[{λ},Expand[ℰ/.(Subscript[g, ν_,i_,j_]):>(Subscript[λ, ν]) (Subscript[p, ν,i])(Subscript[x, ν,j])]/.(Subscript[λ, _]^(k_.)):>1/k!]

(Subscript[Zip, {}])[ℰ_]:=ℰ;
(Subscript[Zip, {ζ_,ζs___}])[ℰ_] := (Collect[ℰ//(Subscript[Zip, {ζs}]),ζ] /. f_.(ζ^(d_.)):>(D[f,{(SuperStar[ζ]),d}]))/.(SuperStar[ζ])->0

px2g[ℰ_]:=CF@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[[3]],x0[[3]]]),{p0,ps},{x0,xs}];
Expand[(Subscript[Zip, ps⋃xs])[ℰ (E^Q)]/.(Subscript[g, α_,β_,i_,j_]):>If[α===β,(Subscript[g, α,i,j]),0]]
]

gRules

From pensieve://Talks/MonteVerita-2604/Theta.nb

(Subscript[gR, s_,i_,j_]):={
(Subscript[g, ν_,j,β_]):>(Subscript[g, ν,(SuperPlus[j]),β])+(Subscript[δ, j,β]),(Subscript[g, ν_,i,β_]):>(Subscript[T, ν]^s)(Subscript[g, ν,(SuperPlus[i]),β])+(1-(Subscript[T, ν]^s))(Subscript[g, ν,(SuperPlus[j]),β])+(Subscript[δ, i,β]),
(Subscript[g, ν_,α_,(SuperPlus[i])]):>(Subscript[T, ν]^s)(Subscript[g, ν,α,i])+(Subscript[δ, α,(SuperPlus[i])]),(Subscript[g, ν_,α_,(SuperPlus[j])]):>(Subscript[g, ν,α,j])+(1-(Subscript[T, ν]^s))(Subscript[g, ν,α,i])+(Subscript[δ, α,(SuperPlus[j])])
}

Inverse gRules written locally:

(Subscript[igR, s_,i_,j_]):={
(Subscript[g, ν_,(SuperPlus[j]),β_]):>(Subscript[g, ν,j,β])-(Subscript[δ, j,β]), (Subscript[g, ν_,(SuperPlus[i]),β_]):>(Subscript[T, ν]^(-s))(Subscript[g, ν,i,β])-((Subscript[T, ν]^(-s))-1)(Subscript[g, ν,(SuperPlus[j]),β])-(Subscript[T, ν]^(-s))(Subscript[δ, i,β]),
(Subscript[g, ν_,α_,i]):>(Subscript[T, ν]^(-s))((Subscript[g, ν,α,(SuperPlus[i])])-(Subscript[δ, α,(SuperPlus[i])])),(Subscript[g, ν_,α_,j]):>(Subscript[g, ν,α,(SuperPlus[j])])-(1-(Subscript[T, ν]^s))(Subscript[g, ν,α,i])-(Subscript[δ, α,(SuperPlus[j])])
}

Some Knot Theory

(Subscript[Kink, i_]):=(Subscript[CC, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->i]);
(Subscript[(OverBar[Kink]), i_]):=(Subscript[CC, 3])(Subscript[(OverBar[R]), 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->i])

RVK[pd_PD]:=Module[{n,xs,x,rots,front={0},k},
n=Length@pd;rots=Table[0,{2n}];
xs=Cases[pd,x_X:>(Piecewise[{{Xp[x[[4]],x[[1]]], PositiveQ@x}, {Xm[x[[2]],x[[1]]], True}}])];
For[k=0,k<2n,++k,If[k==0∨FreeQ[front,-k],
front=Flatten[front/.k->(xs/.{
Xp[k+1,l_]|Xm[l_,k+1]:>{l,k+1,1-l},
Xp[l_,k+1]|Xm[k+1,l_]:>(++rots[[l]];{1-l,k+1,l})
})],
Cases[front,k|-k]/.{k,-k}:>--rots[[k+1]];
]];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];

rot[i_,0]:=(Subscript[𝔼, {}->{i}])[1,0,ϵSeries[]];
rot[i_,n_]:=Module[{j},If[n>0,rot[i,n-1](Subscript[CC, j]),rot[i,n+1](Subscript[(OverBar[CC]), j])]//(Subscript[m, i,j->i])];

Z[K_] := Z[RVK@K];
Z[rvk_RVK] := (*Z[rvk] =*)Module[{todo,n,rots,ζ,done,st,cx, ζ1, i,j,k,k1,k2,k3},
{todo,rots}=List@@rvk;
AppendTo[rots,0];
n=Length[todo];
ζ=(Subscript[𝔼, {}->{0}])[1,0,ϵSeries[]];
done={0};
st=Range[0,2n+1];
While[{}=!=($M=todo),
{cx}=MaximalBy[todo, Length[done⋂{#[[1]], #[[2]], #[[1]]-1,#[[2]]-1}]&,1];
{i,j}=List@@cx;
ζ1=Switch[Head[cx],
 Xp, ((Subscript[R, i,j])(Subscript[(OverBar[Kink]), k]))//(Subscript[m, j,k->j]),
 Xm, ((Subscript[(OverBar[R]), i,j])(Subscript[Kink, k]))//(Subscript[m, j,k->j])
];
ζ1=(rot[k,rots[[i]]]ζ1)//(Subscript[m, k,i->i]); rots[[i]]=0;
ζ1=(ζ1 rot[k, rots[[i+1]]])//(Subscript[m, i,k->i]); rots[[i+1]]=0;
ζ1=(rot[k,rots[[j]]]ζ1)//(Subscript[m, k,j->j]); rots[[j]]=0;
ζ1=(ζ1 rot[k, rots[[j+1]]])//(Subscript[m, j,k->j]); rots[[j+1]]=0;
ζ*=ζ1;
If[MemberQ[done, i], ζ=ζ//(Subscript[m, i,i+1->i]); st=st/.st[[i+2]]->st[[i+1]]];
If[MemberQ[done, i-1],  ζ=ζ//(Subscript[m, st[[i]],i->st[[i]]]); st=st/.st[[i+1]]->st[[i]]]; 
If[MemberQ[done, j],  ζ=ζ//(Subscript[m, j,j+1->j]); st=st/.st[[j+2]]->st[[j+1]]]; 
If[MemberQ[done, j-1],  ζ=ζ//(Subscript[m, st[[j]],j->st[[j]]]); st=st/.st[[j+1]]->st[[j]]];
done=done⋃{i-1,i,j-1,j};
todo=DeleteCases[todo, cx]
];
CF/@ (ζ (*/. {(Subscript[x, 0])->x,(Subscript[y, 0])->y,(Subscript[a, 0])->a}*))
]

(Subscript[ρ, 1]) testing

From Talks/Bonn-2505/Itype.nb:

ℒ[(Subscript[X, i_,j_])[s_]]:=(T^(s/2))𝔼[{
(Subscript[x, i])((Subscript[p, i+1])-(Subscript[p, i]))+(Subscript[x, j])((Subscript[p, j+1])-(Subscript[p, j]))+((T^s)-1)(Subscript[x, i])((Subscript[p, i+1])-(Subscript[p, j+1])),0,0,(ϵ s/2)×((Subscript[x, i])((Subscript[p, i])-(Subscript[p, j]))(((T^s)-1)(Subscript[x, i])(Subscript[p, j])+2(1-(Subscript[x, j])(Subscript[p, j])))-1)
}]
ℒ[(Subscript[C, i_])[φ_]]:=(T^(φ/2))𝔼[(Subscript[x, i])((Subscript[p, i+1])-(Subscript[p, i]))+ϵ φ((1/2)-(Subscript[x, i])(Subscript[p, i]))]
ℒ[K_]:=CF[ℒ/@Features[K][[2]]]
vs[K_]:=Join@@Table[{(Subscript[p, i]),(Subscript[x, i])},{i,Features[K][[1]]}]

From Projects/BabyDoPeGDO/Solving to $k=3.nb:

(Subscript[R, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[1,((Subscript[T, 1])-1) (Subscript[x, 1,j]) ((Subscript[p, 1,i])-(Subscript[p, 1,j])),ϵSeries[0]];
(Subscript[(OverBar[R]), i_,j_]):=(Subscript[𝔼, {}->{i,j}])[1,((Subscript[T, 1]^(-1))-1) (Subscript[x, 1,j]) ((Subscript[p, 1,i])-(Subscript[p, 1,j])),ϵSeries[0]];
(Subscript[CC, i_]):=(Subscript[𝔼, {}->{i}])[(Sqrt[(Subscript[T, 1])]),0,ϵSeries[0,0]];
(Subscript[(OverBar[CC]), i_]):=(Subscript[𝔼, {}->{i}])[(1/(Sqrt[(Subscript[T, 1])])),0,ϵSeries[0,0]];

$k=0;
(Subscript[R, i,j])
(Subscript[(OverBar[R]), i,j])
(Subscript[CC, i])
(Subscript[(OverBar[CC]), i])

(Subscript[CC, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->1])

(Subscript[CC, 3])(Subscript[R, 1,2])
(Subscript[CC, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])

$k=0; {
{"C(OverBar[C])", ((Subscript[CC, 1])(Subscript[(OverBar[CC]), 2])//(Subscript[m, 1,2->1]))≡(Subscript[𝔼, {}->{1}])[1,0,ϵSeries[]]},
{"An R1", ((Subscript[CC, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->1]))≡((Subscript[(OverBar[CC]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1]))},
{"R2b",((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))≡(Subscript[𝔼, {}->{1,2}])[1,0,ϵSeries[]]},
{"R3",((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))≡((Subscript[R, 2,3])(Subscript[R, 4,5])(Subscript[R, 1,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))}
}

NewBit[K_]:=Module[{Alex=Alexander[K][(Subscript[T, 1])]},
(Subscript[T, 1]^3)((Alex^2)/((Subscript[T, 1])-1))Z[K][[3,2]]//Factor]

NewBit/@AllKnots[{3,5}]

In pensieve://Projects/BabyDoPeGDO/Solving to $k=3.nb that was 

{2-T+(T^2),(1+T) (1-3 T+(T^2)),((4-3 T+5 (T^2)-3 (T^3)+3 (T^4)-(T^5)+(T^6))/(T^2)),9-11 T+7 (T^2)-(T^3)}

And now θ

(Subscript[T, 3])=(Subscript[T, 1])(Subscript[T, 2]);
ℒ[(Subscript[X, i_,j_])[s_]]:=(Subscript[T, 3]^s)𝔼[CF@{
(∑_(ν=1)^3)((Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,i]))+(Subscript[x, ν,j])((Subscript[p, ν,(SuperPlus[j])])-(Subscript[p, ν,j]))+((Subscript[T, ν]^s)-1)(Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,(SuperPlus[j])]))),
((Subscript[T, 1]^s)-1)(Subscript[p, 3,j])(Subscript[x, 1,i])((Subscript[T, 2]^s)(Subscript[x, 2,i])-(Subscript[x, 2,j])),
ϵ s((Subscript[T, 3]^s)-1)(Subscript[p, 1,j])((Subscript[p, 2,i])-(Subscript[p, 2,j]))(Subscript[x, 3,i])/((Subscript[T, 2]^s)-1),
ϵ s(1/2+(Subscript[T, 2]^s)(Subscript[p, 1,i])(Subscript[p, 2,j])(Subscript[x, 1,i])(Subscript[x, 2,i])-(Subscript[p, 1,i])(Subscript[p, 2,j])(Subscript[x, 1,i])(Subscript[x, 2,j])-(Subscript[p, 3,i])(Subscript[x, 3,i])-((Subscript[T, 2]^s)-1)(Subscript[p, 2,j])(Subscript[p, 3,i])(Subscript[x, 2,i])(Subscript[x, 3,i])+((Subscript[T, 3]^s)-1)(Subscript[p, 2,j])(Subscript[p, 3,j])(Subscript[x, 2,i])(Subscript[x, 3,i])+2 (Subscript[p, 2,j])(Subscript[p, 3,i])(Subscript[x, 2,j])(Subscript[x, 3,i])+(Subscript[p, 1,i])(Subscript[p, 3,j])(Subscript[x, 1,i])(Subscript[x, 3,j])-(Subscript[p, 2,i])(Subscript[p, 3,j])(Subscript[x, 2,i])(Subscript[x, 3,j])-(Subscript[T, 2]^s)(Subscript[p, 2,j])(Subscript[p, 3,j])(Subscript[x, 2,i])(Subscript[x, 3,j])+(((Subscript[T, 1]^s)-1)(Subscript[p, 1,j])(Subscript[x, 1,i])((Subscript[T, 2]^(2s))(Subscript[p, 2,j])(Subscript[x, 2,i])-(Subscript[T, 2]^s)(Subscript[p, 2,j])(Subscript[x, 2,j])-((Subscript[T, 2]^s)+1)((Subscript[T, 3]^s)-1)(Subscript[p, 3,j])(Subscript[x, 3,i])+(Subscript[T, 2]^s)(Subscript[p, 3,j])(Subscript[x, 3,j]))+((Subscript[T, 3]^s)-1)(Subscript[p, 3,j])(Subscript[x, 3,i])(1-(Subscript[T, 2]^s)(Subscript[p, 1,i])(Subscript[x, 1,i])+(Subscript[p, 2,i])(Subscript[x, 2,j])+((Subscript[T, 2]^s)-2)(Subscript[p, 2,j])(Subscript[x, 2,j])))/((Subscript[T, 2]^s)-1))}]

ℒ[(Subscript[C, i_])[φ_]]:=(Subscript[T, 3]^φ)𝔼[{(∑_(ν=1)^3)(Subscript[x, ν,i])((Subscript[p, ν,(SuperPlus[i])])-(Subscript[p, ν,i])),ϵ φ((Subscript[p, 3,i])(Subscript[x, 3,i])-1/2)}]

(Subscript[R, i_,j_]):=CF[ℒ[(Subscript[X, i,j])[1]]/.ω_ 𝔼[{Q_,P0_,P1a_,P1b_}]:>(Subscript[𝔼, {}->{i,j}])[
ω,(∑_(ν=1)^3)(((Subscript[T, ν])-1) (Subscript[x, ν,j]) ((Subscript[p, ν,i])-(Subscript[p, ν,j]))),
ϵSeries[P0,P1a+P1b/.ϵ->1]
]];
(Subscript[(OverBar[R]), i_,j_]):=CF[ℒ[(Subscript[X, i,j])[-1]]/.ω_ 𝔼[{Q_,P0_,P1a_,P1b_}]:>(Subscript[𝔼, {}->{i,j}])[
ω,(∑_(ν=1)^3)(((Subscript[T, ν]^(-1))-1) (Subscript[x, ν,j])((Subscript[p, ν,i])-(Subscript[p, ν,j]))),
ϵSeries[P0,P1a+P1b/.ϵ->1]
]];
(Subscript[CC, i_]):=CF[ℒ[(Subscript[C, i])[1]]/. ω_ 𝔼[{Q_,P_}]:> (Subscript[𝔼, {}->{i}])[
ω,0,ϵSeries[0,P/.ϵ->1]
]];
(Subscript[(OverBar[CC]), i_]):=CF[ℒ[(Subscript[C, i])[-1]]/. ω_ 𝔼[{Q_,P_}]:> (Subscript[𝔼, {}->{i}])[
ω,0,ϵSeries[0,P/.ϵ->1]
]];

(Subscript[(OverBar[R]), i,j])//CF

(Subscript[CC, 1])//CF

(Subscript[(OverBar[CC]), 1])//CF

$k=0; {
{"C(OverBar[C])", ((Subscript[CC, 1])(Subscript[(OverBar[CC]), 2])//(Subscript[m, 1,2->1]))≡(Subscript[𝔼, {}->{1}])[1,0,ϵSeries[]]},
{"An R1", ((Subscript[CC, 3])(Subscript[R, 1,2])//(Subscript[m, 2,3->2])//(Subscript[m, 2,1->1]))≡((Subscript[(OverBar[CC]), 3])(Subscript[R, 1,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,2->1]))},
{"R2b",((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))≡(Subscript[𝔼, {}->{1,2}])[1,0,ϵSeries[]]},
{"R3",((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))≡((Subscript[R, 2,3])(Subscript[R, 4,5])(Subscript[R, 1,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3]))}
}

$k=0;
(Subscript[R, 1,2])//CF
(Subscript[(OverBar[R]), 3,4])//CF
R2LHS=((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))

R2LHS0=(Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])

CF[R2LHS0[[2]]+R2LHS0[[3,1]]]