Pensieve header: Trees and Wheels for the Borromean Rings.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2013-03"];
<< FreeLie.m

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]
));
(* LieDerivation[der_][f_List] := MapAt[LieDerivation[der], f, {All, 2}]; *)
LieMorphism[mor_][f_List] := MapAt[LieMorphism[mor], f, {All, 2}];
M /: M[λ1_, ω1_]⋃ M[λ2_, ω2_] := M[λ1 ⋃ λ2, ω1+ω2];
M[λ1_, ω1_] ≡ M[λ2_, ω2_] := (λ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], ω];
RC[u_, λx_LieSeries, ub_][ser_] := StableApply[
LieMorphism[⟨u⟩ -> Ad[λx][⟨ub⟩]],
ser
];
RC[u_, λx_LieSeries][ser_] := ser // RC[⟨u⟩, λx,⟨"υ"⟩] // LieMorphism[⟨"υ"⟩->⟨u⟩];
J[u_, λx_] := Module[{s},
IntegrateCWSeries[
div[⟨u⟩,λx // RC[⟨u⟩, s λx]] // LieMorphism[⟨u⟩ -> Ad[-s λx][⟨u⟩]],
{s,0,1}
]
];
tha[u_, x_][λ_List] := MapAt[RC[⟨u⟩, x /. λ], λ, {All, 2}];
tha[u_, x_][M[λ_, ω_]] := M[λ // tha[u,x], (ω+J[⟨u⟩,x /. λ]) // RC[⟨u⟩, x /. λ]];
dm[a_,b_,c_][μ_] := μ // tha[⟨a⟩,b] // tm[⟨a⟩,⟨b⟩,⟨c⟩] // hm[a,b,c];
(SuperPlus[R])[u_,x_] := M[{x->MakeLieSeries[⟨u⟩], u->MakeLieSeries[0]}, MakeCWSeries[0]];
(SuperMinus[R])[u_,x_] := M[{x->MakeLieSeries[-⟨u⟩], u->MakeLieSeries[0]}, MakeCWSeries[0]];

μ0= (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[μ0 = μ0 // dm[r,k,r], {k,1,3}];
Do[μ0 = μ0 // dm[g,k,g], {k,4,6}];
Do[μ0 = μ0 // dm[b,k,b], {k,7,9}];
μ0

Trees

trees=Table[(r/.First[μ0])@k, {k, 8}];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
]

Wheels

n=7;
wheels=Table[Last[μ0]@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))