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

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\KBH"];

The Program

We load FreeLie.m and modify the formating of CWSeries:

<< FreeLie.m
$SeriesShowDegree=3; $SeriesCompareDegree = 5;

Format[s_CWSeries, StandardForm] := MapAt[
Style[#, GrayLevel[0.6]]&,
TopBracketForm[s[{$SeriesShowDegree}]],
1];
CWSeries[ser_Symbol][{dd_Integer}] := MapAt[
Style[#, GrayLevel[0.6]]&,
TopBracketForm[CWS@@Table[ser[d], {d, dd}]],
1];

t1=BCH[⟨u⟩, ⟨v⟩]

t1@{6}

Some set theoretic definitions:

Domain[f_List] := First /@ f;
f_∖key_ := DeleteCases[f, key -> _];
f_ ∖ keys_List := Fold[#1∖#2&, f, keys];
f1_List ≡ f2_List := Domain[f1]===Domain[f2] && (And @@ (
((#/.f1)≡(#/.f2))& /@ Domain[f1]));
LieMorphism[mor_][f_List] := MapAt[LieMorphism[mor], f, {All, 2}];
M[λ1_, ω1_] ≡ M[λ2_, ω2_] := (λ1≡λ2) && (ω1≡ω2);

(Subscript[RC, u_])[γ_LieSeries, ub_][s_] := StableApply[LieMorphism[⟨u⟩ -> Ad[γ][⟨ub⟩]], s];
(Subscript[RC, u_])[γ_LieSeries][s_] := s // (Subscript[RC, u])[γ,⟨υ⟩] // LieMorphism[⟨υ⟩->⟨u⟩];
(Subscript[J, u_])[γ_] := Module[{s},(∫_0^1)(γ // (Subscript[RC, u])[s γ] // (Subscript[div, u]) // LieMorphism[u -> Ad[-s γ][u]])\[DifferentialD]s];

(Subscript[J, v])[t1]@{4}

M /: M[λ1_, ω1_]*M[λ2_, ω2_] := M[λ1 ⋃ λ2, ω1+ω2];tm[u_,v_,w_][λ_List] := λ //  LieMorphism[⟨u⟩->⟨w⟩, ⟨v⟩->⟨w⟩];
tm[u_,v_,w_][M[λ_, ω_]] := LieMorphism[⟨u⟩->⟨w⟩, ⟨v⟩->⟨w⟩] /@ M[λ, ω];
hm[x_,y_,z_][λ_List] := Union[λ∖{x,y}, {z->BCH[x/.λ, y/.λ]}];
hm[x_,y_,z_][M[λ_, ω_]] := M[λ // hm[x,y,z], ω];
tha[u_, x_][λ_List] := MapAt[(Subscript[RC, u])[x /. λ], λ, {All, 2}];
tha[u_, x_][M[λ_, ω_]] := M[λ // tha[u,x], (ω+(Subscript[J, u])[x /. λ]) // (Subscript[RC, u])[x /. λ]];

hϵ[x_] := M[{x->MakeLieSeries[0]}, MakeCWSeries[0]]
(SuperPlus[ρ])[u_,x_] := M[{x->MakeLieSeries[⟨u⟩]}, MakeCWSeries[0]];
(SuperMinus[ρ])[u_,x_] := M[{x->MakeLieSeries[-⟨u⟩]}, MakeCWSeries[0]];

(SuperPlus[R])[a_,b_] := (SuperPlus[ρ])[a,b]*hϵ[a]; (SuperMinus[R])[a_,b_] := (SuperMinus[ρ])[a,b]*hϵ[a];
dm[a_,b_,c_][μ_] := μ // tha[⟨a⟩,b] // tm[⟨a⟩,⟨b⟩,⟨c⟩] // hm[a,b,c];

Testing Properties and Relations

Testing tm

Print /@ {{u=⟨"u"⟩, v=⟨"v"⟩, w=⟨"w"⟩};
1 -> (t1= M[{
x->MakeLieSeries[u+v+w], y->MakeLieSeries[b[u,v]+b[v,w]]
}, MakeCWSeries[CW["uvw"]]]),
2 -> (t1 // tm[u,v,u]),
3 -> (t2=t1 // tm[u,v,u]// tm[u,w,u]),
4 -> (t1 // tm[v,w,v]),
5 -> (t3=t1 // tm[v,w,v] // tm[u,v,u]),
6 -> (t2≡t3)};

Testing hm

Print /@ {
1-> (t1=(SuperPlus[ρ])[u,x](SuperPlus[ρ])[v,y](SuperPlus[ρ])[w,z]),
2-> (t1 // hm[x,y,x]),
3-> (t2=t1 // hm[x,y,x] // hm[x,z,x]),
4-> (t1 // hm[y,z,y]),
5-> (t3=t1 // hm[y,z,y] // hm[x,y,x]),
6-> (t2≡t3)};

Testing t-action

Print /@ {{u=⟨"u"⟩, v=⟨"v"⟩, w=⟨"w"⟩, t=⟨"t"⟩};
1-> (t1=M[{
x -> MakeLieSeries[u+b[u,t]], y -> MakeLieSeries[u+b[u,t]]
}, MakeCWSeries[CW["uu"]+CW["tuv"]]]),
2-> (t2=t1 // tm[u,v,w] // tha[w,x]),
3-> (t3=t1 // tha[u,x] // tha[v,x] // tm[u,v,w]),
4-> (t2≡t3)};

Testing h-action

Print /@ {{u=⟨"u"⟩, v=⟨"v"⟩};
1-> (t1=M[{
x -> MakeLieSeries[u+b[u,v]], y -> MakeLieSeries[v+b[u,v]]
}, MakeCWSeries[CW["uu"]+CW["uvv"]]]),
2-> (t2=t1 // hm[x,y,z] // tha[u,z]),
3-> (t3=t1 // tha[u,x] // tha[u,y] // hm[x,y,z]),
4-> (t2≡t3)};

Testing the Conjugation Relation

Print /@ {
1 -> (t1=(SuperPlus[ρ])[u,x](SuperPlus[ρ])[v,y](SuperPlus[ρ])[w,z]),
2 -> (t2=t1//tm[v,w,v] // hm[x,y,x] // tha[u,z]),
3 -> (t3=(SuperPlus[ρ])[v,x](SuperPlus[ρ])[w,z](SuperPlus[ρ])[u,y]),
4 -> (t4=t3 // tm[v,w,v] // hm[x,y,x]),
5 -> (t2≡t4)};

Demo 1 - The Knot (Subscript[8, 17])

μ1=(SuperMinus[R])[12,1](SuperMinus[R])[2,7](SuperMinus[R])[8,3](SuperMinus[R])[4,11](SuperPlus[R])[16,5](SuperPlus[R])[6,13](SuperPlus[R])[14,9](SuperPlus[R])[10,15]

Do[μ1 = μ1 // dm[1,k,1], {k,2,16}];
Last[μ1]@{6}

Series[Log[-(1/(X^3))+(4/(X^2))-(8/X)+11-8 X+4 (X^2)-(X^3) /. X->(E^x)], {x,0,6}]

Demo 2 - The Borromean Tangle

μ2= (SuperMinus[R])[r,6](SuperPlus[R])[2,4](SuperMinus[R])[g,9](SuperPlus[R])[5,7](SuperMinus[R])[b,3](SuperPlus[R])[8,1];
(Do[μ2 = μ2 // dm[r,k,r], {k,1,3}]; Do[μ2 = μ2 // dm[g,k,g], {k,4,6}];
Do[μ2 = μ2 // dm[b,k,b], {k,7,9}];  μ2)

(r/.First[μ2])@{5}

Last[μ2]@{5}

Further Runs for the KBH paper

(Subscript[T, 0])=(SuperMinus[R])[3,a](SuperPlus[R])[b,2](SuperPlus[R])[1,4];
(Subscript[T, 0])//dm[2,1,1]//dm[4,b,b]//dm[1,a,a]//dm[3,a,a]

trees=Table[(r/.First[μ2])@k, {k, 6}];t1= Series[(List@@trees //. w_LW :> B@@Reverse[LyndonFactorization[w]] /. B[s_] :> s /. t_B:> Tree[t]).(ℏ^(Range[Length[trees]])),
{ℏ,0,Length[trees]}
] /. {"r"->r, "g"->g, "b"->b};
t1 /. t_Tree :> TreeForm[t,
VertexRenderingFunction-> (Switch[#2,
Tree, {
Red,
Polygon[{{-0.4,0.4}-#1, {0.4, 0.4}-#1, {0.3,-0.4}-#1, {-0.3,-0.4}-#1}]
},
B, {},
_, {
ReleaseHold[#2 /. {r -> Red, g->Green, b->Blue}],
Disk[-#1, 0.4]
}
]&),
EdgeRenderingFunction->({
Brown, Thickness[0.03],
Line[-#]
}&),
PlotRangePadding -> 0, ImageSize -> 60, AspectRatio -> 1
]

n=6;
wheels=Table[Last[μ2]@k, {k,n}];
SetOptions[Rasterize, {RasterSize -> 256, ImageSize -> 256}];
Collect[
Expand[(Plus@@wheels)] /. CW[s_String] :> (ℏ^(StringLength[s]))Show[ImageCrop[PieChart3D[
Table[1, {StringLength[s]}],
ChartStyle :> (Characters[s] /. {"r"->Red, "g"->Green, "b"->Blue}),
SectorOrigin->{{RandomReal[{0,2π}],"Counterclockwise"},1},
ChartBaseStyle->EdgeForm[{Thickness[0.03],Black}],
ChartElementFunction->"ProfileSector3D",
ImagePadding -> 0, ImageMargins -> 0, PlotRangePadding->0
]], ImageSize -> 52],
ℏ, Factor]+((O[ℏ])^(n+1))

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"
]

e[a_,b_]:=MatrixExp[(({{b (Subscript[c, β]), -a (Subscript[c, β])}, {-b (Subscript[c, α]), a (Subscript[c, α])}}))];
e[1,0].e[0,1] == e[(((Subscript[c, α])+(Subscript[c, β]))/((E^((Subscript[c, α])+(Subscript[c, β])))-1))(((E^(Subscript[c, α]))-1)/(Subscript[c, α])), (((Subscript[c, α])+(Subscript[c, β]))/((E^((Subscript[c, α])+(Subscript[c, β])))-1))(E^(Subscript[c, α]))(((E^(Subscript[c, β]))-1)/(Subscript[c, β]))] // Simplify