(* ::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:: *)
SetDirectory["C:\\drorbn\\AcademicPensieve\\2017-05"];


(* ::Input::Initialization:: *)
AlgebraAtom = g|G[_]|e|h|H[_]|f;
$PBWRule={G[_]->1,g->2,e->3,H[_]->4,h->5,f->6};


(* ::Input::Initialization:: *)
B[g,e] = \[Gamma] e; B[e,G[n_]]=(E^(-n \[Gamma] \[Eta])-1)U[G[n],e]; B[g,G[_]]=0;
B[h,f] = -\[Eta] f; B[f,H[n_]]=(E^(n \[Gamma] \[Eta])-1)U[H[n],f]; B[h,H[_]]=0;



(* ::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[U, 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[sd_SeriesData] := MapAt[USimp, sd, {3,All}];
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, s__][sd_SeriesData] := MapAt[Subscript[m, s], sd, {3,All}];
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[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][specs_,sd_SeriesData] := MapAt[\[DoubleStruckCapitalO][specs,#]&, sd, {3,All}];
\[DoubleStruckCapitalO][specs_, poly_] := 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[poly, vars] /. (ps_ -> c_) :> c(
specs /. MapThread[((#1->_) :> #3^#2)&,{vars,ps,elems}] /. Subscript[U, i_]:>Subscript[UU, i]
)]
]


(* ::Input::Initialization:: *)
Subscript[q\[CapitalDelta], i_->j_,k_][\[ScriptCapitalE]_] := USimp@Module[{tj,tk}, \[ScriptCapitalE] /. {
Subscript[U, i][] -> Subscript[U, j][]Subscript[U, k][],
Subscript[U, i][g,xs___] :> (USimp[(Subscript[U, j][g]Subscript[U, k][]+Subscript[U, j][]Subscript[U, k][g])Subscript[q\[CapitalDelta], i->tj,tk][Subscript[U, i][xs]]] // Subscript[m, j,tj->j] // Subscript[m, k,tk->k]),
Subscript[U, i][G[n_],xs___] :> (USimp[Subscript[U, j][G[n]]Subscript[U, k][G[n]]Subscript[q\[CapitalDelta], i->tj,tk][Subscript[U, i][xs]]] // Subscript[m, j,tj->j] // Subscript[m, k,tk->k]),
Subscript[U, i][e,xs___] :> (USimp[(Subscript[U, j][e]Subscript[U, k][G[1]]+Subscript[U, j][]Subscript[U, k][e])Subscript[q\[CapitalDelta], i->tj,tk][Subscript[U, i][xs]]] // Subscript[m, j,tj->j] // Subscript[m, k,tk->k]),
Subscript[U, i][h,xs___] :> (USimp[(Subscript[U, j][h]Subscript[U, k][]+Subscript[U, j][]Subscript[U, k][h])Subscript[q\[CapitalDelta], i->tj,tk][Subscript[U, i][xs]]] // Subscript[m, j,tj->j] // Subscript[m, k,tk->k]),
Subscript[U, i][H[n_],xs___] :> (USimp[Subscript[U, j][H[n]]Subscript[U, k][H[n]]Subscript[q\[CapitalDelta], i->tj,tk][Subscript[U, i][xs]]] // Subscript[m, j,tj->j] // Subscript[m, k,tk->k]),
Subscript[U, i][f,xs___] :> (USimp[(Subscript[U, j][f]Subscript[U, k][]+Subscript[U, j][H[1]]Subscript[U, k][f])Subscript[q\[CapitalDelta], i->tj,tk][Subscript[U, i][xs]]] // Subscript[m, j,tj->j] // Subscript[m, k,tk->k])
}];


(* ::Input::Initialization:: *)
Subscript[q\[CapitalDelta], i_->j_,k_,l__][\[ScriptCapitalE]_] := \[ScriptCapitalE] // Subscript[q\[CapitalDelta], i->j,k]//Subscript[q\[CapitalDelta], k->k,l]


(* ::Input::Initialization:: *)
S[g]=-g; S[G[n_]]:=G[-n]; S[e] = -E^(\[Gamma] \[Eta]) U[G[-1],e];
S[h]=-h; S[H[n_]]:=H[-n]; S[f] = -U[H[-1],f];
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]]]]
]];


(* ::Input::Initialization:: *)
 P[U[],U[]] = 1;
P[U[], U[H[_]]] = P[U[G[_]],U[]] = 1;
P[U[], U[__]] = P[U[__],U[]] = 0;
({
 {P[U[g],U[h]]=1, P[U[g],U[H[n_]]]=n \[Gamma], P[U[g],U[f]]=0},
 {P[U[G[n_]],U[h]]=n \[Eta], P[U[G[n_]],U[H[m_]]]=E^(n m \[Eta] \[Gamma]), P[U[G[_]],U[f]]=0},
 {P[U[e],U[h]]=0, P[U[e],U[H[_]]]=0, P[U[e],U[f]]=1}
});


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


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


(* ::Input::Initialization:: *)
Subscript[dm, i_,j_->k_][\[ScriptCapitalE]_] := Module[{t1,t2,t3,h1,h2,h3},
\[ScriptCapitalE] // Subscript[q\[CapitalDelta], i->h1,h2,h3]//Subscript[S, h1]//Subscript[q\[CapitalDelta], -j->t1,t2,t3]//Subscript[P, h1,t1]//Subscript[P, h3,t3]//Subscript[m, h2,j->k]//Subscript[m, -i,t2->-k]]


(* ::Input::Initialization:: *)
Subscript[R, i_,j_][d_] := Module[{x,y},\[DoubleStruckCapitalO][
Subscript[U, -i][Subscript[x, 1]->h, Subscript[x, 2]->f]Subscript[U, i][]Subscript[U, -j][]Subscript[U, j][Subscript[y, 1]->g,Subscript[y, 2]->e],
Series[Exp[\[HBar] Subscript[x, 1] Subscript[y, 1]+\!\(
\*UnderoverscriptBox[\(\[Sum]\), \(k = 1\), \(d\)]
\*FractionBox[\(
\*SuperscriptBox[\((1 - 
\*SuperscriptBox[\(E\), \(\[HBar]\ \[Eta]\ \[Gamma]\)])\), \(k\)] 
\*SuperscriptBox[\((\[HBar]\ 
\*SubscriptBox[\(x\), \(2\)] 
\*SubscriptBox[\(y\), \(2\)])\), \(k\)]\), \(k \((1 - 
\*SuperscriptBox[\(E\), \(k\ \[HBar]\ \[Eta]\ \[Gamma]\)])\)\)]\)], {\[HBar],0,d}]
]]



