Pensieve header: Scatter and Glow in OneCo. Continues pensieve://2016-02/.

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

SetDirectory["C:\\drorbn\\AcademicPensieve\\2016-03"]

I ought to be able to replace c[i] with a[c,i], and ca with aa, everywhere!

Generalities

DQ[is___] := (Sort[{is}]===Union[{is}]);
OQ[is___] := OrderedQ[{is}]; (* tests for non-strict ordering. Also true when {is} is {i,i}. *)
(Subscript[Kδ, is__]):=KroneckerDelta[1,Length[Union[{is}]]];

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

γ[f_, j_,k_] := δa[f,j,k]-c[(Subscript[ϵ, 48])(Subscript[b, j])f,k];
γa[f_, j_,k_,l_,m_] := δaa[f,j,k,l,m]-ca[(Subscript[ϵ, 48])(Subscript[b, j])f,k,l,m];

Bases

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

δaa relations

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

UU[expr_] // S := UU[S[expr]];  (* Temporary fixture! *)

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[ϵ, 4])(Subscript[b, k])f,l,i,j] + ca[-(Subscript[ϵ, 4])(Subscript[b, i])f,l,k,j] + ca[-(Subscript[ϵ, 4])(Subscript[b, k])f,j,i,l] + ca[(Subscript[ϵ, 4])(Subscript[b, i])f,j,k,l],
δaa[f_,i_,k_,j_,k_] /; !OQ[i,j] :> δaa[f,j,k,i,k] + δa[-(Subscript[ϵ, 2])(Subscript[b, i])f,j,k] + δa[(Subscript[ϵ, 2])(Subscript[b, j])f,i,k]
}]];

tm, hm, hts, dm

UU[expr_] // tm[x_,y_,z_] := S[UU[Expand[expr /. {
a[f_,x,j_] :> a[f,z,j]+(Subscript[ϵ, 13])γ[(∂_(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//Replace[x|y->z], j, k//Replace[x|y->z], l]
} /. (Subscript[b, x|y])->(Subscript[b, z])]]];

UU[expr_] // hm[x_,y_,z_] := S[UU[Expand[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] + (Subscript[ϵ, 12])γ[f,j,z],
ca[f_,i_,j_,k_] :> ca[f,i//Replace[x|y->z],j,k//Replace[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//Replace[x|y->z], k, l//Replace[x|y->z]]
}]]];

UU[expr_] // hts[y_,x_] := S[UU[Expand[expr /. {
a[f_,i_,j_] :> a[f,i,j] - (Subscript[ϵ, 11])(Subscript[Kδ, j,y])γ[(∂_(Subscript[b, x]))f,i,y] - (Subscript[Kδ, i,x])(Subscript[Kδ, j,y])((Subscript[ϵ, 5])β[f (Subscript[b, x])]+(Subscript[ϵ, 6])c[f,y]-(Subscript[ϵ, 7])δβ[(Subscript[b, x])(∂_(Subscript[b, x]))f]),
δa[f_,x,y] :> δa[f,x,y] - (Subscript[ϵ, 8])δβ[f (Subscript[b, x])],
ca[f_,i_,j_,k_] :> ca[f,i,j,k] + (Subscript[ϵ, 10])(Subscript[Kδ, i,y])(Subscript[Kδ, j,x])γ[f,x,k] + (Subscript[Kδ, j,x])(Subscript[Kδ, k,y])c[-(Subscript[ϵ, 9])f (Subscript[b, x]),i],
δaa[f_,i_,j_,k_,l_] :> δaa[f,i,j,k,l] + (Subscript[ϵ, 14])(Subscript[Kδ, i,x])(Subscript[Kδ, j,y])δa[-(Subscript[b, x])f,k,l] + (Subscript[ϵ, 3])(Subscript[Kδ, i,x])(Subscript[Kδ, l,y])(-δa[(Subscript[b, k])f,x,j]+δa[(Subscript[b, x])f,k,j]) + (Subscript[ϵ, 1])(Subscript[Kδ, k,x])(Subscript[Kδ, j,y])(δa[(Subscript[b, i])f,x,l]-δa[(Subscript[b, x])f,i,l]) + (Subscript[ϵ, 15])(Subscript[Kδ, k,x])(Subscript[Kδ, l,y])δa[-(Subscript[b, x])f,i,j] + (Subscript[ϵ, 16])(Subscript[Kδ, i,x])(Subscript[Kδ, j,l,y])δβ[(Subscript[b, x])(Subscript[b, k])f]+2(Subscript[ϵ, 0])(Subscript[Kδ, x,i,k])(Subscript[Kδ, y,j,l])δβ[(Subscript[b, x])(Subscript[b, x])f]
}]]];

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

tσ, hσ, dσ on {β, a, δβ, c, δa, ca, δaa}

tσ[x_List,y_List][expr_] := Module[{rule=Thread[x->y]},
expr /. (Subscript[b, i_]):>(Subscript[b, i /. rule]) /. {
a[f_,i_,j_] :> a[f,i/.rule,j],
δa[f_,i_,j_] :> δa[f,i/.rule,j],
ca[f_,i_,j_,k_] :> ca[f,i,j/.rule,k],
δaa[f_,i_,j_,k_,l_] :> δaa[f,i/.rule,j,k/.rule,l]
}
];
tσ[x_,y_][expr_] := tσ[{x},{y}][expr];
hσ[x_List,y_List][expr_] := Module[{rule=Thread[x->y]},
S[expr /. {
a[f_,i_,j_] :> a[f,i,j/.rule],
c[f_,i_] :> c[f,i/.rule],
δa[f_,i_,j_] :> δa[f,i,j/.rule],
ca[f_,i_,j_,k_] :> ca[f,i/.rule,j,k/.rule],
δaa[f_,i_,j_,k_,l_] :> δaa[f,i,j/.rule,k,l/.rule]
}]
];
hσ[x_,y_][expr_] := hσ[{x},{y}][expr];
dσ[x_,y_][expr_] := expr // tσ[x,y] // hσ[x,y];

tb, hb, thb, htb, db, bb on {β, a, δβ, c, δa, ca, δaa}

tb[x_][UU[L_],UU[R_]] := Module[{p},S[UU[Expand[Distribute[p[L,R]] /. {
p[0,_] -> 0, p[_,0] -> 0,
p[_β|_δβ|_c|_δa|_ca|_δaa, _β|_δβ|_c|_δa|_ca|_δaa] -> 0,
p[u_β|u_δβ|u_c|u_δa|u_ca|u_δaa, v_a] :> -p[v,u]
} /. {
p[a[f_,x,j_], u_] :> (u /. {
β[g_] :> (Subscript[ϵ, 39])γ[f(∂_(Subscript[b, x]))g,x,j],
a[g_,k_,l_] :> (Subscript[ϵ, 40])γa[f(∂_(Subscript[b, x]))g,x,j,k,l] +(Subscript[Kδ, x,k])(-γa[(Subscript[ϵ, 41])g(∂_(Subscript[b, k]))f,k,l,x,j] + ca[(Subscript[ϵ, 17])f g,l,x,j]-ca[(Subscript[ϵ, 17])f g,j,k,l]),
_ -> 0
}),
p[a[f_,j_,k_], a[g_,x,l_]] :> -γa[(Subscript[ϵ, 42])g(∂_(Subscript[b, x]))f,x,l,j,k],
p[_,_] -> 0
}]]]];

hb[y_][UU[L_],UU[R_]] := Module[{p},S[UU[Expand[Distribute[p[L,R]] /. {
p[0,_] -> 0, p[_,0] -> 0,
p[_β|_δβ,_] -> 0,
p[_, _β|_δβ] -> 0,
p[_c|_δa|_ca|_δaa, _c|_δa|_ca|_δaa] -> 0,
p[u_c|u_δa|u_ca|u_δaa, v_a] :> -p[v,u]
} /. {
p[a[f_,i_,y], u_] :> (u /. {
a[g_,j_,k_] :> (Subscript[ϵ, 18])(Subscript[Kδ, y,k])(a[(Subscript[b, j])f g,i,y]-a[(Subscript[b, i])f g,j,k]),
c[g_, j_] :> (Subscript[ϵ, 19])(Subscript[Kδ, y,j])γ[f g,i,j],
δa[g_,j_,k_] :> (Subscript[ϵ, 20])(Subscript[Kδ, y,k])(δa[(Subscript[b, j])f g,i,y]-δa[(Subscript[b, i])f g,j,k]),
ca[g_,j_,k_,l_] :> (Subscript[Kδ, y,j])γa[(Subscript[ϵ, 21])f g,i,j,k,l] + (Subscript[Kδ, y,l])(ca[(Subscript[ϵ, 22])(Subscript[b, k])f g,j,i,y]-ca[(Subscript[ϵ, 22])(Subscript[b, i])f g,j,k,l]),
δaa[g_,j_,k_,l_,m_] :> (Subscript[ϵ, 23])(Subscript[Kδ, y,k])(δaa[(Subscript[b, j])f g,i,y,l,m]-δaa[(Subscript[b, i])f g,j,k,l,m]) + (Subscript[ϵ, 24])(Subscript[Kδ, y,m])(δaa[(Subscript[b, l])f g,j,k,i,y]-δaa[(Subscript[b, i])f g,j,k,l,m])
}),
_p -> 0
}]]]];

thb[x_,y_][UU[L_],UU[R_]] := Module[{p},S[UU[Expand[Distribute[p[L,R]] /. {
p[0,_] -> 0, p[_,0] -> 0,
p[_β|_δβ|_c|_δa|_ca|_δaa, _β|_δβ|_c|_δa|_ca|_δaa] -> 0,
p[_a,_β|_δβ] -> 0,
p[β[f_], a[g_,i_,j_]] :> (Subscript[Kδ, y,j])γ[(Subscript[ϵ, 43])g(∂_(Subscript[b, x]))f, i,y],
p[a[f_,i_,j_], a[g_,k_,l_]] :> (Subscript[Kδ, y,l])(
γa[(Subscript[ϵ, 44])g(∂_(Subscript[b, x]))f,k,l,i,j]+(Subscript[Kδ, x,i])(
γ[-(Subscript[ϵ, 45])(Subscript[b, k])g(∂_(Subscript[b, x]))f,i,j]+δa[(Subscript[ϵ, 46])(Subscript[b, k])g(∂_(Subscript[b, x]))f,i,j]-δa[(Subscript[ϵ, 47])(Subscript[b, i])g(∂_(Subscript[b, x]))f,k,j]-a[(Subscript[ϵ, 25])(Subscript[b, k])f g,i,j]+a[(Subscript[ϵ, 25])(Subscript[b, i])f g,k,j]+ca[(Subscript[ϵ, 26])f g, j,k,l]-ca[(Subscript[ϵ, 26])f g,l,k,j]
)
),
p[a[f_,i_,j_], c[g_,k_]] :> -(Subscript[ϵ, 27])(Subscript[Kδ, i,x])(Subscript[Kδ, k,y])γ[f g,i,j],
p[a[f_,i_,j_], δa[g_,k_,l_]] :> (Subscript[ϵ, 28])(Subscript[Kδ, x,i])(Subscript[Kδ, y,l])(-δa[(Subscript[b, k])f g,i,j]+δa[(Subscript[b, i])f g,k,j]),
p[a[f_,i_,j_], ca[g_,k_,l_,m_]] :> (Subscript[Kδ, x,i])(
-(Subscript[ϵ, 29])(Subscript[Kδ, y,k])γa[f g,i,j,l,m]+(Subscript[ϵ, 30])(Subscript[Kδ, y,m])(-ca[(Subscript[b, l])f g,k,i,j]+ca[(Subscript[b, i])f g,k,l,j])-(Subscript[ϵ, 31])(Subscript[Kδ, y,k,m])γ[(Subscript[b, l])f g,x,j]
),
p[a[f_,i_,j_], δaa[g_,k_,l_,m_,n_]] :> (Subscript[Kδ, x,i])(
(Subscript[ϵ, 32])(Subscript[Kδ, y,l])(-δaa[(Subscript[b, k])f g,i,j,m,n]+δaa[(Subscript[b, i])f g,k,j,m,n]) + (Subscript[ϵ, 33])(Subscript[Kδ, y,n])(-δaa[(Subscript[b, m])f g,k,l,i,j]+δaa[(Subscript[b, i])f g,k,l,m,j])+(Subscript[ϵ, 34])(Subscript[Kδ, y,l,n])(δa[(Subscript[b, x])(Subscript[b, m])f g,k,j]-δa[(Subscript[b, k])(Subscript[b, m])f g,x,j])
),
p[_δβ|_c,_a] -> 0,
p[δa[f_,i_,j_], a[g_,k_,l_]] :> (Subscript[ϵ, 35])(Subscript[Kδ, x,i])(Subscript[Kδ, y,l])(-δa[(Subscript[b, k])f g,i,j]+δa[(Subscript[b, i])f g,k,j]),
p[ca[f_,m_,i_,j_], a[g_,k_,l_]] :> (Subscript[ϵ, 36])(Subscript[Kδ, x,i])(Subscript[Kδ, y,l])(-ca[(Subscript[b, k])f g,m,i,j]+ca[(Subscript[b, i])f g,m,k,j]),
p[δaa[f_,i_,j_,m_,n_], a[g_,k_,l_]] :> (Subscript[ϵ, 37])(Subscript[Kδ, x,i])(Subscript[Kδ, y,l])(-δaa[(Subscript[b, k])f g,i,j,m,n]+δaa[(Subscript[b, i])f g,k,j,m,n]) + (Subscript[ϵ, 38])(Subscript[Kδ, x,m])(Subscript[Kδ, y,l])(-δaa[(Subscript[b, k])f g,i,j,m,n]+δaa[(Subscript[b, m])f g,i,j,k,n])
}]]]];
htb[x_,y_][L_UU,R_UU] := -thb[y,x][R,L];

(Subscript[t, 1])(Subscript[h, 1])(Subscript[t, 2])(Subscript[h, 2]) -> (Subscript[t, 1])(Subscript[t, 2])(Subscript[h, 1])(Subscript[h, 2]) -> (Subscript[t, 2])(Subscript[t, 1])(Subscript[h, 1])(Subscript[h, 2]) -> (Subscript[t, 2])(Subscript[t, 1])(Subscript[h, 2])(Subscript[h, 1]) -> (Subscript[t, 2])(Subscript[h, 2])(Subscript[t, 1])(Subscript[h, 1]):

db[x_][u_UU,v_UU] := Module[{t,h}, Plus[
htb[x,x][u//tσ[x,t],v//hσ[x,h]] // tm[t,x,x] // hm[x,h,x],
tb[x][u,v//hσ[x,h]] // hm[x,h,x],
hb[x][u,v//tσ[x,t]] // tm[t,x,x],
thb[x,x][u//hσ[x,h],v//tσ[x,t]] // tm[t,x,x] // hm[x,h,x]
]];

bb[S_List] := Module[{w,bar,t,n=0},
bar[x_] := -x;
w=#2//dσ[S,bar/@S];
Sum[
t=db[S[[k]]][#1,w // dσ[bar[S[[k]]], S[[k]]]];
Do[t=t//dm[bar[S[[i]]], S[[i]], S[[i]]], {i,1,k-1}];
Do[t=t//dm[S[[i]], bar[S[[i]]], S[[i]]], {i,k+1,Length@S}];
t,
{k,Length@S}
]
]&
bb[S___] := bb[{S}]

ct (contract)

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[_β|_δβ,_] -> 0,
p[a[f_,i_,h], β[g_]] :> β[f (Subscript[b, i])(((∂_(Subscript[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])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), j,k],
p[a[f_,i_,h], c[g_,j_]] :> c[f (Subscript[b, i])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), j],
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])(((∂_(Subscript[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])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), l,j,k],
p[a[f_,i_,h], δaa[g_,t,j_,t,k_]]  -> 0,
p[a[f_,i_,h], δaa[g_,t,j_,k_,l_]] :> δaa[f(g/.(Subscript[b, t])->0), i,j,k,l],
p[a[f_,i_,h], δaa[g_,j_,k_,t,l_]] :> δaa[f(g/.(Subscript[b, t])->0), j,k,i,l],
p[a[f_,i_,h], δaa[g_,j_,k_,l_,m_]] :> δaa[f (Subscript[b, i])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), j,k,l,m],
p[a[__], _] -> 0,
p[c[f_,h], β[g_]] :> δβ[f (((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0)],
p[_c,_β]->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_]] :> δa[f(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), j,k],
p[_c,_a]->0,
p[_c|_δa|_ca|_δaa, _δβ|_c|_δa|_ca|_δaa] -> 0,
p[δa[f_,i_,h], β[g_]] :> δβ[f (Subscript[b, i])(((∂_(Subscript[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])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), j,k],
p[_δa,_] -> 0,
p[ca[_,h,_,h], _] -> 0,
p[ca[f_,h,i_,j_], β[g_]] :> δa[f(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), i,j],
p[ca[f_,i_,j_,h], β[g_]] :> c[f (Subscript[b, j])(((∂_(Subscript[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_]] :> δaa[f(((∂_(Subscript[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])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), i,k,l],
p[_ca,_] -> 0,
p[δaa[_,_,h,_,h], _] -> 0,
p[δaa[f_,i_,h,j_,k_], β[g_]] :> δa[f (Subscript[b, i])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0),j,k],
p[δaa[f_,i_,h,j_,k_], a[g_,t,l_]] :> δaa[f (g/.(Subscript[b, t])->0),i,l,j,k],
p[δaa[f_,i_,h,j_,k_], a[g_,l_,m_]] :> δaa[f (Subscript[b, i])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), j,k,l,m],
p[δaa[f_,i_,j_,k_,h], β[g_]] :> δa[f (Subscript[b, k])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), i,j],
p[δaa[f_,i_,j_,k_,h], a[g_,t,l_]] :> δaa[f (g/.(Subscript[b, t])->0),i,j,k,l],
p[δaa[f_,i_,j_,k_,h], a[g_,l_,m_]] :> δaa[f (Subscript[b, k])(((∂_(Subscript[b, t]))g) /. (Subscript[b, t])->0), i,j,l,m],
p[_δaa, _] -> 0
}]]];