Pensieve header: An isolated attempt to compute the multiplication tensor of QU.

The implementation of QU is modified from pensieve://Projects/SL2Portfolio/SL2PortfolioProgram.nb.

Initialization / Utilities

$k=1; $U=QU; $E:={$k};
$trim:={(ϵ^(k_.))/;k>$k->0};
SetAttributes[{SS,SST},HoldAll];
(Subscript[q, ℏ_]):=(E^(γ ϵ ℏ));
(* Upper to lower and lower to Upper: *)
U2l={(Subscript[B, i_]^(p_.))->(E^(-p ℏ γ (Subscript[b, i]))),(B^(p_.))->(E^(-p ℏ γ b)), (Subscript[T, i_]^(p_.))->(E^(p ℏ (Subscript[t, i]))),(T^(p_.))->(E^(p ℏ t)),(Subscript[𝒜, i_]^(p_.))->(E^(p γ (Subscript[α, i]))),(𝒜^(p_.))->(E^(p γ α))}; 
l2U={(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c/(ℏ γ)))(E^d),(E^(c_.b+d_.)):>(B^(-c/(ℏ γ)))(E^d),
(E^(c_.(Subscript[t, i_])+d_.)):>(Subscript[T, i]^(c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^(c/γ))(E^d),(E^(c_.α+d_.)):>(𝒜^(c/γ))(E^d),
(E^(ℰ_)):>(E^(Expand@ℰ))}; 
SS[ℰ_,op_]:=Collect[Normal@Series[ℰ,{ϵ,0,$k}],ϵ,op];
SS[ℰ_]:=SS[ℰ,Together];
SST[ℰ_,op___]:=SS[ℰ/.U2l,op];
Simp[ℰ_,op_]:=Collect[ℰ,_CU|_QU,op];
Simp[ℰ_]:=Simp[ℰ,SS[#,Expand]&];
SimpT[ℰ_]:=Collect[ℰ,_CU|_QU,SST[#,Expand]&];
Kδ/:(Subscript[Kδ, i_,j_]):=If[i===j,1,0];
(Subscript[c_Integer, k_Integer]) := c+((O[ϵ])^(k+1));

CF[ℰ_] := ExpandDenominator@ExpandNumerator@Together[Expand[ℰ] //. (E^(x_))(E^(y_)):>(E^(x+y)) /. (E^(x_)):>(E^(CF[x]))];

Unprotect[SeriesData];
SeriesData /: CF[sd_SeriesData] := MapAt[CF,sd,3];
SeriesData /: Expand[sd_SeriesData] := MapAt[Expand,sd,3];
SeriesData /: Simplify[sd_SeriesData] := MapAt[Simplify,sd,3];
SeriesData /: Together[sd_SeriesData] := MapAt[Together,sd,3];
SeriesData /: Collect[sd_SeriesData,specs__] := MapAt[Collect[#,specs]&,sd,3];
Protect[SeriesData];

Self-Pair (SP):

(Subscript[SP, {}])[P_]:=P; (Subscript[SP, {ξ_->x_,ps___}])[P_] := Expand[P//(Subscript[SP, {ps}])] /. f_.(ξ^(d_.)):>(∂_({x,d}))f

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;
B[x_,y_,e_]:=B[x,y,e]=B[x,y];

DeclareAlgebra[U_Symbol, opts__Rule] := Module[
{gp,sr,g,cp,M,pow,k=0,
gs=Generators /. {opts},
cs=Centrals /. {opts} /. Centrals -> {}
},
U[Generators]=gs;
((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 *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[ℰ_]:=Collect[ℰ,_U,Expand]/.(E^(x_)):>(E^(Expand[x]))/.$trim;
(Subscript[U, i_])[ℰ_]:=ℰ/.{t:cp:>(Subscript[t, i]),u_U:>((Subscript[#, i])&)/@u};
(Subscript[U, i_])[NCM[]]=pow[ℰ_,0]=U@{}=(Subscript[1, U])=U[];
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_**(c_.(Subscript[1, U])):=CE[c x]; (c_.(Subscript[1, U]))**x_:=CE[c x];
(a_.U[xx___,x_])**(b_.U[y_,yy___]) :=If[OrderedQ[{x,y}/.sr],
CE@M[a b/.$trim,U[xx,x,y,yy]],
U@xx**CE@M[a b/.$trim,U@y**U@x+B[U@x,U@y,$E]]**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];
(Subscript[𝕆, U])[specs___,𝔼[L_,Q_,P_]]:=(Subscript[𝕆, U])[specs,SS@Normal[P (E^(L+Q))]];
pow[ℰ_,n_]:=pow[ℰ,n-1]**ℰ;
(Subscript[𝕊, U])[ℰ_,ss___Rule] := CE@Total[
CoefficientRules[ℰ,First/@{ss}]/.(p_->c_):>c NCM@@MapThread[pow,{Last/@{ss},p}]];
(Subscript[σ, rs___])[c_.*u_U] := (c/.(Subscript[(t:cp), j_]):>(Subscript[t, j/.{rs}]))U[List@@(u/.(Subscript[v_, j_]):>(Subscript[v, j/.{rs}]))];
(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])]];
U /: c_.*u_U*v_U := CE[c u**v];
(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]]];
(Subscript[Δ, i_->j_,k_])[c_.*u_U]:= CE[((c/.(Subscript[Δ, i->j,k])[U,Centrals])DeleteCases[u,(Subscript[_, i])])**(NCM@@Cases[u,(Subscript[x_, i]):>(Subscript[σ, 1->j,2->k])@Δ@U@x] /. NCM[]->U[])]; ]

(Subscript[𝕊, QU])[((a^2)+a)b,a->QU[y,x],b->7QU[]]

Meta-Operations

(Subscript[σ, rs___])[ℰ_Plus] := (Subscript[σ, rs])/@ℰ;
(Subscript[m, j_->j_])=Identity; (Subscript[m, j_->k_])[0] = 0;
(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])/@ℰ];
(Subscript[Δ, is___])[ℰ_Plus] := Simp[(Subscript[Δ, is])/@ℰ];

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

Verify σ and Δ! Also Generalize Δ to (Subscript[Δ, i,(Subscript[j, 1]),(Subscript[j, 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@(Subscript[y, CU])=-(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])};
Δ@(Subscript[y, CU])=CU@(Subscript[y, 1])+CU@(Subscript[y, 2]); Δ@(Subscript[a, CU])=CU@(Subscript[a, 1])+CU@(Subscript[a, 2]); Δ@(Subscript[x, CU])=CU@(Subscript[x, 1])+CU@(Subscript[x, 2]);
(Subscript[Δ, i_->j_,k_])[CU,Centrals]={(Subscript[t, i])->(Subscript[t, j])+(Subscript[t, k])};

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

ℏ=γ=1;
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[(Subscript[q, ℏ])-1]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))};
Δ@(Subscript[y, QU]):=(Subscript[𝕆, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1])}, 1]),(Subscript[{(Subscript[y, 2])}, 2]),SS[(Subscript[y, 1])+(Subscript[T, 1])(E^(-ℏ ϵ (Subscript[a, 1])))(Subscript[y, 2])]]; Δ@(Subscript[a, QU])=QU@(Subscript[a, 1])+QU@(Subscript[a, 2]); Δ@(Subscript[x, QU]):=(Subscript[𝕆, QU])[(Subscript[{(Subscript[a, 1]),(Subscript[x, 1])}, 1]),(Subscript[{(Subscript[x, 2])}, 2]),SS[(Subscript[x, 1])+(E^(-ℏ ϵ (Subscript[a, 1])))(Subscript[x, 2])]];
(Subscript[Δ, i_->j_,k_])[QU,Centrals]={(Subscript[t, i])->(Subscript[t, j])+(Subscript[t, k]),(Subscript[T, i])->(Subscript[T, j])(Subscript[T, k])};

B[(Subscript[x, QU]),(Subscript[y, QU])]

tSW

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

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:

(Subscript[SW, xy])[U_,kk_] :=  (Subscript[SW, xy])[U,kk] =Block[{$U=U,$k=kk,$p=kk},Module[{G,F,fs,f,bs,e,b,es},
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_])[η]:>(ϵ^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}]];
F=F/.DSolve[es,fs,η][[1]];
𝔼[0,
ξ x+η y+(U /. {CU->-t η ξ, QU-> η ξ(1-T)/ℏ}),
F+(Subscript[0, $k])/.{(E^(_))->1,U->Times}
] /. (v:η|ξ|t|T|y|a|x)->(Subscript[v, 1])
]];
(Subscript[tSW, xy_,i_,j_->k_]):=(Subscript[SW, xy])[$U,$k] /. {(Subscript[ξ, 1])->(Subscript[ξ, i]),(Subscript[η, 1])->(Subscript[η, j]),(Subscript[(v:t|T|y|a|x), 1])->(Subscript[v, k])};
(Subscript[tSW, xa,i_,j_->k_]):=𝔼[(Subscript[α, j])(Subscript[a, k]),(E^(-γ (Subscript[α, j])))(Subscript[ξ, i])(Subscript[x, k]),1];
(Subscript[tSW, ay,i_,j_->k_]):=𝔼[(Subscript[α, i])(Subscript[a, k]),(E^(-γ (Subscript[α, i])))(Subscript[η, j])(Subscript[y, k]),1];

Exponentials as needed.

Task. Define  (Subscript[Exp, (Subscript[U, i]),k])[ξ,P] which computes (e^(ξ 𝕆(P))) to (ϵ^k) in the algebra (Subscript[U, i]), where ξ is a scalar, X is (Subscript[x, i]) or (Subscript[y, i]), and P is an ϵ-dependent near-docile element, giving the answer in 𝔼-form. Should satisfy U@(Subscript[Exp, (Subscript[U, i]),k])[ξ,P] == (Subscript[𝕊, U])[(e^(ξ x)), x->𝕆(P)].
Methodology. If (Subscript[P, 0]):=(Subscript[P, ϵ=0]) and (e^(ξ 𝕆(P)))=𝕆((e^(ξ (Subscript[P, 0])))F(ξ)), then F(ξ=0)=1 and we have:
𝕆((e^(ξ (Subscript[P, 0])))((Subscript[P, 0])F(ξ)+(∂_ξ)F))=𝕆((∂_ξ)(e^(ξ (Subscript[P, 0])))F(ξ))=(∂_ξ)𝕆((e^(ξ (Subscript[P, 0])))F(ξ))=(∂_ξ)(e^(ξ 𝕆(P)))=(e^(ξ 𝕆(P)))𝕆(P)=𝕆((e^(ξ (Subscript[P, 0])))F(ξ))𝕆(P).
This is an ODE for F. Setting inductively (Subscript[F, k])=(Subscript[F, k-1])+(ϵ^k)φ we find that (Subscript[F, 0])=1 and solve for φ.

(* Bug: The first line is valid only if 𝕆((E^(Subscript[P, 0])))==(E^(𝕆((Subscript[P, 0])))). *)
(* Bug: ξ must be a symbol. *)
(Subscript[Exp, (Subscript[U_, i_]),0])[ξ_,P_]:=Module[{LQ=Normal@P /. ϵ->0},
𝔼[ξ LQ/.(Subscript[(x|y), i])->0, ξ LQ/.(Subscript[(t|a), i])->0,1] ];
(Subscript[Exp, (Subscript[U_, i_]),k_])[ξ_,P_]:=Block[{$U=U,$k=k},
Module[{P0,φ,φs,F,j,rhs,at0,atξ},
P0=Normal@P /. ϵ->0;
φs=Flatten@Table[(Subscript[φ, j1,j2,j3])[ξ],{j2,0,k},{j1,0,2k+1-j2},{j3,0,2k+1-j2-j1}];
F=Normal@Last@(Subscript[Exp, (Subscript[U, i]),k-1])[ξ,P]+(ϵ^k)φs.(φs/.(Subscript[φ, js__])[ξ]:>Times@@(({(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])})^({js})));
rhs=Normal@Last@(Subscript[m, i,j->i])[𝔼[ξ P0/.(Subscript[(x|y), i])->0,ξ P0/.(Subscript[(t|a), i])->0, F+(Subscript[0, k])](Subscript[m, i->j])@𝔼[0,0,P+(Subscript[0, k])]];
at0=(#==0)& /@ Flatten@CoefficientList[F-1 /. ξ->0, {(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}];
atξ=(#==0)& /@ Flatten@CoefficientList[((∂_ξ)F)+P0 F-rhs, {(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}];
𝔼[ξ P0/.(Subscript[(x|y), i])->0,ξ P0/.(Subscript[(t|a), i])->0, F+(Subscript[0, k])] /. DSolve[And@@(at0⋃atξ),φs,ξ][[1]] ]]

$k=1

$Basis={(Subscript[a, QU]),(Subscript[x, QU]),(Subscript[y, QU])};
Module[{a,b},Table[{a,b}->CE[B[a,b]],{a,$Basis},{b,$Basis}]] //MatrixForm

$Basis={(Subscript[a, QU]),(Subscript[x, QU]),(Subscript[y, QU])};
Module[{a,b},
DeleteCases[Flatten[Table[{a,b,c}->CE[B[a,b]+B[b,a]],{a,$Basis},{b,$Basis}]], _->0]
]
Module[{a,b,c},
DeleteCases[Flatten[Table[{a,b,c}->CE[B[a,B[b,c]]+B[b,B[c,a]]+B[c,B[a,b]]],{a,$Basis},{b,$Basis},{c,$Basis}]], _->0]
]
$ABasis={(Subscript[a, QU]),(Subscript[x, QU]),(Subscript[y, QU]),QU[y,y],QU[y,a],QU[y,x],QU[a,a],QU[a,x],QU[x,x]};
Module[{a,b,c},
DeleteCases[Flatten[Table[{a,b,c}->CE[a**CE[b**c]-CE[a**b]**c],{a,$ABasis},{b,$ABasis},{c,$ABasis}]], _->0]
]

Module[{a,b,c},
Table[{a,b,c}->CE[a**CE[b**c]],{a,$ABasis},{b,$ABasis},{c,$ABasis}]
];

B[(Subscript[x, QU]),(Subscript[y, QU])]//CE

B[(Subscript[x, QU]),B[(Subscript[x, QU]),(Subscript[y, QU])]]//CE

B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),(Subscript[y, QU])]]]//CE

B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),(Subscript[y, QU])]]]]//CE

B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),(Subscript[y, QU])]]]]]//Expand

B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),B[(Subscript[x, QU]),(Subscript[y, QU])]]]]]]//Expand

adPower[x_,k_,Env_][c_*y_QU]:=CE[c adPower[x,k,Env][y]];
adPower[x_,k_,Env_][y_Plus] := adPower[x,k,Env]/@ y;
adPower[_,0,Env_][y_]:=y;
adPower[x_,k_,Env_][0]=0;
adPower[x_,k_,Env_][y_QU]:=adPower[x,k,Env][y]=CE@B[adPower[x,k-1,Env][y],x];
adPower[x_,k_][y_]:=adPower[x,k,$E][y];

adPower[(Subscript[x, QU]),1][(Subscript[y, QU])]

adPower[(Subscript[x, QU]),2][(Subscript[y, QU])]

adPower[(Subscript[x, QU]),3][(Subscript[y, QU])]

adPower[(Subscript[x, QU]),4][(Subscript[y, QU])]

adPower[(Subscript[x, QU]),5][(Subscript[y, QU])]

NilQ[(Subscript[x, QU])]=NilQ[(Subscript[y, QU])]=True; NilQ[(Subscript[a, QU])]=False;
PotQ[c_.*x_QU]:=¬NilQ[x];  (* Potent Q *)
NilQ[c_*x_QU]:=NilQ[x];
PotQ[x_Plus]:=And@@(PotQ/@(List@@x));
NilQ[x_Plus]:=And@@(NilQ/@(List@@x));

Ad[0]=Identity;
Ad[c_.(Subscript[a, QU])][z_]:=z/.w_QU:>(E^(c γ (Count[w,y]-Count[w,x])))w;
Ad[c_.QU[]][z_]:=z;

Ad[x_][y_]/;NilQ[x]:=Expand@Module[{k=0,s=0},
While[adPower[x,k][y]=!=0,
s+=adPower[x,k][y]/k!;
++k
];
s
]

Ad[(Subscript[x, QU])][(Subscript[y, QU])]

$k

Ad[c (Subscript[a, QU])]/@{QU[],(Subscript[x, QU]),(Subscript[y, QU]),QU[x,y]}

Ad[(α1+α2+ϵ fa[λ]) (Subscript[a, QU])]/@{QU[],(Subscript[x, QU]),(Subscript[y, QU]),QU[x,y]}

Normal@Series[(E^(-γ (α1+α2+ϵ fa[λ]))),{ϵ,0,$k}]

CE[Ad[(α1+α2+ϵ fa[λ]) (Subscript[a, QU])]/@{QU[],(Subscript[x, QU]),(Subscript[y, QU]),QU[x,y]}/.(E^(ℰ_)):>Normal@Series[(E^ℰ),{ϵ,0,$k}]]

Ad[(Subscript[a, QU])][Ad[(Subscript[x, QU])][(Subscript[y, QU])]]

(Subscript[TT, λ_])[]=0; (* Translated Tangent *)
(Subscript[TT, λ_])[xs___,x_]:=CE[Ad[x][(Subscript[TT, λ])[xs]]+(∂_λ)x];
(Subscript[TT, λ_])[xs_List]:=(Subscript[TT, λ])@@xs

(Subscript[TT, λ])[λ (Subscript[y, QU]),λ (Subscript[a, QU]),λ (Subscript[x, QU])]

(Subscript[Seepage, U_])[{},c_]=c;
(Subscript[Seepage, U_])[ξs_List,P_]:=Module[{gs=U[Generators],lx},
lx=gs[[Length@ξs]];
Collect[P,lx,(Ad[Last[ξs](Subscript[lx, U])][(Subscript[𝕆, U])[gs,(Subscript[Seepage, U])[Most@ξs,#]]]/.U->Times)&]
]

B[(Subscript[y, QU]),α (Subscript[a, QU])]

(Subscript[Seepage, QU])[{η,α,ξ},y]

TTL=(Subscript[TT, λ])[λ η1 (Subscript[y, QU]),α1 (Subscript[a, QU]),λ ξ1 (Subscript[x, QU]),λ η2 (Subscript[y, QU]),α2 (Subscript[a, QU]),λ ξ2 (Subscript[x, QU])]

f={fy0[λ]+ϵ fy1[λ],α1+α2+ϵ fa1[λ],fx0[λ]+ϵ fx1[λ]}
g=(ft0[λ]+ϵ ft1[λ])+(ϵ fyx1[λ])y x
G=SS[(E^g)]

𝒮[B_]:=CE[SS@(Subscript[𝕆, QU])[{y,a,x},(Subscript[Seepage, QU])[f,SS@B]]];
𝒮[G]

(Subscript[Invert, U_])[ℰ_]:= Module[{A,B,β},(* ℰ=A U[]+ϵ B *)
A=Coefficient[ℰ,(Subscript[1, U])]/.ϵ->0;
B=CE[(ϵ^(-1))(ℰ-A (Subscript[1, U]))];
(Subscript[𝕊, U])[SS[(((A+ϵ β))^(-1))],  β->B]
]

(Subscript[Invert, QU])[𝒮[G]]

CE[(Subscript[Invert, QU])[𝒮[G]]**𝒮[G]]

G

((∂_λ)(f.QU@Generators)G+(∂_λ)G)

TTR=CE[(Subscript[Invert, QU])[𝒮[G]]**𝒮[((∂_λ)(f.QU@Generators)G+(∂_λ)G)]]

diff=CE[TTL-TTR]

diff/.ϵ->0

{sol1}=DSolve[Coefficient[diff/.ϵ->0,(Subscript[x, QU])]==0∧fx0[0]==0, fx0,λ]

CE[diff/.sol1/.ϵ->0]

{sol2}=DSolve[Coefficient[CE[diff/.sol1/.ϵ->0],(Subscript[y, QU])]==0∧fy0[0]==0, fy0,λ]

CE[diff/.sol1/.sol2/.ϵ->0]

{sol3}=DSolve[Coefficient[CE[diff/.sol1/.sol2/.ϵ->0],QU[]]==0∧ft0[0]==0, ft0,λ]

CE[diff/.sol1/.sol2/.sol3]/.ϵ->0

CE[diff/.sol1/.sol2/.sol3]

{sol4}=DSolve[Coefficient[CE[diff/.sol1/.sol2/.sol3],QU[y,x]]==0∧fyx1[0]==0, fyx1,λ]

CE[diff/.sol1/.sol2/.sol3/.sol4]

{sol5}=DSolve[Coefficient[CE[diff/.sol1/.sol2/.sol3/.sol4],QU[a]]==0∧fa1[0]==0, fa1,λ]

CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5]

{sol6}=DSolve[Coefficient[CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5],QU[y]]==0∧fy1[0]==0, fy1,λ]

CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5/.sol6]

{sol7}=DSolve[Coefficient[CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5/.sol6],QU[x]]==0∧fx1[0]==0, fx1,λ]

CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5/.sol6/.sol7]

{sol8}=DSolve[Coefficient[CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5/.sol6/.sol7],QU[]]==0∧ft1[0]==0, ft1,λ]

CE[diff/.sol1/.sol2/.sol3/.sol4/.sol5/.sol6/.sol7/.sol8]

r=Simplify[(f.QU@Generators+g)/.sol1/.sol2/.sol3/.sol4/.sol5/.sol6/.sol7/.sol8]

The following was imported from pensieve://Projects/SL2Portfolio2/PortfolioTesting.nb:

km=Plus[(Subscript[a, k]) (Subscript[α, i])+(Subscript[a, k]) (Subscript[α, j]),(Subscript[y, k]) (Subscript[η, i])+(((Subscript[y, k]) (Subscript[η, j]))/(Subscript[𝒜, i]))+(((Subscript[x, k]) (Subscript[ξ, i]))/(Subscript[𝒜, j]))+(((1-T) (Subscript[η, j]) (Subscript[ξ, i]))/ℏ)+(Subscript[x, k]) (Subscript[ξ, j]),(2 T (Subscript[a, k]) (Subscript[η, j]) (Subscript[ξ, i])+((γ ℏ (Subscript[x, k]) (Subscript[y, k]) (Subscript[η, j]) (Subscript[ξ, i]))/((Subscript[𝒜, i]) (Subscript[𝒜, j])))+(((γ-3 T γ) (Subscript[y, k]) (Subscript[η, j]^2) (Subscript[ξ, i]))/(2 (Subscript[𝒜, i])))+(((γ-3 T γ) (Subscript[x, k]) (Subscript[η, j]) (Subscript[ξ, i]^2))/(2 (Subscript[𝒜, j])))+(((γ-4 T γ+3 (T^2) γ) (Subscript[η, j]^2) (Subscript[ξ, i]^2))/(4 ℏ))) ϵ]/.{ℏ->1,γ->1,(Subscript[v_, k]):>v,(Subscript[η, i])->η1,(Subscript[α, i])->α1,(Subscript[𝒜, i])->(E^(α1)),(Subscript[ξ, i])->ξ1,(Subscript[η, j])->η2,(Subscript[α, j])->α2,(Subscript[𝒜, j])->(E^(α2)),(Subscript[ξ, j])->ξ2}

Expand[(r/.λ->1)-km]