Pensieve header:  The Engine, with Zip3 encapsulation.

The Engine

Canonical Forms:

CCF[ℰ_] := (Subscript[PP, CCF])@Factor[ℰ]; (*Coefficient Canonical Form *)
LogReduce[ℰ_]:=ℰ/.c_*Log[a_]:>Log@Factor[(a^c)]//.Log[a_]+Log[b_]:>Log@Factor[a b];
CF[ℰ_] := (Subscript[PP, CF])@Module[
{vs=Cases[ℰ,(Subscript[(y|a|x|η|β|τ|ξ), _]),∞]⋃{y,a,x,η,β,τ,ξ}},
Total[(CCF[#[[2]]](Times@@(vs^(#[[1]]))))& /@ CoefficientRules[ℰ, vs]]
];
CF[ℰ_𝔼]:=CF/@MapAt[LogReduce,ℰ,1];
CF[U_𝕌]:=CF/@MapAt[LogReduce,U,1]; 
CF[ℰ_List]:=CF/@ℰ; 
CF[(Subscript[𝔼, sp___])[ℰs___]]:=CF/@(Subscript[𝔼, sp])[ℰs];
CF[(Subscript[𝕌, sp___])[Us___]]:=CF/@(Subscript[𝕌, sp])[Us];

Logging CCF

$MaxTime=0;
$CCFLogFile=OpenWrite[EchoLabel["CCFLogFile is"]@StringJoin[
"CCFLog-",StringReplace[":"->"-"][DateString["ISODateTime"]],".m"
]];
CCF[ℰ_]:=(Subscript[PP, CCF])@Module[{ti=TimeUsed[], r},
r=Together[ℰ];
If[TimeUsed[]-ti>$MaxTime,
$MaxTime=TimeUsed[]-ti;
Write[$CCFLogFile, {Echo@$MaxTime, ℰ}]
];
r]

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[(vs_List)]):=(v|->(SuperStar[v]))/@vs;
(SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]);
ϝ[(Subscript[u_, i_])]:=ϝ[(Subscript[u, i])]=(Subscript[ToExpression["ϝ"<>ToString[u]], i])

Weights:

Clear[Wt];
Evaluate[Wt/@{y,b,t,a,x,η,β,τ,α,ξ}]={1,0,0,2,1,1,2,2,0,1};
Wt[(Subscript[u_, i_])]:=Wt[u];

The maximal weight $n, i.e. the n of gl(n). Initially and for a long while this will not be tested beyond $n==2.

$n=2;

Upper to lower and lower to Upper:

U2l[ℰ_]:=ℰ/.{(Subscript[B, i_]^(p_.)):>(E^(-p ℏ (Subscript[b, i]))),(B^(p_.)):>(E^(-p ℏ b)), (Subscript[T, i_]^(p_.)):>(E^(p ℏ (Subscript[t, i]))),(T^(p_.)):>(E^(p ℏ t)),(Subscript[𝒜, i_]^(p_.)):>(E^(p (Subscript[α, i]))),(𝒜^(p_.)):>(E^(p α))}; 
l2U[ℰ_]:=ℰ//.{(E^(c_.(Subscript[b, i_])+d_.)):>(Subscript[B, i]^(-c/ℏ))(E^d),(E^(c_.b+d_.)):>(B^(-c/ℏ))(E^d),(E^(c_.(Subscript[t, i_])+d_.)):>(Subscript[T, i]^(c/ℏ))(E^d),(E^(c_.t+d_.)):>(T^(c/ℏ))(E^d),
(E^(c_.(Subscript[α, i_])+d_.)):>(Subscript[𝒜, i]^c)(E^d),(E^(c_.α+d_.)):>(𝒜^c)(E^d),(E^(𝒳_)):>(E^(Expand@l2U@𝒳))};
l2U[r_Rule]:=Module[{U=r[[1]]/.{b->B,t->T,α->𝒜}},U->l2U[U2l[U]/.r]];
AlsoUpper[rs_List] := rs⋃(l2U/@rs);

Derivatives in the presence of exponentiated variables:

(Subscript[D, b])[f_]:=(∂_b)f-ℏ B(∂_B)f; (Subscript[D, (Subscript[b, i_])])[f_]:=(∂_(Subscript[b, i]))f-ℏ (Subscript[B, i])(∂_(Subscript[B, i]))f;
(Subscript[D, t])[f_]:=(∂_t)f+ℏ T(∂_T)f; (Subscript[D, (Subscript[t, i_])])[f_]:=(∂_(Subscript[t, i]))f+ℏ (Subscript[T, i])(∂_(Subscript[T, i]))f; 
(Subscript[D, α])[f_]:=(∂_α)f+𝒜 (∂_𝒜)f; (Subscript[D, (Subscript[α, i_])])[f_]:=(∂_(Subscript[α, i]))f+(Subscript[𝒜, i]) (∂_(Subscript[𝒜, i]))f;
(Subscript[D, v_])[f_]:=(∂_v)f;

𝔼 operations:

ℰ_𝔼[$]:=Length[ℰ]-1; (Subscript[𝔼, _])[ℰs___][$]:=𝔼[ℰs][$];ℰ_𝔼[k_Integer]:=ℰ[[k+1]]; (Subscript[𝔼, _])[ℰs___][k_Integer]:={ℰs}[[k+1]];
𝔼/:ℰ1_𝔼≡ℰ2_𝔼:=Inner[CF@#1==CF@#2&, ℰ1,ℰ2,And];
(Subscript[𝔼, d1_->r1_])[ℰ1s___]≡(Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (d1==d2)∧(r1==r2)∧(𝔼[ℰ1s]≡𝔼[ℰ2s]);
𝔼/:ℰ1_𝔼*ℰ2_𝔼:=𝔼@@Table[CF[ℰ1[kk]+ℰ2[kk]],{kk,0,Min[ℰ1[$],ℰ2[$]]}];
(Subscript[𝔼, d1_->r1_])[ℰ1s___](Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[ℰ1s]𝔼[ℰ2s]);

(Subscript[𝔼, d1_->r1_])[ℰ1s___]//(Subscript[𝔼, d2_->r2_])[ℰ2s___] :=Module[{is=r1⋂d2,lvs},
lvs=Flatten@Table[{(Subscript[y, $@i]),(Subscript[b, $@i]),(Subscript[t, $@i]),(Subscript[a, $@i]),(Subscript[x, $@i])},{i,is}];
(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@((Subscript[Zip, lvs⋃(SuperStar[lvs])])[{(ϝ/@(SuperStar[lvs])).(ϝ/@lvs),Times[
𝔼[ℰ1s]/.Table[(Subscript[(v:b|B|t|T|a|x|y), i])->(Subscript[v, $@i]),{i,is}],
𝔼[ℰ2s]/.Table[(Subscript[(v:β|τ|α|𝒜|ξ|η), i])->(Subscript[v, $@i]),{i,is}]
]}])
]

(Subscript[Λ2𝔼, d_->r_])[Λ_]:=Module[{k},(Subscript[𝔼, d->r])@@l2U@Table[SeriesCoefficient[Λ,{ϵ,0,k}],{k,0,$k}]];

Zipping! Lemmas 2 and 3 are combined, yet they must be applied first to the middle weight variables and then to the heavy and light variables.

Comment. Zip3 of the outer variables must occur after all other operations are completed, because we must allow for gluings of the weight n variables in perturbations with the weight 0 variables in the coefficients of Q.

(Subscript[Zip, vs_])[{ℱ_,ℰ_}]:={ℱ,ℰ}//(Subscript[Zip1, vs])(*//(Subscript[Zip2, Select[vs,(0<Wt[#]<$n)&]])*)//(Subscript[Zip2, Select[vs,(Wt[#]==0∨Wt[#]==$n)&]])//(Subscript[EZip3, Select[vs,(0<Wt[#]<$n)&]])//(Subscript[Zip3, Select[vs,(Wt[#]==0∨Wt[#]==$n)&]])//Last;

Getting rid of the quadratic.

(Subscript[Zip1, {}])=Identity;
(Subscript[Zip1, vs_])@{ℱ_,𝔼[Q_,P___]} := (Subscript[PP, Zip1])@Module[{ℐ,F,G,u,v},
ℐ=IdentityMatrix@Length@vs;
F=Table[If[Wt[u]+Wt[v]==$n,(∂_(ϝ[u],ϝ[v]))ℱ,0],{u,vs},{v,vs}];
G=Table[If[Wt[u]+Wt[v]==$n,(∂_(u,v))Q,0],{u,vs},{v,vs}];
{CF[(ϝ/@vs).(F.Inverse[ℐ-G.F]).(ϝ/@vs)/2], 𝔼[CF[Q-PowerExpand@Log[Det[ℐ- G.F]]/2-vs.G.vs/2],P]}
]

Getting rid of linear terms.

(Subscript[Zip2, {}])=Identity;
(Subscript[Zip2, vs_])@{ℱ_,𝔼[Q_,P___]} := (Subscript[PP, Zip2])@Module[{F,Y,u,v},
F=Table[If[Wt[u]+Wt[v]==$n,CF[(∂_(ϝ[u],ϝ[v]))ℱ],0],{u,vs},{v,vs}];
Y=Table[(∂_v)Q,{v,vs}]/.AlsoUpper@Table[v->0,{v,vs}];
CF/@({ℱ, 𝔼[Q-Y.vs+Y.F.Y/2, P]}/.AlsoUpper@Thread[vs->vs+F.Y])
]

Dealing with Feynman diagrams.

Note that the power m of λ is at most k-1+((2k+2)/2)=2k. We write (Subscript[Z, λ])=∑Z[m](λ^m).

(Subscript[Zip3, vs_])@{ℱ_,ℰ_𝔼} := (Subscript[PP, Zip3])@Module[{F,u,v,Z,$k,kk,jj,$m=0,m,n},
$k=Length[ℰ]-1;
Do[Z[0,kk]=ℰ[[kk+1]],{kk,0,$k}];
F[u_,v_]:=F[u,v]=CF@If[Wt[u]+Wt[v]==$n,(∂_(ϝ[u],ϝ[v]))ℱ,0];
Z[m_,kk_,u_]:=Z[m,kk,u]=(Subscript[D, u])[Z[m,kk]];
Z[m_,kk_,u_,v_]:=Z[m,kk,u,v]=(Subscript[D, v])[Z[m,kk,u]];
For[m=0,m≤2$m,++m,For[kk=0,kk≤$k,++kk,
Z[m+1,kk]=CF@Sum[
If[F[u,v]===0,0,((F[u,v])/(2(m+1)))(Z[m,kk,u,v]+Sum[Z[n,jj,u]*Z[m-n,kk-jj,v],{n,0,m},{jj,0,kk}])],
{u,vs},{v,vs}];
If[Z[m+1,kk]=!=0, $m=m+1]
]];
CF/@({
ℱ-Sum[F[u,v]*ϝ[u]*ϝ[v]/2,{u,vs},{v,vs}],
𝔼@@Table[Sum[Z[m,kk],{m,0,$m}],{kk,0,$k}]
}/.AlsoUpper@Table[v->0,{v,vs}])
]

Encapsulation.

(Subscript[EZip3, vs_])@{ℱ_,ℰ_𝔼} := (Subscript[PP, EZip3])@Module[
{nℰ,nℱ,rc,ps,rr={(*release rules*)},ϝvs},
rc=0; nℰ=Total[
CoefficientRules[#, vs] /. (ps_->c_) :> (AppendTo[rr,cℰ[++rc]->c]; cℰ[rc](Times@@(vs^ps)))
]& /@ ℰ;
rc=0; ϝvs=ϝ/@vs;nℱ=Total[CoefficientRules[ℱ, ϝvs] /. (ps_->c_) :> (AppendTo[rr,cℱ[++rc]->c]; cℱ[rc](Times@@((ϝvs)^ps)))];
CF[Expand[{nℱ,nℰ}//(Subscript[Zip3, vs])]/.rr]
]

Exponentials and logarithms as in Exp.nb

Task. Define  (Subscript[Exp, m])[U:(Subscript[𝕌, {___}->{i_}])[__]] to compute (e^(𝕆(U))) to order (ϵ^(Length@{U}-1)) using the (Subscript[m, i,i->i]) multiplication, where U is an ϵ-dependent sub-balanced near-docile element, giving the answer in 𝔼-form.
Example: (Subscript[Exp, dm,1])[(Subscript[𝕌, {}->{2}])[(Subscript[b, 2])(Subscript[a, 2])+(Subscript[y, 2])(Subscript[x, 2]),0]] is the exponential of the arrow on strand 2, computed to degree 1.

(Subscript[Exp, m_])[U:(Subscript[𝕌, is_->{i1_}])[__]]:=Module[{λ,μ,k,n,F,f,i,j,lhs,rhs,U1,MI(*multi-index*),mis,mi,yax},
MI/:Coefficient[ℰ_,MI[p_,n_,q_]]:=Coefficient[Coefficient[Coefficient[ℰ,(Subscript[y, i]),p],(Subscript[a, i]),n],(Subscript[x, i]),q];
yax/:(yax^(MI[p_,n_,q_])):=(Subscript[y, i]^p)(Subscript[a, i]^n)(Subscript[x, i]^q);
U1=U/.(Subscript[(v:(y|b|t|a|x|B|T|𝒜)), i1])->(Subscript[v, i]);
F=(Subscript[𝔼, is->{i}])[];
Do[AppendTo[F,0]; Do[
mis=Flatten@Table[MI[p,n,q],{p,0,Min[k+1,2k+2-2n]},{q,0,Min[k+1,2k+2-2n-p]}];
F[[-1]]+=Sum[(Subscript[f, mi])[λ](yax^mi),{mi,mis}];
lhs=((∂_μ)U2l@Last[F(F/.{λ->μ,i->j})//(Subscript[m, i,j->i])])/. μ->0/.(Subscript[f, _])[0]->0/.Table[(Subscript[f, mi])'[0]->Coefficient[U1[[k+1]],mi],{mi,mis}];
rhs=(∂_λ)U2l@Last[F];
F=l2U[F/.First@DSolve[Table[Coefficient[lhs-rhs,mi]==0∧(Subscript[f, mi])[0]==0, {mi,mis}],Table[(Subscript[f, mi]),{mi,mis}],λ]],
{n,k+1,0,-1}],{k,0,Length[U1]-1}];
CF@l2U[F/.{λ->1,i->i1}] ]

Logarithms

Task. Define  (Subscript[Log, m])[ℰ:(Subscript[𝔼, {___}->{i_}])[__]] to compute Log@𝕆[(e^ℰ)] to order (ϵ^(Length@{U}-1)) using the (Subscript[m, i,i->i]) multiplication, where ℰ is an ϵ-dependent sub-balanced docile element, giving the answer in 𝕌-form.

(Subscript[Log, m_])[ℰ:(Subscript[𝔼, is_->{i_}])[__]]:=Module[{e,k,n,G,c,g,eqn,Sanify,MI(*multi-index*),mis,mi,yax,p,q},
G=(Subscript[𝕌, is->{i}])[(Subscript[c, 1]) (Subscript[a, i])+(Subscript[c, 2])(Subscript[x, i]) (Subscript[y, i])]; eqn=U2l[Last[(Subscript[Exp, m])[G]]-ℰ[[1]]];
{eqn,G}=CF/@({eqn,G}/.First@Solve[Coefficient[eqn,(Subscript[a, i])]==0,(Subscript[c, 1])]);
Sanify[{{v_->s_}}]:=v->PowerExpand[Normal[s]/.(C[_])->0];
G=CF[G/.Sanify@Solve[Coefficient[eqn,(Subscript[x, i])(Subscript[y, i])]==0,(Subscript[c, 2])]];
G[[1]]+=(Subscript[c, 0])+(Subscript[c, 1])(Subscript[x, i])+(Subscript[c, 2])(Subscript[y, i]); eqn=U2l[Last[(Subscript[Exp, m])[G]]-ℰ[[1]]];
{eqn,G}=CF/@({eqn,G}/.First@Solve[Coefficient[eqn,(Subscript[x, i])]==0∧Coefficient[eqn,(Subscript[y, i])]==0,{(Subscript[c, 1]),(Subscript[c, 2])}]);
G=G/.First@Solve[eqn==0,(Subscript[c, 0])];
MI/:Coefficient[e_,MI[p_,n_,q_]]:=Coefficient[Coefficient[Coefficient[e,(Subscript[y, i]),p],(Subscript[a, i]),n],(Subscript[x, i]),q];
yax/:(yax^(MI[p_,n_,q_])):=(Subscript[y, i]^p)(Subscript[a, i]^n)(Subscript[x, i]^q);
Do[
mis=Flatten@Table[MI[p,n,q],{n,0,k+1},{p,0,Min[k+1,2k+2-2n]},{q,0,Min[k+1,2k+2-2n-p]}];
AppendTo[G,Sum[(Subscript[g, mi])(yax^mi),{mi,mis}]];
eqn=U2l[Last[(Subscript[Exp, m])[G]]-ℰ[[k+1]]];
G=CF[G/.First@Solve[Table[Coefficient[eqn,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]]],
{k,Length[ℰ]-1}];
CF[l2U@G]
]