Pensieve header: Exponentiation in  ybax algebras.

Startup

Date[]
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\FullDoPeGDO"];
Once[<<KnotTheory`];
Once[Get@"../Profile/Profile.m"];
BeginProfile[];
$k=1;
<<Engine.m
<<Objects.m
<<KT.m
HL[ℰ_] := Style[ℰ, Background -> If[TrueQ@ℰ,,]];

Exponentials

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 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.

m=cm;U=(Subscript[𝕌, {}->{i}])[(Subscript[a, i]) (Subscript[b, i])+(Subscript[x, i]) (Subscript[y, i]),(Subscript[x, i])+(Subscript[y, i]),(Subscript[x, i]^2)(Subscript[y, i])]

k=Length@{U}-1

Fa=(Subscript[𝔼, {}->{i}])[fa[λ](Subscript[a, i])];
Fa
Fa/.{λ->μ,i->j}

Fa(Fa/.{λ->μ,i->j})//(Subscript[m, i,j->i])

la=((∂_μ)First[Fa(Fa/.{λ->μ,i->j})//(Subscript[m, i,j->i])])/. μ->0/.{fa[0]->0, fa'[0]->(∂_(Subscript[a, i]))U[[1]]}

ra=((∂_μ)First[Fa/.λ->λ+μ])/.μ->0

Sa=DSolve[la==ra∧fa[0]==0, fa,λ][[1,1]]

F0=(Subscript[𝔼, {}->{i}])[f[λ]+fa[λ](Subscript[a, i])+fx[λ](Subscript[x, i])+fy[λ](Subscript[y, i])+fxy[λ](Subscript[x, i])(Subscript[y, i])]/.Sa;
F0
F0/.{λ->μ,i->j}

F0(F0/.{λ->μ,i->j})//(Subscript[m, i,j->i])

l0=((∂_μ)First[F0(F0/.{λ->μ,i->j})//(Subscript[m, i,j->i])])/. μ->0/.{(f|fx|fy|fxy)[0]->0}/. Thread[{f'[0],fx'[0],fy'[0],fxy'[0]}->({U[[1]],(∂_(Subscript[x, i]))U[[1]],(∂_(Subscript[y, i]))U[[1]],(∂_((Subscript[x, i]),(Subscript[y, i])))U[[1]]}/.(Subscript[(a|x|y), i])->0)]

r0=((∂_μ)First[F0/.λ->λ+μ])/.μ->0

UnDot[ℰ_,vs_]:=Thread[{Times@@(vs^(#[[1]])),#[[2]]}& /@CoefficientRules[ℰ,vs]];
UnDot[U[[1]],{(Subscript[a, i]),(Subscript[x, i]),(Subscript[y, i])}]

UnDot[l0-r0,{(Subscript[a, i]),(Subscript[x, i]),(Subscript[y, i])}]

{S0}=DSolve[(#==0)&/@UnDot[l0-r0,{(Subscript[a, i]),(Subscript[x, i]),(Subscript[y, i])}][[2]]⋃{f[0]==0,fx[0]==0,fy[0]==0,fxy[0]==0},{f,fx,fy,fxy},λ]

(F0/.{λ->μ,i->j})/.S0

κ=1;
F1=Append[F0/.S0,Total@Flatten@Table[(Subscript[f, m,p,q])[λ](Subscript[a, i]^m)(Subscript[x, i]^p)(Subscript[y, i]^q),{m,0,2κ+2,2},{p,0,2κ+2-2m},{q,0,2κ+2-2m-p}]]

{mons,fs}=UnDot[Last@F1,{(Subscript[a, i]),(Subscript[x, i]),(Subscript[y, i])}]

Alternatives@@(fs/.λ->0)

mis=Flatten@Table[MI[m,p,q],{m,0,2κ+2,2},{p,0,2κ+2-2m},{q,0,2κ+2-2m-p}]

MI/:Coefficient[ℰ_,MI[m_,p_,q_]]:=Coefficient[Coefficient[Coefficient[ℰ,(Subscript[a, i]),m],(Subscript[x, i]),p],(Subscript[y, i]),q]

axy/:(axy^(MI[m_,p_,q_])):=(Subscript[a, i]^m)(Subscript[x, i]^p)(Subscript[y, i]^q)

Table[(Subscript[f, Sequence@@mi])'[0]->Coefficient[U[[κ+1]],mi],{mi,mis}]

l1=((∂_μ)Last[F1(F1/.{λ->μ,i->j})//(Subscript[m, i,j->i])])/. μ->0/.Alternatives@@(fs/.λ->0)->0/.Table[(Subscript[f, Sequence@@mi])'[0]->Coefficient[U[[κ+1]],mi],{mi,mis}]

r1=((∂_μ)Last[F1/.λ->λ+μ])/.μ->0

l1-r1//CF

{S1}=DSolve[Table[Coefficient[l1-r1,mi]==0∧(Subscript[f, Sequence@@mi])[0]==0, {mi,mis}],Table[(Subscript[f, Sequence@@mi]),{mi,mis}],λ]

κ=2;
F2=Append[l2U[F1/.S1],Total@Flatten@Table[(Subscript[f, m,p,q])[λ](Subscript[a, i]^m)(Subscript[x, i]^p)(Subscript[y, i]^q),{m,0,2κ+2,2},{p,0,2κ+2-2m},{q,0,2κ+2-2m-p}]]

mis=Flatten@Table[MI[m,p,q],{m,0,2κ+2,2},{p,0,2κ+2-2m},{q,0,2κ+2-2m-p}]

l2=U2l[((∂_μ)Last[F2(F2/.{λ->μ,i->j})//(Subscript[m, i,j->i])])/. μ->0/.Alternatives@@(fs/.λ->0)->0/.Table[(Subscript[f, Sequence@@mi])'[0]->Coefficient[U[[κ+1]],mi],{mi,mis}]]

r2=((∂_μ)Last[F2/.λ->λ+μ])/.μ->0

{S2}=DSolve[Table[Coefficient[l2-r2,mi]==0∧(Subscript[f, Sequence@@mi])[0]==0, {mi,mis}],Table[(Subscript[f, Sequence@@mi]),{mi,mis}],λ]

l2U[F2/.S2/.λ->1]

Previous attempt

mons[i_]:=Flatten@Table[(ϵ^κ)(Subscript[a, i]^m)(Subscript[x, i]^p)(Subscript[y, i]^q),{κ,0,k},{m,0,2κ+2,2},{p,0,2κ+2-2m},{q,0,2κ+2-2m-p}];
mons[1]

fs[λ_]:=Flatten@Table[(Subscript[f, κ,m,p,q])[λ],{κ,0,k},{m,0,2κ+2,2},{p,0,2κ+2-2m},{q,0,2κ+2-2m-p}];
fs[μ]

F[λ_,i_]:=(Subscript[Λ2𝔼, {}->{i}])[fs[λ].mons[i]];
F[λ,i]
F[μ,j]

F[λ,i]F[μ,j]//(Subscript[m, i,j->i])

l1=((∂_μ)List@@(F[λ,i]F[μ,j]//(Subscript[m, i,j->i])))/.μ->0/.(Subscript[f, ___])[0]->0

r1=((∂_μ)List@@F[λ+μ,i])/.μ->0

eqs1=And@@((#==0)&/@Flatten@CoefficientList[l1-r1, {(Subscript[a, i]),(Subscript[x, i]),(Subscript[y, i])}])/.(Subscript[f, _])[0]->0

l2=Take[{U},1]

r2=((∂_μ)List@@F[μ,i])/.μ->0

eqs2=And@@((#==0)&/@Flatten@CoefficientList[l2-r2, {(Subscript[a, i]),(Subscript[x, i]),(Subscript[y, i])}])

eqs3=eqs1/.{(Subscript[f, 5])'[0]->1,(Subscript[f, 2])'[0]->(Subscript[b, 2]),(Subscript[f, _])'[0]->0}

DSolve[(Subscript[f, 1])[0]==0∧(Subscript[f, 2])[0]==0∧(Subscript[f, 3])[0]==0∧(Subscript[f, 4])[0]==0∧(Subscript[f, 5])[0]==0∧eqs3,{(Subscript[f, 1])[λ],(Subscript[f, 2])[λ],(Subscript[f, 3])[λ],(Subscript[f, 4])[λ],(Subscript[f, 5])[λ]},λ]

DSolve[(Subscript[f, 2])[0]==0∧(Subscript[b, 2])-(Subscript[f, 2])'[λ]==0,{(Subscript[f, 2])[λ]},λ]

ans=FullSimplify[(Subscript[f, 5])[λ]/.DSolve[-(Subscript[b, 2]) (Subscript[f, 5])[λ]-(((E^(-λ (Subscript[b, 2]))) (-ℏ-(E^(λ (Subscript[b, 2]))) (Subscript[f, 5])[λ]+(E^(λ (Subscript[b, 2]))) (Subscript[B, 2]) (Subscript[f, 5])[λ]))/ℏ)-(Subscript[f, 5])'[λ]==0∧(Subscript[f, 5])[0]==0,(Subscript[f, 5])[λ],λ]]

FullSimplify[ans/.(Subscript[b, 2])->0]