Pensieve header: A unified verification notebook for the $sl_2$-portfolio project; continues pensieve://Projects/PPSA/nb/Verification.pdf.

Continues pensieve://2017-06/ and pensieve://2017-08/.

Prolog

Go;

wdir=SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Portfolio"];
NotebookOpen[wdir<>"\\MakeSnips.nb"];

HL[ℰ_] := Style[ℰ, Background -> Yellow];

Initialization / Utilities

The “degree carrier / filtration parameter” is ℏ, and all “coupling constants” are proportional to it.

$p=2; $k=1; 
If[$k==0, ϵ=0, ϵ /: (ϵ^(k_ ))/; k>$k :=0];
SetAttributes[{SS, SST}, HoldAll];
TRule={(Subscript[T, i_])-> (E^(ℏ (Subscript[t, i]))),T-> (E^(ℏ t))}; qrule=q->(E^(γ e ℏ));
SS[ℰ_] := Block[{ℏ,ϵ}, (* Shielded Series *)
Collect[Normal@Series[ℰ, {ℏ,0,$p}],ℏ,Together] ];
SST[ℰ_] := Block[{ℏ,ϵ},Collect[Normal@Series[ℰ/.TRule, {ℏ,0,$p}],ℏ,Together] ];
Simp[ℰ_, op_]:= Collect[ℰ, _CU|_QU, op];
Simp[ℰ_]:=Simp[ℰ,Collect[Normal@Series[#, {ℏ,0,$p}],ℏ,Expand]&];
SimpT[ℰ_]:= Collect[ℰ, _CU|_QU, Collect[Normal@Series[#/.TRule, {ℏ,0,$p}],ℏ,Expand]&];

Differential polynomials (DP):

(Subscript[DP, α_->(Subscript[D, x_]),β_->(Subscript[D, y_])])[P_][λ_]:=Total[CoefficientRules[P,{α,β}]/.({m_,n_}->c_):>c D[λ,{x,m},{y,n}]]

DeclareAlgebra

Unprotect[NonCommutativeMultiply]; Attributes[NonCommutativeMultiply]={};
(NCM=NonCommutativeMultiply)[x_] := x;
NCM[x_,y_,z__] := (x**y)**z;
0**_=_**0=0;
(x_Plus)**y_:=(#**y)&/@x; x_**(y_Plus):=(x**#)&/@y;
B[x_,x_]=0; B[x_,y_] := x**y-y**x;

DeclareAlgebra[U_Symbol, opts__Rule] := Module[{gp,sr,g,cp,CE,pow,k=0,
gs=Generators /. {opts}, cs=Centrals /. {opts} },
((Subscript[#, U])=U@#)&/@gs;
gp=Alternatives@@gs; gp=gp|(Subscript[gp, _]);(* gens *)
sr=Flatten@Table[{g->++k, (Subscript[g, i_])->{i,k}},{g,gs}]; (* sorting -> *) 
cp=Alternatives@@cs; (* cents *)
CE[ℰ_]:= Collect[ℰ, _U, (Expand[#] /. (ℏ^(d_))/;d>$p:>0)&];
(Subscript[U, i_])[ℰ_] := ℰ /. {t:cp:>(Subscript[t, i]),u_U :> Replace[u, x_ :> (Subscript[x, i]),1]};
(Subscript[U, i_])[NCM[]]=pow[ℰ_,0]=U@{}=(Subscript[1, U])=U[];
B[U@(Subscript[(x_), i_]),U@(Subscript[(y_), i_])]:=B[U@(Subscript[x, i]),U@(Subscript[y, i])]=(Subscript[U, i])@B[U@x,U@y];
B[U@(Subscript[(x_), i_]),U@(Subscript[(y_), j_])] /; i=!=j := 0;
B[U@y_,U@x_]:=CE[-B[U@x,U@y]];
x_**(Subscript[1, U]):=x; (Subscript[1, U])**x_:=x;
(a_.*x_U)**(b_.*y_U) := If[a b === 0, 0, CE[a b (x**y)]];
U[xx___,x_] ** U[y_,yy___] := If[OrderedQ[{x,y}/.sr],U[xx,x,y,yy], U@xx**(U@y**U@x+B[U@x,U@y])**U@yy];
U@{c_.*(((l:gp))^(n_)),r___}/;FreeQ[c, gp]:= CE[c U@Table[l,{n}]**U@{r}];
U@{c_.*l:gp,r___} := CE[c U[l]**U@{r}];
U@{c_,r___}/;FreeQ[c, gp]:= CE[c U@{r}];
U@{l_Plus, r___} := CE[U@{#,r}& /@ l];
U@{l_,r___} := U@{Expand[l],r};
U[ℰ_NonCommutativeMultiply]:=U/@ℰ;
(Subscript[𝕆, U])[specs___,poly_] := Module[{sp,null,vs,us},
sp=Replace[{specs}, l_List:>(Subscript[l, null]), {1}];
vs=Join@@(First /@ sp);
us=Join@@(sp /. (Subscript[l_, s_]) :> (l/.(Subscript[x_, i_]):>(Subscript[x, s])));
CE[Total[
CoefficientRules[poly, vs] /. (p_->c_) :> c U@((us^p))
]] /. (Subscript[x_, null]):>x];
pow[ℰ_,n_]:=pow[ℰ,n-1]**ℰ;
(Subscript[𝕊, U])[ℰ_,ss___Rule] := CE@Total[
CoefficientRules[ℰ,First/@{ss}]/.(p_->c_):>c NCM@@MapThread[pow,{Last/@{ss},p}]];
(Subscript[m, j_->k_])[c_.*u_U] := CE[((c/.(Subscript[(t:cp), j])->(Subscript[t, k]))DeleteCases[u,(Subscript[_, j|k])])**U@@Cases[u,(Subscript[w_, j]):>(Subscript[w, k])]**U@@Cases[u,(Subscript[_, k])]];
(Subscript[S, i_])[c_.*u_U]:= CE[((c/.(Subscript[S, i])[U,Centrals])DeleteCases[u,(Subscript[_, i])])**(Subscript[U, i])[NCM@@Reverse@Cases[u,(Subscript[x_, i]):>S@U@x]]] ]

DeclareMorphism

DeclareMorphism[m_,U_->V_, ongs_List, oncs_List:{}] := (
Replace[ongs, (g_->img_) :> (m[U[g]]=img), {1}];
m[(Subscript[1, U])]=(Subscript[1, V]);
m[U[(Subscript[g_, i_])]] := (Subscript[V, i])[m[U@g]];
m[U[vs__]] := NCM@@(m/@U/@{vs});
m[ℰ_] := Simp[ℰ /. oncs /.  u_U:>m[u]]; )

Meta-Operations

(Subscript[m, j_->j_])=Identity;
(Subscript[m, j_->k_])[ℰ_Plus] := Simp[(Subscript[m, j->k])/@ℰ];
(Subscript[m, is___,i_,j_->k_])[ℰ_]:=(Subscript[m, j->k])@(Subscript[m, is,i->j])@ℰ;
(Subscript[S, i_])[ℰ_Plus] := Simp[(Subscript[S, i])/@ℰ];

Implementing CU=𝒰((Subscript[sl, 2]^(γϵ)))

DeclareAlgebra[CU,Generators->{y,a,x},Centrals->{t}];
B[(Subscript[a, CU]),(Subscript[y, CU])]=-γ (Subscript[y, CU]); B[(Subscript[x, CU]),(Subscript[a, CU])]=-γ (Subscript[x, CU]);
B[(Subscript[x, CU]),(Subscript[y, CU])]=2ϵ (Subscript[a, CU])-t (Subscript[1, CU]);
(S@CU@y=-(Subscript[y, CU]); S@(Subscript[a, CU])=-(Subscript[a, CU]); S@(Subscript[x, CU])=-(Subscript[x, CU]);)
(Subscript[S, i_])[CU,Centrals]={(Subscript[t, i])->-(Subscript[t, i])};

Verifying associativity on triples of generators:

With[{bas=CU/@{y,a,x}},
Table[z1**(z2**z3)-(z1**z2)**z3 // Simp // HL,
{z1,bas},{z2,bas},{z3,bas} ] ]

Verifying associativity on a “random” triple:

With[{z1=CU[y,y,a,a,x,x], z2=CU[y,a,x], z3=CU[y,y,a,x]}, {
(rhs=(z1**z2)**z3 // Simp) // Short,
z1**(z2**z3)-rhs // Simp //HL
}]// Timing

Verifying that S is an anti-homomorphism on CU:

With[{bas=CU/@{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}},
Table[HL@Simp[(Subscript[S, 1])[z1**z2]-(Subscript[S, 1])[z2]**(Subscript[S, 1])[z1]],
{z1,bas},{z2,bas} ] ]

Verifying the involutivity of S on products of triples:

With[{bas=CU/@{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}},
Table[HL@Simp[z1**z2**z3-(Subscript[S, 1])@(Subscript[S, 1])[z1**z2**z3]],
{z1,bas},{z2,bas},{z3,bas} ] ]

Verifying relabeling:

(Subscript[t, 1])(Subscript[t, 3])CU[(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 2])]+(Subscript[t, 1])(Subscript[t, 1])CU[(Subscript[y, 1]),(Subscript[a, 2]),(Subscript[x, 2])] // (Subscript[m, 1->3])

Verifying meta-associativity:

Module[{z,u},
Table[u=CU[(Subscript[z[[1]], 1]),(Subscript[z[[2]], 2]),(Subscript[z[[3]], 3])]; z->HL[(Subscript[m, 1,3->3])@(Subscript[m, 2,3->3])@u==(Subscript[m, 2,3->3])@(Subscript[m, 1,2->2])@u],
{z,Tuples[{y,a,x},3]}]]

Implementing QU=(Subscript[𝒰, q])((Subscript[sl, 2]^(γϵ)))

Series[(1-T (E^(-2e a h)))/h, {a,0,3}]

DeclareAlgebra[QU, Generators -> {y,a,x}, Centrals -> {t,T}];
B[(Subscript[a, QU]),(Subscript[y, QU])]=-γ (Subscript[y, QU]); B[(Subscript[x, QU]),(Subscript[a, QU])]=-γ QU@x;
B[(Subscript[x, QU]),(Subscript[y, QU])]=SS[q-1/.qrule/.e->ϵ]QU@{y,x}+(Subscript[𝕆, QU])[{a},SS[(1-T (E^(-2ϵ a ℏ)))/ℏ]];
(S@(Subscript[y, QU])=(Subscript[𝕆, QU])[{a,y},SS[-(T^(-1))(E^(ℏ ϵ a))y]]; S@(Subscript[a, QU])=-(Subscript[a, QU]); S@(Subscript[x, QU])=(Subscript[𝕆, QU])[{a,x},SS[-(E^(ℏ ϵ a))x]];)
(Subscript[S, i_])[QU,Centrals]={(Subscript[t, i])->-(Subscript[t, i]), (Subscript[T, i])->(Subscript[T, i]^(-1))};

With[{bas=QU/@{y,a,x}},Table[{z1,z2}->Simp[z1**z2-z2**z1],{z1,bas},{z2,bas}] ]

Verifying associativity on triples of generators:

With[{bas=QU/@{y,a,x}},
Table[HL[z1**(z2**z3)-(z1**z2)**z3] // Simp,
{z1,bas},{z2,bas},{z3,bas} ] ]

Verifying associativity on a “random” triple (~34 secs @ $p=5, $k=2):

With[{z1=QU[y,y,a,a,x,x], z2=QU[y,a,x], z3=QU[y,y,a,x]}, {
(rhs=(z1**z2)**z3 // Simp) // Short,
HL[z1**(z2**z3)-rhs // Simp ]
}]// Timing

Verifying that S is an anti-homomorphism on QU:

With[{bas=QU/@{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}},
Table[{z1,z2}->HL@Simp[(Subscript[S, 1])[z1**z2]-(Subscript[S, 1])[z2]**(Subscript[S, 1])[z1]],
{z1,bas},{z2,bas} ] ]

Verifying that (Subscript[Lim, ℏ->0])QU=CU using a “random” product (~23 secs @ $p=5, $k=2):

With[{z1=CU[y,y,a,a,x,x], z2=CU[y,a,x], z3=CU[y,y,a,x]}, {
Short[lhs=z1**(z2**z3)],
Short[rhs=(QU@@z1)**((QU@@z2)**(QU@@z3))],
Expand[Limit[rhs /. TRule⋃{QU->CU}, ℏ->0]-lhs] // HL
}] // Timing

Implementing θ

DeclareMorphism[Cθ,CU->CU, {y->-(Subscript[x, CU]), a->-(Subscript[a, CU]), x->-(Subscript[y, CU])}, {t->-t, T->(T^(-1))}];DeclareMorphism[Qθ,QU->QU, {y->(Subscript[𝕆, QU])[{a,x},SS[-(T^(-1/2))(E^(ℏ ϵ a))x]], a->-(Subscript[a, QU]), x->(Subscript[𝕆, QU])[{a,y},SS[-(T^(-1/2))(E^(ℏ ϵ a))y]]}, {t->-t, T->(T^(-1))}]

Verifying involutivity on CU:

With[{bas=CU/@{y,a,x}},
Table[z->Cθ[z]->HL[Cθ[Cθ[z]]], {z,bas}] ]

Verifying that θ is a multiplicative homomorphism on CU:

With[{bas=CU/@{y,a,x}},
Table[Cθ[z1**z2]-Cθ[z1]**Cθ[z2] // HL, {z1,bas},{z2,bas}] ]

Verifying involutivity on QU:

With[{bas=QU/@{y,a,x}},
Table[z->Qθ[z]->HL[Simp[Qθ[Qθ[z]],PowerExpand]], {z,bas}] ]

Verifying that θ is a multiplicative homomorphism on QU:

With[{bas=QU/@{y,a,x}},
Table[{z1,z2}->HL[Simp[Qθ[z1**z2]-Qθ[z1]**Qθ[z2]]], {z1,bas},{z2,bas}] ]

The Asymmetric Dequantizator

Following pensieve://People/VanDerVeen/Dequant1.pdf.

A𝔻$f=γ((Cosh[ℏ(a e+((γ e)/2)-(t/2))]-Cosh[ℏ(Sqrt[(((((t-γ e)/2)))^2)+e ω])])/(ℏ (E^(ℏ((a+γ)e-t/2)))Sinh[((γ e ℏ)/2)]((a^2)e+a γ e-a t-ω)));

Scaling behaviour of A𝔻$f:

HL@Simplify[A𝔻$f == ((A𝔻$f /. γ->1) /. {e->γ e, a->(γ^(-1))a, ω->(γ^(-1))ω})]

HL@FullSimplify[A𝔻$f == ((A𝔻$f /. γ->1) /. {ℏ -> (γ^2)ℏ,e->e/γ, a->a/γ, t->(γ^(-2))t, ω->(γ^(-3))ω})]

A𝔻$ω=γ CU[y,x]+ϵ CU[a,a]-(t-γ ϵ)CU[a];

DeclareMorphism[A𝔻,QU->CU,{a->(Subscript[a, CU]),x->CU@x, y->(Subscript[𝕊, CU])[SS[A𝔻$f]/.e->ϵ,a->(Subscript[a, CU]),ω->A𝔻$ω]**(Subscript[y, CU])}]

Verifying that the asymmetric dequantizator is a homomorphism:

With[{bas=QU/@{y,a,x}},Table[{z1,z2}->HL[SimpT[A𝔻[z1**z2]-A𝔻[z1]**A𝔻[z2]]], {z1,bas},{z2,bas}] ]

The Symmetric Dequantizator

Following pensieve://People/VanDerVeen/Dequant1.pdf.

S𝔻$g=(Sqrt[((2γ(Cosh[(ℏ/2)(Sqrt[(t^2)+(γ^2) (e^2)+4 e ϖ])]-Cosh[((t-e γ-2e a)/(2/ℏ))]))/(Sinh[((γ e ℏ)/2)](t (2 a+γ)-2 a (a+γ) e+2 ϖ) ℏ))]);

Verify agreement with the formulas in pensieve://People/VanDerVeen/Dequant1.pdf:

{S𝔻$P=((Cosh[ℏ(((e-t)/2)+e a)]-Cosh[ℏ(Sqrt[(((t^2)+(e^2))/4)+e ϖ])])/(ℏ Sinh[((-e ℏ)/2)](ϖ-e (a^2)+(t-e)a+t/2))),
Simplify[S𝔻$P == (S𝔻$P /. {a->-a-1, t->-t})] // HL,
PowerExpand@Simplify[(S𝔻$P/.{ℏ -> (γ^2)ℏ,e->e/γ, a->a/γ, t->(γ^(-2))t, ϖ->(γ^(-3))ϖ}) == S𝔻$g(S𝔻$g /. {a->-a-γ, t->-t})] // HL,
S𝔻$Q=Simplify[S𝔻$P /. {a->c-1/2}],
Simplify[S𝔻$Q==(S𝔻$Q /. {c->-c, t->-t})] // HL,
FullSimplify[S𝔻$g==FullSimplify[(Sqrt[S𝔻$Q]) /. c->a+1/2/.{ℏ -> (γ^2)ℏ,e->e/γ, a->a/γ, t->(γ^(-2))t, ϖ->(γ^(-3))ϖ}]] // HL
}

S𝔻$f=Simplify[(E^(ℏ(t/2-e a)))(S𝔻$g /. {a->-a, t->-t})];

S𝔻$ϖ=γ CU[y,x]+ϵ CU[a,a]-(t-γ ϵ)CU[a]-t γ (Subscript[1, CU])/2;

DeclareMorphism[S𝔻,QU->CU,{a->(Subscript[a, CU]),
x->(Subscript[𝕊, CU])[SS[S𝔻$f]/.e->ϵ,a->(Subscript[a, CU]),ϖ->S𝔻$ϖ]**(Subscript[x, CU]),
y->(Subscript[𝕊, CU])[SS[S𝔻$g]/.e->ϵ,a->(Subscript[a, CU]),ϖ->S𝔻$ϖ]**(Subscript[y, CU]) }]

Verifying the θ-symmetry:

Table[HL@SimpT[Cθ[S𝔻[z]]==S𝔻[Qθ[z]]], {z, QU/@{y,a,x}}]

Verifying that the symmetric dequantizator is a homomorphism:

With[{bas=QU/@{y,a,x}},Table[{z1,z2}->HL@SimpT[S𝔻[z1**z2]-S𝔻[z1]**S𝔻[z2]], {z1,bas},{z2,bas}] ]

The representation ρ

ρ@(Subscript[y, CU])=ρ@(Subscript[y, QU])=(({{0, 0}, {ϵ, 0}}));ρ@(Subscript[a, CU])=ρ@(Subscript[a, QU])=(({{γ, 0}, {0, 0}}));
ρ@(Subscript[x, CU])=(({{0, γ}, {0, 0}})); ρ@(Subscript[x, QU])=SS@(({{0, (1-(E^(-γ ϵ ℏ)))/(ϵ ℏ)}, {0, 0}}));
ρ[(E^(ℰ_))]:=MatrixExp[ρ[ℰ]];
ρ[ℰ_]:=(ℰ/.{t->γ ϵ,T->(E^(ℏ γ ϵ))}/.(U:CU|QU)[u___]:>Fold[Dot,(({{1, 0}, {0, 1}})),ρ/@U/@{u}])

Verifying that ρ represents CU and QU:

Table[ρ[z1**z2]==ρ[z1].ρ[z2] // SS // HL, {U,{CU,QU}},{z1,U/@{y,a,x}},{z2,U/@{y,a,x}} ]

Œ and the logoi Λ

Logoi from Pensieve://Talks/Toulouse-1705/DogmaDemo.nb and from Pensieve://Talks/Sydney-1708/ExtraDetails@@.nb.

CU@(Subscript[Œ, CU])[specs___,Q_,P_] := (Subscript[𝕆, CU])[specs,SS[(E^Q)P]];
QU@(Subscript[Œ, QU])[specs___,Q_,P_] := (Subscript[𝕆, QU])[specs,SS[(E^Q)P]];

HL[ρ[(E^(ξ CU@x))].ρ[(E^(α CU@a))]==ρ[(E^(α CU@a))].ρ[(E^((E^(-γ α))ξ CU@x))]]

(Subscript[Λ, U_])[{ξ_,α_},{x,a}]:=(Subscript[Œ, U])[{a,x},α a+(E^(-γ α))ξ x,1];
(Subscript[Λ, U_])[{α_,η_},{a,y}]:=(Subscript[Œ, U])[{y,a},α a+(E^(-γ α))η y,1];

{(Subscript[Λ, #])[{ξ,α},{x,a}], lhs=#@(Subscript[Œ, #])[{x,a},ℏ(ξ x+α a),1], HL[lhs==#@(Subscript[Λ, #])[ℏ{ξ,α},{x,a}]]}& /@ {CU,QU}

{(Subscript[Λ, #])[{α,η},{a,y}], lhs=#@(Subscript[Œ, #])[{a,y},ℏ(η y+α a),1], HL[lhs==#@(Subscript[Λ, #])[ℏ{α,η},{a,y}]]}& /@ {CU,QU}

Goal. In either U, compute F=(e^(-ηy))(e^(ξx))(e^(ηy))(e^(-ξx)). First compute G=(e^(ξx))((ye)^(-ξx)), a finite sum. Now F satisfies the ODE (∂_η)F=(∂_η)((e^(-ηy))(e^(ηG)))=-yF+FG with initial conditions F(η=0)=1. So we set it up and solve:

If[$k>0,With[{U=CU},
Module[{G,F,fs,bs,e,b,es,sol},
G=Echo@Simp[Table[(ξ^k)/k!, {k,0, $k+1}].NestList[Simp[B[(Subscript[x, U]) ,# ]]&, (Subscript[y, U]), $k+1]];
fs=Echo@Flatten@Table[(Subscript[f, l,i,j,k])[η],{l,0,$k},{i,0, l},{j,0, l},{k,0, l}];
F=Echo[fs.(bs=fs/.(Subscript[f, l_,i_,j_,k_])[η]:>(ϵ^l)U@{(y^i),(a^j),(x^k)})];
es=Flatten[Table[Coefficient[e,b]==0,{e,{F-(Subscript[1, U])/.η->0,F**G-(Subscript[y, U])**F-(∂_η)F}},{b,bs}]];
sol=Echo@First[F/.DSolve[es,fs,η]];
Echo[sol/.{(E^(_))->1,U->Times}];
Collect[sol/.{(E^(_))->1,U->Times}, ϵ, Simplify]
]]]

(Subscript[Λ, U_])[{ξ1_,η1_},{x,y}]:=(Subscript[Λ, U])[{ξ1,η1},{x,y}]=Module[{ξ,η,G,F,fs,f,bs,eq,b,eqs},
G=Simp[Table[(ξ^k)/k!, {k,0, $k+1}].NestList[Simp[B[(Subscript[x, U]) ,# ]]&, (Subscript[y, U]), $k+1]];
fs=Flatten@Table[(Subscript[f, l,i,j,k])[η],{l,0,$k},{i,0, l},{j,0, l},{k,0, l}];
F=fs.(bs=fs/.(Subscript[f, l_,i_,j_,k_])[η]:>(e^l)U@{(y^i),(a^j),(x^k)}/.e->ϵ);
eqs=Flatten[Table[Coefficient[eq,b]==0,{eq,{F-(Subscript[1, U])/.η->0,F**G-(Subscript[y, U])**F-(∂_η)F}},{b,bs}]];
F=F/.DSolve[eqs,fs,η][[1]];
(Subscript[Œ, U])[{y,a,x},
ξ x+η y+(U /. {CU->-t η ξ, QU-> η ξ(1-T)/ℏ}),
F/.{(E^(_))->1,U->Times}
] /. {ξ->ξ1,η->η1}];

{(Subscript[Λ, CU])[{ξ,η},{x,y}], lhs=CU@(Subscript[Œ, CU])[{x,y},ℏ(ξ x+η y),1], HL[lhs==CU@(Subscript[Λ, CU])[ℏ{ξ,η},{x,y}]]}

{(Subscript[Λ, QU])[{ξ,η},{x,y}], lhs=QU@(Subscript[Œ, QU])[{x,y},ℏ(ξ x+η y),1], HL@SimpT[lhs==QU@(Subscript[Λ, QU])[ℏ{ξ,η},{x,y}]]}

{tt=Last[(Subscript[Λ, CU])[{ξ,η},{x,y}]],Normal@Series[Log[tt],{ϵ,0,$k}]}

{tt=Last[(Subscript[Λ, QU])[{ξ,η},{x,y}]],Normal@Series[Log[tt],{ϵ,0,$k}]}

Simp[(Subscript[Œ, U_])[specs___,Q_,P_]] := (Subscript[Œ, U])[specs,ExpandNumerator@Together[Q],Collect[P,ϵ,ExpandNumerator@*Together]];
(Subscript[Λ, U_])[{υ1_,ω1_,δ_},{u_,w_}] := Simp@Module[{υ,ω,yax,q,p,Q,d},
{yax,q,p}=List@@(Subscript[Λ, U])[{υ,ω},{u,w}];
(Subscript[Œ, U])[yax,Q=(υ u+ω w+δ u w+d υ ω)/(1-d δ),Expand[(((1-d δ))^(-1))(E^(-Q))(Subscript[DP, υ->(Subscript[D, u]),ω->(Subscript[D, w])])[p][(E^Q)]]] /. {d->(∂_(υ,ω))q}/.{υ->υ1,ω->ω1}]

{(Subscript[Λ, CU])[{ξ,η,δ},{x,y}], lhs=CU@(Subscript[Œ, CU])[{x,y},ℏ(ξ x+η y+δ x y),1], HL[lhs==CU@(Subscript[Λ, CU])[ℏ{ξ,η,δ},{x,y}]]}

{(Subscript[Λ, QU])[{ξ,η,δ},{x,y}], lhs=QU@(Subscript[Œ, QU])[{x,y},ℏ(ξ x+η y+δ x y),1],HL@SimpT[lhs==QU@(Subscript[Λ, QU])[ℏ{ξ,η,δ},{x,y}]]}

{tt=Last[(Subscript[Λ, CU])[{ξ,η,δ},{x,y}]],Normal@Series[Log[tt],{ϵ,0,$k}]}

{tt=Last[(Subscript[Λ, QU])[{ξ,η,δ},{x,y}]],Normal@Series[Log[tt],{ϵ,0,$k}]}

Reorderings with Rord

(Subscript[Rord, (Subscript[u_, i_]),(Subscript[w_, j_])->k_])[(Subscript[Œ, U_])[L___,(Subscript[{l___,(Subscript[u_, i_]),(Subscript[w_, j_]),r___}, s_]),R___,Q_,P_]] := Simp@Module[{υ,ω,δ,Λ1,yax,q,p,δ1=(∂_((Subscript[u, i]),(Subscript[w, j])))Q},
{yax,q,p}=List@@If[δ1===0,(Subscript[Λ, U])[{υ,ω},{u,w}],(Subscript[Λ, U])[{υ,ω,δ},{u,w}]] /. {y->(Subscript[y, k]),a->(Subscript[a, k]),x->(Subscript[x, k]),t->(Subscript[t, s]),T->(Subscript[T, s])};
(Subscript[Œ, U])[L,(Subscript[{l,Sequence@@yax,r}, s]),R,q+(Q/.(Subscript[u, i])|(Subscript[w, j])->0), (E^(-q))(Subscript[DP, (Subscript[u, i])->(Subscript[D, υ]),(Subscript[w, j])->(Subscript[D, ω])])[P][p (E^q)]] /. {υ->(∂_(Subscript[u, i]))Q/.(Subscript[w, j])->0,ω->(∂_(Subscript[w, j]))Q/.(Subscript[u, i])->0, δ->δ1}]

With[{c𝕠=(Subscript[Œ, CU])[(Subscript[{(Subscript[y, 1]),(Subscript[x, 1])}, 1]), (Subscript[{(Subscript[x, 2]),(Subscript[a, 2]),(Subscript[y, 2])}, 2]),ℏ (Subscript[t, 1])(Subscript[a, 2])+ℏ (Subscript[t, 1]^(-1))((E^(Subscript[t, 1]))-1)(Subscript[y, 1])(Subscript[x, 2]),1+ϵ (Subscript[x, 1])(Subscript[y, 2])]},
{Short[rhs=c𝕠//(Subscript[Rord, (Subscript[x, 2]),(Subscript[a, 2])->3]),3], HL[CU[c𝕠]==CU[rhs]]}]

With[{c𝕠=(Subscript[Œ, CU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}, 1]), (Subscript[{(Subscript[x, 2]),(Subscript[a, 2]),(Subscript[y, 2])}, 2]),
ℏ((Subscript[l, 11])(Subscript[t, 1])(Subscript[a, 1])+(Subscript[l, 12])(Subscript[t, 1])(Subscript[a, 2])+(Subscript[l, 21])(Subscript[t, 2])(Subscript[a, 1])+(Subscript[l, 22])(Subscript[t, 2])(Subscript[a, 2])+(Subscript[γ, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[γ, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[γ, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[γ, 22])(Subscript[x, 2])(Subscript[y, 2])),1+ϵ((Subscript[l, 1])(Subscript[a, 1])+(Subscript[l, 2])(Subscript[a, 2])+(Subscript[p, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[p, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[p, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[p, 22])(Subscript[x, 2])(Subscript[y, 2]))]},
{Short[rhs=c𝕠//(Subscript[Rord, (Subscript[x, 2]),(Subscript[a, 2])->3]),3], HL[CU[c𝕠]==CU[rhs]]}]

With[{q𝕠=(Subscript[Œ, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}, 1]), (Subscript[{(Subscript[x, 2]),(Subscript[a, 2]),(Subscript[y, 2])}, 2]),
ℏ((Subscript[l, 11])(Subscript[t, 1])(Subscript[a, 1])+(Subscript[l, 12])(Subscript[t, 1])(Subscript[a, 2])+(Subscript[l, 21])(Subscript[t, 2])(Subscript[a, 1])+(Subscript[l, 22])(Subscript[t, 2])(Subscript[a, 2])+(Subscript[γ, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[γ, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[γ, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[γ, 22])(Subscript[x, 2])(Subscript[y, 2])),1+ϵ((Subscript[l, 1])(Subscript[a, 1])+(Subscript[l, 2])(Subscript[a, 2])+(Subscript[p, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[p, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[p, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[p, 22])(Subscript[x, 2])(Subscript[y, 2]))]},
{Short[rhs=q𝕠//(Subscript[Rord, (Subscript[x, 2]),(Subscript[a, 2])->3]),3], HL[QU[q𝕠]==QU[rhs]]}]

With[{q𝕠=(Subscript[Œ, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}, 1]), (Subscript[{(Subscript[x, 2]),(Subscript[a, 2]),(Subscript[y, 2])}, 2]),
ℏ((Subscript[l, 11])(Subscript[t, 1])(Subscript[a, 1])+(Subscript[l, 12])(Subscript[t, 1])(Subscript[a, 2])+(Subscript[l, 21])(Subscript[t, 2])(Subscript[a, 1])+(Subscript[l, 22])(Subscript[t, 2])(Subscript[a, 2])+(Subscript[γ, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[γ, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[γ, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[γ, 22])(Subscript[x, 2])(Subscript[y, 2])),1+ϵ((Subscript[l, 1])(Subscript[a, 1])+(Subscript[l, 2])(Subscript[a, 2])+(Subscript[p, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[p, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[p, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[p, 22])(Subscript[x, 2])(Subscript[y, 2]))]},
{Short[rhs=q𝕠//(Subscript[Rord, (Subscript[a, 2]),(Subscript[y, 2])->3]),3], HL[QU[q𝕠]==QU[rhs]]}]

With[{q𝕠=(Subscript[Œ, QU])[(Subscript[{(Subscript[x, 1]),(Subscript[y, 1])}, 1]), (Subscript[{(Subscript[x, 2]),(Subscript[a, 2]),(Subscript[y, 2])}, 2]),
ℏ((Subscript[l, 12])(Subscript[t, 1])(Subscript[a, 2])+(Subscript[l, 22])(Subscript[t, 2])(Subscript[a, 2])+(Subscript[γ, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[γ, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[γ, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[γ, 22])(Subscript[x, 2])(Subscript[y, 2])),1+ϵ((Subscript[l, 2])(Subscript[a, 2])+(Subscript[p, 11])(Subscript[x, 1])(Subscript[y, 1])+(Subscript[p, 12])(Subscript[x, 1])(Subscript[y, 2])+(Subscript[p, 21])(Subscript[x, 2])(Subscript[y, 1])+(Subscript[p, 22])(Subscript[x, 2])(Subscript[y, 2]))]},
{Short[rhs=q𝕠//(Subscript[Rord, (Subscript[x, 1]),(Subscript[y, 1])->3]),5], HL@SimpT[QU[q𝕠]==QU[rhs]]}]

R in QU.

Faddeev-Quesne’s formula:

(Subscript[E, q_,k_])[x_]:=E^((∑_(j=1)^k) (((((1-q))^j)(x^j))/(j(1-(q^j))))); (Subscript[E, q_])[x_]:=(Subscript[E, q,$k])[x]

Table[Together@SeriesCoefficient[(Subscript[E, q,5])[x], {x,0,n}], {n,0,5}]

Table[HL@FunctionExpand[QFactorial[n,q]SeriesCoefficient[(Subscript[E, q,5])[x], {x,0,n}]], {n,0,5}]

QU[(Subscript[R, i_,j_])]:=(Subscript[𝕆, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1])}, i]),(Subscript[{(Subscript[a, 2]),(Subscript[x, 2])}, j]),SS[(E^(ℏ (Subscript[b, 1])(Subscript[a, 2])))(Subscript[E, q/.qrule/.e->ϵ])[ℏ (Subscript[y, 1])(Subscript[x, 2])]/.(Subscript[b, 1])->(γ^(-1))(ϵ (Subscript[a, 1])-(Subscript[t, i]))]];
QU[(Subscript[R, i_,j_]^(-1))]:=(Subscript[S, j])@QU[(Subscript[R, i,j])];

QU[(Subscript[R, 3,4])] // Short

Verifying R2 (~2 secs @ $p=4, $k=2):

QU[(Subscript[R, 1,2])**(Subscript[R, 1,2]^(-1))] // Simp // HL // Timing

Verifying R3 (~156 secs @ $p=4, $k=2):

{Short[lhs=QU[(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])]], HL@SimpT[lhs-QU[(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])]]} // Timing

R in (Subscript[Œ, QU]).

(Subscript[Œ, QU])[(Subscript[R, i_,j_])]:=(Subscript[Œ, QU])[(Subscript[{(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}, i]),(Subscript[{(Subscript[y, j]),(Subscript[a, j]),(Subscript[x, j])}, j]), -ℏ (γ^(-1))(Subscript[t, i])(Subscript[a, j])+ℏ (Subscript[y, i])(Subscript[x, j]),Normal@Series[(E^(ℏ (γ^(-1))(Subscript[t, i])(Subscript[a, j])-ℏ (Subscript[y, i])(Subscript[x, j])))((E^(ℏ (Subscript[b, i])(Subscript[a, j])))(Subscript[E, q])[ℏ (Subscript[y, i])(Subscript[x, j])]/.(Subscript[b, i])->(γ^(-1))(e (Subscript[a, i])-(Subscript[t, i]))) /. qrule, {e,0,$k}] /. e->ϵ]

(Subscript[Œ, QU])[(Subscript[R, 1,2])]

𝔼

𝔼[L,Q,P] means (e^(ℏ(L+Q)))P, where L is linear in the a’s, Q is a combination of (Subscript[x, i])(Subscript[y, j]), and P is a perturbation polynomial. It should be interpreted via C𝕆[𝔼[...], (Subscript[{(Subscript[x, 1]), (Subscript[a, 1]), (Subscript[y, 1])}, i]),...] (with some default for direct interpretation), or likewise via Q𝕆[𝔼[...], (Subscript[{(Subscript[x, 1]), (Subscript[a, 1]), (Subscript[y, 1])}, i]),...]. In themselves, C𝕆 and Q𝕆 should have an interpretation in CU/QU by casting.

Alternative Algorithms

(Subscript[λ, alt])[CU]:=If[$k==0,1,Module[{eq,d,b,c,so},
eq=ρ@(E^(ξ (Subscript[x, CU]))).ρ@(E^(η (Subscript[y, CU])))==ρ@(E^(d (Subscript[y, CU]))).ρ@(E^(c(t (Subscript[1, CU]) - 2ϵ (Subscript[a, CU])))).ρ@(E^(b (Subscript[x, CU])));
{so}=Solve[Thread[Flatten/@eq],{d,b,c}]/.C@1->0;
Normal@Series[(E^(-η y-ξ x+η ξ t+c t + d y - 2ϵ c a + b x))/.so,{ϵ,0,$k}]]];

{(Subscript[λ, alt])[CU], HL@Simplify[(Subscript[λ, alt])[CU]==Last[(Subscript[Λ, CU])[{ξ,η},{x,y}]]]}