(* ::Package:: *)

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

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


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


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


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


(* ::Input::Initialization:: *)
DeclareAlgebra[U_Symbol, opts__Rule] := Module[{gp,sr,g,cp,M,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 \[Rule] *) 
cp=Alternatives@@cs; (* cents *)
SetAttributes[M,HoldRest]; M[0,_]=0; M[a_,x_]:=a x;
CE[\[ScriptCapitalE]_]:= Collect[\[ScriptCapitalE], _U, (Expand[#] /. \[HBar]^d_/;d>$p:>0)&];
Subscript[U, i_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. {t:cp:>Subscript[t, i],u_U :> Replace[u, x_ :> Subscript[x, i],1]};
Subscript[U, i_][NCM[]]=pow[\[ScriptCapitalE]_,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_**(c_. Subscript[1, U]):=CE[c x]; (c_. Subscript[1, U])**x_:=CE[c x];
(*(a_.*x_U)**(b_.*y_U) := CE[M[a b,x**y]];*)
(a_. U[xx___,x_])**(b_. U[y_,yy___]) :=If[OrderedQ[{x,y}/.sr],
CE@M[a b,U[xx,x,y,yy]],
U@xx**CE@M[a b,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[\[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]]];
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[DD, j,k]@U@x]];Subscript[P, i_,j_][c_.*u_U]:=CE[(P[U@Cases[c U[],Subscript[_, i]]**(U@@Cases[u,Subscript[_, i]]),(U@Cases[c U[],Subscript[_, j]])**(U@@Cases[u,Subscript[_, j]])]DeleteCases[c U[],Subscript[_, i|j]]**U@@DeleteCases[u,Subscript[_, i|j]])]/.U[]->1];


(* ::Input::Initialization:: *)
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[\[ScriptCapitalE]_] := Simp[\[ScriptCapitalE] /. oncs /.  u_U:>m[u]]; )


(* ::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]];
Subscript[\[CapitalDelta], i_->j_,k_][\[ScriptCapitalE]_Plus]:=Simp[Subscript[\[CapitalDelta], i->j,k]/@\[ScriptCapitalE]];
Subscript[P, i_,j_][\[ScriptCapitalE]_Plus]:=Simp[Subscript[P, i,j]/@\[ScriptCapitalE]];
Subscript[\[CapitalDelta], i_->j_,k_][c_ *QU[]]:=Collect[(c/.Subscript[\[CapitalDelta], i->j,k][QU,Centrals])QU[], _U, (Expand[#] /. \[HBar]^d_/;d>$p:>0)&];
Subscript[\[CapitalDelta], i_->j_,k_][c_ *CU[]]:=Collect[(c/.Subscript[\[CapitalDelta], i->j,k][CU,Centrals])CU[], _U, (Expand[#] /. \[HBar]^d_/;d>$p:>0)&];


(* ::Input::Initialization:: *)
DeclareAlgebra[CU, Generators -> {X,Y,Z,b,a,z,y,x}, Centrals -> {ss,tt}];
B[Subscript[x, CU],Subscript[a, CU]]=2 CU@x;
B[Subscript[x, CU],Subscript[b, CU]]=-CU@x;
B[Subscript[y, CU],Subscript[b, CU]]=2 CU@y;
B[Subscript[y, CU],Subscript[a, CU]]=-CU@y;
B[Subscript[z, CU],Subscript[a, CU]]=CU@z;
B[Subscript[z, CU],Subscript[b, CU]]=CU@z;
B[Subscript[x, CU],Subscript[y, CU]]=Subscript[z, CU];
B[Subscript[x, CU],Subscript[z, CU]]=0;
B[Subscript[a, CU],Subscript[b, CU]]=0;
B[Subscript[y, CU],Subscript[z, CU]]=0;
B[Subscript[a, CU],Subscript[X, CU]]=2Subscript[X, CU];
B[Subscript[b, CU],Subscript[X, CU]]=-Subscript[X, CU];
B[Subscript[a, CU],Subscript[Y, CU]]=-Subscript[Y, CU];
B[Subscript[b, CU],Subscript[Y, CU]]=2Subscript[Y, CU];
B[Subscript[a, CU],Subscript[Z, CU]]=Subscript[Z, CU];B[Subscript[b, CU],Subscript[Z, CU]]=Subscript[Z, CU];
B[Subscript[x, CU],Subscript[X, CU]]=ss Subscript[1, CU]+2\[Epsilon] CU[a];
B[Subscript[y, CU],Subscript[Y, CU]]=tt Subscript[1, CU]+2 \[Epsilon] CU[b];
B[Subscript[z, CU],Subscript[Z, CU]]=(ss +tt )Subscript[1, CU]+2\[Epsilon] (Subscript[a, CU]+Subscript[b, CU]);
B[Subscript[y, CU],Subscript[Z, CU]]=Subscript[X, CU];B[Subscript[x, CU],Subscript[Z, CU]]=-CU[Y];
B[Subscript[z, CU],Subscript[X, CU]]=2\[Epsilon] Subscript[y, CU];
B[Subscript[z, CU],Subscript[Y, CU]]=-2 \[Epsilon] CU[x];B[Subscript[y, CU],Subscript[X, CU]]=0;
B[Subscript[x, CU],Subscript[Y, CU]]=0;
B[Subscript[X, CU],Subscript[Y, CU]]=2\[Epsilon] Subscript[Z, CU];B[Subscript[X, CU],Subscript[Z, CU]]=0;B[Subscript[Z, CU],Subscript[Y, CU]]=0;


(* ::Input::Initialization:: *)
DeclareAlgebra[QU, Generators -> {X,Y,Z,b,a,z,y,x}, Centrals -> {s,t}];
B[Subscript[a, QU],Subscript[x, QU]]=-2 QU@x;B[Subscript[b, QU],Subscript[x, QU]]=QU@x;
B[Subscript[b, QU],Subscript[y, QU]]=-2 QU@y;B[Subscript[a, QU],Subscript[y, QU]]=QU@y;
B[Subscript[a, QU],Subscript[z, QU]]=-QU@z;B[Subscript[b, QU],Subscript[z, QU]]=-QU@z;
B[Subscript[y, QU],Subscript[x, QU]]=-Subscript[z, QU]+\[Epsilon] \[HBar] QU[y,x];B[Subscript[z, QU],Subscript[x, QU]]=-\[Epsilon] \[HBar] QU[z,x];B[Subscript[b, QU],Subscript[a, QU]]=0;B[Subscript[z, QU],Subscript[y, QU]]=\[Epsilon] \[HBar] QU[z,y];
B[Subscript[a, QU],Subscript[X, QU]]=2Subscript[X, QU];B[Subscript[b, QU],Subscript[X, QU]]=-Subscript[X, QU];
B[Subscript[a, QU],Subscript[Y, QU]]=-Subscript[Y, QU];B[Subscript[b, QU],Subscript[Y, QU]]=2Subscript[Y, QU];
B[Subscript[a, QU],Subscript[Z, QU]]=Subscript[Z, QU];B[Subscript[b, QU],Subscript[Z, QU]]=Subscript[Z, QU];
B[Subscript[x, QU],Subscript[X, QU]]=-2\[Epsilon] \[HBar] QU@{X,x}+((1-s) QU[])/\[HBar]+2 s \[Epsilon] QU[a];
B[Subscript[y, QU],Subscript[Y, QU]]=-2\[Epsilon] \[HBar] QU@{Y,y}+((1-t) QU[])/\[HBar]+2 t \[Epsilon] QU[b];
B[Subscript[z, QU],Subscript[Z, QU]]=-2\[Epsilon] \[HBar] QU@{Z,z}+((1-s t) QU[])/\[HBar]+2 s t \[Epsilon] QU[a]+2 s t \[Epsilon] QU[b];
B[Subscript[y, QU],Subscript[Z, QU]]=Subscript[X, QU]-\[Epsilon] \[HBar] QU@{Z,y};B[Subscript[x, QU],Subscript[Z, QU]]= -\[Epsilon] \[HBar] QU@{Z,x}-(s+s \[Epsilon] \[HBar]) QU[Y]+2s \[Epsilon] \[HBar] QU[Y,a];
B[Subscript[z, QU],Subscript[X, QU]]=2\[Epsilon] Subscript[y, QU]-\[Epsilon] \[HBar] QU@{X,z};
B[Subscript[z, QU],Subscript[Y, QU]]=-2t \[Epsilon] QU[x]-\[Epsilon] \[HBar] QU[Y,z];B[Subscript[y, QU],Subscript[X, QU]]=\[Epsilon] \[HBar] QU[X,y];
B[Subscript[x, QU],Subscript[Y, QU]]=\[Epsilon] \[HBar] QU[Y,x];
B[Subscript[X, QU],Subscript[Y, QU]]=2\[Epsilon] Subscript[Z, QU]-\[Epsilon] \[HBar] QU[X,Y];B[Subscript[X, QU],Subscript[Z, QU]]=\[Epsilon] \[HBar] QU[X,Z];B[Subscript[Z, QU],Subscript[Y, QU]]=\[Epsilon] \[HBar] QU[Y,Z];



