Pensieve header: Solving the $PR^4$ relation degree by degree.

Startup

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Portfolio2"];
<<"../Profile/Profile.m";
<<"Engine-Speedy.m";
HL[ℰ_] := Style[ℰ, Background -> If[TrueQ@ℰ,,]];

The Objects

Symmetric Algebra Objects

(Subscript[sm, i_,j_->k_]):=(Subscript[𝔼, {i,j}->{k}])[(Subscript[b, k])((Subscript[β, i])+(Subscript[β, j]))+(Subscript[t, k])((Subscript[τ, i])+(Subscript[τ, j]))+(Subscript[a, k])((Subscript[α, i])+(Subscript[α, j]))+(Subscript[y, k])((Subscript[η, i])+(Subscript[η, j]))+(Subscript[x, k])((Subscript[ξ, i])+(Subscript[ξ, j]))];
(Subscript[sΔ, i_->j_,k_]):=(Subscript[𝔼, {i}->{j,k}])[(Subscript[β, i])((Subscript[b, j])+(Subscript[b, k]))+(Subscript[τ, i])((Subscript[t, j])+(Subscript[t, k]))+(Subscript[α, i])((Subscript[a, j])+(Subscript[a, k]))+(Subscript[η, i])((Subscript[y, j])+(Subscript[y, k]))+(Subscript[ξ, i])((Subscript[x, j])+(Subscript[x, k]))];
(Subscript[sS, i_]):=(Subscript[𝔼, {i}->{i}])[-(Subscript[β, i])(Subscript[b, i])-(Subscript[τ, i])(Subscript[t, i])-(Subscript[α, i])(Subscript[a, i])-(Subscript[η, i])(Subscript[y, i])-(Subscript[ξ, i])(Subscript[x, i])];
(Subscript[sη, i_]):=(Subscript[𝔼, {}->{i}])[0];(Subscript[sϵ, i_]):=(Subscript[𝔼, {i}->{}])[0];

(Subscript[sσ, i_->j_]):=(Subscript[𝔼, {i}->{j}])[(Subscript[β, i])(Subscript[b, j])+(Subscript[τ, i])(Subscript[t, j])+(Subscript[α, i])(Subscript[a, j])+(Subscript[η, i])(Subscript[y, j])+(Subscript[ξ, i])(Subscript[x, j])];
(Subscript[sΥ, i_->j_,k_,l_,m_]):=(Subscript[𝔼, {i}->{j,k,l,m}])[(Subscript[β, i])(Subscript[b, k])+(Subscript[τ, i])(Subscript[t, k])+(Subscript[α, i])(Subscript[a, l])+(Subscript[η, i])(Subscript[y, j])+(Subscript[ξ, i])(Subscript[x, m])];

The CU Definitions

cΛ=((Subscript[η, i])+(((E^(-γ (Subscript[α, i])-ϵ (Subscript[β, i]))) (Subscript[η, j]))/(1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i]))))(Subscript[y, k])+((Subscript[β, i])+(Subscript[β, j])+((Log[1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])])/ϵ))(Subscript[b, k])+((Subscript[α, i])+(Subscript[α, j])+((Log[1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])])/γ))(Subscript[a, k])+((((E^(-γ (Subscript[α, j])-ϵ (Subscript[β, j]))) (Subscript[ξ, i]))/(1+γ ϵ (Subscript[η, j]) (Subscript[ξ, i])))+(Subscript[ξ, j]))(Subscript[x, k]);
Define[(Subscript[cm, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[cΛ]]

Define[(Subscript[cσ, i->j])=(Subscript[sσ, i,j])/.(Subscript[τ, i])->0,(Subscript[cϵ, i])=(Subscript[sϵ, i]), (Subscript[cη, i])=(Subscript[sη, i]),(Subscript[cΔ, i->j,k])=(Subscript[sΔ, i->j,k]),
(Subscript[cS, i])=(Subscript[sS, i])//(Subscript[sΥ, i->1,2,3,4])//(Subscript[cm, 4,3->i])//(Subscript[cm, i,2->i])//(Subscript[cm, i,1->i])];

$k=1; (*ℏ=γ=1;*)

Booting Up QU

Define[(Subscript[aσ, i->j])=(Subscript[𝔼, {i}->{j}])[(Subscript[a, j]) (Subscript[α, i])+(Subscript[x, j]) (Subscript[ξ, i])],(Subscript[bσ, i->j])=(Subscript[𝔼, {i}->{j}])[(Subscript[b, j]) (Subscript[β, i])+(Subscript[y, j]) (Subscript[η, i])]]

Define[(Subscript[am, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[((Subscript[α, i])+(Subscript[α, j]))(Subscript[a, k])+((Subscript[𝒜, j]^(-1))(Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k])],
(Subscript[bm, i,j->k])=(Subscript[𝔼, {i,j}->{k}])[((Subscript[β, i])+(Subscript[β, j]))(Subscript[b, k])+((Subscript[η, i])+(E^(- ϵ (Subscript[β, i])))(Subscript[η, j]))(Subscript[y, k])]]

The (PR^4) Equation

rhs=((Subscript[R, o1,u1])(Subscript[R, o3,u2])(Subscript[R, o2,u3])(Subscript[R, o4,u4]))//((Subscript[bm, o1,o3->o1])(Subscript[bm, o2,o4->o2])(Subscript[am, u1,u3->u1])(Subscript[am, u2,u4->u2]))

lhs=((Subscript[R, oa,u1])(Subscript[R, ob,u2])//(Subscript[bm, oa,ob->o]))((Subscript[R, o1,ua])(Subscript[R, o2,ub])//(Subscript[am, ua,ub->u]))//(Subscript[P, o,u]);

lhs≡rhs

Solving the (PR^4) Equation

(Subscript[Invert[R_,k_], i_,j_]):=(Subscript[𝔼, {i,j}->{}])[(Subscript[β, i])(Subscript[α, j])/ℏ,(Subscript[η, i])(Subscript[ξ, j])/ℏ,1+If[k==0,0,(Subscript[((Subscript[Invert[R,k-1], i,j])), k])[3]-
((Subscript[R, 1,2])//((Subscript[((Subscript[Invert[R,0], 1,j])), k])(Subscript[((Subscript[Invert[R,k-1], i,2])), k])))[3]]]

(Subscript[RR[0], i_,j_]):=(Subscript[𝔼, {}->{i,j}])[ℏ (Subscript[a, j]) (Subscript[b, i]),ℏ (Subscript[x, j]) (Subscript[y, i]),1];
(Subscript[PP[0], i_,j_]):=(Subscript[Invert[RR[0],0], i,j]);

Eq[k_]:=Last[((Subscript[RR[k], o1,u1])(Subscript[RR[k], o3,u2])(Subscript[RR[k], o2,u3])(Subscript[RR[k], o4,u4]))//((Subscript[bm, o1,o3->o1])(Subscript[bm, o2,o4->o2])(Subscript[am, u1,u3->u1])(Subscript[am, u2,u4->u2]))]-Last[((Subscript[RR[k], oa,u1])(Subscript[RR[k], ob,u2])//(Subscript[bm, oa,ob->o]))((Subscript[RR[k], o1,ua])(Subscript[RR[k], o2,ub])//(Subscript[am, ua,ub->u]))//(Subscript[PP[k], o,u])]

Block[{$k=0}, Eq[0]]

Block[{$k=1}, Eq[0]]

(Subscript[RR[1], i_,j_]):=(Subscript[𝔼, {}->{i,j}])[ℏ (Subscript[a, j]) (Subscript[b, i]),ℏ (Subscript[x, j]) (Subscript[y, i]),1+ϵ((Subscript[f, 1])[(Subscript[b, i])]+(Subscript[f, 2])[(Subscript[b, i])](Subscript[y, i])(Subscript[x, j])+(Subscript[f, 3])[(Subscript[b, i])](Subscript[y, i]^2)(Subscript[x, j]^2)+(Subscript[f, 4])[(Subscript[b, i])](Subscript[a, j])+(Subscript[f, 5])[(Subscript[b, i])](Subscript[a, j])(Subscript[y, i])(Subscript[x, j])+(Subscript[f, 6])[(Subscript[b, i])](Subscript[a, j]^2))+((O[ϵ])^2)];
(Subscript[PP[1], i_,j_]):=(Subscript[Invert[RR[1],1], i,j]);
(Subscript[PP[1], i,j])

Block[{$k=1},(Subscript[RR[1], i,j])//(Subscript[PP[1], i,k])]

CoefficientRules[Simplify@SeriesCoefficient[Block[{$k=1}, Eq[1]],1],{(Subscript[a, u1]),(Subscript[a, u2]),(Subscript[x, u1]),(Subscript[x, u2]),(Subscript[y, o1]),(Subscript[y, o2])}] // Column

CoefficientRules[Simplify@SeriesCoefficient[Block[{$k=1}, Eq[1]]/.(Subscript[f, 1|2|4|5|6])[_]->0,1],{(Subscript[a, u1]),(Subscript[a, u2]),(Subscript[x, u1]),(Subscript[x, u2]),(Subscript[y, o1]),(Subscript[y, o2])}] // Column

CoefficientRules[Simplify@SeriesCoefficient[Block[{$k=1}, Eq[1]]/.{(Subscript[f, 1|4|5|6])[_]->0,(Subscript[f, 3])[_]->-γ (ℏ^3)/4},1],{(Subscript[a, u1]),(Subscript[a, u2]),(Subscript[x, u1]),(Subscript[x, u2]),(Subscript[y, o1]),(Subscript[y, o2])}] // Column