(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
HL[\[ScriptCapitalE]_] := Style[\[ScriptCapitalE], Background -> Yellow];


(* ::Input::Initialization:: *)
$p=2; $k=1; $E:={$k,$p};
$trim:={\[HBar]^p_./;p>$p->0, \[Epsilon]^k_./;k>$k->0};
SetAttributes[{SS,SST},HoldAll];
TRule={Subscript[T, i_]->E^(\[HBar] Subscript[t, i]),T->E^(\[HBar] t)}; Subscript[q, \[HBar]]=E^(\[Gamma] \[Epsilon] \[HBar]);
SS[\[ScriptCapitalE]_,op_]:=Collect[
Normal@Series[If[$p>0,\[ScriptCapitalE],\[ScriptCapitalE]/.TRule],{\[HBar],0,$p}],
\[HBar],op];
SS[\[ScriptCapitalE]_]:=SS[\[ScriptCapitalE],Together];
SST[\[ScriptCapitalE]_,op___]:=SS[\[ScriptCapitalE]/.TRule,op];
Simp[\[ScriptCapitalE]_,op_]:=Collect[\[ScriptCapitalE],_CU|_QU,op];
Simp[\[ScriptCapitalE]_]:=Simp[\[ScriptCapitalE],SS[#,Expand]&];
SimpT[\[ScriptCapitalE]_]:=Collect[\[ScriptCapitalE],_CU|_QU,SST[#,Expand]&];


(* ::Input::Initialization:: *)
Subscript[DP, \[Alpha]_->Subscript[D, x_],\[Beta]_->Subscript[D, y_]][P_][\[Lambda]_]:=Total[CoefficientRules[Normal@P,{\[Alpha],\[Beta]}]/.({m_,n_}->c_):>c \!\(
\*SubscriptBox[\(\[PartialD]\), \({x, m}, {y, n}\)]\[Lambda]\)]


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


(* ::Input::Initialization:: *)
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];


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(SP\), \({}\)]\)[P_]:=P; \!\(\*SubscriptBox[\(SP\), \({\[Xi]_ \[Rule] x_, ps___}\)]\)[P_] := Expand[P//\!\(\*SubscriptBox[\(SP\), \({ps}\)]\)] /. f_. \[Xi]^d_.:>\!\(
\*SubscriptBox[\(\[PartialD]\), \({x, d}\)]f\)


(* ::Input::Initialization:: *)
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];


(* ::Input::Initialization:: *)
DeclareAlgebra[U_Symbol, opts__Rule] := Module[{gp,sr,g,cp,M,CE,pow,k=0,
gs=Generators /. {opts},
cs=Centrals /. {opts} /. Centrals -> {} },
(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 \[Rule] *) 
cp=Alternatives@@cs; (* cents *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[\[ScriptCapitalE]_]:=Collect[\[ScriptCapitalE],_U,Expand]/.$trim;
Subscript[U, i_][\[ScriptCapitalE]_]:=\[ScriptCapitalE]/.{t:cp:>Subscript[t, i],u_U:>(Subscript[#, i]&)/@u};
Subscript[U, i_][NCM[]]=pow[\[ScriptCapitalE]_,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[\[ScriptCapitalE]_NonCommutativeMultiply]:=U/@\[ScriptCapitalE];
Subscript[\[DoubleStruckCapitalO], 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[\[ScriptCapitalE]_,n_]:=pow[\[ScriptCapitalE],n-1]**\[ScriptCapitalE];
Subscript[\[DoubleStruckCapitalS], U][\[ScriptCapitalE]_,ss___Rule] := CE@Total[
CoefficientRules[\[ScriptCapitalE],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]]];
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]]] ]


(* ::Input::Initialization:: *)
DeclareMorphism[m_,U_->V_, ongs_List, oncs_List:{}] := (
Replace[ongs, {(g_->img_) :> (m[U[g]]=img),(g_:>img_) :> (m[U[g]]:=img/.$trim)}, {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[\[ScriptCapitalE]_] := Simp[\[ScriptCapitalE] /. oncs /.  u_U:>m[u]] /. $trim; )


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


(* ::Input::Initialization:: *)
DeclareAlgebra[CU,Generators->{y,a,x},Centrals->{t}];
B[Subscript[a, CU],Subscript[y, CU]]=-\[Gamma] Subscript[y, CU]; B[Subscript[x, CU],Subscript[a, CU]]=-\[Gamma] Subscript[x, CU];
B[Subscript[x, CU],Subscript[y, CU]]=2\[Epsilon] 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]};


(* ::Input::Initialization:: *)
DeclareAlgebra[QU, Generators -> {y,a,x}, Centrals -> {t,T}];
B[Subscript[a, QU],Subscript[y, QU]]=-\[Gamma] Subscript[y, QU]; B[Subscript[x, QU],Subscript[a, QU]]=-\[Gamma] QU@x;
B[Subscript[x, QU],Subscript[y, QU]]:=SS[Subscript[q, \[HBar]]-1]QU@{y,x}+Subscript[\[DoubleStruckCapitalO], QU][{a},SS[(1-T E^(-2\[Epsilon] a \[HBar]))/\[HBar]]];
(S@Subscript[y, QU]:=Subscript[\[DoubleStruckCapitalO], QU][{a,y},SS[-T^-1 E^(\[HBar] \[Epsilon] a) y]]; S@Subscript[a, QU]=-Subscript[a, QU]; S@Subscript[x, QU]:=Subscript[\[DoubleStruckCapitalO], QU][{a,x},SS[-E^(\[HBar] \[Epsilon] a)x]];)
Subscript[S, i_][QU,Centrals]={Subscript[t, i]->-Subscript[t, i], Subscript[T, i]->\!\(\*SubsuperscriptBox[\(T\), \(i\), \(-1\)]\)};


(* ::Input::Initialization:: *)
DeclareMorphism[C\[Theta],CU->CU, {y->-Subscript[x, CU], a->-Subscript[a, CU], x->-Subscript[y, CU]}, {t->-t, T->T^-1}];DeclareMorphism[Q\[Theta],QU->QU, {y:>Subscript[\[DoubleStruckCapitalO], QU][{a,x},SS[-T^(-1/2) E^(\[HBar] \[Epsilon] a) x]], a->-Subscript[a, QU], x:>Subscript[\[DoubleStruckCapitalO], QU][{a,y},SS[-T^(-1/2) E^(\[HBar] \[Epsilon] a) y]]}, {t->-t, T->T^-1}]


(* ::Input::Initialization:: *)
A\[DoubleStruckCapitalD]$f=\[Gamma] (Cosh[\[HBar](a \[Epsilon]+(\[Gamma] \[Epsilon])/2-t/2)]-Cosh[\[HBar] Sqrt[((t-\[Gamma] \[Epsilon])/2)^2+\[Epsilon] \[Omega]]])/(\[HBar] E^(\[HBar]((a+\[Gamma])\[Epsilon]-t/2)) Sinh[(\[Gamma] \[Epsilon] \[HBar])/2](a^2 \[Epsilon]+a \[Gamma] \[Epsilon]-a t-\[Omega]));


(* ::Input::Initialization:: *)
A\[DoubleStruckCapitalD]$\[Omega]=\[Gamma] CU[y,x]+\[Epsilon] CU[a,a]-(t-\[Gamma] \[Epsilon])CU[a];


(* ::Input::Initialization:: *)
DeclareMorphism[A\[DoubleStruckCapitalD],QU->CU,{a->Subscript[a, CU],x->CU@x, y:>Subscript[\[DoubleStruckCapitalS], CU][SS[A\[DoubleStruckCapitalD]$f],a->Subscript[a, CU],\[Omega]->A\[DoubleStruckCapitalD]$\[Omega]]**Subscript[y, CU]}]


(* ::Input::Initialization:: *)
S\[DoubleStruckCapitalD]$g=Sqrt[(2\[Gamma](Cosh[\[HBar]/2 Sqrt[t^2+\[Gamma]^2 \[Epsilon]^2+4 \[Epsilon] \[CurlyPi]]]-Cosh[(t-\[Epsilon] \[Gamma]-2\[Epsilon] a)/(2/\[HBar])]))/(Sinh[(\[Gamma] \[Epsilon] \[HBar])/2](t (2 a+\[Gamma])-2 a (a+\[Gamma]) \[Epsilon]+2 \[CurlyPi]) \[HBar])];


(* ::Input::Initialization:: *)
S\[DoubleStruckCapitalD]$f=Simplify[E^(\[HBar](t/2-\[Epsilon] a)) (S\[DoubleStruckCapitalD]$g /. {a->-a, t->-t})];


(* ::Input::Initialization:: *)
S\[DoubleStruckCapitalD]$\[CurlyPi]=\[Gamma] CU[y,x]+\[Epsilon] CU[a,a]-(t-\[Gamma] \[Epsilon])CU[a]-t \[Gamma] Subscript[1, CU]/2;


(* ::Input::Initialization:: *)
DeclareMorphism[S\[DoubleStruckCapitalD],QU->CU,{a->Subscript[a, CU],
x:>Subscript[\[DoubleStruckCapitalS], CU][SS[S\[DoubleStruckCapitalD]$f],a->Subscript[a, CU],\[CurlyPi]->S\[DoubleStruckCapitalD]$\[CurlyPi]]**Subscript[x, CU],
y:>Subscript[\[DoubleStruckCapitalS], CU][SS[S\[DoubleStruckCapitalD]$g],a->Subscript[a, CU],\[CurlyPi]->S\[DoubleStruckCapitalD]$\[CurlyPi]]**Subscript[y, CU] }]


(* ::Input::Initialization:: *)
\[Rho]@Subscript[y, CU]=\[Rho]@Subscript[y, QU]=({
 {0, 0},
 {\[Epsilon], 0}
});\[Rho]@Subscript[a, CU]=\[Rho]@Subscript[a, QU]=({
 {\[Gamma], 0},
 {0, 0}
});
\[Rho]@Subscript[x, CU]=({
 {0, \[Gamma]},
 {0, 0}
}); \[Rho]@Subscript[x, QU]=\!\(\*
TagBox[
RowBox[{"(", "", GridBox[{
{"0", 
RowBox[{
RowBox[{"(", 
RowBox[{"1", "-", 
SuperscriptBox["E", 
RowBox[{
RowBox[{"-", "\[Gamma]"}], " ", "\[Epsilon]", " ", "\[HBar]"}]]}], ")"}], "/", 
RowBox[{"(", 
RowBox[{"\[Epsilon]", " ", "\[HBar]"}], ")"}]}]},
{"0", "0"}
},
GridBoxAlignment->{"Columns" -> {{Center}}, "ColumnsIndexed" -> {}, "Rows" -> {{Baseline}}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}},
GridBoxSpacings->{"Columns" -> {Offset[0.27999999999999997`], {Offset[0.7]}, Offset[0.27999999999999997`]}, "ColumnsIndexed" -> {}, "Rows" -> {Offset[0.2], {Offset[0.4]}, Offset[0.2]}, "RowsIndexed" -> {}, "Items" -> {}, "ItemsIndexed" -> {}}], "", ")"}],
Function[BoxForm`e$, MatrixForm[BoxForm`e$]]]\);
\[Rho][E^\[ScriptCapitalE]_]:=MatrixExp[\[Rho][\[ScriptCapitalE]]];
\[Rho][\[ScriptCapitalE]_]:=(\[ScriptCapitalE]/.TRule/.t->\[Gamma] \[Epsilon]/.(U:CU|QU)[u___]:>Fold[Dot,({
 {1, 0},
 {0, 1}
}),\[Rho]/@U/@{u}])


(* ::Input::Initialization:: *)
Subscript[\[CapitalOE], U_][s1__,Q1_,P1_]Subscript[\[CapitalOE], U_][s2__,Q2_,P2_] ^:= Subscript[\[CapitalOE], U][s1,s2,Q1+Q2,P1 P2];


(* ::Input::Initialization:: *)
CU@Subscript[\[CapitalOE], CU][specs___,Q_,P_] := Subscript[\[DoubleStruckCapitalO], CU][specs,SS[E^Q P]];
QU@Subscript[\[CapitalOE], QU][specs___,Q_,P_] := Subscript[\[DoubleStruckCapitalO], QU][specs,SS[E^Q P]];


(* ::Input::Initialization:: *)
Subscript[c_Integer, k_Integer] := c+O[\[Epsilon]]^(k+1);
Subscript[\[CapitalLambda], U_,k_][{\[Alpha]_,\[Beta]_},{x_,x_}]:=Subscript[\[CapitalOE], U][{x},(\[Alpha]+\[Beta])x,Subscript[1, k]];
Subscript[\[CapitalLambda], U_,k_][{\[Xi]_,\[Alpha]_},{x,a}]:=Subscript[\[CapitalOE], U][{a,x},\[Alpha] a+E^(-\[Gamma] \[Alpha]) \[Xi] x,Subscript[1, k]];
Subscript[\[CapitalLambda], U_,k_][{\[Alpha]_,\[Eta]_},{a,y}]:=Subscript[\[CapitalOE], U][{y,a},\[Alpha] a+E^(-\[Gamma] \[Alpha]) \[Eta] y,Subscript[1, k]];


(* ::Input::Initialization:: *)
Subscript[\[CapitalLambda], U_,kk_][{\[Xi]1_,\[Eta]1_},{x,y}]:=Subscript[\[CapitalLambda], U][{\[Xi]1,\[Eta]1},{x,y}]=Block[{$k=kk,$p=kk},Module[{\[Xi],\[Eta],G,F,fs,f,bs,e,b,es},
G=Simp[Table[\[Xi]^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][\[Eta]],{l,0,$k},{i,0, l},{j,0, l},{k,0, l}];
F=fs.(bs=fs/.Subscript[f, l_,i_,j_,k_][\[Eta]]:>\[Epsilon]^l U@{y^i,a^j,x^k});
es=Flatten[Table[Coefficient[e,b]==0,{e,{F-Subscript[1, U]/.\[Eta]->0,F**G-Subscript[y, U]**F-\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Eta]\)]F\)}},{b,bs}]];
F=F/.DSolve[es,fs,\[Eta]][[1]];
Subscript[\[CapitalOE], U][{y,a,x},
\[Xi] x+\[Eta] y+(U /. {CU->-t \[Eta] \[Xi], QU-> \[Eta] \[Xi] (1-T)/\[HBar]}),
F+Subscript[0, $k]/.{E^_->1,U->Times}
] /. {\[Xi]->\[Xi]1,\[Eta]->\[Eta]1}]];


(* ::Input::Initialization:: *)
(*SimpPQ[PQ_] := Expand@Collect[PQ, {Subscript[x, _],Subscript[y, _],Subscript[a, _]},CC]  /. \[ExponentialE]^\[ScriptCapitalE]_\[RuleDelayed]\[ExponentialE]^Expand@Together[\[ScriptCapitalE]]/. CC\[Rule]ExpandDenominator@*ExpandNumerator@*Together;*)
SimpPQ[PQ_] := Simplify[PQ//. E^\[ScriptCapitalE]_:>E^Simplify[\[ScriptCapitalE]]];
Simp[Subscript[\[CapitalOE], U_][specs___,Q_,P_]] := Subscript[\[CapitalOE], U][specs,CF[Q],CF[P]];


(* ::Input::Initialization:: *)
Subscript[\[CapitalLambda], U_,k_][{\[Upsilon]1_,\[Omega]1_,\[Delta]_},{u_,w_}] := Simp@Module[{\[Upsilon],\[Omega],yax,q,p,Q,d},
{yax,q,p}=List@@Subscript[\[CapitalLambda], U,k][{\[Upsilon],\[Omega]},{u,w}];
Subscript[\[CapitalOE], U][yax,Q=(\[Upsilon] u+\[Omega] w+\[Delta] u w+d \[Upsilon] \[Omega])/(1-d \[Delta]),Expand[(1-d \[Delta])^-1 E^-Q Subscript[DP, \[Upsilon]->Subscript[D, u],\[Omega]->Subscript[D, w]][p][E^Q]]+Subscript[0, k]] /. {d->\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Upsilon], \[Omega]\)]q\)}/.{\[Upsilon]->\[Upsilon]1,\[Omega]->\[Omega]1}];


(* ::Input::Initialization:: *)
Subscript[Rord, Subscript[u_, i_],Subscript[w_, j_]->k_][Subscript[\[CapitalOE], U_][L___,Subscript[{l___,Subscript[u_, i_],Subscript[w_, j_],r___}, s_],R___,Q_,P_]] := Simp@Module[{\[Upsilon],\[Omega],\[Delta],\[CapitalLambda]1,yax,q,p,kk=P[[5]],\[Delta]1=\!\(
\*SubscriptBox[\(\[PartialD]\), \(
\*SubscriptBox[\(u\), \(i\)], 
\*SubscriptBox[\(w\), \(j\)]\)]Q\)},
{yax,q,p}=Echo[List@@If[\[Delta]1===0,Subscript[\[CapitalLambda], U,kk][{\[Upsilon],\[Omega]},{u,w}],Subscript[\[CapitalLambda], U,kk][{\[Upsilon],\[Omega],\[Delta]},{u,w}]] /. {y->Subscript[y, k],a->Subscript[a, k],x->Subscript[x, k],t->Subscript[t, s],T->Subscript[T, s]}];
Subscript[\[CapitalOE], 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, \[Upsilon]],Subscript[w, j]->Subscript[D, \[Omega]]][P][p E^q]] /. {\[Upsilon]->\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(u\), \(i\)]]Q\)/.Subscript[w, j]->0,\[Omega]->\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(w\), \(j\)]]Q\)/.Subscript[u, i]->0, \[Delta]->\[Delta]1}];


(* ::Input::Initialization:: *)
Subscript[Rord, Subscript[u_, i_],Subscript[w_, j_]->k_][Subscript[\[CapitalOE], U_][L___,Subscript[{l___,Subscript[u_, i_],Subscript[w_, j_],r___}, s_],R___,Q_,P_]] := Simp@Module[{\[Upsilon],\[Omega],\[Delta],\[CapitalLambda]1,yax,q,p,n,kk=P[[5]],\[Delta]1=\!\(
\*SubscriptBox[\(\[PartialD]\), \(
\*SubscriptBox[\(u\), \(i\)], 
\*SubscriptBox[\(w\), \(j\)]\)]Q\)},
{yax,q,p}=List@@If[\[Delta]1===0,Subscript[\[CapitalLambda], U,kk][{\[Upsilon],\[Omega]},{u,w}],Subscript[\[CapitalLambda], U,kk][{\[Upsilon],\[Omega],\[Delta]},{u,w}]] /. {y->Subscript[y, n],a->Subscript[a, n],x->Subscript[x, n],t->Subscript[t, s],T->Subscript[T, s]};
(*Echo@{{{Subscript[u, i],\[Upsilon]},{Subscript[w, j],\[Omega]}},P,p \[ExponentialE]^q};*)
Subscript[\[CapitalOE], U][L,Subscript[{l,Sequence@@yax,r}, s],R,q+(Q/.Subscript[u, i]|Subscript[w, j]->0), E^-q \!\(\*SubscriptBox[\(SP\), \({
\*SubscriptBox[\(u\), \(i\)] \[Rule] \[Upsilon], 
\*SubscriptBox[\(w\), \(j\)] \[Rule] \[Omega]}\)]\)[P p E^q]] /. {n->k,\[Upsilon]->\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(u\), \(i\)]]Q\)/.Subscript[w, j]->0,\[Omega]->\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(w\), \(j\)]]Q\)/.Subscript[u, i]->0, \[Delta]->\[Delta]1}];


(* ::Input::Initialization:: *)
Cord[Subscript[\[CapitalOE], U_][L___,Subscript[{l___,Subscript[u_, i_],Subscript[w_, j_],r___}, s_],R___,Q_,P_]] /; OrderedQ[{w,u} /. {y->1,a->2,x->3}] := Cord[Subscript[Rord, Subscript[u, i],Subscript[w, j]->Unique[]][Subscript[\[CapitalOE], U][L,Subscript[{l,Subscript[u, i],Subscript[w, j],r}, s],R,Q,P]]];
Cord[Subscript[\[CapitalOE], U_][specs__,Q_,P_]] := Subscript[\[CapitalOE], U][Sequence@@Sort@{specs},Q,P] /. Flatten[{specs} /. Subscript[{yax__}, s_]:>({yax}/.Subscript[u_, i_]:>(Subscript[u, i]->Subscript[u, s]))]


(* ::Input::Initialization:: *)
Subscript[m, j_->k_][Subscript[\[CapitalOE], U_][specs__,Q_,P_]] := Cord[Subscript[\[CapitalOE], U][Sequence@@Append[DeleteCases[{specs},Subscript[{__}, j|k]],Subscript[Flatten[{Cases[{specs},Subscript[{us__}, j]:>{us}],Cases[{specs},Subscript[{us__}, k]:>{us}]}], k]],Q,P] /. {Subscript[t, j]->Subscript[t, k],Subscript[T, j]->Subscript[T, k]}]


(* ::Input::Initialization:: *)
Subscript[\[CapitalOE], U_][sp1__,Q1_,P1_]\[Congruent]Subscript[\[CapitalOE], U_][sp2__,Q2_,P2_] := Sort[{sp1}]==Sort[{sp2}]\[And]Simplify[Q1==Q2]\[And]Simplify[Normal[P1-P2]==0]


(* ::Input::Initialization:: *)
Subscript[E, q_,k_][x_]:=E^(\!\(
\*UnderoverscriptBox[\(\[Sum]\), \(j = 1\), \(k + 1\)]\ 
\*FractionBox[\(
\*SuperscriptBox[\((1 - q)\), \(j\)] 
\*SuperscriptBox[\(x\), \(j\)]\), \(j \((1 - 
\*SuperscriptBox[\(q\), \(j\)])\)\)]\)); Subscript[E, q_][x_]:=Subscript[E, q,$k][x]


(* ::Input::Initialization:: *)
QU[Subscript[R, i_,j_]]:=Subscript[\[DoubleStruckCapitalO], QU][Subscript[{Subscript[y, 1],Subscript[a, 1]}, i],Subscript[{Subscript[a, 2],Subscript[x, 2]}, j],SS[E^(\[HBar] Subscript[b, 1] Subscript[a, 2]) Subscript[E, Subscript[q, \[HBar]]][\[HBar] Subscript[y, 1] Subscript[x, 2]]/.Subscript[b, 1]->\[Gamma]^-1 (\[Epsilon] Subscript[a, 1]-Subscript[t, i])]];
QU[\!\(\*SubsuperscriptBox[\(R\), \(i_, j_\), \(-1\)]\)]:=Subscript[S, j]@QU[Subscript[R, i,j]];


(* ::Input::Initialization:: *)
Subscript[\[CapitalOE], QU,k_][Subscript[R, i_,j_]]:=Subscript[\[CapitalOE], QU][Subscript[{Subscript[y, i],Subscript[a, i],Subscript[x, i]}, i],Subscript[{Subscript[y, j],Subscript[a, j],Subscript[x, j]}, j], -\[HBar] \[Gamma]^-1 Subscript[t, i] Subscript[a, j]+\[HBar] Subscript[y, i] Subscript[x, j],Series[E^(\[HBar] \[Gamma]^-1 Subscript[t, i] Subscript[a, j]-\[HBar] Subscript[y, i] Subscript[x, j]) (E^(\[HBar] Subscript[b, i] Subscript[a, j]) Subscript[E, Subscript[q, \[HBar]],k][\[HBar] Subscript[y, i] Subscript[x, j]]/.Subscript[b, i]->\[Gamma]^-1 (\[Epsilon] Subscript[a, i]-Subscript[t, i])), {\[Epsilon],0,k}]]


(* ::Input::Initialization:: *)
Subscript[\[CapitalOE], U_,k_][a_*b_] := Subscript[\[CapitalOE], U,k][a]Subscript[\[CapitalOE], U,k][b];
Subscript[\[CapitalOE], U_,k_][Subscript[m, is__][a_]] := Subscript[m, is][Subscript[\[CapitalOE], U,k][a]];


(* ::Input::Initialization:: *)
Subscript[\[Lambda], alt,k_][CU]:=If[k==0,1,Module[{eq,d,b,c,so},
eq=\[Rho]@(E^(\[Xi] Subscript[x, CU])).\[Rho]@(E^(\[Eta] Subscript[y, CU]))==\[Rho]@(E^(d Subscript[y, CU])).\[Rho]@(E^(c(t Subscript[1, CU] - 2\[Epsilon] Subscript[a, CU]))).\[Rho]@(E^(b Subscript[x, CU]));
{so}=Solve[Thread[Flatten/@eq],{d,b,c}]/.C@1->0;
Series[E^\!\(TraditionalForm\`\(-\[Eta]\)\ y - \[Xi]\ x + \[Eta]\ \[Xi]\ t + c\ t\  + \ d\ y\  - \ 2  \[Epsilon]\ c\ a\  + \ b\ x\)/.so,{\[Epsilon],0,k}]]];



