(* ::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:: *)
$TD=3; \[HBar] /: \[HBar]^d_. /;d>$TD :=0;


(* ::Input::Initialization:: *)
q=E^(\[HBar] \[Alpha] \[Beta]); 


(* ::Input::Initialization:: *)
AlgebraAtom = a|A[_]|x|b|B[_]|y;
$PBWRule={y->1,B[_]->2,b->3,A[_]->4,a->5,x->6};


(* ::Input::Initialization:: *)
B[a,x] = \[Alpha] x; B[x,A[n_]]=(E^(n \[HBar] \[Alpha] \[Beta])-1)U[A[n],x]; B[a,A[_]]=0;
S[a]=-a; S[A[n_]]:=A[-n]; S[x] = - U[A[-1],x];
Si[a]=-a; Si[A[n_]]:=A[-n]; Si[x] = - U[x,A[-1]];
\[CapitalDelta][a]=Subscript[U, 1][a]Subscript[U, 2][]+Subscript[U, 1][]Subscript[U, 2][a]; \[CapitalDelta][A[n_]]:=Subscript[U, 1][A[n]]Subscript[U, 2][A[n]]; \[CapitalDelta][x]=Subscript[U, 1][x]Subscript[U, 2][]+Subscript[U, 1][A[1]]Subscript[U, 2][x];
B[y,b] = \[Beta] y; B[B[n_],y]=(E^(n \[HBar] \[Alpha] \[Beta])-1)U[y,B[n]]; B[b,B[_]]=0;
S[b]=-b; S[B[n_]]:=B[-n]; S[y] = - U[y,B[-1]];
Si[b]=-b; Si[B[n_]]:=B[-n]; Si[y] = - U[B[-1],y];
\[CapitalDelta][b]=Subscript[U, 1][b]Subscript[U, 2][]+Subscript[U, 1][]Subscript[U, 2][b]; \[CapitalDelta][B[n_]]:=Subscript[U, 1][B[n]]Subscript[U, 2][B[n]]; \[CapitalDelta][y]=Subscript[U, 1][y]Subscript[U, 2][B[1]]+Subscript[U, 1][]Subscript[U, 2][y];
(* This extra line is annoying *)


(* ::Input::Initialization:: *)
ExpandAB[\[ScriptCapitalE]_] := Expand@Normal@Series[\[ScriptCapitalE] //. {
c_. Subscript[U, i_][\[Lambda]___, A[n_],\[Rho]___] :> Expand[c Sum[((-1)^d \[HBar]^d \[Beta]^d n^d)/d! Subscript[U, i][\[Lambda],Sequence@@Table[a,{d}],\[Rho]],{d,0,$TD}]],
c_. Subscript[U, i_][\[Lambda]___, B[n_],\[Rho]___] :> Expand[c Sum[((-1)^d \[HBar]^d \[Alpha]^d n^d)/d! Subscript[U, i][\[Lambda],Sequence@@Table[b,{d}],\[Rho]],{d,0,$TD}]]
}, {\[HBar],0,$TD}]


(* ::Input::Initialization:: *)
B[0,_]=0; B[_,0]=0;
B[c_*x:AlgebraAtom,y_]:=Expand[c B[x,y]];
B[y_,c_*x:AlgebraAtom]:=Expand[c B[y,x]];
B[x_Plus,y_] := B[#,y]& /@ x;
B[x_,y_Plus] := B[x,#]& /@ y;
B[x_,x_] =0;
B[y_,x_] := Expand[-B[x,y]];


(* ::Input::Initialization:: *)
x_\[PrecedesEqual]y_:=OrderedQ[{x,y}/.$PBWRule]; x_\[Precedes]y_:=!OrderedQ[{y,x}/.$PBWRule];
Subscript[UU, i_][] := Subscript[U, i][]; Subscript[UU, i_][1] := Subscript[U, i][];
Subscript[UU, i_][x_[n_]^p_] := Subscript[U, i][x[n p]];
Subscript[UU, i_][x_^p_]:=Subscript[UU, i]@@Table[x,{p}];
Subscript[UU, i_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. {
U[xs__] :> Subscript[UU, i][xs],
x:AlgebraAtom:>Subscript[U, i][x]
};
Subscript[UU, i_][x_,xs__] := Subscript[UU, t1][x]Subscript[UU, t2][xs] // Expand // Subscript[m, t1,t2->i];
USimp[\[ScriptCapitalE]_]:= Collect[\[ScriptCapitalE], Times[Subscript[U, _][__]..], Expand];
USimp[\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE]];


(* ::Input::Initialization:: *)
Subscript[m, s__][0]=0;
Subscript[m, s__][x_Plus] := Subscript[m, s]/@x;
Subscript[m, i_->j_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. Subscript[U, i]->Subscript[U, j];


(* ::Input::Initialization:: *)
Subscript[m, i_,j_->k_][c_. Subscript[U, i_][x___]Subscript[U, j_][]]:=c Subscript[U, k][x];
Subscript[m, i_,j_->k_][c_. Subscript[U, i_][]Subscript[U, j_][y___]]:=c Subscript[U, k][y];
Subscript[m, i_,j_->k_][c_. Subscript[U, i_][xx___,x_[n1_]]Subscript[U, j_][x_[n2_],yy___]]:= USimp[c If[TrueQ[n1+n2==0], Subscript[U, i][xx]Subscript[U, j][yy], Subscript[U, i][xx,x[n1+n2]]Subscript[U, j][yy]] // Subscript[m, i,j->k]];
Subscript[m, i_,j_->k_][c_. Subscript[U, i_][xx___,x_]Subscript[U, j_][y_,yy___]]:=If[x\[PrecedesEqual]y,
c Subscript[U, k][xx,x,y,yy],
((Subscript[U, i][xx](Subscript[U, j][y,x]+Subscript[UU, j][B[x,y]]) // Expand // Subscript[m, i,j->i])Subscript[U, j][yy] // Expand // Subscript[m, i,j->k])c // USimp
];


(* ::Input::Initialization:: *)
Supp[\[ScriptCapitalE]_]:= Union@Cases[{\[ScriptCapitalE]}, Subscript[U, i_][___]:>i, \[Infinity]];


(* ::Input::Initialization:: *)
Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
x_**y_ := Module[
{Sx=Supp[x], Sy=Supp[y],is,\[Sigma],z},
If[MatchQ[Sx\[Union]Sy,{_Integer...}]&&Min[Sx\[Union]Sy]<0,
is=Abs[Sx]\[Intersection]Abs[Sy];
z=x; Do[z=Subscript[m, -i->-\[Sigma]@i][Subscript[m, i->\[Sigma]@i][z]], {i,is}];
z=USimp[y z]; Do[z=Subscript[dm, \[Sigma]@i,i->i][z], {i,is}];
z,
(* else *) is=Sx\[Intersection]Sy;
z=x; Do[z=Subscript[m, i->\[Sigma]@i][z], {i,is}];
z=USimp[y z]; Do[z=Subscript[m, \[Sigma]@i,i->i][z], {i,is}];
z
]
];
UB[x_,y_] := USimp[x**y-y**x];


(* ::Input::Initialization:: *)
\[DoubleStruckCapitalO][func_] := Normal@Series[func,{\[HBar],0,$TD}];
\[DoubleStruckCapitalO][specs_, func_] := Module[{rules,vars,elems},
rules=Union@@Cases[{specs}, Subscript[U, _][u___]:>Cases[{u},r_Rule], \[Infinity]];
vars=First/@rules; elems=Last/@rules;
USimp@Total[CoefficientRules[\[DoubleStruckCapitalO][func], vars] /. (ps_ -> c_) :> c(
specs /. MapThread[((#1->_) :> #3^#2)&,{vars,ps,elems}] /. Subscript[U, i_]:>Subscript[UU, i]
)]
]


(* ::Input::Initialization:: *)
Subscript[\[CapitalDelta], i_->j_,k_][\[ScriptCapitalE]_] := USimp@Module[{tj,tk}, \[ScriptCapitalE] /. {
Subscript[U, i][] -> Subscript[U, j][]Subscript[U, k][],
Subscript[U, i][f_,fs___] :> (USimp[(\[CapitalDelta][f]/. {Subscript[U, 1]->Subscript[U, j],Subscript[U, 2]->Subscript[U, k]})Subscript[\[CapitalDelta], i->tj,tk][Subscript[U, i][fs]]]  // Subscript[m, j,tj->j] // Subscript[m, k,tk->k])
}];
Subscript[\[CapitalDelta], i_->j_,k_,l__][\[ScriptCapitalE]_] := \[ScriptCapitalE] // Subscript[\[CapitalDelta], i->j,k]//Subscript[\[CapitalDelta], k->k,l]


(* ::Input::Initialization:: *)
Subscript[S, i_][\[ScriptCapitalE]_] := Module[{ti}, USimp[
\[ScriptCapitalE] /. Subscript[U, i][x_,xs___] :> Subscript[m, ti,i->i][Expand[Subscript[UU, i][S[x]]Subscript[S, ti][Subscript[U, ti][xs]]]]
]];
Subscript[Si, i_][\[ScriptCapitalE]_] := Module[{ti}, USimp[
\[ScriptCapitalE] /. Subscript[U, i][x_,xs___] :> Subscript[m, ti,i->i][Expand[Subscript[UU, i][Si[x]]Subscript[Si, ti][Subscript[U, ti][xs]]]]
]];


(* ::Input::Initialization:: *)
P[U[], U[A[_]]] = P[U[B[_]],U[]] = 1;
P[U[], U[__]] = P[U[__],U[]] = 0;
({
 {P[U[b],U[a]]=\[HBar]^-1, P[U[b],U[A[n_]]]=-n \[Beta], P[U[b],U[x]]=0},
 {P[U[B[n_]],U[a]]=-n \[Alpha], P[U[B[n_]],U[A[m_]]]=E^(n m \[HBar] \[Alpha] \[Beta] ), P[U[B[_]],U[x]]=0},
 {P[U[y],U[a]]=0, P[U[y],U[A[_]]]=0, P[U[y],U[x]]=\[HBar]^-1}
});


(* ::Input::Initialization:: *)
P[U[],U[]] = 1; 
Subscript[P, i_,j_][\[ScriptCapitalE]_] := USimp[\[ScriptCapitalE] /. Subscript[U, i][ys___]Subscript[U, j][xs___] -> P[U[ys],U[xs]]];


(* ::Input::Initialization:: *)
P[U[y_,ys__], U[x_]] := P[U[y,ys],U[x]] = Module[{i,j,k,l}, USimp[Subscript[U, i][y]Subscript[UU, j][ys]Subscript[\[CapitalDelta], k->k,l][Subscript[U, k][x]]] // Subscript[P, i,k] // Subscript[P, j,l]];
P[U[ys__],U[x_,xs__]] := P[U[ys],U[x,xs]] = Module[{i,j,k,l}, USimp[Subscript[\[CapitalDelta], i->i,j][Subscript[UU, i][ys]]Subscript[U, k][x]Subscript[UU, l][xs]] // Subscript[P, i,k] // Subscript[P, j,l]];


(* ::Input::Initialization:: *)
DUForm[\[ScriptCapitalE]_] := \[ScriptCapitalE] //. Subscript[U, i_][fs___]Subscript[U, j_][gs___] /; i+j==0\[And]j>0 :> Subscript["DU", j][fs,gs];
Subscript[DU, i_][a]:=Subscript[U, -i][]Subscript[U, i][a]; Subscript[DU, i_][A[n_]]:=Subscript[U, -i][]Subscript[U, i][A[n]]; Subscript[DU, i_][x]:=Subscript[U, -i][]Subscript[U, i][x];
Subscript[DU, i_][y]:=Subscript[U, -i][y]Subscript[U, i][];  Subscript[DU, i_][b]:=Subscript[U, -i][b]Subscript[U, i][];   Subscript[DU, i_][B[n_]]:=Subscript[U, -i][B[n]]Subscript[U, i][];
Subscript[DU, i_][] := Subscript[U, -i][]Subscript[U, i][];


(* ::Input::Initialization:: *)
Subscript[dm, i_,j_->k_][\[ScriptCapitalE]_] := Module[{t1,t2,t3,h1,h2,h3},
\[ScriptCapitalE] // Subscript[\[CapitalDelta], i->h1,h2,h3]//Subscript[Si, h3]//Subscript[\[CapitalDelta], -j->t1,t2,t3]//Subscript[P, t1,h3]//Subscript[P, t3,h1]//Subscript[m, h2,j->k]//Subscript[m, -i,t2->-k]];
Subscript[d\[CapitalDelta], i_->j_,k_][\[ScriptCapitalE]_] := \[ScriptCapitalE] // Subscript[\[CapitalDelta], i->j,k]//Subscript[\[CapitalDelta], -i-> -k,-j]; (*using opposite comult on the dual!*)
Subscript[dS, i_][\[ScriptCapitalE]_] := Module[{h}, (\[ScriptCapitalE] // Subscript[m, i->h] // Subscript[S, h] // Subscript[Si, -i])Subscript[U, -h][]Subscript[U, i][] // Expand // Subscript[dm, h,i->i]];


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


(* ::Input::Initialization:: *)
Subscript[R, i_,j_] :=\[DoubleStruckCapitalO][Subscript[U, -i][y->y,b->b]Subscript[U, i][]Subscript[U, -j][]Subscript[U, j][a->a,x->x], E^(\[HBar] b a) Subscript[E, q][\[HBar] x y]]


(* ::Input::Initialization:: *)
Subscript[u, i_]:=Subscript[R, 1,2]//Subscript[dS, 1]//Subscript[dm, 2,1->i]


(* ::Input::Initialization:: *)
Subscript[ui, i_]:=Subscript[R, 1,2]//Subscript[dS, 2]//Subscript[dS, 2]//Subscript[dm, 2,1->i]


(* ::Input::Initialization:: *)
Subscript[v, i_]:=(\[DoubleStruckCapitalO][Subscript[U, -i][b->b]Subscript[U, i][a->a],Exp[\[HBar]/2 (\[Alpha] b+\[Beta] a)]])**Subscript[u, i]


(* ::Input::Initialization:: *)
Subscript[cap, i_]:=\[DoubleStruckCapitalO][Subscript[U, -i][b->b]Subscript[U, i][a->a],Exp[\[HBar]/2 (\[Alpha] b+\[Beta] a)]]
Subscript[cup, i_]:=\[DoubleStruckCapitalO][Subscript[U, -i][b->b]Subscript[U, i][a->a],Exp[-(\[HBar]/2)(\[Alpha] b+\[Beta] a)]]


(* ::Input::Initialization:: *)
Subscript[\[Phi], 0][x_] := E^x;
Subscript[\[Phi], k_][x_] := Module[{t},Simplify[(E^t-Normal@Series[E^t,{t,0,k-1}])/t^k /. t->x]];



