# [GIF] All Day (Hamiltonian cycle on the 24-cell)

Posted 2 years ago
3398 Views
|
|
3 Total Likes
|
 All DaySame idea as Touch Â’Em All: this is the stereographic image of a Hamiltonian cycle on the 24-cell. The idea behind the code is the same, so look back at that post for an explanation (as before, the definition of ProjectedSphere[] is not reproduced here; see Inside). Stereo[{x1_, y1_, x2_, y2_}] := {x1/(1 - y2), y1/(1 - y2), x2/(1 - y2)} smootherstep[t_] := 6 t^5 - 15 t^4 + 10 t^3; twenty4cellvertices = Normalize /@ DeleteDuplicates[ Flatten[ Permutations /@ ({-1, -1, 0, 0}^Join[#, {1, 1}] & /@ Tuples[{0, 1}, 2]), 1] ]; sorted24CellVertices = Module[{v = twenty4cellvertices, M, ?, cycle}, M = Table[ If[v[[i]] != -v[[j]] && HammingDistance[v[[i]], v[[j]]] == 2, 1, 0], {i, 1, Length[v]}, {j, 1, Length[v]}]; ? = AdjacencyGraph[M]; cycle = FindHamiltonianCycle[?]; v[[#[[1]] & /@ (cycle[[1]] /. UndirectedEdge -> List)]] ]; DynamicModule[{?, viewpoint = 1/2 {-1, 1, 1}, pts = N[sorted24CellVertices], cols = RGBColor /@ {"#04E762", "#00A1E4", "#DC0073", "#011627"}}, Manipulate[ ? = ?/3 smootherstep[t]; Graphics3D[{Specularity[.4, 10], Table[ ProjectedSphere[RotationMatrix[?, {pts[[i]], pts[[Mod[i + 1, Length[pts], 1]]]}].pts[[i]], .2], {i, 1, Length[pts]}]}, PlotRange -> 4.5, ViewAngle -> ?/3, ViewPoint -> viewpoint, Boxed -> False, Background -> cols[[-1]], ImageSize -> 540, Lighting -> {{"Directional", cols[[1]], 50 {1, -1, 2}}, {"Directional", cols[[2]], 50 {1, 2, -1}}, {"Directional", cols[[3]], 50 {-2, -1, -1}}, {"Ambient", cols[[-1]]}}], {t, 0, 1}] ]