Pensieve header: Exp relative to am, bm, cm, dm.

Follows code in Projects/SL2Portfolio/SL2PortfolioProgram.nb.

Startup

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Portfolio2"];
(*Once[<< KnotTheory`];*)
Once[<<"../Profile/Profile.m";];
<<"Engine-Speedy.m";
<<"Objects.m";
$k=3;
HL[ℰ_] := Style[ℰ, Background -> Green];

Exponentials as needed.

Task. Define  (Subscript[Exp, m,i,k])[λ,P] which computes (e^(λ 𝕆(P))) to (ϵ^k) in the using the (Subscript[m, i,i->i]) multiplication, where λ is a scalar and P is an ϵ-dependent near-docile element, giving the answer in 𝔼-form.
Methodology. If (Subscript[P, 0]):=(Subscript[P, ϵ=0]) and (e^(λ 𝕆(P)))=𝕆((e^(λ (Subscript[P, 0])))F(λ)), then F(λ=0)=1 and we have:
𝕆((e^(λ (Subscript[P, 0])))((Subscript[P, 0])F(λ)+(∂_λ)F))=𝕆((∂_λ)(e^(λ (Subscript[P, 0])))F(λ))=(∂_λ)𝕆((e^(λ (Subscript[P, 0])))F(λ))=(∂_λ)(e^(λ 𝕆(P)))=(e^(λ 𝕆(P)))𝕆(P)=𝕆((e^(λ (Subscript[P, 0])))F(λ))𝕆(P).
This is an ODE for F. Setting inductively (Subscript[F, k])=(Subscript[F, k-1])+(ϵ^k)φ we find that (Subscript[F, 0])=1 and solve for φ.

(* Bug: The first line is valid only if 𝕆((E^(Subscript[P, 0])))==(E^(𝕆((Subscript[P, 0])))). *)
(* Bug: λ must be a symbol. *)
(Subscript[Exp, m_,i_,0])[λ_,P_]:=Module[{LQ=Normal@P /. ϵ->0},
𝔼[λ LQ/.(Subscript[(x|y), i])->0, λ LQ/.(Subscript[(b|a|t), i])->0,1] ];
(Subscript[Exp, m_,i_,k_])[λ_,P_]:=Block[{$k=k},
Module[{P0,φ,φs,F,j,rhs,at0,atλ},
P0=Normal@P /. ϵ->0;
φs=Flatten@Table[(Subscript[φ, j1,j2,j3,j4])[λ],{j2,0,k},{j3,0,k-j2},{j1,0,2k+1-j2-j3},{j4,0,2k+1-j3-j2-j1}];
F=Normal@Last@(Subscript[Exp, m,i,k-1])[λ,P]+(ϵ^k)φs.(φs/.(Subscript[φ, js__])[λ]:>Times@@(({(Subscript[y, i]),(Subscript[b, i]),(Subscript[a, i]),(Subscript[x, i])})^({js})));
rhs=Normal@Last@(Subscript[m, i,j->i])[(Subscript[𝔼, {}->{i}])[λ P0/.(Subscript[(x|y), i])->0,λ P0/.(Subscript[(b|a|t), i])->0, F+((O[ϵ])^(k+1))](Subscript[𝔼, {}->{j}])[0,0,P+((O[ϵ])^(k+1))/.(Subscript[u_, i]):>(Subscript[u, j])]];
at0=(#==0)& /@ Flatten@CoefficientList[F-1 /. λ->0, {(Subscript[y, i]),(Subscript[b, i]),(Subscript[a, i]),(Subscript[x, i])}];
atλ=(#==0)& /@ Flatten@CoefficientList[((∂_λ)F)+P0 F-rhs, {(Subscript[y, i]),(Subscript[b, i]),(Subscript[a, i]),(Subscript[x, i])}];
(Subscript[𝔼, {}->{i}])[λ P0/.(Subscript[(x|y), i])->0,λ P0/.(Subscript[(b|a|t), i])->0, F+((O[ϵ])^(k+1))] /. DSolve[And@@(at0⋃atλ),φs,λ][[1]] ]
]

(Subscript[Exp, dm,1,2])[ξ,(Subscript[x, 1])+ϵ (Subscript[y, 1])]

(Subscript[dS, 1])[(Subscript[𝔼, {}->{1}])[0,0,#]]&/@{(Subscript[y, 1]),(Subscript[x, 1])}

Timing@{lhs=(Subscript[𝔼, {1}->{1}])[0,(Subscript[ξ, 1])(Subscript[x, 1]),1]//(Subscript[dS, 1]), rhs=(Subscript[Exp, dm,1,$k])[ξ,Last@(Subscript[dS, 1])[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[x, 1])]]] /. {ξ->(Subscript[ξ, 1]), {}->{1}}; HL[lhs≡rhs]}

Timing@{lhs=(Subscript[𝔼, {1}->{1}])[0,(Subscript[η, 1])(Subscript[y, 1]),1]//(Subscript[dS, 1]), rhs=(Subscript[Exp, dm,1,$k])[η,Last@(Subscript[dS, 1])[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[y, 1])]]] /. {η->(Subscript[η, 1]), {}->{1}}; HL[lhs≡rhs]}

Timing@{lhs=(Subscript[𝔼, {1}->{1}])[0,(Subscript[ξ, 1])(Subscript[x, 1]),1]//(Subscript[cS, 1]), rhs=(Subscript[Exp, cm,1,$k])[ξ,Last@(Subscript[cS, 1])[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[x, 1])]]] /. {ξ->(Subscript[ξ, 1]), {}->{1}}; HL[lhs≡rhs]}

Timing@{lhs=(Subscript[𝔼, {1}->{1}])[0,(Subscript[η, 1])(Subscript[y, 1]),1]//(Subscript[cS, 1]), rhs=(Subscript[Exp, cm,1,$k])[η,Last@(Subscript[cS, 1])[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[y, 1])]]] /. {η->(Subscript[η, 1]), {}->{1}}; HL[lhs≡rhs]}