Pensieve header: Exponentiation in  ybax algebras.

Startup

Date[]
SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\FullDoPeGDO"];
Once[<<KnotTheory`];
Once[Get@"../Profile/Profile.m"];
BeginProfile[];
$k=2;
<<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 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}] ]

(Subscript[Exp, cm])[(Subscript[𝕌, {}->{i}])[ℏ (Subscript[a, i]) (Subscript[b, i])+ℏ (Subscript[x, i]) (Subscript[y, i]),c((Subscript[x, i])+(Subscript[y, i]))]]

PrintProfile[]

(Subscript[Exp, cm])[(Subscript[𝕌, {}->{i}])[ℏ (Subscript[a, i]) (Subscript[b, i])+ℏ (Subscript[x, i]) (Subscript[y, i]),(Subscript[c, 1])((Subscript[x, i])+(Subscript[y, i])),0]]

PrintProfile[]

Testing dS

(Subscript[η, 1])(((∂_(Subscript[η, 1]))#)/.{(Subscript[(η|β|α|ξ), 1])->0,(Subscript[𝒜, 1])->1})&/@(Subscript[dS, 1]) /. 𝔼->𝕌

(Subscript[Exp, dm])[(Subscript[𝕌, {1}->{1}])[-(((Subscript[y, 1]) (Subscript[η, 1]))/(Subscript[B, 1]))]]

(Subscript[Exp, dm])[(Subscript[𝕌, {1}->{1}])[-(((Subscript[y, 1]) (Subscript[η, 1]))/(Subscript[B, 1])),((ℏ (Subscript[y, 1])(Subscript[η, 1]))/(Subscript[B, 1]))]]

(Subscript[Exp, dm])[(Subscript[𝕌, {1}->{1}])[-(((Subscript[y, 1]) (Subscript[η, 1]))/(Subscript[B, 1])),((ℏ (Subscript[y, 1])(Subscript[η, 1]))/(Subscript[B, 1])),-(((ℏ^2) (Subscript[y, 1]) (Subscript[η, 1]))/(2 (Subscript[B, 1])))]]

(Subscript[𝔼, {1}->{1}])[(Subscript[η, 1])(Subscript[y, 1]),0,0]//(Subscript[dS, 1])

PrintProfile[]

Exp step by step #1

Exp step by step #2

{m=cm,is={},i1=i,U=(Subscript[𝔼, {}->{i}])[(Subscript[g, MI[0,1,0]])(Subscript[a, i])+(Subscript[g, MI[0,0,0]])+(Subscript[g, MI[0,0,1]]) (Subscript[x, i])+(Subscript[g, MI[0,0,2]]) (Subscript[x, i]^2)+(Subscript[g, MI[1,0,0]]) (Subscript[y, i])+(Subscript[g, MI[1,0,1]]) (Subscript[x, i]) (Subscript[y, i])+(Subscript[g, MI[2,0,0]]) (Subscript[y, i]^2)]}

Generic exponentiation

CF@@(Subscript[Exp, cm])[(Subscript[𝕌, {}->{i}])[(Subscript[c, 1]) (Subscript[a, i]) (Subscript[b, i])+(Subscript[c, 2])(Subscript[x, i]) (Subscript[y, i])+(Subscript[c, 3])(Subscript[x, i])+(Subscript[c, 4])(Subscript[y, i])]]

Block[{CCF=FullSimplify},(Subscript[Exp, cm])[(Subscript[𝕌, {}->{i}])[(Subscript[c, 0])+(Subscript[c, 1]) (Subscript[a, i]) (Subscript[b, i])+(Subscript[c, 2])(Subscript[x, i]) (Subscript[y, i])+(Subscript[c, 3])(Subscript[x, i])+(Subscript[c, 4])(Subscript[y, i])]]]

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_->{i1_}])[__]]:=Module[{e,k,n,G,g,lhs,rhs,MI(*multi-index*),mis,mi,yax,p,q,pq},
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);
G=(Subscript[𝕌, is->{i}])[];
Do[AppendTo[G,0]; Do[ Do[
mis=Echo@Flatten@Table[MI[p,n,pq-p],{p,Max[0,pq-1-k],Min[k+1,pq]}];
G[[-1]]+=Sum[(Subscript[g, mi])(yax^mi),{mi,mis}];
lhs=Last[(Subscript[Exp, m])[G]];
rhs=ℰ[[k+1]];
G=CF[G/.First@Solve[Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]]],
{pq,2k+2-2n,0,-1}],{n,k+1,0,-1}],{k,0,Length[ℰ]-1}];
G
]

(Subscript[Log, cm])[(Subscript[𝔼, {}->{i}])[ℏ (Subscript[a, i]) (Subscript[b, i])+(((1-(Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i])),(Subscript[c, 1]) (Subscript[x, i])+(Subscript[c, 1]) (Subscript[y, i])+(((ℏ-ℏ (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i]))+(((Subscript[a, i]) (-1+(Subscript[B, i])+ℏ (Subscript[b, i]) (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i]^2))+(((1-4 (Subscript[B, i])+3 (Subscript[B, i]^2)+2 ℏ (Subscript[b, i]) (Subscript[B, i]^2)) (Subscript[x, i]^2) (Subscript[y, i]^2))/(2 (Subscript[b, i]^3))),(1/2) (Subscript[b, i]) (Subscript[c, 1]^2)+(1/2) ℏ (Subscript[c, 1]) (Subscript[x, i])+(1/2) ℏ (Subscript[c, 1]) (Subscript[y, i])+((((ℏ^2)-(ℏ^2) (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(2 (Subscript[b, i])))+(((Subscript[a, i]) (-ℏ+ℏ (Subscript[B, i])+(ℏ^2) (Subscript[b, i]) (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i]^2))+(((Subscript[a, i]^2) (2-2 (Subscript[B, i])-2 ℏ (Subscript[b, i]) (Subscript[B, i])-(ℏ^2) (Subscript[b, i]^2) (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(2 (Subscript[b, i]^3)))+(((Subscript[a, i]) (-3+12 (Subscript[B, i])+4 ℏ (Subscript[b, i]) (Subscript[B, i])-9 (Subscript[B, i]^2)-10 ℏ (Subscript[b, i]) (Subscript[B, i]^2)-4 (ℏ^2) (Subscript[b, i]^2) (Subscript[B, i]^2)) (Subscript[x, i]^2) (Subscript[y, i]^2))/(2 (Subscript[b, i]^4)))+(((1+2 ℏ (Subscript[b, i])-8 (Subscript[B, i])-8 ℏ (Subscript[b, i]) (Subscript[B, i])+7 (Subscript[B, i]^2)+12 ℏ (Subscript[b, i]) (Subscript[B, i]^2)+6 (ℏ^2) (Subscript[b, i]^2) (Subscript[B, i]^2)) (Subscript[x, i]^2) (Subscript[y, i]^2))/(2 (Subscript[b, i]^4)))+(((2-15 (Subscript[B, i])+30 (Subscript[B, i]^2)+12 ℏ (Subscript[b, i]) (Subscript[B, i]^2)-17 (Subscript[B, i]^3)-18 ℏ (Subscript[b, i]) (Subscript[B, i]^3)-6 (ℏ^2) (Subscript[b, i]^2) (Subscript[B, i]^3)) (Subscript[x, i]^3) (Subscript[y, i]^3))/(3 (Subscript[b, i]^5)))]]

Logarithms step by step

{m=cm, ℰ=(Subscript[𝔼, {}->{i}])[ℏ (Subscript[a, i]) (Subscript[b, i])+(((1-(Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i])),(Subscript[c, 1]) (Subscript[x, i])+(Subscript[c, 1]) (Subscript[y, i])+(((ℏ-ℏ (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i]))+(((Subscript[a, i]) (-1+(Subscript[B, i])+ℏ (Subscript[b, i]) (Subscript[B, i])) (Subscript[x, i]) (Subscript[y, i]))/(Subscript[b, i]^2))+(((1-4 (Subscript[B, i])+3 (Subscript[B, i]^2)+2 ℏ (Subscript[b, i]) (Subscript[B, i]^2)) (Subscript[x, i]^2) (Subscript[y, i]^2))/(2 (Subscript[b, i]^3)))]}

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);
G=(Subscript[𝕌, {}->{i}])[]

Length[ℰ]-1

k=0

AppendTo[G,0]

n=1

mis=Flatten@Table[MI[p,n,q],{p,0,Min[k+1,2k+2-2n]},{q,0,Min[k+1,2k+2-2n-p]}]

G[[-1]]+=Sum[(Subscript[g, mi])(yax^mi),{mi,mis}]

G

lhs=Last[(Subscript[Exp, m])[G]]

rhs=ℰ[[k+1]]

Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}]

First@Solve[Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]]

G=CF[G/.First@Solve[Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]]]

n=0

mis=Flatten@Table[MI[p,n,q],{p,0,Min[k+1,2k+2-2n]},{q,0,Min[k+1,2k+2-2n-p]}]

G[[-1]]+=Sum[(Subscript[g, mi])(yax^mi),{mi,mis}]

lhs=Last[(Subscript[Exp, m])[G]]

rhs=ℰ[[k+1]]

Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}]//FullSimplify

First@Solve[Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]]

{solxy}=Block[{mis={MI[1,0,1]}},
First@Solve[Echo@Table[Coefficient[lhs-rhs,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]] ]

lhs/.solxy

rhs/.solxy

Block[{mis={MI[0,0,1]}},
First@Solve[Echo@Table[Coefficient[(lhs-rhs)/.solxy,mi]==0, {mi,mis}],Table[(Subscript[g, mi]),{mi,mis}]] ]