Message Boards Message Boards

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

GROUPS:

Stereographic projection of a Hamiltonian cycle on the 24-cell

All Day

Same 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}]
 ]
POSTED BY: Clayton Shonkwiler
Answer
6 months ago

enter image description here - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming!

POSTED BY: Moderation Team
Answer
6 months ago

Group Abstract Group Abstract