(* ::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:: *)
<< C:\drorbn\AcademicPensieve\People\Kuno\Profile.m


(* ::Input::Initialization:: *)
(* Subscript[PP, _]=Identity *)


(* ::Input::Initialization:: *)
RotateToMinimal[aw_]:=Module[
{best=aw,rotated=RotateLeft[aw]},
While[rotated=!=aw,
best=First[Sort[{best,rotated}]];
rotated=RotateLeft[rotated]
];
best
];


(* ::Input::Initialization:: *)
CF[Subscript[CW, i_][iw___]]:=RotateToMinimal@Subscript[CW, i][iw];
Subscript[tr, i_->j_][\[ScriptCapitalE]_]:=\[ScriptCapitalE]/.Subscript[AW, i][iw___]:>CF@Subscript[CW, j][iw]


(* ::Input::Initialization:: *)
Subscript[Basis, d_,ps_][Subscript[AW, i_]]:=Subscript[AW, i]@@@Tuples[ps,d]
Subscript[Basis, d_,ps_][Subscript[AW, i_]more_]:=Flatten@Table[Outer[Times,Subscript[Basis, d1,ps][Subscript[AW, i]],Subscript[Basis, d-d1,ps][more]],{d1,0,d}];
Subscript[Basis, d_,ps_][Subscript[CW, i_]]:=Union[Subscript[tr, i->i]/@Subscript[Basis, d,ps][Subscript[AW, i]]];
Subscript[Basis, d_,ps_][Subscript[CW, i_]more_]:=Flatten@Table[Outer[Times,Subscript[Basis, d1,ps][Subscript[CW, i]],Subscript[Basis, d-d1,ps][more]],{d1,0,d}]


(* ::Input::Initialization:: *)
Subscript[\[Sigma], i_->j_][\[ScriptCapitalE]_]:=Subscript[PP, FAA\[Sigma]][\[ScriptCapitalE]/.{Subscript[AW, i][iw___]:>Subscript[AW, j][iw],Subscript[CW, i][iw___]:>Subscript[CW, j][iw]}]


(* ::Input::Initialization:: *)
Subscript[m, i_,j_->k_][\[ScriptCapitalE]_]:=Subscript[PP, FAAm][\[ScriptCapitalE]/.Subscript[AW, i][iw___]Subscript[AW, j][jw___]:>Subscript[AW, k][iw,jw]]


(* ::Input::Initialization:: *)
Subscript[\[DoubleStruckCapitalD][v_], i_->j_,k_][\[ScriptCapitalE]_]:=Subscript[PP, FA\[DoubleStruckCapitalD]]@Expand[\[ScriptCapitalE]/.{
Subscript[AW, i][]->0,
Subscript[AW, i][iw__]:>Sum[If[{iw}[[\[Alpha]]]===v,Take[Subscript[AW, j][iw],\[Alpha]-1]Drop[Subscript[AW, k][iw],\[Alpha]],0],{\[Alpha],Length@{iw}}]
}];
Subscript[\[DoubleStruckCapitalD][v_], i_->j_][\[ScriptCapitalE]_]:=Subscript[PP, FA\[DoubleStruckCapitalD]]@Expand[\[ScriptCapitalE]/.{
Subscript[CW, i][]->0,
Subscript[CW, i][iw__]:>Sum[If[{iw}[[\[Alpha]]]===v,Most@RotateLeft[Subscript[AW, j][iw],\[Alpha]],0],{\[Alpha],Length@{iw}}]
}]


(* ::Input::Initialization:: *)
Subscript[\[CapitalDelta], i_->j_,k_][\[ScriptCapitalE]_]:=Subscript[PP, FA\[CapitalDelta]]@Expand@Module[{\[Alpha]s,all},
\[ScriptCapitalE]/.{
Subscript[AW, i][iw___]:>(
all=Range@Length@{iw};
Sum[
Subscript[AW, j][iw][[\[Alpha]s]]Subscript[AW, k][iw][[Complement[all,\[Alpha]s]]],
{\[Alpha]s,Subsets@all}
]),
Subscript[CW, i][iw___]:>(
all=Range@Length@{iw};
Sum[
CF[Subscript[CW, j][iw][[\[Alpha]s]]]CF[Subscript[CW, k][iw][[Complement[all,\[Alpha]s]]]],
{\[Alpha]s,Subsets@all}
])
}
]


(* ::Input::Initialization:: *)
Subscript[S, i_->j_][\[ScriptCapitalE]_]:=Subscript[PP, FAS]@Expand[
\[ScriptCapitalE]/.{
Subscript[AW, i][iw___]:>(-1)^Length@{iw} Reverse[Subscript[AW, j][iw]],
Subscript[CW, i][iw___]:>(-1)^Length@{iw} CF@Reverse[Subscript[CW, j][iw]]
}
]


(* ::Input::Initialization:: *)
Subscript[\[Eta], i_][\[ScriptCapitalE]_]:=Expand[\[ScriptCapitalE] Subscript[AW, i][]]


(* ::Input::Initialization:: *)
FA[rs___Rule][\[ScriptCapitalE]_]:=Subscript[PP, FAFA]@Expand[\[ScriptCapitalE]/.Subscript[AW, i_][iw___]:>Distribute[Subscript[AW, i][iw]/.{rs}/.Subscript[AW, i][___,0,___]->0]]


(* ::Input::Initialization:: *)
Subscript[EM, d_][\[ScriptCapitalE]1_,\[ScriptCapitalE]2_]:=Subscript[PP, FAEM]@Module[{E1,E2,j,j1},
E1=CoefficientList[\[ScriptCapitalE]1/.{Subscript[AW, i_][iw__]:>\[HBar]^Length@{iw} Subscript[AW, i][iw],Subscript[CW, i_][iw__]:>\[HBar]^Length@{iw} Subscript[CW, i][iw]},\[HBar]];
E2=CoefficientList[\[ScriptCapitalE]2/.{Subscript[AW, i_][iw__]:>\[HBar]^Length@{iw} Subscript[AW, i][iw],Subscript[CW, i_][iw__]:>\[HBar]^Length@{iw} Subscript[CW, i][iw]},\[HBar]];
Sum[
Expand[E1[[j1+1]]E2[[j-j1+1]]],
{j,0,d},{j1,0,j}]
]



