Pensieve header: Images for http://www.math.toronto.edu/~drorbn/Talks/Toronto-1303/.

The Borromean Tangle

Formulas from http://paulbourke.net/geometry/borromean/

SetDirectory["C:\\drorbn\\AcademicPensieve\\2013-03"]

r=N[(Sqrt[3])/3];
{s1,s2,s3} =Table[
{
{Cos[u], Sin[u]+r, Cos[3u]/3},
{Cos[u]+0.5, Sin[u]-r/2, Cos[3u]/3},
{Cos[u]-0.5, Sin[u]-r/2, Cos[3u]/3}
},
{u,0., 2π, 2π/48}
] // Transpose;
Rasterize[Graphics3D[{
{Red, Tube[s1, 0.15]},
{Green, Tube[s2, 0.15]},
{Blue, Tube[s3, 0.15]}
}]]

SetOptions[Rasterize, {RasterSize -> 800, ImageSize -> 800}];
rr=N[(Sqrt[3])/3]; du=π/192.;
s1=Table[{Cos[u], Sin[u]+rr, -Cos[3u]/6}, {u, 4π/6, 15π/6, du}];
s2=Table[{Cos[u]+0.5, Sin[u]-rr/2, -Cos[3u]/6}, {u, 12π/6, 23π/6, du}];
s3=Table[{Cos[u]-0.5, Sin[u]-rr/2, -Cos[3u]/6}, {u, 8π/6, 19π/6, du}];
L=Length[s1];
rs=Table[Which[
k>L/11, 0.15,
k≤L/11, 3k/L
], {k,L,1,-1}];
gg=Graphics3D[{CapForm["Square"],
{Red, Tube[s1, rs]},
{Blue, Tube[s2, rs]},
{Green, Tube[s3, rs]}
},
Boxed -> False, ViewPoint -> {0,0,Infinity}];
MakeImage["BorromeanTangle", gg]

Trees

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

trees=LS[0,⟨"bg"⟩,((⟨"bbg"⟩)/2)+((⟨"bgg"⟩)/2)+⟨"bgr"⟩,((⟨"bbbg"⟩)/6)+((⟨"bbgg"⟩)/4)+((⟨"bbgr"⟩)/2)+((⟨"bggg"⟩)/6)+((⟨"bggr"⟩)/2)+((⟨"bgrr"⟩)/2),((⟨"bbbbg"⟩)/24)+((⟨"bbbgg"⟩)/12)+((⟨"bbbgr"⟩)/6)-((⟨"bbgbg"⟩)/12)+((⟨"bbggg"⟩)/12)+((⟨"bbggr"⟩)/4)-⟨"bbgrg"⟩+((⟨"bbgrr"⟩)/4)-2 ⟨"bbrgg"⟩+((⟨"bgbgr"⟩)/2)-⟨"bgbrg"⟩+((⟨"bgggg"⟩)/24)+((⟨"bgggr"⟩)/6)+((⟨"bggrr"⟩)/4)-((⟨"bgrgr"⟩)/2)+((⟨"bgrrr"⟩)/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}

t={x,{x,y}}

Framed[TreeForm[t,
VertexRenderingFunction-> (If[#2===List, {},
{
Text[ToString[#2], #1],
Disk[#1, 0.2]
}
]&),
PlotRangePadding->0
]]

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

data=CWS[0,0,2 CW["bgr"],CW["bbgr"]-CW["bgbr"]+CW["bggr"]-CW["bgrg"]+CW["bgrr"]-CW["brgr"],((CW["bbbgr"])/3)-((CW["bbgbr"])/2)+((CW["bbggr"])/2)+((CW["bbgrg"])/2)+((CW["bbgrr"])/2)+((CW["bbrbg"])/2)-((3 CW["bbrgr"])/2)+((CW["bgbrr"])/2)-((3 CW["bggbr"])/2)+((CW["bgggr"])/3)-((CW["bggrg"])/2)+((CW["bggrr"])/2)+((CW["bgrgg"])/2)-((3 CW["bgrrg"])/2)+((CW["bgrrr"])/3)+((CW["brggr"])/2)-((CW["brgrr"])/2)+((CW["brrgr"])/2)];
SetOptions[Rasterize, {RasterSize -> 256, ImageSize -> 256}];
Collect[
Expand[(Plus@@data)] /. 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[ℏ])^6)