Pensieve header: Testing and implementing lemmas 1,2,3 of the DoPeGDO handouts. Continues pensieve://2019-12/, continued pensieve://2020-03/.

Goals:
Implement the container 𝔼[ω,Q,P]:=ω (e^(Q+P)).
Implement the containers (Subscript[|F,ℰ|, B]):= (Subscript[[F:ℰ], B]) and (Subscript[⟨F,ℰ⟩, B]):= (Subscript[⟨F:ℰ⟩, B]), their evaluator (Subscript[Ev, k]) as power series in ℏ to degree k, and verify lemmas 1, 2, and 3. Inserting ℏ in the appropriate places is user responsibility.
Implement DaGauss, DeLin, and a Lemma 3 evaluator, PEv.

Utilities

HL[ℰ_] := Style[ℰ, Background -> If[TrueQ@ℰ,,]];

Generic Polynomials:

GenericPolynomial[d_Integer, vars_List, gc_] := Total[Map[
(Subscript[gc, Sequence@@#])Times@@((vars^(#)))&,
Join@@(Permutations /@ IntegerPartitions[d+Length@vars,{Length@vars}])-1
]];
GenericPolynomial[specs_List, vars_List, gc_] := Sum[GenericPolynomial[specs[[1]],vars,gc],specs]

Preliminary Definitions

Unprotect[SeriesData];
Expand[sd_SeriesData] ^:= MapAt[Expand,sd,3];
Protect[SeriesData];

CF[(Subscript[⟨F_,ℰ_⟩, B_])]:=(Subscript[⟨Simplify@F,Simplify@ℰ⟩, B]);

Variables and their duals:

{(SuperStar[t]),(SuperStar[b]),(SuperStar[y]),(SuperStar[a]),(SuperStar[x]),(SuperStar[z])}={τ,β,η,α,ξ,ζ}; 
{(SuperStar[τ]),(SuperStar[β]),(SuperStar[η]),(SuperStar[α]),(SuperStar[ξ]),(SuperStar[ζ])}={t,b,y,a,x,z}; (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]); (SuperStar[(B_List)]):=(SuperStar[#])&/@B;

Act and Contract:

(Subscript[Ev, k_])@(Subscript[\[LeftBracketingBar]F_,ℰ_\[RightBracketingBar], B_]):=Expand[Total[
CoefficientRules[Normal@Series[(E^((SuperStar[B]).F.(SuperStar[B])/2)),{ℏ,0,k}],(SuperStar[B])] /. (ps_->c_) :> c D[ℰ,Sequence@@Thread[{B,ps}]]
]+((O[ℏ])^(k+1))];
(Subscript[Ev, k_])@(Subscript[⟨F_,ℰ_⟩, B_]):= (Subscript[Ev, k])@(Subscript[\[LeftBracketingBar]F,ℰ\[RightBracketingBar], B])/.Alternatives@@B->0

{(Subscript[Ev, 2])@(Subscript[\[LeftBracketingBar]ℏ(({{0, 1}, {1, 0}})),(E^(x y))\[RightBracketingBar], {x,y}]),(Subscript[Ev, 3])@(Subscript[⟨ℏ(({{0, 1}, {1, 0}})),(E^(3x y))⟩, {x,y}])}

Testing Lemma 1

{p=10,B={x}, ℐ=IdentityMatrix@Length@B,F=ℏ{{f}}, G={{g}}, ℰ=GenericPolynomial[{d,0,4},B,c]}
lhs=(Subscript[Ev, p])@(Subscript[⟨F,ℰ (E^(B.G.B/2))⟩, B])
rhs=(Subscript[Ev, p])@(Subscript[⟨F.Inverse[ℐ-G.F],((Det[ℐ- G.F])^(-1/2))ℰ⟩, B]);
HL[lhs==rhs]

{p=2,B={x,y}, ℐ=IdentityMatrix@Length@B,F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[⟨F,ℰ (E^(B.G.B/2))⟩, B])]
rhs=(Subscript[Ev, p])@(Subscript[⟨F.Inverse[ℐ-G.F],((Det[ℐ- G.F])^(-1/2))ℰ⟩, B]);
HL[lhs==rhs]

{p=2,B={x,y}, ℐ=IdentityMatrix@Length@B,F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[⟨F,ℰ (E^(B.G.B/2))⟩, B])]
rhs=Expand[Series[((Det[ℐ- G.F])^(-1/2)),{ℏ,0,p}](Subscript[Ev, p])[(Subscript[⟨F.Inverse[ℐ-G.F],ℰ⟩, B])]]
HL[lhs==rhs]

{p=2,B={x,y}, ℐ=IdentityMatrix@Length@B,F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,ℰ (E^(B.G.B/2))\[RightBracketingBar], B])];
rhs=Series[((Det[ℐ- G.F])^(-1/2))(E^(B.G.Inverse[ℐ-F.G].B/2)),{ℏ,0,p}]((Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F.Inverse[ℐ-G.F],ℰ\[RightBracketingBar], B])/.Thread[B->Inverse[ℐ-F.G].B]);
HL@FullSimplify[Normal[lhs-rhs]==0]

Variants of Lemma 1

{p=2,B={x,y}, ℐ=IdentityMatrix@Length@B,F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,ℰ (E^(B.G.B/2))\[RightBracketingBar], B])];
rhs=Series[((Det[ℐ- F.G])^(-1/2))(E^(B.G.Inverse[ℐ-F.G].B/2)),{ℏ,0,p}]((Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F.Inverse[ℐ-G.F],ℰ\[RightBracketingBar], B])/.Thread[B->Inverse[ℐ-F.G].B]);
HL@FullSimplify[Normal[lhs-rhs]==0]

{p=1,B={x,y}, ℐ=IdentityMatrix@Length@B,F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,ℰ (E^(B.G.B/2))\[RightBracketingBar], B])];
rhs=Series[((Det[ℐ- G.F])^(-1/2))(E^(B.F.Inverse[ℐ-G.F].B/2)),{ℏ,0,p}]((Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F.Inverse[ℐ-G.F],ℰ\[RightBracketingBar], B])/.Thread[B->Inverse[ℐ-F.G].B]);
HL@FullSimplify[Normal[lhs-rhs]==0]

{p=1,B={x,y}, ℐ=IdentityMatrix@Length@B,F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,ℰ (E^(B.G.B/2))\[RightBracketingBar], B])];
rhs=Series[((Det[ℐ- G.F])^(-1/2))(E^(B.G.Inverse[ℐ-F.G].B/2)),{ℏ,0,p}]((Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F.Inverse[ℐ-G.F],ℰ\[RightBracketingBar], B])/.Thread[B->Inverse[ℐ-G.F].B]);
HL@FullSimplify[Normal[lhs-rhs]==0]

Implementing Lemma 1

DeGauss@(Subscript[⟨F_,ℰ_⟩, B_]):= Module[{ℐ,Q,G,M,Δ},
ℐ=IdentityMatrix@Length@B;
Q=Log[Normal[ℰ]/.ϵ->0];
G=Table[(∂_(i,j))Q,{i,B},{j,B}];
M=Inverse[ℐ-G.F];
Δ=Simplify@Det@M;
CF@(Subscript[⟨F.M,(Δ^(1/2))ℰ (E^(-B.G.B/2))⟩, B])
]

{p=2,B={x,y},F=ℏ(({{(Subscript[f, 11]), (Subscript[f, 12])}, {(Subscript[f, 12]), (Subscript[f, 22])}})), G=(({{(Subscript[g, 11]), (Subscript[g, 12])}, {(Subscript[g, 12]), (Subscript[g, 22])}})),  ℰ=1+ϵ GenericPolynomial[{d,0,2},B,c]};
lhs=(Subscript[⟨F,ℰ (E^(B.G.B/2))⟩, B])
rhs=DeGauss@(Subscript[⟨F,ℰ (E^(B.G.B/2))⟩, B])
HL[(Subscript[Ev, p])@lhs==(Subscript[Ev, p])@rhs]

Implementing / Testing Lemma 2

{n=2,p=2,B=Table[(Subscript[z, i]),{i,n}],ℐ=IdentityMatrix@Length@B, Y=Table[(Subscript[y, i]),{i,n}],F=ℏ Table[(Subscript[f, {10,1}.Sort[{i,j}]]), {i,n},{j,n}],ℰ=1+ϵ GenericPolynomial[{d,0,3},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[⟨F,ℰ (E^(Y.B))⟩, B])]
Timing[rhs=(Subscript[Ev, p])@(Subscript[⟨F,(E^(Y.F.Y/2))ℰ /.Thread[B->B+F.Y]⟩, B])]
HL@Expand[lhs==rhs]

{n=2,p=2,B=Table[(Subscript[z, i]),{i,n}],ℐ=IdentityMatrix@Length@B, Y=Table[(Subscript[y, i]),{i,n}],F=ℏ Table[(Subscript[f, {10,1}.Sort[{i,j}]]), {i,n},{j,n}],ℰ=1+ϵ GenericPolynomial[{d,0,3},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,ℰ (E^(Y.B))\[RightBracketingBar], B])] // Short
Timing[rhs=(E^(Y.B))(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,(E^(Y.F.Y/2))ℰ /.Thread[B->B+F.Y]\[RightBracketingBar], B])];
HL@Expand[lhs==rhs]

{n=2,p=2,B=Table[(Subscript[z, i]),{i,n}],ℐ=IdentityMatrix@Length@B, Y=Table[(Subscript[y, i]),{i,n}],F=ℏ Table[(Subscript[f, {10,1}.Sort[{i,j}]]), {i,n},{j,n}],ℰ=1+ϵ GenericPolynomial[{d,0,3},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,ℰ (E^(Y.B))\[RightBracketingBar], B])] // Short
Timing[rhs=(E^(Y.B))((Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]F,(E^(Y.F.Y/2))ℰ \[RightBracketingBar], B])/.Thread[B->B+F.Y])];
HL@Expand[lhs==rhs]

DeLin@(Subscript[⟨F_,ℰ_⟩, B_]):= Module[{L,Y},
L=PowerExpand@Log[Normal[ℰ]/.ϵ->0];
Y=Table[(∂_i)L,{i,B}];
CF@(Subscript[⟨F,(E^(Y.F.Y/2))((E^(-B.Y))ℰ/.Thread[B->B+F.Y])⟩, B])
]

{n=2,p=2,B=Table[(Subscript[z, i]),{i,n}], Y=Table[(Subscript[y, i]),{i,n}],F=ℏ Table[(Subscript[f, {10,1}.Sort[{i,j}]]), {i,n},{j,n}],ℰ=1+ϵ GenericPolynomial[{d,0,3},B,c]}
Timing[lhs=(Subscript[Ev, p])@(Subscript[⟨F,ℰ (E^(Y.B))⟩, B])]
Timing[rhs=(Subscript[Ev, p])@DeLin@(Subscript[⟨F,ℰ (E^(Y.B))⟩, B])]
HL@Simplify[lhs==rhs]

Testing Lemma 3

{n=2,p=2,B=Table[(Subscript[b, i]),{i,n}],F=ℏ Table[(Subscript[f, {10,1}.Sort[{i,j}]]), {i,n},{j,n}], P=GenericPolynomial[{d,0,2},B,c]}

Z=PowerExpand@Expand@Log[(Subscript[Ev, p])@(Subscript[\[LeftBracketingBar]λ F,(E^P)\[RightBracketingBar], B])]

Z/.λ->0

(Z/.λ->0)-P

lhs=(∂_λ)Z

Short[rhs=Expand@Sum[((∂_(b1,b2))(B.F.B))((∂_(b1,b2))Z+((∂_b1)Z)((∂_b2)Z))/4,{b1,B},{b2,B}]]

HL[Normal[lhs-rhs]==0]

Z /. λ->1 /.Alternatives@@B->0