(* ::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.                                                         *)
(************************************************************************)



\[Epsilon] /: \[Epsilon]^n_/;n>1 :=0;
PBWBasis={c,u,w};
B[U@c,U@w]=-(B[U@w,U@c]=U@w);
B[U@u,U@c]=-(B[U@c,U@u]=U@u);
B[U@w,U@u]=-(B[U@u,U@w]=(t-1)U[]-\[Epsilon]  U[u,w]+2\[Epsilon] t  U[c]);


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];
Subscript[U, i_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. {t->Subscript[t, i], u_U :> UU@@Replace[u, x_ :> Subscript[x, i],1]};


B[x_,x_]=0;
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_,y_] := x**y-y**x;


x_\[PrecedesEqual]y_:=OrderedQ[{x,y}]; x_\[Precedes]y_:=!OrderedQ[{y,x}];
Simp[\[ScriptCapitalE]_]:= Collect[\[ScriptCapitalE], _U, Expand];


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;
U[x_]**U[y_] := (*U[x]**U[y] =*) If[x\[Precedes]y, U[x,y], U[y,x]+B[U@x,U@y]];
U[x_] ** U[y1_,yy__] := (*U[x] ** U[y1,yy] =*)If[x\[PrecedesEqual]y1,U[x,y1,yy],(U@x**U@y1)**U@yy];
U[xx__,xn_]**U[yy__] := (*U[xx,xn]**U[yy] =*) U@xx**(U@xn**U@yy);


\[Sigma][i_,j_][\[ScriptCapitalE]_] := \[ScriptCapitalE] /. {Subscript[b, i]->Subscript[b, j],Subscript[t, i]->Subscript[t, j],Subscript[c, i]->Subscript[c, j],Subscript[u, i]->Subscript[u, j],Subscript[w, i]->Subscript[w, j]};


m[i_,j_][\[ScriptCapitalE]_] := Simp[\[ScriptCapitalE] /. x_U :> DeleteCases[x,Subscript[_, j]]**U@@Cases[x,Subscript[y_, j]:>Subscript[y, i]] /. {Subscript[b, j]->Subscript[b, i], Subscript[t, j]->Subscript[t, i]}];
m[i_,j_,k_][\[ScriptCapitalE]_] := \[ScriptCapitalE] // m[i,j] // \[Sigma][i,k];


\[CapitalDelta][i_,j_,k_][\[ScriptCapitalE]_] := Simp[\[ScriptCapitalE]/. {
a_. U[]:>(a /. {Subscript[b, i]->Subscript[b, j]+Subscript[b, k],Subscript[t, i]->Subscript[t, j] Subscript[t, k]})U[],
a_. x_U :> (a /. {Subscript[b, i]->Subscript[b, j]+Subscript[b, k],Subscript[t, i]->Subscript[t, j] Subscript[t, k]})NonCommutativeMultiply@@(x /. {
Subscript[c, i]->U@Subscript[c, j]+U@Subscript[c, k], Subscript[u, i]->Subscript[t, k]U@Subscript[u, j]+\[Epsilon] Subscript[t, k]UU[Subscript[c, k],Subscript[u, j]]+U@Subscript[u, k], Subscript[w, i]->U@Subscript[w, j]+\[Epsilon] UU[Subscript[c, k],Subscript[w, j]]+U@Subscript[w, k], Subscript[y_, l_]:>U@Subscript[y, l]
})
}]


S[i_][\[ScriptCapitalE]_] := Simp[\[ScriptCapitalE] /. {a_. x_U:>(a /. {Subscript[b, i]->-Subscript[b, i],Subscript[t, i]->Subscript[t, i]^-1})S[i][x]}];
S[i_][U[]]=U[];
S[i_][U[Subscript[y_, j_],more___]] /; i!=j := U[Subscript[y, j]]**S[i][U[more]];
S[i_][U[Subscript[c, i_],more___]] := S[i][U[more]]**(-U@Subscript[c, i]);
S[i_][U[Subscript[u, i_],more___]] := S[i][U[more]]**(-Subscript[t, i]^-1U@Subscript[u, i]+Expand[\[Epsilon] Subscript[t, i]^-1 UU[Subscript[u, i],Subscript[c, i]]]);
S[i_][U[Subscript[w, i_],more___]] := S[i][U[more]]**(-U@Subscript[w, i]+Expand[\[Epsilon] UU[Subscript[w, i],Subscript[c, i]]]);


LBasis[n_Integer] := LBasis[Range[n]];
LBasis[S_] := DeleteCases[0]@Module[{i,j,k,l}, SortBy[(# /. {\[Epsilon]->2,Subscript[c, _]->2,Subscript[u, _]->2,Subscript[w, _]->2, U->Times})&][
Union@Flatten[{{U[],\[Epsilon] U[]},
Table[{U@Subscript[c, i],U@Subscript[u, i],U@Subscript[w, i],\[Epsilon] U@Subscript[c, i],\[Epsilon] U@Subscript[u, i],\[Epsilon] U@Subscript[w, i]}, {i,S}],
Table[{U[Subscript[u, i],Subscript[w, j]],\[Epsilon] U[Subscript[u, i],Subscript[w, j]],\[Epsilon] U@@Sort@{Subscript[c, i],Subscript[c, j]},\[Epsilon] U[Subscript[c, i],Subscript[u, j]],\[Epsilon] U[Subscript[c, i],Subscript[w, j]]}, {i,S}, {j,S}],
Table[{\[Epsilon] U[Subscript[c, i],Subscript[u, j],Subscript[w, k]],\[Epsilon] U@@Sort@{Subscript[u, i],Subscript[u, j],Subscript[w, k]},\[Epsilon] U@@Sort@{Subscript[u, i],Subscript[w, j],Subscript[w, k]}}, {i,S}, {j,S},{k,S}],
Table[\[Epsilon] U@@Sort@{Subscript[u, i],Subscript[u, j],Subscript[w, k],Subscript[w, l]}, {i,S}, {j,S},{k,S},{l,S}] }]
]]


BLBasis[n_Integer] := BLBasis[Range[n]];
BLBasis[S_] := DeleteCases[0]@Module[{i,j,k,l}, SortBy[(# /. {\[Epsilon]->2,Subscript[c, _]->2,Subscript[u, _]->2,Subscript[w, _]->2, U->Times})&][
Union@Flatten[{{U[],\[Epsilon] U[]},
Table[{U@Subscript[c, i],\[Epsilon] U@Subscript[c, i]}, {i,S}],
Table[{U[Subscript[u, i],Subscript[w, j]],\[Epsilon] U[Subscript[u, i],Subscript[w, j]],\[Epsilon] U@@Sort@{Subscript[c, i],Subscript[c, j]}}, {i,S}, {j,S}],
Table[{\[Epsilon] U[Subscript[c, i],Subscript[u, j],Subscript[w, k]]}, {i,S}, {j,S},{k,S}],
Table[\[Epsilon] U@@Sort@{Subscript[u, i],Subscript[u, j],Subscript[w, k],Subscript[w, l]}, {i,S}, {j,S},{k,S},{l,S}] }]
]]


UExp[\[ScriptCapitalE]_,n_]:=Module[{t=U[],k}, U[]+Sum[(t=t**\[ScriptCapitalE])/k!, {k,n}]]//Simp


ToDegree[n_][\[ScriptCapitalE]_] := Simp[\[ScriptCapitalE]/.\[HBar]->1] /. {\[Epsilon]->\[HBar] \[Epsilon], Subscript[b, i_]:>\[HBar] Subscript[b, i], Subscript[t, i_]:>E^(\[HBar] Subscript[b, i]),b->\[HBar] b,  t:>E^(\[HBar] b),x_U:>\[HBar]^Count[x,u|Subscript[u, _]] x} /. a_. x_U :>Normal[Series[a,{\[HBar],0,n}]]*x


R[i_,j_,d_]:= Simp[Module[{n,p},
Sum[
Sum[n=p-m;
Subscript[b, i]^m/(m!n!) UU[Subscript[u, i]^n,Subscript[c, j]^m,Subscript[w, j]^n]+(\[Epsilon] m Subscript[b, i]^(m-1))/(m!n!) UU[Subscript[u, i]^n,Subscript[c, i],Subscript[c, j]^m,Subscript[w, j]^n]-If[p<d,1,0] (\[Epsilon] n(n-1)Subscript[b, i]^m)/(4m!n!) UU[Subscript[u, i]^n,Subscript[c, j]^m,Subscript[w, j]^n],
{m,0,p}],
{p,0,d}
]
]] // ToDegree[d]



