Pensieve header: The free-Lie meta-crossed-product structure.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-07"];
<< ../Projects/FreeLie/FreeLie.m

λCollect[λ[ω_, μ_]] := λ[ω, Collect[μ, _h, Expand]];
λ /: Series[λ[ω_, μ_], d_Integer] := λ[ω, Collect[μ, _h, MakeLieSeries[d,#]&]];
Randomλ[d_,m_,n_] := Module[{bas},
bas=AllLyndonWords[{d}, Characters[StringTake["1234567890", m]]];
Series[λ[0, Expand[Sum[
h[j](RandomInteger[{-2,2},Length[bas]].bas),
{j,n}
]]], d] // λCollect
];
hL[λ_] := Union[Cases[λ, h[s_] :> s, Infinity]];
λ /: λ[ω1_, μ1_] == λ[ω2_, μ2_] := ω1==ω2 && (And @@ ((D[μ1, h[#]]==D[μ2, h[#]])& /@ hL[{μ1, μ2}]));

tm[x_,y_,z_][λ[ω_, μ_]] := λ[0, μ // LieMorphism[{⟨x⟩->⟨z⟩, ⟨y⟩->⟨z⟩}]];
hm[x_,y_,z_][λ[ω_, μ_]] := λ[0, Plus[
μ /. {h[x]->0, h[y]->0},
h[z]BCH[D[μ, h[x]], D[μ, h[y]]]
]];
hta[x_,y_,z_][λ[ω_, μ_]] := λ[0,
FixedPoint[LieMorphism[{
LW[y] -> Ad[-D[μ, h[x]]][LW[z]]
}],
μ]
];
hta[x_,y_][λ_] := λ // hta[x,y,LW["z"]] // LieMorphism[{LW["z"] -> LW[y]}];
dm[x_,y_,z_][λ_] := λ // hta[y,x] // tm[x,y,z] // hm[x,y,z];
Rp[x_,y_] := λ[0,h[y]⟨x⟩];
λ /: λ[ω1_, μ1_]λ[ω2_,μ2_] := λ[ω1+ω2, μ1+μ2];

BCH[4]

{λ0=Randomλ[4, 3,1],
λ0 // tm[1,2,2],
t1 = λ0 // tm[1,2,2] // tm[2,3,3],
λ0 // tm[2,3,3],
t2 = λ0 // tm[2,3,3] // tm[1,3,3],
t1==t2
} // ColumnForm

{λ0=Randomλ[4, 2,3],
λ0 // hm[1,2,2],
t1 = λ0 // hm[1,2,2] // hm[2,3,3],
t2 = λ0 // hm[2,3,3] // hm[1,3,3],
t1==t2
} // ColumnForm

{t=Series[Rp[1,3]Rp[2,4], 4],
t // hm[3,4,3],
t // hta[3,2,5]
} // ColumnForm

{λ0=Randomλ[4,2,3],
λ0 // hta[1,1],
λ0 // hta[1,1] // hta[2,1],
t1= λ0 // hta[1,1] // hta[2,1] // hm[1,2,1],
t2= λ0 // hm[1,2,1] // hta[1,1],
t1==t2
} // ColumnForm

{λ0=Randomλ[3,4,4],
λ0 // dm[1,2,1],
t1 = λ0 // dm[1,2,1] // dm[1,3,1],
t2 = λ0 // dm[2,3,2] // dm[1,2,1],
t1==t2
} // ColumnForm

{λ0=Randomλ[3,4,4],
λ0 // dm[1,2,1],
t1 = λ0 // dm[1,2,1] // dm[1,3,1],
t2 = λ0 // dm[2,3,2] // dm[1,2,1],
t1==t2
} // Timing