Free Lie Algebras Routines

Lazy Evaluation Version

Pensieve header: A free-Lie calculator, lazy evaluation version.

Global Definitions

$LieSeriesShowDegree=3; $LieSeriesCompareDegree = 3;

NonCommutativeMultiply

Unprotect[NonCommutativeMultiply];
x_**0=0; 0**y_=0;
(c_*x_AW) ** y_ := Expand[c(x**y)];
x_ ** (c_*y_AW) := Expand[c(x**y)];
x_Plus ** y_ := (#**y)& /@ x;
x_**y_Plus := (x**#)& /@ y;
AW[w1_String] ** AW[w2_String] := AW[w1<>w2];

Words and Lyndon Words

A Lyndon word is a word lexicographically smaller than all of its proper right factors; see http://katlas.math.toronto.edu/drorbn/AcademicPensieve/Projects/FreeLie/index.html

LyndonQ[AW[w_String]] := And @@ (
OrderedQ[{w, #}]& /@ Table[StringDrop[w,i], {i,1,StringLength[w]-1}]
);
AllWords[0, _List] = {AW[""]};
AllWords[n_ /; n>0, ab_List] := AllWords[n, ab] = AW /@ Flatten[Outer[
StringJoin[#1, #2]&,
First /@ AllWords[n-1, ab],
ab
]];
AllLyndonWords[n_Integer, ab_List] := LW @@@ Select[AllWords[n, ab], LyndonQ];
AllLyndonWords[{n_}, ab_List] := Join@@Table[AllLyndonWords[k,ab], {k,n}];
LyndonFactorization[LW[w_String] /; StringLength[w] == 1] := LW[w];
LyndonFactorization[LW[w_String] /; StringLength[w] > 1] := Module[
{rf},
rf=First[Sort[Table[StringDrop[w,i], {i,1,StringLength[w]-1}]]];
LW /@ {StringDrop[w, -StringLength[rf]], rf}
];
LW[s_Symbol] := LW[ToString[s]];
LW[LW[w_]]:=LW[w];
LW /: LW[x_] ≤ LW[y_] := OrderedQ[{x,y}];
LW /: x_LW ≥y_LW := y≤x;
LW /: x_LW > y_LW := !(x≤y);
LW /: x_LW<y_LW := !(y≤x);
Format[LW[w_], StandardForm] := Defer[⟨w⟩];
⟨w__⟩:=LW[w];
LW[is__Integer] := LW[StringJoin@@(StringTake["1234567890abcdefghijklmnopqrstuvwxyz", {#}]& /@ {is})];
Deg[LW[x_]] := StringLength[x];

{LyndonQ[AW@"abba"], LyndonQ[AW@"ababb"]}

{AllWords[3, {"1", "2"}], AllLyndonWords[{3}, {"1", "2"}]}

Table[Length[AllLyndonWords[k, {"1", "2"}]], {k,10}]

Table[Length[AllLyndonWords[k, {"1", "2", "3"}]], {k,10}]

TreeForm[LW["12122"] //. w_LW :> LyndonFactorization[w] /. LW[w_] :> w]

The Bracket for Lie Elements

b[0,_] =0; b[_,0]=0;
b[c_*(x_AW|x_LW), y_] := Expand[c b[x,y]];
b[x_, c_*(y_AW|y_LW)] := Expand[c b[x,y]];
b[x_Plus, y_] := b[#,y]& /@ x;
b[x_, y_Plus] := b[x,#]& /@ y;
b[w_AW, z_AW] := w**z-z**w;
b[w_LW, z_LW] := LWBracket[w,z];
ad[x_][y_]:=b[x,y];

LWBracket[w_LW, z_LW] := Which[
w===z, 0,
z<w, Expand[-b[z,w]],
Deg[w]==1, LW[First[w]<>First[z]],
True, Module[{x,y},
{x,y}=LyndonFactorization[w];
If[y≥z,
LW[First[w]<>First[z]],
LWBracket[w,z]=b[x,LWBracket[y,z]]+b[LWBracket[x,z],y]
]
]
];

b[LW["112"], LW["122"]]

Outer[b, AllLyndonWords[{3}, {"1", "2"}], AllLyndonWords[{3}, {"1", "2"}]] // MatrixForm

Union[Flatten[Outer[(b[#1,#2]+b[#2,#1])&,
AllLyndonWords[{6}, {"1", "2"}], AllLyndonWords[{6}, {"1", "2"}]
]]]

Outer[(b[#1,b[#2,#3]]+b[#2,b[#3,#1]]+b[#3,b[#1,#2]])&,
AllLyndonWords[{5}, {"1", "2"}], AllLyndonWords[{5}, {"1", "2"}], AllLyndonWords[{5}, {"1", "2"}]
] // Flatten // Union

LieSeries

LieSeries[ser_Symbol][e___] := ser[e];
Format[LieSeries[s_Symbol], StandardForm] := LS@@Table[s[d], {d, $LieSeriesShowDegree}];
MakeLieSeries[s_LieSeries] := s;
MakeLieSeries[expr_] := MakeLieSeries[expr] = MakeLieSeries[Unique[MakeLieSeries], expr];
MakeLieSeries[ser_Symbol, expr_] := (
ser[] = Hold[MakeLieSeries[ser, expr]];
ser[d_Integer] := ser[d] = expr /. w_LW /; Deg[w] ≠ d -> 0;
LieSeries[ser]
);
s1_LieSeries ≡ s2_LieSeries := And @@ ((s1[#]==s2[#])& /@ Range[$LieSeriesCompareDegree]);

Print /@ {ts1=⟨"1122"⟩ // MakeLieSeries, ts1[], ts1 /@ Range[6]};

b[s1_LieSeries, s2_LieSeries] := b[s1,s2] = Module[{ser},
ser=Unique[b];
ser[] = Hold[b[s1,s2]];
ser[d_Integer] := ser[d] = Sum[
b[s1[k], s2[d-k]],
{k,1,d-1}
];
LieSeries[ser]
];
b[s_LieSeries, y_] := b[s, MakeLieSeries[y]];
b[x_, s_LieSeries] := b[MakeLieSeries[x], s];

{ts2=⟨"122"⟩+⟨"11122"⟩ // MakeLieSeries, ts3=b[ts1,ts2], ts3[], ts3 /@ Range[10]}

LieSeries /: EulerE[s_LieSeries] := Module[{ser},
ser=Unique[EulerE];
ser[] = Hold[EulerE[s]];
ser[d_Integer] := ser[d] = Expand[d*s[d]];
LieSeries[ser]
];

{ts4=EulerE[ts3], ts4[], ts4 /@ Range[10]}

adPower[0, x_LieSeries][ψ_LieSeries] := adPower[0,x][ψ] = Module[{ser},
ser=Unique[adPower];
ser[] = Hold[adPower[0,x][ψ]];
ser[d_Integer] := ser[d] = ψ[d];
LieSeries[ser]
];
adPower[n_Integer, x_LieSeries][ψ_LieSeries] := adPower[n,x][ψ] = Module[{ser},
ser=Unique[adPower];
ser[] = Hold[adPower[n,x][ψ]];
ser[d_Integer] := ser[d] =  b[x,adPower[n-1, x][ψ]][d];
LieSeries[ser]
];
adSeries[f_, x_LieSeries][ψ_LieSeries] := adSeries[f, x][ψ] = Module[{ser},
ser=Unique[adSeries];
ser[] = Hold[adSeries[f,x][ψ]];
ser[d_Integer] := ser[d] = Module[{c},
Expand[Sum[
c=SeriesCoefficient[f,{ad, 0, k}];
If[c==0, 0, c*adPower[k, x][ψ][d]],
{k,0,d-1}
]]
];
LieSeries[ser]
];
adSeries[f_, x_][ψ_] := adSeries[f, MakeLieSeries[x]][MakeLieSeries[ψ]];
Ad[x_] := adSeries[E^(-ad), x];

{xs=MakeLieSeries[LW["x"]], ys=MakeLieSeries[LW["y"]], ts5=adPower[0,xs][ys], ts5[], ts5 /@ Range[5]}

adPower[3,xs][ys] /@ Range[5]

{adSeries[E^(-ad), xs][ys] /@ Range[5], adSeries[E^(-ad), ys][xs] /@ Range[5]}

Ad[xs][ys][5]

Ad[xs][ys][]

LieMorphism

LieMorphism[mor_][es___] := mor[es];
LieMorphism[rules_List] := LieMorphism[rules] = LieMorphism[Unique[LieMorphism], rules];
LieMorphism[mor_Symbol, rules_List] := (
mor[]=Hold[LieMorphism[mor, rules]];
(mor[w_LW] /; Deg[w] == 1) := (mor[w] = MakeLieSeries[w /. rules]);
mor[w_LW] := (mor[w] = b @@ (mor /@ LyndonFactorization[w]));
mor[s_LieSeries] := mor[s] = Module[{ser},
ser=Unique[LieMorphismOnLieSeries];
ser[] = Hold[mor[s]];
ser[d_] := ser[d] = Sum[
mor[s[k]][d],
{k,1, d}
];
LieSeries[ser]
];
mor[expr_][d_] := Expand[expr /. w_LW :> mor[w][d]];
LieMorphism[mor]
);

{lm1=LieMorphism[{LW["x"] -> Ad[LW["y"]][LW["x"]]}], lm1[],
lm1[LW["y"]], lm1[LW["x"]], lm1[LW["x"]][4], lm1[⟨"xxy"⟩],  lm1[⟨"xxy"⟩][8]
}

StableApply

StableApply[mor_LieMorphism, s_LieSeries] := StableApply[mor, s] = Module[{ser},
ser=Unique[StableApply];
ser[] = Hold[StableApply[mor, s]];
ser[d_] := ser[d] = Nest[mor, s, d][d];
(* ser[d_] := ser[d] = Module[{mm},
mm=FixedPoint[mor, s, SameTest -> (#1[d]==#2[d]&)];
mm[d]
]; *)
LieSeries[ser]
];

BCH

BCHBase = Module[{bch},
bch=Unique["BCHBase"];
bch[] = Hold[BCHBase];
bch[1] = ⟨"x"⟩+⟨"y"⟩;
bch[d_Integer] := bch[d] = Expand[Plus[
adSeries[E^(-ad), MakeLieSeries[⟨"y"⟩]][MakeLieSeries[⟨"x"⟩]][d],
-adSeries[(1-E^(-ad))/ad-1, LieSeries[bch]][EulerE[LieSeries[bch]]][d]
]/d];
LieSeries[bch]
];
BCH[x_, y_] := LieMorphism[{LW["x"] -> x, LW["y"] -> y}][BCHBase];

{BCHBase, BCHBase[], BCHBase[8]}

{BCH[LW["y"], LW["z"]], BCH[LW["y"], LW["z"]][6]}

{
t1=BCH[LW["x"], BCH[LW["y"], LW["z"]]],
t2=BCH[BCH[LW["x"], LW["y"]], LW["z"]],
t1==t2,
Table[t1[d]==t2[d], {d,10 }]
} // Timing

ι[w_LW] /; Deg[w]==1 := AW@@w;
ι[w_LW] := ι[w] = b @@ (ι /@ LyndonFactorization[w]);
ι[s_LieSeries] := Prepend[ι/@(ASeries @@ s), 0];
ι[expr_] := Expand[expr /. w_LW :> ι[w]];

t1=ι[BCH[3]]

ASeries /: Expand[s_ASeries] := Expand /@ s;
ASeries /: Plus[ss__ASeries] := Module[
{l=Min[Length /@ {ss}]},
ASeries @@ Total[Take[List @@ #, l]& /@ {ss}]
];
ASeries /: c_ * s_ASeries := Expand[c*#]& /@ s;
s1_ASeries**s2_ASeries := Module[
{d,k,m1,m2},
m1=LengthWhile[s1, #==0&];
m2=LengthWhile[s2, #==0&];
ASeries @@ Table[
Sum[s1[[k+1]]**s2[[d-k+1]], {k,m1,d-m2}],
{d, 0, Min[m1+Length[s2]-1, m2+Length[s1]-1]}
]
];
ASeries /: EulerE[s_ASeries] := ASeries @@ Expand[Range[{0,1+Length[s]}]*(List@@s)];

ASeries[AW[""],0,0,0]+t1+t1**t1/2+t1**t1**t1/6

ASeries[AW[""],AW["x"],AW["xx"]/2,AW["xxx"]/6]**ASeries[AW[""],AW["y"],AW["yy"]/2,AW["yyy"]/6]

σ[y_LW, w_LW] /; Deg[y]==1 := σ[y,w] = Which[
y===w, AW[""],
Deg[w]===1, 0,
True, Module[{w1,w2},
{w1,w2}=LyndonFactorization[w];
ι[w1]**σ[y,w2]-ι[w2]**σ[y,w1]
]
];
σ[y_, expr_] := Expand[expr /. w_LW :> σ[LW[y], w]] /. LieSeries -> ASeries;

(#->σ[1, #])& /@ AllLyndonWords[{5}, {"1","2"}]

xw=⟨"x"⟩; yw=⟨"y"⟩;
{σ[xw, BCH[5,xw,yw]], σ[yw, BCH[5,xw,yw]]}/. AW[s_] :> s

σ[xw, BCH[8,xw,yw]] /. AW[s_] :> s