(* ::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]^2=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]=b U[]-2\[Epsilon] U@c);


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


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


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


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


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


(* ::Input::Initialization:: *)
Subscript[bc, i_]:=Subscript[b, i]U[]-\[Epsilon] U[Subscript[c, i]];
Subscript[a, i_,j_]:=Subscript[bc, i]**U@Subscript[c, j]+U@Subscript[u, i]**U@Subscript[w, j];


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


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


(* ::Input::Initialization:: *)
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}] }]
]]


(* ::Input::Initialization:: *)
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}] }]
]]


(* ::Input::Initialization:: *)
AutoEa[\[Tau]_,i_,j_][x_] := Module[{bas,n,k, f,t, guess, InitCond, DiffCond, sol},
bas=LBasis@{i,j};
n=0; guess=Sum[
\!\(\*SubscriptBox[\(f\), \(++n\)]\)[t]y,{y,bas}];
InitCond=Table[0==Coefficient[(guess/.t->0)-x, y] /. \[Epsilon]->0, {y,bas}];
DiffCond=Table[0==Coefficient[D[guess,t]-B[Simp[\[Tau] Subscript[a, i,j]],guess], y] /. \[Epsilon]->0, {y,bas}];
{sol}=DSolve[InitCond\[Union]DiffCond, Table[Subscript[f, k][t],{k,n}], t];
guess /. sol /. t->1
]


(* ::Input::Initialization:: *)
Ea[___][0] = 0;
Ea[x___][a_.*U[]] := a U[];
Ea[x___][y_Plus] := Ea[x] /@ y;
Ea[\[Tau]_,i_,j_][U@Subscript[c, i_]] := U[Subscript[c, i]]-(E^(-\[Tau] Subscript[b, i]) (-1+E^(\[Tau] Subscript[b, i])) U[Subscript[u, i],Subscript[w, j]])/Subscript[b, i]+(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])-\[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)-(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])-\[Tau] Subscript[b, i]) U[Subscript[c, i],Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)+(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])-\[Tau] Subscript[b, i]) U[Subscript[c, j],Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)+(E^(-2 \[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(2 \[Tau] Subscript[b, i])-2 E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[u, i],Subscript[w, j],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(3\)]\);
Ea[\[Tau]_,i_,j_][U@Subscript[c, j_]] := U[Subscript[c, j]]+(E^(-\[Tau] Subscript[b, i]) (-1+E^(\[Tau] Subscript[b, i])) U[Subscript[u, i],Subscript[w, j]])/Subscript[b, i]-(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])-\[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)+(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])-\[Tau] Subscript[b, i]) U[Subscript[c, i],Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)-(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])-\[Tau] Subscript[b, i]) U[Subscript[c, j],Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)-(E^(-2 \[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(2 \[Tau] Subscript[b, i])-2 E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[u, i],Subscript[w, j],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(3\)]\);
Ea[\[Tau]_,i_,j_][U@Subscript[c, k_]] /; (k=!=i)\[And](k=!=j):= U@Subscript[c, k];
Ea[\[Tau]_,i_,j_][U@Subscript[u, i_]] :=U[Subscript[u, i]]-\[Epsilon] \[Tau] U[Subscript[c, j],Subscript[u, i]]-(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[u, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\);
Ea[\[Tau]_,i_,j_][U@Subscript[u, j_]] := -(((-1+E^(\[Tau] Subscript[b, i])) Subscript[b, j] U[Subscript[u, i]])/Subscript[b, i])-(\[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) Subscript[b, j] U[Subscript[u, i]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)+E^(\[Tau] Subscript[b, i]) U[Subscript[u, j]]+(\[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) Subscript[b, j] U[Subscript[c, i],Subscript[u, i]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)-E^(\[Tau] Subscript[b, i]) \[Epsilon] \[Tau] U[Subscript[c, i],Subscript[u, j]]+(\[Epsilon] (-2 Subscript[b, i]+2 E^(\[Tau] Subscript[b, i]) Subscript[b, i]-Subscript[b, j]+E^(\[Tau] Subscript[b, i]) Subscript[b, j]-\[Tau] Subscript[b, i] Subscript[b, j]) U[Subscript[c, j],Subscript[u, i]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)-1/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(3\)]\) E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-Subscript[b, i]+2 E^(\[Tau] Subscript[b, i]) Subscript[b, i]-E^(2 \[Tau] Subscript[b, i]) Subscript[b, i]+2 E^(\[Tau] Subscript[b, i]) Subscript[b, j]-2 E^(2 \[Tau] Subscript[b, i]) Subscript[b, j]+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i] Subscript[b, j]+E^(2 \[Tau] Subscript[b, i]) \[Tau] Subscript[b, i] Subscript[b, j]) U[Subscript[u, i],Subscript[u, i],Subscript[w, j]]+(\[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[u, j],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\);
Ea[\[Tau]_,i_,j_][U@Subscript[u, k_]] /; (k=!=i)\[And](k=!=j):= U@Subscript[u, k];
Ea[\[Tau]_,i_,j_][U@Subscript[w, i_]] := U[Subscript[w, i]]+E^(-\[Tau] Subscript[b, i]) (-1+E^(\[Tau] Subscript[b, i])) U[Subscript[w, j]]-(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (-1+E^(\[Tau] Subscript[b, i])+\[Tau] Subscript[b, i]) U[Subscript[c, i],Subscript[w, j]])/Subscript[b, i]+\[Epsilon] \[Tau] U[Subscript[c, j],Subscript[w, i]]+(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[c, j],Subscript[w, j]])/Subscript[b, i]+(E^(-\[Tau] Subscript[b, i]) \[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[w, i],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\)+(E^(-2 \[Tau] Subscript[b, i]) (1+E^(\[Tau] Subscript[b, i])) \[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[w, j],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\);
Ea[\[Tau]_,i_,j_][U@Subscript[w, j_]] := E^(-\[Tau] Subscript[b, i]) U[Subscript[w, j]]+E^(-\[Tau] Subscript[b, i]) \[Epsilon] \[Tau] U[Subscript[c, i],Subscript[w, j]]-(E^(-2 \[Tau] Subscript[b, i]) \[Epsilon] (1-E^(\[Tau] Subscript[b, i])+E^(\[Tau] Subscript[b, i]) \[Tau] Subscript[b, i]) U[Subscript[u, i],Subscript[w, j],Subscript[w, j]])/
\!\(\*SubsuperscriptBox[\(b\), \(i\), \(2\)]\);
Ea[\[Tau]_,i_,j_][U@Subscript[w, k_]] /; (k=!=i)\[And](k=!=j):= U@Subscript[w, k];
Ea[x___][a_.*u_U] := Simp[a NonCommutativeMultiply@@(Ea[x] /@ (U/@u))];
Ea[i_,j_] := Ea[-1,i,j];
