Today. A riddle on spheres, Charlene’s project, Etienne’s project, a more efficient Jones algorithm.

Topics (in no particular order). Whatever you may suggest; whatever comes to my mind; the Fibonacci numbers; the Catalan numbers; the Jones polynomial; a more efficient Jones algorithm; a riddle on spheres; Khovanov homology; Γ-calculus; the Hopf fibration; Hilbert’s 13th problem; non-commutative Gaussian elimination; free Lie algebras; the Baker-Campbell-Hausdorff formula; wacky numbers; an order 4 torus; the Schwarz Lantern; knot colourings; the Temperley-Lieb pairing; the dodecahedral link; sound experiments; barycentric subdivisions; a Peano curve; braid closures and Vogel’s algorithm; the insolubility of the quintic; phase portraits; the Mandelbrot set; shadows of the Cantor aerogel; quilt plots; some image transformations; De Bruijn graphs; the Riemann series theorem; finite type invariants and the Willerton fish.

Pensieve header: October 6: A riddle on spheres.

A great riddle. (2^n) yellow unit balls are centered at the vertices of the n-dimensional cube (({-1,1})^n). Let (Subscript[B, n]) be the largest blue ball centered at 0 bound by the yellow balls, and let (Subscript[C, n]) be the smallest red cube bounding the yellow balls. Compute (lim_(n->∞))((Vol((Subscript[B, n])))/(Vol((Subscript[C, n])))).

Tuples[{1,-1},3]

Graphics3D[{
Yellow, Opacity[0.5], Table[Sphere[c,1], {c, Tuples[{1,-1},3]}],
Red, Opacity[0.2], Cuboid[{-2,-2,-2},{2,2,2}],
Blue, Opacity[1],Sphere[{0,0,0}, Sqrt[3]-1]
}]

Plot3D[Cos[(x^2)+(y^2)], {x,-5,5},{y,-5,5}, PlotPoints->50]

Graphics3D[{
Yellow, Opacity[0.5], Table[Sphere[c,1], {c, Tuples[{1,-1},3]}],
Red, Opacity[0.2], Cuboid[{-2,-2,-2},{2,2,2}],
Blue, Opacity[1],Sphere[{0,0,0}, Sqrt[3]-1]
}, Boxed -> False]

Graphics[{
Yellow, Table[Disk[c,1], {c, Tuples[{1,-1},2]}],
Blue, Disk[{0,0}, Sqrt[2]-1]
}]

r[n_]:= ((2 (π^(n/2)) ((((Sqrt[n])-1))^n))/((4^n)n (Gamma[(n/2)])))

r[n]

Table[r[n], {n,2,50}]//N

ListPlot[Table[r[n], {n,2,500}], PlotRange->All]

ListPlot[Table[Log[r[n]], {n,2,500}], PlotRange->All]

ListPlot[Table[Log[r[n]], {n,2,5000}]]

n=2;
While[r[n]<1, ++n];
n

ListPlot[Table[Log[r[n]], {n,1100,1300}]]