(* ::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:: *)
$p=2; $k=1; $U=QU; $E:={$k,$p};
$trim:={\[HBar]^p_./;p>$p->0, \[Epsilon]^k_./;k>$k->0};
Subscript[q, \[HBar]]=E^(\[Gamma] \[Epsilon] \[HBar]);
T2t={\!\(
\*SubsuperscriptBox[\(T\), \(i_\), \(p_.\)] -> 
\*SuperscriptBox[\(E\), \(p\ \[HBar]\ 
\*SubscriptBox[\(t\), \(i\)]\)]\),T^p_.->E^(p \[HBar] t)};
t2T={E^(c_. Subscript[t, i_]+b_.):>\!\(
\*SubsuperscriptBox[\(T\), \(i\), \(c/\[HBar]\)] 
\*SuperscriptBox[\(E\), \(b\)]\),E^(c_. t+b_.):>T^(c/\[HBar]) E^b,E^\[ScriptCapitalE]_:>E^Expand@\[ScriptCapitalE]}; 
SetAttributes[SS,HoldAll];
SS[\[ScriptCapitalE]_,op_]:=Collect[
Normal@Series[If[$p>0,\[ScriptCapitalE],\[ScriptCapitalE]/.T2t],{\[HBar],0,$p}],
\[HBar],op];
SS[\[ScriptCapitalE]_]:=SS[\[ScriptCapitalE],Together];
Simp[\[ScriptCapitalE]_,op_]:=Collect[\[ScriptCapitalE],_CU|_QU,op];
Simp[\[ScriptCapitalE]_]:=Simp[\[ScriptCapitalE],SS[#,Expand]&];
K\[Delta]/:Subscript[K\[Delta], i_,j_]:=If[i===j,1,0];
Subscript[c_Integer, k_Integer] := c+O[\[Epsilon]]^(k+1);


(* ::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:: *)
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,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[]]=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];
Subscript[\[DoubleStruckCapitalO], U][specs___,\[DoubleStruckCapitalE][L_,Q_,P_]]:=Subscript[\[DoubleStruckCapitalO], U][specs,SS@Normal[P E^(L+Q)]];
Subscript[\[Sigma], 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[\[CapitalDelta], i_->j_,k_][c_.*u_U]:= CE[((c/.Subscript[\[CapitalDelta], i->j,k][U,Centrals])DeleteCases[u,Subscript[_, i]])**(NCM@@Cases[u,Subscript[x_, i]:>Subscript[\[Sigma], 1->j,2->k]@\[CapitalDelta]@U@x] /. NCM[]->U[])]; ]


(* ::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[\[Sigma], rs___][\[ScriptCapitalE]_Plus] := Subscript[\[Sigma], rs]/@\[ScriptCapitalE];
Subscript[m, j_->j_]=Identity; Subscript[m, j_->k_][0] = 0;
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]];
Subscript[\[CapitalDelta], is___][\[ScriptCapitalE]_Plus] := Simp[Subscript[\[CapitalDelta], is]/@\[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@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]};
\[CapitalDelta]@Subscript[y, CU]=CU@Subscript[y, 1]+CU@Subscript[y, 2]; \[CapitalDelta]@Subscript[a, CU]=CU@Subscript[a, 1]+CU@Subscript[a, 2]; \[CapitalDelta]@Subscript[x, CU]=CU@Subscript[x, 1]+CU@Subscript[x, 2];
Subscript[\[CapitalDelta], i_->j_,k_][CU,Centrals]={Subscript[t, i]->Subscript[t, j]+Subscript[t, k]};


(* ::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\)]\)};
\[CapitalDelta]@Subscript[y, QU]:=Subscript[\[DoubleStruckCapitalO], QU][Subscript[{Subscript[y, 1],Subscript[a, 1]}, 1],Subscript[{Subscript[y, 2]}, 2],SS[Subscript[y, 1]+Subscript[T, 1] E^(-\[HBar] \[Epsilon] Subscript[a, 1]) Subscript[y, 2]]]; \[CapitalDelta]@Subscript[a, QU]=QU@Subscript[a, 1]+QU@Subscript[a, 2]; \[CapitalDelta]@Subscript[x, QU]:=Subscript[\[DoubleStruckCapitalO], QU][Subscript[{Subscript[a, 1],Subscript[x, 1]}, 1],Subscript[{Subscript[x, 2]}, 2],SS[Subscript[x, 1]+E^(-\[HBar] \[Epsilon] Subscript[a, 1]) Subscript[x, 2]]];
Subscript[\[CapitalDelta], i_->j_,k_][QU,Centrals]={Subscript[t, i]->Subscript[t, j]+Subscript[t, k],Subscript[T, i]->Subscript[T, j] Subscript[T, k]};


(* ::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]/.T2t/.t->\[Gamma] \[Epsilon]/.(U:CU|QU)[u___]:>Fold[Dot,({
 {1, 0},
 {0, 1}
}),\[Rho]/@U/@{u}])


(* ::Input::Initialization:: *)
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[\[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]];
\[DoubleStruckCapitalE][0,
\[Xi] x+\[Eta] y+(U /. {CU->-t \[Eta] \[Xi], QU-> \[Eta] \[Xi] (1-T)/\[HBar]}),
F+Subscript[0, $k]/.{E^_->1,U->Times}
] /. (v:\[Eta]|\[Xi]|t|T|y|a|x)->Subscript[v, 1]
]];
Subscript[tSW, xy_,i_,j_->k_]:=Subscript[SW, xy][$U,$k] /. {Subscript[\[Xi], 1]->Subscript[\[Xi], i],Subscript[\[Eta], 1]->Subscript[\[Eta], j],Subscript[(v:t|T|y|a|x), 1]->Subscript[v, k]};
Subscript[tSW, xa,i_,j_->k_]:=\[DoubleStruckCapitalE][Subscript[\[Alpha], j] Subscript[a, k],E^(-\[Gamma] Subscript[\[Alpha], j]) Subscript[\[Xi], i] Subscript[x, k],1];
Subscript[tSW, ay,i_,j_->k_]:=\[DoubleStruckCapitalE][Subscript[\[Alpha], i] Subscript[a, k],E^(-\[Gamma] Subscript[\[Alpha], i]) Subscript[\[Eta], j] Subscript[y, k],1];


(* ::Input::Initialization:: *)
(* Bug: The first line is valid only if \[DoubleStruckCapitalO](\[ExponentialE]^Subscript[P, 0])\[Equal](\[ExponentialE]^(\[DoubleStruckCapitalO](Subscript[P, 0]))). *)
(* Bug: \[Xi] must be a symbol. *)
Subscript[Exp, Subscript[U_, i_],0][\[Xi]_,P_]:=Module[{LQ=Normal@P /. \[Epsilon]->0},
\[DoubleStruckCapitalE][\[Xi] LQ/.Subscript[(x|y), i]->0, \[Xi] LQ/.Subscript[(t|a), i]->0,1] ];
Subscript[Exp, Subscript[U_, i_],k_][\[Xi]_,P_]:=Block[{$U=U,$k=k},
Module[{P0,\[CurlyPhi],\[CurlyPhi]s,F,j,rhs,at0,at\[Xi]},
P0=Normal@P /. \[Epsilon]->0;
\[CurlyPhi]s=Flatten@Table[Subscript[\[CurlyPhi], j1,j2,j3][\[Xi]],{j2,0,k},{j1,0,2k+1-j2},{j3,0,2k+1-j2-j1}];
F=Normal@Last@Subscript[Exp, Subscript[U, i],k-1][\[Xi],P]+\[Epsilon]^k \[CurlyPhi]s.(\[CurlyPhi]s/.Subscript[\[CurlyPhi], js__][\[Xi]]:>Times@@\!\(\*SuperscriptBox[\({
\*SubscriptBox[\(y\), \(i\)], 
\*SubscriptBox[\(a\), \(i\)], 
\*SubscriptBox[\(x\), \(i\)]}\), \({js}\)]\));
rhs=Normal@Last@Subscript[m, i,j->i][\[DoubleStruckCapitalE][\[Xi] P0/.Subscript[(x|y), i]->0,\[Xi] P0/.Subscript[(t|a), i]->0, F+Subscript[0, k]]Subscript[m, i->j]@\[DoubleStruckCapitalE][0,0,P+Subscript[0, k]]];
at0=(#==0)& /@ Flatten@CoefficientList[F-1 /. \[Xi]->0, {Subscript[y, i],Subscript[a, i],Subscript[x, i]}];
at\[Xi]=(#==0)& /@ Flatten@CoefficientList[(\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Xi]\)]F\))+P0 F-rhs, {Subscript[y, i],Subscript[a, i],Subscript[x, i]}];
\[DoubleStruckCapitalE][\[Xi] P0/.Subscript[(x|y), i]->0,\[Xi] P0/.Subscript[(t|a), i]->0, F+Subscript[0, k]] /. DSolve[And@@(at0\[Union]at\[Xi]),\[CurlyPhi]s,\[Xi]][[1]] ]]


(* ::Input::Initialization:: *)
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][L1_,Q1_,P1_]\[Congruent]\[DoubleStruckCapitalE][L2_,Q2_,P2_]:=CF[L1==L2]\[And]CF[Q1==Q2]\[And]CF[Normal[P1-P2]==0];
\[DoubleStruckCapitalE]/:\[DoubleStruckCapitalE][L1_,Q1_,P1_]\[DoubleStruckCapitalE][L2_,Q2_,P2_]:=\[DoubleStruckCapitalE][L1+L2,Q1+Q2,P1*P2];


(* ::Input::Initialization:: *)
{SuperStar[t],SuperStar[y],SuperStar[a],SuperStar[x],SuperStar[z]}={\[Tau],\[Eta],\[Alpha],\[Xi],\[Zeta]}; {SuperStar[\[Tau]],SuperStar[\[Eta]],SuperStar[\[Alpha]],SuperStar[\[Xi]],SuperStar[\[Zeta]]}={t,y,a,x,z}; SuperStar[(Subscript[u_, i_])]:=Subscript[(SuperStar[u]), i];


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Zip\), \({}\)]\)[P_]:=P; \!\(\*SubscriptBox[\(Zip\), \({\[Zeta]_, \[Zeta]s___}\)]\)[P_] := (Expand[P//\!\(\*SubscriptBox[\(Zip\), \({\[Zeta]s}\)]\)] /. f_. \[Zeta]^d_.:>\!\(
\*SubscriptBox[\(\[PartialD]\), \({
\*SuperscriptBox[\(\[Zeta]\), \(*\)], d}\)]f\)) /. SuperStar[\[Zeta]]->0


(* ::Input::Initialization:: *)
Subscript[QZip, \[Zeta]s_List,simp_]@\[DoubleStruckCapitalE][L_,Q_,P_] := Module[{\[Zeta],z,zs,c,ys,\[Eta]s,qt,zrule,Q1,Q2},
zs=Table[SuperStar[\[Zeta]],{\[Zeta],\[Zeta]s}];
c=Q/.Alternatives@@(\[Zeta]s\[Union]zs)->0;
ys=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Zeta]\)]\((Q /. Alternatives @@ zs -> 0)\)\),{\[Zeta],\[Zeta]s}];
\[Eta]s=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(z\)]\((Q /. Alternatives @@ \[Zeta]s -> 0)\)\),{z,zs}];
qt=Inverse@Table[Subscript[K\[Delta], z,SuperStar[\[Zeta]]]-\!\(
\*SubscriptBox[\(\[PartialD]\), \(z, \[Zeta]\)]Q\),{\[Zeta],\[Zeta]s},{z,zs}];
zrule=Thread[zs->qt.(zs+ys)];
Q2=(Q1=c+\[Eta]s.zs/.zrule)/.Alternatives@@zs->0;
simp /@ \[DoubleStruckCapitalE][L,Q2,Det[qt]E^-Q2 Subscript[Zip, \[Zeta]s][E^Q1 (P/.zrule)]] ];
Subscript[QZip, \[Zeta]s_List]:=Subscript[QZip, \[Zeta]s,CF];


(* ::Input::Initialization:: *)
Subscript[LZip, \[Zeta]s_List,simp_]@\[DoubleStruckCapitalE][L_,Q_,P_] := Module[{\[Zeta],z,zs,c,ys,\[Eta]s,lt,zrule,L1,L2,Q1,Q2},
zs=Table[SuperStar[\[Zeta]],{\[Zeta],\[Zeta]s}];
c=L/.Alternatives@@(\[Zeta]s\[Union]zs)->0;
ys=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(\[Zeta]\)]\((L /. Alternatives @@ zs -> 0)\)\),{\[Zeta],\[Zeta]s}];
\[Eta]s=Table[\!\(
\*SubscriptBox[\(\[PartialD]\), \(z\)]\((L /. Alternatives @@ \[Zeta]s -> 0)\)\),{z,zs}];
lt=Inverse@Table[Subscript[K\[Delta], z,SuperStar[\[Zeta]]]-\!\(
\*SubscriptBox[\(\[PartialD]\), \(z, \[Zeta]\)]L\),{\[Zeta],\[Zeta]s},{z,zs}];
zrule=Thread[zs->lt.(zs+ys)];
L2=(L1=c+\[Eta]s.zs/.zrule)/.Alternatives@@zs->0;
Q2=(Q1=Q/.T2t/.zrule)/.Alternatives@@zs->0;
simp /@ \[DoubleStruckCapitalE][L2,Q2,Det[lt]E^(-L2-Q2) Subscript[Zip, \[Zeta]s][E^(L1+Q1) (P/.T2t/.zrule)]]//.t2T ];
Subscript[LZip, \[Zeta]s_List]:=Subscript[LZip, \[Zeta]s,CF];


(* ::Input::Initialization:: *)
\!\(\*SubscriptBox[\(Bind\), \({}\)]\)[L_,R_]:=L R;
\!\(\*SubscriptBox[\(Bind\), \({is__}\)]\)[L_\[DoubleStruckCapitalE],R_\[DoubleStruckCapitalE]] := Module[{n},
Times[
L/.Table[Subscript[(v:T|t|a|x|y), i]->Subscript[v, n@i],{i,{is}}],
R/.Table[Subscript[(v:\[Tau]|\[Alpha]|\[Xi]|\[Eta]), i]->Subscript[v, n@i],{i,{is}}]
] // Subscript[LZip, Flatten@Table[{Subscript[\[Tau], n@i],Subscript[a, n@i]},{i,{is}}]] // Subscript[QZip, Flatten@Table[{Subscript[\[Xi], n@i],Subscript[y, n@i]},{i,{is}}]] ];
Subscript[B, l_List]:=Subscript[Bind, l]; Subscript[B, is___]:=\!\(\*SubscriptBox[\(Bind\), \({is}\)]\);
Bind[\[ScriptCapitalE]_\[DoubleStruckCapitalE]] := \[ScriptCapitalE];
Bind[Ls__,\[Zeta]s_List,R_] := Subscript[Bind, \[Zeta]s][Bind[Ls],R];


(* ::Input::Initialization:: *)
t\[Eta]=t\[DoubleStruckOne]=\[DoubleStruckCapitalE][0,0,1+Subscript[0, $k]];


(* ::Input::Initialization:: *)
Subscript[tm, i_,j_->k_]:=Module[{tk},
\[DoubleStruckCapitalE][(Subscript[\[Tau], i]+Subscript[\[Tau], j])Subscript[t, k]+Subscript[\[Alpha], i] Subscript[a, k]+Subscript[\[Alpha], j] Subscript[a, k],Subscript[\[Eta], i] Subscript[y, k]+Subscript[\[Xi], j] Subscript[x, k],1](Subscript[tSW, xy,i,j->tk] /. {Subscript[t, tk]->Subscript[t, k],Subscript[T, tk]->Subscript[T, k],Subscript[y, tk]->E^(-\[Gamma] Subscript[\[Alpha], i]) Subscript[y, k],Subscript[a, tk]->Subscript[a, k],Subscript[x, tk]->E^(-\[Gamma] Subscript[\[Alpha], j]) Subscript[x, k]})];
Subscript[m, j_->k_][\[ScriptCapitalE]_\[DoubleStruckCapitalE]]:=\[ScriptCapitalE]~Subscript[B, j,k]~Subscript[tm, j,k->k];


(* ::Input::Initialization:: *)
S[U_,kk_]:=S[U,kk]=Module[{OE},
OE=Subscript[m, 3,2,1->1][Subscript[Exp, Subscript[QU, 1],$k][\[Eta],Subscript[S, 1][QU[Subscript[y, 1]]]/.QU->Times]Subscript[Exp, Subscript[QU, 2],$k][\[Alpha],Subscript[S, 2][QU[Subscript[a, 2]]]/.QU->Times]Subscript[Exp, Subscript[QU, 3],$k][\[Xi],Subscript[S, 3][QU[Subscript[x, 3]]]/.QU->Times]];
\[DoubleStruckCapitalE][-Subscript[t, 1] Subscript[\[Tau], 1]+OE[[1]], OE[[2]],OE[[3]]] /.{\[Eta]->Subscript[\[Eta], 1],\[Alpha]->Subscript[\[Alpha], 1],\[Xi]->Subscript[\[Xi], 1]}];
Subscript[tS, i_]:=S[$U,$k]/.{Subscript[(v:\[Tau]|\[Eta]|\[Alpha]|\[Xi]), 1]->Subscript[v, i],Subscript[(v:t|T|y|a|x), 1]->Subscript[v, i]};


(* ::Input::Initialization:: *)
\[CapitalDelta][U_,kk_]:=\[CapitalDelta][U,kk]=Module[{OE},
OE=Block[{$k=kk,$p=kk+1},Subscript[m, 1,3,5->1]@Subscript[m, 2,4,6->2]@Times[ (* Warning: wrong unless $p\[GreaterEqual]$k+1! *)
ReplacePart[1->0]@Subscript[Exp, Subscript[QU, 1],$k][\[Eta],Subscript[\[CapitalDelta], 1->1,2][QU[Subscript[y, 1]]]/.QU->Times],
ReplacePart[2->0]@Subscript[Exp, Subscript[QU, 3],$k][\[Alpha],Subscript[\[CapitalDelta], 3->3,4][QU[Subscript[a, 3]]]/.QU->Times],
ReplacePart[1->0]@Subscript[Exp, Subscript[QU, 5],$k][\[Xi],Subscript[\[CapitalDelta], 5->5,6][QU[Subscript[x, 5]]]/.QU->Times]
] /. {\[Eta]->Subscript[\[Eta], 1], \[Alpha]->Subscript[\[Alpha], 1], \[Xi]->Subscript[\[Xi], 1]}];
\[DoubleStruckCapitalE][Subscript[\[Tau], 1](Subscript[t, 1]+Subscript[t, 2])+Subscript[\[Alpha], 1](Subscript[a, 1]+Subscript[a, 2]), OE[[2]],OE[[3]]]];
Subscript[t\[CapitalDelta], i_->j_,k_]:=\[CapitalDelta][$U,$k] /. {Subscript[(v:\[Tau]|\[Eta]|\[Alpha]|\[Xi]), 1]->Subscript[v, i],Subscript[(v:t|T|y|a|x), 1]->Subscript[v, j],Subscript[(v:t|T|y|a|x), 2]->Subscript[v, k]};


(* ::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:: *)
R[QU,kk_]:=R[QU,kk]=\[DoubleStruckCapitalE][-((\[HBar] Subscript[a, 2] Subscript[t, 1])/\[Gamma]), \[HBar] Subscript[x, 2] Subscript[y, 1],Series[E^(\[HBar] \[Gamma]^-1 Subscript[t, 1] Subscript[a, 2]-\[HBar] Subscript[y, 1] Subscript[x, 2]) (E^(\[HBar] Subscript[b, 1] Subscript[a, 2]) Subscript[E, Subscript[q, \[HBar]],kk][\[HBar] Subscript[y, 1] Subscript[x, 2]]/.Subscript[b, 1]->\[Gamma]^-1 (\[Epsilon] Subscript[a, 1]-Subscript[t, 1])), {\[Epsilon],0,kk}]] ;
Subscript[tR, i_,j_]:=R[$U,$k] /. {Subscript[(v:t|T|y|a|x), 1]->Subscript[v, i],Subscript[(v:t|T|y|a|x), 2]->Subscript[v, j]};
Subscript[\!\(\*OverscriptBox[\(tR\), \(_\)]\), i_,j_]:=Subscript[\!\(\*OverscriptBox[\(tR\), \(_\)]\), i,j]=Subscript[tR, i,j]~Subscript[B, j]~Subscript[tS, j];


(* ::Input::Initialization:: *)
Subscript[tC, i_]:=\[DoubleStruckCapitalE][0,0,\!\(
\*SubsuperscriptBox[\(T\), \(i\), \(1/2\)] 
\*SuperscriptBox[\(E\), \(\(-\[Epsilon]\)\(\ \)
\*SubscriptBox[\(a\), \(i\)] \(\[HBar]\)\(\ \)\)]\)+Subscript[0, $k]];
Subscript[\!\(\*OverscriptBox[\(tC\), \(_\)]\), i_ ]:=\[DoubleStruckCapitalE][0,0,\!\(
\*SubsuperscriptBox[\(T\), \(i\), \(\(-1\)/2\)] 
\*SuperscriptBox[\(E\), \(\(\[Epsilon]\)\(\ \)
\*SubscriptBox[\(a\), \(i\)] \(\[HBar]\)\(\ \)\)]\)+Subscript[0, $k]];


(* ::Input::Initialization:: *)
Kink[QU,kk_]:= Kink[QU,kk]=Block[{$k=kk},(Subscript[tR, 1,3] Subscript[\!\(\*OverscriptBox[\(tC\), \(_\)]\), 2])~Subscript[B, 1,2]~Subscript[tm, 1,2->1]~Subscript[B, 1,3]~Subscript[tm, 1,3->1]];
Subscript[tKink, i_]:=Kink[$U,$k]/.{Subscript[(v:t|T|y|a|x), 1]->Subscript[v, i]};
\!\(\*OverscriptBox[\(Kink\), \(_\)]\)[QU,kk_]:= \!\(\*OverscriptBox[\(Kink\), \(_\)]\)[QU,kk]=Block[{$k=kk},(Subscript[\!\(\*OverscriptBox[\(tR\), \(_\)]\), 1,3] Subscript[tC, 2])~Subscript[B, 1,2]~Subscript[tm, 1,2->1]~Subscript[B, 1,3]~Subscript[tm, 1,3->1]];
Subscript[\!\(\*OverscriptBox[\(tKink\), \(_\)]\), i_]:=\!\(\*OverscriptBox[\(Kink\), \(_\)]\)[$U,$k]/.{Subscript[(v:t|T|y|a|x), 1]->Subscript[v, i]}


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


(* ::Input::Initialization:: *)
\[Alpha]2\[ScriptCapitalA]={E^(c_. Subscript[\[Alpha], i_]+b_.):>\!\(
\*SubsuperscriptBox[\(\[ScriptCapitalA]\), \(i\), \(c/\[Gamma]\)] 
\*SuperscriptBox[\(E\), \(b\)]\),E^(c_. \[Alpha]+b_.):>\[ScriptCapitalA]^(c/\[Gamma]) E^b,E^\[ScriptCapitalE]_:>E^Expand@\[ScriptCapitalE]}; 



