Aw-Calculus Programs for the WKO4 Paper

Pensieve header: Aw-calculus programs for the WKO4 paper.

“d” is “ht”: along tube strands, heads appear before tails.

Utilities

⟨{λ___}⟩ := ⟨λ⟩;
Support[⟨λ___⟩] := First /@ {λ};
λ_∖key_ := DeleteCases[λ, key -> _];
λ_ ∖ keys_List := Fold[#1∖#2&, λ, keys];
(Subscript[⟨λ___⟩, s_]) := s /. {λ};
(λ_AngleBracket)[d_] := ⟨Table[u -> (Subscript[λ, u])[d],{u, Support[λ]}]⟩;
Crop[λ_AngleBracket, d_] := MapAt[Crop[#,d]&, λ, {All,2}];
AngleBracket /: Plus[λs__AngleBracket] := ⟨Table[
u -> Total[(Subscript[#, u])& /@ {λs}],
{u, Union@@(Support[#]& /@ {λs})}
]⟩;
AngleBracket /: c_*λ_AngleBracket := ⟨Table[
u -> Expand[c (Subscript[λ, u])],
{u, Support[λ]}
]⟩;
AngleBracket /: λ_AngleBracket // mor_LieMorphism := MapAt[mor, λ, {All,2}];
λ_AngleBracket //  DegreeScale[h_] := MapAt[DegreeScale[h], λ, {All,2}];
deg /: (((h_))^deg):=DegreeScale[h];

Tangential Derivations, the Tree Bracket tb, div and j

TangentialDerivation[⟨λ___⟩] := LieDerivation[{λ} /. (s_->λs_):>(LW[s]->b[LW[s],λs])];
tb[λ1_AngleBracket, λ2_AngleBracket] /; Support[λ1]==Support[λ2] := ⟨Table[
s -> b[(Subscript[λ1, s]), (Subscript[λ2, s])] + TangentialDerivation[λ1][(Subscript[λ2, s])] - TangentialDerivation[λ2][(Subscript[λ1, s])],
{s, Support[λ1]}
]⟩;
div[λ_AngleBracket] := Sum[(Subscript[div, s])[(Subscript[λ, s])], {s, Support[λ]}];
j[λ_AngleBracket] := DerivationSeries[(((E^der)-1)/der), TangentialDerivation[λ]][div[λ]];

Evaluating Lie Series in ⟨…⟩

LieMorphism[rules__Rule, keys_AngleBracket, br_] := LieMorphism[{rules}, keys, br];
LieMorphism[rules_List, keys_AngleBracket, br_] := New[LieMorphism[mor],
mor[Support] = First /@ rules;
(mor[w_LW] /; Deg[w] == 1) := (mor[w] = w /. rules);
mor[w_LW] := (mor[w] = br @@ (mor /@ LyndonFactorization[w]));
mor[expr_][d_] := Expand[expr /. w_LW :> mor[w][d]];
mor[ls_LieSeries] := mor[ls] = Module[{ser},
⟨Table[
ReleaseHold[Hold[
ser[]=Hold[AngleBracketFromLieMorphism[mor, ls, ss]];
ser[d_Integer] := ser[d] = (Subscript[((∑_(k=1)^d)mor[ls[k]][d]), ss]);
ss->LieSeries[ser]
] /. {ss->s, ser -> Unique[LieSeriesInAngleBracket]}],
{s, List@@keys}
]⟩]
];
BCH[x_, y_, keys_AngleBracket, br_] := LieMorphism[{LW["x"] -> x, LW["y"] -> y}, keys, br][BCHBase];

The AT Presentation (Subscript[E, l]) of (A^w)

El /: El[λ1_,ω1_]⋃El[λ2_,ω2_] /; Support[λ1]⋂Support[λ2]=={} := El[λ1⋃λ2, ω1+ω2];
El /: El[λ1_,ω1_]**El[λ2_,ω2_] /; Support[λ1]==Support[λ2]:= El[BCH[λ1, λ2, ⟨1,2⟩, tb], ω1+DerivationExp[TangentialDerivation[λ1]][ω2]];
El[λ_,ω_] // dA := El[-λ, DerivationExp[TangentialDerivation[λ]][ω]-j[λ]];
El[λ_,ω_] // dS := El[
-λ // (((-1))^deg),
(DerivationExp[TangentialDerivation[λ]][ω]-j[λ]) // (((-1))^deg)
];

The KBH Presentation (Subscript[E, s]) of (A^w)

Es /: Es[λ1_,ω1_]⋃Es[λ2_,ω2_] /; Support[λ1]⋂Support[λ2]=={} := Es[λ1⋃λ2, ω1+ω2];

tσ[us_List -> vs_List][ser_LieSeries|ser_CWSeries|ser_AngleBracket] := ser // LieMorphism[Thread[(LW/@us)->(LW/@vs)]];
tσ[u_, v_] := tσ[{u}->{v}];
tσ[us_List -> vs_List][ζ_Es] := tσ[us->vs] /@ ζ;
hσ[xs_List -> ys_List][λ_AngleBracket] := Union[λ∖xs, ⟨Thread[ys-> Table[(Subscript[λ, x]),{x, xs}]]⟩];
hσ[x_, y_] := hσ[{x}->{y}];
hσ[xs_List -> ys_List][Es[λ_, ω_]] := Es[λ//hσ[xs->ys], ω];
dσ[as_List -> bs_List][ζ_] := ζ // tσ[as->bs] // hσ[as->bs];
dσ[a_, b_][ζ_] := ζ // tσ[a,b] // hσ[a,b];

tm[u_,v_,w_][λ_AngleBracket] := λ //  LieMorphism[LW@u->LW@w, LW@v->LW@w];
tm[u_,v_,w_][Es[λ_, ω_]] := LieMorphism[LW@u->LW@w, LW@v->LW@w] /@ Es[λ, ω];
hm[x_,y_,z_][λ_AngleBracket] := Union[λ∖{x,y}, ⟨z->BCH[(Subscript[λ, x]), (Subscript[λ, y])]⟩];
hm[x_,y_,z_][Es[λ_, ω_]] := Es[λ // hm[x,y,z], ω];
tha[u_LW, x_][λ_AngleBracket] := λ // (Subscript[RC, u])[(Subscript[λ, x])];
tha[u_LW, x_][Es[λ_, ω_]] := Es[λ // tha[u,x], (ω+(Subscript[J, u])[(Subscript[λ, x])]) // (Subscript[RC, u])[(Subscript[λ, x])]];
dm[a_,b_,c_][ζ_] := ζ // tha[LW@a,b] // tm[LW@a,LW@b,LW@c] // hm[a,b,c];
dm[a_,b_,rest__,c_][ζ_] := ζ // dm[b,rest, b] // dm[a,b,c];

Es /: Es[λ1_,ω1_]**Es[λ2_,ω2_] /; Support[λ1]==Support[λ2]:= Module[
{supp, temps, ζ},
supp = Support[λ1];
temps=Complement[Characters["0123456789abcdefghijklmnopqrstuvwxyz"], ToString /@ supp][[1;;Length@supp]];
ζ=Es[λ1,ω1]⋃(Es[λ2, ω2] // dσ[supp->temps]);
MapThread[(ζ=ζ//dm[#1,#2,#1])&, {supp,temps}] // Last
];

tA[u_][expr_] := expr;
hA[x_][Es[λ_, ω_]] := Es[Union[λ∖x, ⟨x->-(Subscript[λ, x])⟩], ω];
dA[a_][μ_] := μ // hA[a] // tha[LW@a,a];
dA[a_, rest__][μ_] := μ // dA[a] // dA[rest];
Es[λ_, ω_] // dA := Es[λ,ω] // (dA@@Support[λ])

tS[u_][λ_AngleBracket] := ⟨Table[x -> LieMorphism[LW@u -> -LW@u][(Subscript[λ, x])], {x, Support[λ]}]⟩;
tS[u_][Es[λ_,ω_]] := Es[λ // tS[u], ω // LieMorphism[LW@u -> -LW@u]];
hS[x_][Es[λ_, ω_]] := Es[Union[λ∖x, ⟨x->-(Subscript[λ, x])⟩], ω];
dS[a_][μ_] := μ // tS[a] // hS[a] // tha[LW@a,a];
dS[a_, rest__][μ_] := μ // dS[a] // dS[rest];
Es[λ_, ω_] // dS := Es[λ,ω] // (dS@@Support[λ])

The (Subscript[E, l]) ↔ (Subscript[E, s]) Conversions

Γ[-1, λ_AngleBracket, _] := ⟨Table[s->MakeLieSeries[0], {s, Support[λ]}]⟩;
Γ[n_, λ_AngleBracket, t_] := Γ[n,λ,t] = Module[{τ,Γ0},
Γ0=Γ[n-1,λ,τ];
⟨Table[
s->(∫_0^t)((Subscript[λ, s]) // DerivationExp[-τ TangentialDerivation[λ]] // adSeries[(ad/((E^ad)-1)), (Subscript[Γ0, s])])\[DifferentialD]τ,
{s, Support[λ]}
]⟩
];
Γ[λ_AngleBracket, t_] := Γ[λ,t] = ⟨Table[
s -> New[LieSeries[ser],
With[{s=s}, ser[d_Integer] := ser[d] = ((Subscript[Γ[d-1, λ,t], s]))[d]];
],
{s, Support[λ]}
]⟩;
Γ[λ_AngleBracket] := Γ[λ,1];
Γi[λ_AngleBracket] := Γi[λ] = ⟨Table[With[{s=s},
s->New[LieSeries[ser],
ser[d_Integer] := ser[d] = (Subscript[λ, s])[d]-(Subscript[Γ[Crop[Γi[λ], d-1]], s])[d]
]],
{s, Support[λ]}
]⟩;
Γ /: (Γ^(-1)) = Γi;
Es[El[λ_,ω_]] := Es[Γ[λ], ω];
El[Es[λ_,ω_]] := El[(Γ^(-1))[λ], ω];