Pensieve header: Scatter and Glow in OneCo. Continued pensieve://2016-01/.

In the U(T)U(H) conventions.

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

Generalities

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 /. (λ_β|λ_a|λ_δβ|λ_δa|λ_c|λ_ca|λ_δaa) :> MapAt[Simp, λ, 1];

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

γ[f_, j_,k_] := δa[f,j,k]-c[(Subscript[b, j])f,k];

Bases

UUBasis[T_List, H_List, f_] := Module[
{ff=f@@Table[(Subscript[b, t]), {t,T}]},
UU /@ Flatten@{
β[ff],
Table[{a[ff, t,h],δa[ff,t,h]}, {t,T}, {h,H}],
δβ[ff],
Table[c[ff, h], {h,H}],
Table[ca[ff, h1,t,h2], {h1,H}, {t,T}, {h2,H}],
Table[δ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];

δaa relations

Switch from thth to tthh indexing? (not for the moment)

UU[expr_] // S := UU[S[expr /. {
δaa[f_,i_,j_,k_,l_] /; !OQ[j,l] :> δaa[f,k,l,i,j],δaa[f_,i_,j_,k_,l_] /; !OQ[i,k]∧DQ[j,l]∧OQ[j,l] :> δ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],
δaa[f_,i_,k_,j_,k_] /; !OQ[i,j] :> δaa[f,j,k,i,k] + δa[-(Subscript[b, i])f,j,k] + δa[(Subscript[b, j])f,i,k]
}]];

tm, hm, hts, dm

UU[expr_] // tm[x_,y_,z_] := UU[S[expr /. {
a[f_,x,j_] :> a[f,z,j]+γ[(∂_(Subscript[b, y]))f,z,j],
a[f_,y,j_] :> a[f,z,j],
δa[f_,x|y,j_] :> δa[f,z,j],
ca[f_,i_,x|y,j_] :> ca[f,i,z,j],
δaa[f_,i_,j_,k_,l_] :> δ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],
δa[f_,i_,x|y] :> δa[f,i,z],
ca[f_,y,j_, x] :> ca[f,z,j,z] + γ[f,j,z],
ca[f_,i_,j_,k_] :> ca[f,i /. x|y->z,j,k /. x|y->z],
δaa[f_,i_,y,k_,x] :> δaa[f,k,z,i,z],
δaa[f_,i_,j_,k_,l_] :> δ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, γ[(∂_(Subscript[b, x]))f,i,y],0] - If[i==x∧j==y, β[f (Subscript[b, x])]+c[f,y]-δβ[(Subscript[b, x])(∂_(Subscript[b, x]))f],0],
δa[f_,x,y] :> δa[f,x,y] -  δβ[f (Subscript[b, x])],
ca[f_,i_,j_,k_] :> ca[f,i,j,k] + Plus[
If[i==y∧j==x, γ[f,x,k], 0],
If[j==x∧k==y, c[-f (Subscript[b, x]),i],0]
],
δaa[f_,i_,j_,k_,l_] :> δaa[f,i,j,k,l] + Plus[
If[i==x∧j==y, δa[-(Subscript[b, x])f,k,l], 0],
If[i==x∧l==y, -δa[(Subscript[b, k])f,x,j]+δa[(Subscript[b, x])f,k,j], 0],
If[k==x∧j==y, (Subscript[ϵ, 2])(δa[(Subscript[b, i])f,x,l]-δa[(Subscript[b, x])f,i,l]), 0],
If[k==x∧l==y, δa[-(Subscript[b, x])f,i,j], 0],
If[i==x∧j==l==y, δβ[(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]

ct (contract)