Pensieve header: Testing lemmas 1,2,3 of the DoPeGDO handouts.

Goal:
Implement (Subscript[Act, k,B])[F,ℰ] := (Subscript[[F,ℰ], B]) and (Subscript[Contract, k,B])[F,ℰ] := (Subscript[⟨F,ℰ⟩, B]) as power series in ℏ, to degree k, and verify lemmas 1, 2, and 3. Inserting ℏ in the appropriate places is user responsibility.

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]

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[Act, k_,B_])[F_,ℰ_]:=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[Contract, k_,B_])[F_,ℰ_]:= (Subscript[Act, k,B])[F,ℰ]/.Alternatives@@B->0

(Subscript[Act, 2,{x}])[ℏ{{1}},(E^(x x))]

Log@(Subscript[Contract, 10,{x}])[ℏ{{1}},(E^(x x))]

(Subscript[Act, 2,{x,y}])[ℏ(({{0, 1}, {1, 0}})),(E^(x y))]

(Subscript[Contract, 3,{x,y}])[ℏ(({{0, 1}, {1, 0}})),(E^(3x y))]

Testing Lemma 1.

{p=10,B={x}, F=ℏ{{f}}, G={{g}}, ℰ=GenericPolynomial[{d,0,4},B,c]}

lhs=Simplify@(Subscript[Contract, p,{x}])[F,ℰ (E^(B.G.B/2))]

rhs=Simplify[Series[
((Det[{{1}}- G.F])^(-1/2))(Subscript[Contract, p,{x}])[F.Inverse[{{1}}-G.F],ℰ ],
{ℏ,0,p}
]]

Simplify[lhs/rhs]

{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])}})), ℰ=GenericPolynomial[{d,0,2},B,c]}

lhs=Simplify@(Subscript[Contract, p,B])[F,ℰ (E^(B.G.B/2))]

rhs=Simplify[Series[
((Det[(({{1, 0}, {0, 1}}))-G.F])^(-1/2))(Subscript[Contract, p,B])[F.Inverse[(({{1, 0}, {0, 1}}))-G.F],ℰ ],
{ℏ,0,p}
]]

Simplify[lhs/rhs]

Testing Lemma 2.

{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}], ℰ=GenericPolynomial[{d,0,3},B,c]}

lhs=Simplify@(Subscript[Contract, p,B])[F,ℰ (E^(Y.B))]

rhs=Simplify[Series[
(E^(Y.F.Y/2))(Subscript[Contract, p,B])[F,ℰ /.Thread[B->B+F.Y]],
{ℏ,0,p}]]

Simplify[lhs==rhs]

Testing Lemma 3.

{n=2,p=3,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]}

Short[Z=Simplify@PowerExpand@Simplify@Log[(Subscript[Act, p,B])[λ F,(E^P)]],5]

Simplify[Z/.λ->0]

Simplify[(Z/.λ->0)==P]

lhs=(∂_λ)Z

B.F.B // Expand

Table[(∂_(b1,b2))(B.F.B)/2, {b1,B},{b2,B}]//MatrixForm

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

Simplify[lhs==rhs]