Pensieve header: The free-Lie meta-group-action structure; continued 2012-08.

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

Randomλ[d_,m_,n_] := Module[{bas},
bas=AllLyndonWords[{d}, Characters[StringTake["1234567890", m]]];
λ[
MakeCWSeries[RandomInteger[{-2,2},Length[bas]].bas /. LW->CW],
Sum[h[j]MakeLieSeries[RandomInteger[{-2,2},Length[bas]].bas], {j,n}]
]
];
hL[λ_] := Union[Cases[λ, h[s_] :> s, Infinity]];
λ[ω_,μ_][d_] := λ[ω[d], μ /. s_LieSeries :> s[d]];
λ[ω1_, μ1_] ≡ λ[ω2_, μ2_] := ω1≡ω2 && (And @@ ((D[μ1, h[#]]≡D[μ2, h[#]])& /@ hL[{μ1, μ2}]));
LieDerivation[der_][λ[ω_, μ_]] := λ[ω//der, Collect[μ, _h, der]];
LieMorphism[mor_][λ[ω_, μ_]] := λ[ω//mor, Collect[μ, _h, mor]];

{Randomλ[1,3,3], Randomλ[3,3,3]}

λ /: λ[ω1_, μ1_]λ[ω2_, μ2_] := λ[
AddCWSeries[ω1, ω2],
Collect[μ1+μ2, _h,
(# /. ls1_LieSeries + ls2_LieSeries :> AddLieSeries[ls1,ls2])&
]
];
tm[x_,y_,z_][λ[ω_, μ_]] := λ[ω, μ] //  LieMorphism[{⟨x⟩->⟨z⟩, ⟨y⟩->⟨z⟩}];
hm[x_,y_,z_][λ[ω_, μ_]] := λ[ω, Plus[
μ /. {h[x]->0, h[y]->0},
h[z]BCH[D[μ, h[x]], D[μ, h[y]]]
]];
hta[x_,y_,z_][λ[ω_, μ_]] := Module[{μx, Adμx},
μx = MakeLieSeries[D[μ, h[x]]];
Adμx = LieMorphism[{LW[y] -> Ad[ScaleLieSeries[-1,μx]][LW[z]]}];
λ[
AddCWSeries[StableApply[Adμx, ω], J[LW[y], μx]],
Collect[μ, _h, StableApply[Adμx,#]&]
]
];
hta[x_,y_][λ[ω_, μ_]] := λ[ω, μ] // hta[x,y,⟨"z"⟩] // LieMorphism[{LW["z"] -> LW[y]}];
dm[x_,y_,z_][λ_] := λ // hta[y,x] // tm[x,y,z] // hm[x,y,z];
Rp[x_,y_] := λ[MakeCWSeries[0],h[y]MakeLieSeries[⟨x⟩]];
Rm[x_,y_] := λ[MakeCWSeries[0],h[y]MakeLieSeries[-⟨x⟩]];

n=$SeriesShowDegree=$SeriesCompareDegree = 4;
Print /@ {
λ0=Randomλ[3,2,2],
λ0 // hta[1,1],
λ1=ReplacePart[λ0, 1->MakeCWSeries[0]],
λ1 // hta[1,1]
};

Testing tm

n=$SeriesShowDegree=$SeriesCompareDegree = 3;
Print /@ {λ0=Randomλ[n, 4,1],
λ0 // tm[1,2,2],
λ0 // tm[2,3,3],
t1 = λ0 // tm[1,2,2] // tm[2,3,3],
t2 = λ0 // tm[2,3,3] // tm[1,3,3],
t1≡t2
};

t1 = λ0 // tm[1,2,2] // tm[2,3,3] // InputForm

Testing hm

Print /@ {λ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
};

Testing hta

n=$SeriesShowDegree=$SeriesCompareDegree = 4;
Print /@ {λ0=Randomλ[3,2,2], λ0 // hta[1,1]};

Print /@ {λ0=Randomλ[n,3,2],
t1= λ0 // hta[1,1] // hta[1,2] // tm[1,2,1],
t2= λ0 // tm[1,2,1] // hta[1,1],
t1≡t2
};

n=$SeriesShowDegree=$SeriesCompareDegree = 5;
Print /@ {λ0=ReplacePart[Randomλ[n,2,3], 1->MakeCWSeries[0]],
t1= λ0 // hta[1,1] // hta[2,1] // hm[1,2,1],
t2= λ0 // hm[1,2,1] // hta[1,1],
t1≡t2
};

Testing dm

$SeriesShowDegree=3;
$SeriesCompareDegree = n=5;
Timing[Print /@ {λ0=Randomλ[n,4,4],
t1 = λ0 // dm[1,2,1] // dm[1,3,1],
t2 = λ0 // dm[2,3,2] // dm[1,2,1],
t1≡t2
};]

Testing R-Moves

(Rp[1,2]Rm[3,4]) // dm[1,3,1] // dm[2,4,2]

(Rp[1,2]Rm[3,4]) // dm[1,3,1] // dm[4,2,2]

t1=Rp[1,2]Rp[4,3]Rp[5,6] // dm[1,4,1] // dm[2,5,2] // dm[3,6,3]

t2=Rp[2,3]Rp[1,4]Rp[5,6] // dm[1,5,1] // dm[2,6,2] // dm[3,4,3]

{t1[7], t2[7], t1[7]==t2[7]}