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



SetDirectory["C:\\drorbn\\AcademicPensieve\\2015-12"]


DQ[is___] := (Sort[{is}]===Union[{is}]);
OQ[is___] := OrderedQ[{is}]; (* tests for non-strict ordering; also true when {is} is {i,i}. *)


Simp[expr_] := Simplify[expr];
S[expr_] := expr /. (\[Lambda]_\[Beta]|\[Lambda]_a|\[Lambda]_\[Delta]\[Beta]|\[Lambda]_\[Delta]a|\[Lambda]_c|\[Lambda]_ca|\[Lambda]_\[Delta]aa) :> MapAt[Simp, \[Lambda], 1];


AutoCollecting[\[Lambda]_] := (
\[Lambda] /: \[Lambda][0,___] = 0;
\[Lambda] /: \[Lambda][f_, r___] + \[Lambda][g_, r___] := \[Lambda][Simp[f+g], r];
\[Lambda] /: g_*\[Lambda][f_, r___] := \[Lambda][Simp[g f], r];
);
AutoCollecting /@ {\[Beta], a, \[Delta]\[Beta], c, \[Delta]a, ca, \[Delta]aa};


\[Gamma][f_, j_,k_] := \[Delta]a[f,j,k]-c[Subscript[b, j]f,k];


UUBasis[T_List, H_List, f_] := Module[
{ff=f@@Table[Subscript[b, t], {t,T}]},
UU /@ Flatten@{
\[Beta][ff],
Table[{a[ff, t,h],\[Delta]a[ff,t,h]}, {t,T}, {h,H}],
\[Delta]\[Beta][ff],
Table[c[ff, h], {h,H}],
Table[ca[ff, h1,t,h2], {h1,H}, {t,T}, {h2,H}],
Table[\[Delta]aa[ff, T[[i]],H[[j]],T[[k]],H[[l]]], {k,Length@T},{i,k}, {l,Length@H},{j,l}]
} /. 1[___] -> 1
];
UUBasis[S_List,f_] := UUBasis[S,S,f];
UUBasis[n_Integer,m_Integer,f_] := UUBasis[Range@n,Range@m,f];
UUBasis[n_Integer, f_] := UUBasis[Range@n, f];


UU[expr_] // S := UU[S[expr /. {
\[Delta]aa[f_,i_,j_,k_,l_] /; !OQ[j,l] :> \[Delta]aa[f,k,l,i,j],\[Delta]aa[f_,i_,j_,k_,l_] /; !OQ[i,k]\[And]DQ[j,l]\[And]OQ[j,l] :> \[Delta]aa[f,i,l,k,j] + ca[Subscript[b, k]f,l,i,j] + ca[-Subscript[b, i]f,l,k,j] + ca[-Subscript[b, k]f,j,i,l] + ca[Subscript[b, i]f,j,k,l],
\[Delta]aa[f_,i_,k_,j_,k_] /; !OQ[i,j] :> \[Delta]aa[f,j,k,i,k] + \[Delta]a[-Subscript[b, i]f,j,k] + \[Delta]a[Subscript[b, j]f,i,k]
}]];


UU[expr_] // tm[x_,y_,z_] := UU[S[expr /. {
a[f_,x,j_] :> a[f,z,j]+\[Gamma][\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(y\)]]f\),z,j],
a[f_,y,j_] :> a[f,z,j],
\[Delta]a[f_,x|y,j_] :> \[Delta]a[f,z,j],
ca[f_,i_,x|y,j_] :> ca[f,i,z,j],
\[Delta]aa[f_,i_,j_,k_,l_] :> \[Delta]aa[f,i /. x|y->z, j, k /. x|y->z, l]
} /. Subscript[b, x|y]->Subscript[b, z]]];


UU[expr_] // hm[x_,y_,z_] := S[UU[expr /. {
a[f_,i_,x|y] :> a[f,i,z],
c[f_,x|y] :> c[f,z],
\[Delta]a[f_,i_,x|y] :> \[Delta]a[f,i,z],
ca[f_,y,j_, x] :> ca[f,z,j,z] + \[Gamma][f,j,z],
ca[f_,i_,j_,k_] :> ca[f,i /. x|y->z,j,k /. x|y->z],
\[Delta]aa[f_,i_,y,k_,x] :> \[Delta]aa[f,k,z,i,z],
\[Delta]aa[f_,i_,j_,k_,l_] :> \[Delta]aa[f,i,j /. x|y->z, k, l /. x|y->z]
}]];


UU[expr_] // hts[y_,x_] := S[UU[expr /. {
a[f_,i_,j_] :> a[f,i,j] - If[j==y, \[Gamma][\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]f\),i,y],0] - If[i==x\[And]j==y, \[Beta][f Subscript[b, x]]+c[f,y]-\[Delta]\[Beta][Subscript[b, x]\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]f\)],0],
\[Delta]a[f_,x,y] :> \[Delta]a[f,x,y] -  \[Delta]\[Beta][f Subscript[b, x]],
ca[f_,i_,j_,k_] :> ca[f,i,j,k] + Plus[
If[i==y\[And]j==x, \[Gamma][f,x,k], 0],
If[j==x\[And]k==y, c[-f Subscript[b, x],i],0]
],
\[Delta]aa[f_,i_,j_,k_,l_] :> \[Delta]aa[f,i,j,k,l] + Plus[
If[i==x\[And]j==y, \[Delta]a[-Subscript[b, x]f,k,l], 0],
If[i==x\[And]l==y, -\[Delta]a[Subscript[b, k]f,x,j]+\[Delta]a[Subscript[b, x]f,k,j], 0],
If[k==x\[And]j==y, Subscript[\[Epsilon], 2](\[Delta]a[Subscript[b, i]f,x,l]-\[Delta]a[Subscript[b, x]f,i,l]), 0],
If[k==x\[And]l==y, \[Delta]a[-Subscript[b, x]f,i,j], 0],
If[i==x\[And]j==l==y, \[Delta]\[Beta][Subscript[b, i] Subscript[b, k]f],0]
]
}]];


dm[x_,y_,z_][expr_] := expr // hts[x,y] // tm[x,y,z] // hm[x,y,z]



