Pensieve header: The free-Lie meta-group-action structure for http://www.math.toronto.edu/~drorbn/papers/KBH/.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\KBH"];
<< CellExport.m
<< 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]}

(Subscript[8, 17])

Print /@ {
μ0=Rm[12,1]Rm[2,7]Rm[8,3]Rm[4,11]Rp[16,5]Rp[6,13]Rp[14,9]Rp[10,15],
Do[μ0 = μ0 // dm[1,k,1], {k,2,16}]; μ0
}

$RecursionLimit=2^16;
μ0[{4}]

μ0[{6}]

μ0[{8}]

Print /@ {β=-((1-4 X+8 (X^2)-11 (X^3)+8 (X^4)-4 (X^5)+(X^6))/(X^3))/. X->(E^x),
Series[β , {x,0,8}],
Series[Log[β] , {x,0,9}]
};

Runs for the KBH paper

Rp[u,x]

Format[CW[w_], StandardForm] := "["<>w<>"]";

(Subscript[T, 0])=Rm[3,a]Rp[b,2]Rp[1,4];
ζ=(Subscript[T, 0])//dm[2,1,1]//dm[4,b,b]//dm[1,a,a]//dm[3,a,a];
ζ[{4}]

Graphics3D[{
Red, Thickness[0.02], Line[{{0,-2,0}, {0,-1,0}}],
Thick, Line[Table[
{Cos[θ], Sin[θ], 0},
{θ, 0, 2π, 2π/72}
]],
RGBColor[1,0.65,0.65], Sphere[{0,0,0}, 1]
},
Axes -> True, AxesLabel -> {x,y,t}, LabelStyle -> Directive[Large],
Ticks -> {{}, {}, {-1,1}},
Lighting -> "Neutral"
]