(* ::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}. *)
Subscript[K\[Delta], is__]:=KroneckerDelta[is];


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};
UU /: UU[x_]+UU[y_] := UU[x+y];
UU /: a_*UU[x_] := UU[Expand[a x]];


\[Gamma][f_, j_,k_] := \[Delta]a[f,j,k]-c[Subscript[b, j]f,k];
\[Gamma]a[f_, j_,k_,l_,m_] := \[Delta]aa[f,j,k,l,m]-ca[Subscript[b, j]f,k,l,m];


UUBasis[T_List, H_List, f_] := Module[
{ff,n=0,h,t,h1,h2},
ff:=
\!\(\*SubscriptBox[\(f\), \(++n\)]\)@@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}]
} /. Subscript[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]
}
]];


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] - Subscript[K\[Delta], j,y]\[Gamma][\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]f\),i,y] - Subscript[K\[Delta], i,x] Subscript[K\[Delta], j,y](\[Beta][f Subscript[b, x]]+c[f,y]-\[Delta]\[Beta][Subscript[b, x]\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]f\)]),
\[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] + Subscript[K\[Delta], i,y] Subscript[K\[Delta], j,x]\[Gamma][f,x,k] + Subscript[K\[Delta], j,x] Subscript[K\[Delta], k,y]c[-f Subscript[b, x],i],
\[Delta]aa[f_,i_,j_,k_,l_] :> \[Delta]aa[f,i,j,k,l] + Subscript[K\[Delta], i,x] Subscript[K\[Delta], j,y]\[Delta]a[-Subscript[b, x]f,k,l] + Subscript[K\[Delta], i,x] Subscript[K\[Delta], l,y](-\[Delta]a[Subscript[b, k]f,x,j]+\[Delta]a[Subscript[b, x]f,k,j]) + Subscript[\[Epsilon], 2] Subscript[K\[Delta], k,x] Subscript[K\[Delta], j,y](\[Delta]a[Subscript[b, i]f,x,l]-\[Delta]a[Subscript[b, x]f,i,l]) + Subscript[K\[Delta], k,x] Subscript[K\[Delta], l,y]\[Delta]a[-Subscript[b, x]f,i,j] + Subscript[K\[Delta], i,x] Subscript[K\[Delta], j,l,y]\[Delta]\[Beta][Subscript[b, i] Subscript[b, k]f]
}]];


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


t\[Sigma][x_,y_][expr_] := expr /. Subscript[b, x]->Subscript[b, y] /. {
a[f_,i_,j_] :> a[f,i/.x->y,j],
\[Delta]a[f_,i_,j_] :> \[Delta]a[f,i/.x->y,j],
ca[f_,i_,j_,k_] :> ca[f,i,j/.x->y,k],
\[Delta]aa[f_,i_,j_,k_,l_] :> \[Delta]a[f,i/.x->y,j,k/.x->y,l]
}


tb[x_][UU[L_],UU[R_]] := Module[{p},S[UU[Distribute[p[L,R]] /. {
p[_\[Beta]|_\[Delta]\[Beta]|_c|_\[Delta]a|_ca|_\[Delta]aa, _\[Beta]|_\[Delta]\[Beta]|_c|_\[Delta]a|_ca|_\[Delta]aa] -> 0,
p[u_\[Beta]|u_\[Delta]\[Beta]|u_c|u_\[Delta]a|u_ca|u_\[Delta]aa, v_a] :> -p[v,u]
} /. {
p[a[f_,x,j_], u_] :> (u /. {
\[Beta][g_] :> \[Gamma][f \!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]g\),x,j],
a[g_,k_,l_] :> \[Gamma]a[f \!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]g\),x,j,k,l] +Subscript[K\[Delta], x,k](- \[Gamma]a[g \!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(k\)]]f\),k,l,x,j] + ca[f g,l,x,j]-ca[f g,j,k,l]),
_ -> 0
}),
p[a[f_,j_,k_], a[g_,x,l_]] :> -\[Gamma]a[g \!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(x\)]]f\),x,l,j,k],
p[_,_] -> 0
}]]];


hb[y_][UU[L_],UU[R_]] := Module[{p},S[UU[Distribute[p[L,R]] /. {
p[_\[Beta]|_\[Delta]\[Beta],_] -> 0,
p[_, _\[Beta]|_\[Delta]\[Beta]] -> 0,
p[_c|_\[Delta]a|_ca|_\[Delta]aa, _c|_\[Delta]a|_ca|_\[Delta]aa] -> 0,
p[u_c|u_\[Delta]a|u_ca|u_\[Delta]aa, v_a] :> -p[v,u]
} /. {
p[a[f_,i_,y], u_] :> (u /. {
a[g_,j_,k_] :> Subscript[K\[Delta], y,k](a[Subscript[b, j]f g,i,y]-a[Subscript[b, i]f g,j,k]),
c[g_, j_] :> Subscript[K\[Delta], y,j]\[Gamma][f g,i,j],
\[Delta]a[g_,j_,k_] :> Subscript[K\[Delta], y,k](\[Delta]a[Subscript[b, j]f g,i,y]-\[Delta]a[Subscript[b, i]f g,j,k]),
ca[g_,j_,k_,l_] :> Subscript[K\[Delta], y,j]\[Gamma]a[f g,i,j,k,l] + Subscript[K\[Delta], y,l](ca[Subscript[b, k]f g,j,i,y]-ca[Subscript[b, i]f g,j,k,l]),
\[Delta]aa[g_,j_,k_,l_,m_] :> Subscript[K\[Delta], y,k](\[Delta]aa[Subscript[b, j]f g,i,y,l,m]-\[Delta]aa[Subscript[b, i]f g,j,k,l,m]) + Subscript[K\[Delta], y,m](\[Delta]aa[Subscript[b, l]f g,j,k,i,y]-\[Delta]aa[Subscript[b, i]f g,j,k,l,m])
}),
_p -> 0
}]]];


ct::usage="ct[L,R,{h,t}] contracts the head h in L with the tail t in R. ct[L,R] assumes that both h and t are 0. When ambiguous, L is placeed below R.";
ct[L_,R_] := ct[L,R,{0,0}];
ct[UU[L_],UU[R_], {h_,t_}] := Module[{p}, S[UU[Distribute[p[L,R]] /. {
p[_\[Beta]|_\[Delta]\[Beta],_] -> 0,
p[a[f_,i_,h], \[Beta][g_]] :> \[Beta][f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0)],
p[a[f_,i_,h], a[g_,t,j_]] :> a[f(g/.Subscript[b, t]->0), i,j],
p[a[f_,i_,h], a[g_,j_,k_]] :> a[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j,k],
p[a[f_,i_,h], c[g_,j_]] :> c[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j],
p[a[f_,i_,h], \[Delta]a[g_,t,j_]] :> \[Delta]a[f(g/.Subscript[b, t]->0), i,j],
p[a[f_,i_,h], \[Delta]a[g_,j_,k_]] :> \[Delta]a[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j,k],
p[a[f_,i_,h], ca[g_,k_,t,j_]] :> ca[f(g/.Subscript[b, t]->0), k,i,j],
p[a[f_,i_,h], ca[g_,l_,j_,k_]] :> ca[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), l,j,k],
p[a[f_,i_,h], \[Delta]aa[g_,t,j_,t,k_]]  -> 0,
p[a[f_,i_,h], \[Delta]aa[g_,t,j_,k_,l_]] :> \[Delta]aa[f(g/.Subscript[b, t]->0), i,j,k,l],
p[a[f_,i_,h], \[Delta]aa[g_,j_,k_,t,l_]] :> \[Delta]aa[f(g/.Subscript[b, t]->0), j,k,i,l],
p[a[f_,i_,h], \[Delta]aa[g_,j_,k_,l_,m_]] :> \[Delta]aa[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j,k,l,m],
p[a[__], _] -> 0,
p[c[f_,h], \[Beta][g_]] :> \[Delta]\[Beta][f ((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0)],
p[_c,_\[Beta]]->0,
p[c[f_,h], a[g_,t,j_]] :> c[f(g/.Subscript[b, t]->0), j],
p[c[f_,h], a[g_,j_,k_]] :> \[Delta]a[f((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j,k],
p[_c,_a]->0,
p[_c|_\[Delta]a|_ca|_\[Delta]aa, _\[Delta]\[Beta]|_c|_\[Delta]a|_ca|_\[Delta]aa] -> 0,
p[\[Delta]a[f_,i_,h], \[Beta][g_]] :> \[Delta]\[Beta][f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0)],
p[\[Delta]a[f_,i_,h], a[g_,t,j_]] :> \[Delta]a[f(g/.Subscript[b, t]->0),i,j],
p[\[Delta]a[f_,i_,h], a[g_,j_,k_]] :> \[Delta]a[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j,k],
p[_\[Delta]a,_] -> 0,
p[ca[_,h,_,h], _] -> 0,
p[ca[f_,h,i_,j_], \[Beta][g_]] :> \[Delta]a[f((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), i,j],
p[ca[f_,i_,j_,h], \[Beta][g_]] :> c[f Subscript[b, j]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), i],
p[ca[f_,h,i_,j_], a[g_,t,k_]] :> ca[f (g/.Subscript[b, t]->0), k,i,j],
p[ca[f_,h,i_,j_], a[g_,k_,l_]] :> \[Delta]aa[f((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), i,j,k,l],
p[ca[f_,i_,j_,h], a[g_,t,k_]] :> ca[f (g/.Subscript[b, t]->0),i,j,k],
p[ca[f_,i_,j_,h], a[g_,k_,l_]] :> ca[f Subscript[b, j]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), i,k,l],
p[_ca,_] -> 0,
p[\[Delta]aa[_,_,h,_,h], _] -> 0,
p[\[Delta]aa[f_,i_,h,j_,k_], \[Beta][g_]] :> \[Delta]a[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0),j,k],
p[\[Delta]aa[f_,i_,h,j_,k_], a[g_,t,l_]] :> \[Delta]aa[f (g/.Subscript[b, t]->0),i,l,j,k],
p[\[Delta]aa[f_,i_,h,j_,k_], a[g_,l_,m_]] :> \[Delta]aa[f Subscript[b, i]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), j,k,l,m],
p[\[Delta]aa[f_,i_,j_,k_,h], \[Beta][g_]] :> \[Delta]a[f Subscript[b, k]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), i,j],
p[\[Delta]aa[f_,i_,j_,k_,h], a[g_,t,l_]] :> \[Delta]aa[f (g/.Subscript[b, t]->0),i,j,k,l],
p[\[Delta]aa[f_,i_,j_,k_,h], a[g_,l_,m_]] :> \[Delta]aa[f Subscript[b, k]((\!\(
\*SubscriptBox[\(\[PartialD]\), 
SubscriptBox[\(b\), \(t\)]]g\)) /. Subscript[b, t]->0), i,j,l,m],
p[_\[Delta]aa, _] -> 0
}]]];
