Stitching Direct

MatrixExp[(Subscript[η, 1])ρ[CU@y]].MatrixExp[(Subscript[α, 1])ρ[CU@a]].MatrixExp[(Subscript[ξ, 1])ρ[CU@x]].MatrixExp[(Subscript[η, 2])ρ[CU@y]].MatrixExp[(Subscript[α, 2])ρ[CU@a]].MatrixExp[(Subscript[ξ, 2])ρ[CU@x]] // Simplify // MatrixForm

eqn=MatrixExp[(Subscript[η, 1])ρ[CU@y]].MatrixExp[(Subscript[α, 1])ρ[CU@a]].MatrixExp[(Subscript[ξ, 1])ρ[CU@x]].MatrixExp[(Subscript[η, 2])ρ[CU@y]].MatrixExp[(Subscript[α, 2])ρ[CU@a]].MatrixExp[(Subscript[ξ, 2])ρ[CU@x]] == (E^(τ0 ϵ γ))MatrixExp[η0 ρ[CU@y]].MatrixExp[α0 ρ[CU@a]].MatrixExp[ξ0 ρ[CU@x]]

sol=Block[{ϵ},Solve[Thread[Flatten/@eqn], {τ0,η0,α0,ξ0}]][[1]]

eqn=MatrixExp[(Subscript[η, 1])ρ[CU@y]].MatrixExp[(Subscript[α, 1])ρ[CU@a]].MatrixExp[(Subscript[ξ, 1])ρ[CU@x]].MatrixExp[(Subscript[η, 2])ρ[CU@y]].MatrixExp[(Subscript[α, 2])ρ[CU@a]].MatrixExp[(Subscript[ξ, 2])ρ[CU@x]] == T0 MatrixExp[η0 ρ[CU@y]].MatrixExp[α0 ρ[CU@a]].MatrixExp[ξ0 ρ[CU@x]]

sol=Block[{ϵ},Solve[Thread[Flatten/@eqn], {T0,η0,α0,ξ0}]][[1]]

(Subscript[SS, ϵ])[ℰ_] := Block[{ϵ},Collect[Normal@Series[ℰ, {ϵ,0,$k}],ϵ,Together]];  (* Shielded ϵ-Series *)

CΛ[t1_,y1_,a1_,x1_,ξ1_,η1_,δ_]:=Module[
{eqn,d,b,c,sol,λ,q,ν, ξ, η},
eqn=ρ[(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])))];
sol=Solve[Thread[Flatten/@eqn], {d,b,c}][[1]] /. C[1]->0;
λ=(E^(-η y-ξ x+η ξ t))Normal@Series[(E^(c t + d y - 2ϵ c a + b x))/.sol,{ϵ,0,$k}];
q=(E^(ν(-t ξ η+η y+ξ x+δ y x)));
Collect[ν (q^(-1))(Subscript[DP, ξ->(Subscript[D, x]),η->(Subscript[D, y])])[λ][q] /. ν->(((1+t δ))^(-1)),ϵ,Simplify] /. {t->t1,y->y1,a->a1,x->x1,ξ->ξ1, η->η1} ];

QΛ[T1_,y1_,a1_,x1_,ξ1_,η1_,δ_]:=Module[
{G,F,fs,f,bs,e,b,es,λ,q,ν, ξ, η,t},
G=Simp[Table[(ξ^k)/k!, {k,0, $k+1}].NestList[Simp[(Subscript[x, QU]) ** # - #** (Subscript[x, QU])]&, (Subscript[y, QU]), $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)QU@{(y^i),(a^j),(x^k)});
es=Flatten[Table[Coefficient[e,b]==0,{e,{F-(Subscript[1, QU])/.η->0,F**G-(Subscript[y, QU])**F-(∂_η)F}},{b,bs}]];
{λ}=F/.DSolve[es,fs,η]/.{(E^(_))->1,QU->Times};
q=(E^(ν(-t ξ η+η y+ξ x+δ y x)));
Collect[ν (q^(-1))(Subscript[DP, ξ->(Subscript[D, x]),η->(Subscript[D, y])])[λ][q] /. ν->(((1+t δ))^(-1))/.t->(T-1)/ℏ,ϵ,Simplify] /. {T->T1,y->y1,a->a1,x->x1,ξ->ξ1, η->η1} ];

wc[CU]=t; wc[QU]=(T-1)/ℏ;
Λ[U_] := Λ[U] = Module[{Q,w}, Q=(-w ξ η+η y+ξ x+δ y x)/(1+w δ);
Collect[(((1+w δ))^(-1))(E^(-Q))(Subscript[DP, ξ->(Subscript[D, x]),η->(Subscript[D, y])])[λ[U]][(E^Q)]/. w->wc[U],ϵ,Simplify]];
Λ[U_,t1_,T1_,y1_,a1_,x1_,ξ1_,η1_,δ1_] := Λ[U]/.{t->t1,T->T1,y->y1,a->a1,x->x1,ξ->ξ1,η->η1,δ->δ1};

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

(Subscript[Λ, U_])[{υ1_,ω1_,δ_},{u_,w_}] := Simp@Module[{υ,ω,yax,q,p,Q,uu,ww,d},
{yax,q,p}=List@@(Subscript[Λ, U])[{υ,ω},{u,w}];
(Subscript[Œ, U])[yax,Q=(υ uu+ω ww+δ uu ww+d υ ω)/(1-d δ),Expand[(((1-d δ))^(-1))(E^(-Q))(Subscript[SP, {υ->uu,ω->ww}])[p (E^Q)]]] /. {d->(∂_(υ,ω))q}/.{υ->υ1,ω->ω1,uu->u,ww->w}];

(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}];

(*SimpPQ[PQ_] := Expand@Collect[PQ, {(Subscript[x, _]),(Subscript[y, _]),(Subscript[a, _])},CC]  /. (E^(ℰ_)):>(E^(Expand@Together[ℰ]))/. CC->ExpandDenominator@*ExpandNumerator@*Together;*)
SimpPQ[PQ_] := Simplify[PQ//. (E^(ℰ_)):>(E^(Simplify[ℰ]))];

Next task: (Subscript[Exp, U]):U->Œ...
Next next task: Define (Subscript[SΛ, U,k])[η,α,ξ,δ], whose value is an (Subscript[Œ, U])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}, 1]), Q, P+(Subscript[0, k])] such that U@(Subscript[SΛ, U,k])[η,α,ξ,δ]==(Subscript[S, 1])@U@(Subscript[Œ, U])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}, 1]), η (Subscript[y, 1])+α (Subscript[a, 1])+ξ (Subscript[x, 1])+δ (Subscript[x, 1])(Subscript[y, 1]),(Subscript[0, k])].

(Subscript[SΛ, U_,k_])[η_,α_,ξ_,δ_]

Block[{$p=4,$k=4},TableForm[StringSplit[
"y|a|x|Cθ@(Subscript[y, CU])|Cθ@(Subscript[a, CU])|Cθ@(Subscript[x, CU])|Qθ@(Subscript[y, QU])|Qθ@(Subscript[a, QU])|Qθ@(Subscript[x, QU])|A𝔻@(Subscript[y, QU])|A𝔻@(Subscript[a, QU])|A𝔻@(Subscript[x, QU])|S𝔻@(Subscript[y, QU])|S𝔻@(Subscript[a, QU])|S𝔻@(Subscript[x, QU])|S@(Subscript[y, CU])|S@(Subscript[a, CU])|S@(Subscript[x, CU])|S@(Subscript[y, QU])|S@(Subscript[a, QU])|S@(Subscript[x, QU])|Δ@(Subscript[y, CU])|Δ@(Subscript[a, CU])|Δ@(Subscript[x, CU])|Δ@(Subscript[y, QU])-(Subscript[y, 1])|Δ@(Subscript[a, QU])|Δ@(Subscript[x, QU])-(Subscript[x, 1])", "|"] /. s_String :> {s, Normal@Simplify@Log@Series[ToExpression[s]/.CU|QU->Times,{ϵ,0,$k}]}]]

Task. Define  (Subscript[Exp, U,k])[ξ,X,P] which computes (e^(ξ X·𝕆(P))) to (ϵ^k) in the algebra U, where ξ is a scalar, X is (Subscript[x, i]) or (Subscript[y, i]), and P is an ϵ-dependent docile perturbation, giving the answer in Œ-form. Should satisfy U@(Subscript[Exp, U,k])[ξ, X, P] == (Subscript[𝕊, U])[(e^(ξ x)), x->X·𝕆(P)].
Methodology. If (Subscript[P, 0]):=(Subscript[P, ϵ=0]) and (e^(ξ X·𝕆(P)))=𝕆((e^(ξ X·(Subscript[P, 0])))F(ξ)), then F(ξ=0)=1 and we have:
𝕆((e^(ξ X·(Subscript[P, 0])))(X (Subscript[P, 0])F(ξ)+(∂_ξ)F)=𝕆((∂_ξ)(e^(ξ X·(Subscript[P, 0])))F(ξ))=(∂_ξ)𝕆((e^(ξ X·(Subscript[P, 0])))F(ξ))=(∂_ξ)(e^(ξ X 𝕆(P)))=(e^(ξ X 𝕆(P)))X 𝕆(P)=𝕆((e^(ξ X·(Subscript[P, 0])))F(ξ))X 𝕆(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 φ.

(Subscript[Exp, U_,0])[ξ_,(Subscript[(X:(x|y)), i_]),P_]:=(Subscript[Œ, U])[(Subscript[{(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}, i]), Normal@P /. ϵ->0, 1+(Subscript[0, 0])];
(Subscript[Exp, U_,k_])[ξ_,(Subscript[(X:(x|y)), i_]),P_]:=Module[{P0,f,φ,φs,F,rhs,at0,atξ},
P0=Normal@P /. ϵ->0;
f=Normal@Last@(Subscript[Exp, U,k-1])[ξ,(Subscript[X, i]),P];
φs=Flatten@Table[(Subscript[φ, j1,j2,j3])[ξ],{j2,0, 2k},{j1,0,2k-j2},{j3,0,2k-j2-j1}];
F=f+(ϵ^k)φs.(φs/.(Subscript[φ, j1_,j2_,j3_])[ξ]:>(Subscript[y, i]^j1)(Subscript[a, i]^j2)(Subscript[x, i]^j3));
rhs=Normal@Last@(Subscript[m, i,b,c->i])[(Subscript[Œ, U])[(Subscript[{(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}, i]), ξ (Subscript[X, i]) P0, F+(Subscript[0, k])](Subscript[Œ, U])[(Subscript[{(Subscript[X, b])}, b]),0,(Subscript[X, b])+(Subscript[0, k])](Subscript[m, i->c])@(Subscript[Œ, U])[(Subscript[{(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}, i]),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 (Subscript[X, i]) F-rhs, {(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}];
(Subscript[Œ, U])[(Subscript[{(Subscript[y, i]),(Subscript[a, i]),(Subscript[x, i])}, i]), ξ (Subscript[X, i]) P0, F+(Subscript[0, k])] /. DSolve[And@@(at0⋃atξ),φs,ξ][[1]]
]

The antipode on exponentials in QU.

Computing S((e^(ξx))): If S((e^(ξx)))=𝕆(ax:F (e^(-ξx))), then (Subscript[F, ξ=0])=1 and 𝕆(ax:((∂_ξ)F-x F)(e^(-ξ x)))=(∂_ξ)S((e^(ξx)))=S(((xe)^(ξx)))=S((e^(ξx)))S(x)=𝕆(ax:F (e^(-ξx)))(-(e^(ℏϵa))x)=𝕆((Subscript[axa, 2])(Subscript[x, 2]):-(Subscript[x, 2])F (e^(-ξx+(Subscript[ℏϵa, 2])))), and that’s an ODE for F.

SxF[0]=1;
SxF[k_] := SxF[k]=Module[{fs,bs,F,rhs,at0,atξ},
fs=Flatten@Table[(Subscript[f, i,j])[ξ],{i,0, 2k},{j,0,2k-i}];
F=SxF[k-1]+(ϵ^k)fs.(bs=fs/.(Subscript[f, i_,j_])[ξ]:>(a^i)(x^j));
rhs=Normal@Last@Cord[(Subscript[Œ, QU])[(Subscript[{(Subscript[a, 1]),(Subscript[x, 1]),(Subscript[a, 2]),(Subscript[x, 2])}, 1]),-ξ (Subscript[x, 1]),(F/.{a->(Subscript[a, 1]),x->(Subscript[x, 1])})Series[-(Subscript[x, 2])(E^(ℏ ϵ (Subscript[a, 2]))),{ϵ,0,k}]] /. ξ->ℏ ξ] /. {ξ->(ℏ^(-1))ξ,(Subscript[a, 1])->a,(Subscript[x, 1])->x};
at0=(#==0)& /@ Flatten@CoefficientList[F-1 /. ξ->0, {a,x}];
atξ=(#==0)& /@ Flatten@CoefficientList[((∂_ξ)F)-x F-rhs, {a,x}];
F/.DSolve[And@@(at0⋃atξ),fs,ξ][[1]]
];

Timing@Block[{$p=8,$k=3},{
Collect[SxF[$k], {ϵ,a}],
HL@Simp[(Subscript[S, 1])@(Subscript[QU, 1])@(Subscript[𝕆, QU])[{x},SS[(E^(ℏ ξ x))]] - (Subscript[QU, 1])@(Subscript[𝕆, QU])[{a,x},SS[(E^(-ℏ ξ x))(SxF[$k]/.ξ->ℏ ξ)]]]
}]

Computing S((e^(ηy))): If S((e^(ηy)))=𝕆(ya:F (e^(-(T^(-1))ηy))), then (Subscript[F, η=0])=1 and 𝕆(ya:((∂_η)F-(T^(-1))y F)(e^(-(T^(-1))ηy)))=(∂_η)S((e^(ηy)))=S(((ye)^(ηy)))=S((e^(ηy)))S(y)=𝕆(ya:F (e^(-(T^(-1))ηy)))(-(e^(ℏϵa))(T^(-1))y)=𝕆((Subscript[yaa, 2])(Subscript[y, 2]):-(T^(-1))(Subscript[y, 2])F (e^(-(T^(-1))ηy+(Subscript[ℏϵa, 2])))), and that’s an ODE for F.

SyF[0]=1;
SyF[k_]:= SyF[k]=Module[{fs,bs,F,rhs,at0,atη},
fs=Flatten@Table[(Subscript[f, i,j])[η],{i,0, 2k},{j,0,2k-i}];
F=SyF[k-1]+(ϵ^k)fs.(bs=fs/.(Subscript[f, i_,j_])[η]:>(y^i)(a^j));
rhs=Normal@Last@Cord[(Subscript[Œ, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[a, 2]),(Subscript[y, 2])}, 1]),-(T^(-1))η (Subscript[y, 1]),(F/.{a->(Subscript[a, 1]),y->(Subscript[y, 1])})Series[-(Subscript[y, 2])(T^(-1))(E^(ℏ ϵ (Subscript[a, 2]))),{ϵ,0,k}]] /. η->ℏ η] /. {η->(ℏ^(-1))η,(Subscript[a, 1])->a,(Subscript[y, 1])->y};
at0=(#==0)& /@ Flatten@CoefficientList[F-1 /. η->0, {a,y}];
atη=(#==0)& /@ Flatten@CoefficientList[((∂_η)F)-(T^(-1))y F-rhs, {a,y}];
F/.DSolve[And@@(at0⋃atη),fs,η][[1]]
];

Timing@Block[{$p=8,$k=3},{
Collect[SyF[$k], {ϵ,a}],
HL@Simp[(Subscript[S, 1])@(Subscript[QU, 1])@(Subscript[𝕆, QU])[{y},SS[(E^(ℏ η y))]] - (Subscript[QU, 1])@(Subscript[𝕆, QU])[{y,a},SS[(E^(-ℏ η y/T))(SyF[$k]/.η->ℏ η)]]]
}]

(Subscript[Λ, U_,0])[{ξ1_,η1_},{x,y}] := (Subscript[Œ, QU])[{y,a,x},ξ x+η y+(U/. {CU->-t η ξ, QU-> η ξ(1-T)/ℏ}),1+(Subscript[0, 0])];
(Subscript[Λ, U_,kk_])[{ξ1_,η1_},{x,y}]:=(*(Subscript[Λ, U,kk])[{ξ1,η1},{x,y}]=*)Block[{$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, i,j,k])[η],{i,0, $k},{j,0, $k},{k,0, $k}];
F=(Subscript[𝕆, U])[{y,a,x},Normal@Last@(Subscript[Λ, U,kk-1])[{ξ,η},{x,y}]]+fs.(bs=fs/.(Subscript[f, i_,j_,k_])[η]:>(ϵ^kk)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]];
(Subscript[Œ, U])[{y,a,x},
ξ x+η y+(U /. {CU->-t η ξ, QU-> η ξ(1-T)/ℏ}),
Simplify[F+(Subscript[0, $k])/.{(E^(_))->1,U->Times}]
] /. {ξ->ξ1,η->η1}]];

Timing@Block[{$p=3,$k=1},{
sexp=(Subscript[m, 3,2,1->1])[(Subscript[Exp, (Subscript[QU, 1]),$k])[η,(Subscript[S, 1])[QU[(Subscript[y, 1])]]/.QU->Times](Subscript[Exp, (Subscript[QU, 2]),$k])[α,(Subscript[S, 2])[QU[(Subscript[a, 2])]]/.QU->Times](Subscript[Exp, (Subscript[QU, 3]),$k])[ξ,(Subscript[S, 3])[QU[(Subscript[x, 3])]]/.QU->Times]] /. {η->ℏ η, α->ℏ α, ξ->ℏ ξ},
HL@SimpT[QU@sexp - (Subscript[S, 1])@(Subscript[𝕆, QU])[(Subscript[{(Subscript[y, 1]),(Subscript[a, 1]),(Subscript[x, 1])}, 1]),SS[(E^(ℏ(η (Subscript[y, 1])+α (Subscript[a, 1])+ξ (Subscript[x, 1]))))]]]
}]