(* ::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:: *)
\[Epsilon] /: \[Epsilon]^k_/;k>1:=0;
PBWRule={e->1,l->2,f->3};
B[U@e,U@l]=-U@e; B[U@f,U@l]=U@f; B[U@e,U@f]=h U[]-2\[Epsilon] U@l;


(* ::Input::Initialization:: *)
$TD=3; \[HBar] /: \[HBar]^d_. /;d>$TD :=0;


(* ::Input::Initialization:: *)
x_\[PrecedesEqual]y_:=OrderedQ[{x,y}/.PBWRule]; x_\[Precedes]y_:=!OrderedQ[{y,x}/.PBWRule];
Simp[\[ScriptCapitalE]_]:= Collect[\[ScriptCapitalE], _U, Expand];


(* ::Input::Initialization:: *)
Subscript[U, i_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. {h->Subscript[h, i],t->Subscript[t, i], u_U :> Replace[u, x_ :> Subscript[x, i],1]};
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[x_,x_]=0;
B[U[y_],U[x_]]:=B[U[y],U[x]]=Simp[-B[U[x],U[y]]];
B[x_,y_] := x**y-y**x;


(* ::Input::Initialization:: *)
Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
0**_=_**0=0;
x_**U[]:=x; U[]**x_:=x;
(a_*x_U)**(b_*y_U) := If[a b === 0, 0, Simp[a b (x**y)]];
(a_*x_U)**y_ := Simp[a(x**y)]; x_**(a_*y_U) := Simp[a(x**y)];
(x_Plus)**y_ := (#**y)& /@ x; x_**(y_Plus) := (x**#)& /@ y;


(* ::Input::Initialization:: *)
U[xx___,x_] ** U[y_,yy___] := If[x\[PrecedesEqual]y,U[xx,x,y,yy], U@xx**(U@y**U@x+B[U@x,U@y])**U@yy];


(* ::Input::Initialization:: *)
UU[l___,x_^n_,r___]:= UU[l,Sequence@@Table[x,{n}],r];
UU[l___,1,r___]:= UU[l,r];
UU[]=U[];
UU[l_,r___]:=U[l]**UU[r];


(* ::Input::Initialization:: *)
UProducts[{},0]={UU[]};
UProducts[{},n_Integer] /; n>0 = {};
UProducts[{x_,xs___}, n_Integer] := Sort@Flatten@Table[UU[x^k]**u, {k,0,n},{u,UProducts[{xs},n-k]}];
UProducts[xs_List, k_Integer, n_Integer] := UProducts[Flatten@Table[Subscript[x, j], {x,xs}, {j,k}], n];
UProducts[any__, {n_}] := Flatten@Table[UProducts[any,k], {k,0,n}];


(* ::Input::Initialization:: *)
Subscript[r, i_,j_]:=Simp[\[HBar] (Subscript[h, i]UU[Subscript[l, j]]-\[Epsilon] UU[Subscript[l, i],Subscript[l, j]]+ UU[Subscript[e, i],Subscript[f, j]])]


(* ::Input::Initialization:: *)
UExp[u_]:=Module[{s,t,k},
s=t=U[]; k=0;
While[k<20\[And]0=!=(t=t**u), s+=t/(++k)!];
Simp[s]
];
Subscript[R, i_,j_]:=UExp[Subscript[r, i,j]];


(* ::Input::Initialization:: *)
\[DoubleStruckCapitalO][poly_, specs___] := Module[{vs,us,z},
vs=Join@@(First /@ {specs});
us=Join@@({specs} /. (l_->s_) :> (l/.Subscript[x_, i_]:>Subscript[x, s]));
Simp@Total[CoefficientRules[Normal@Series[poly, {\[HBar],0,$TD}], vs] /. (p_->c_) :> c UU@@(us^p)]
]



