Message Boards Message Boards

GROUPS:

[GIF] Throw (Hamiltonian cycle on the 120-cell)

Posted 11 months ago
1305 Views
|
1 Reply
|
4 Total Likes
|

Hamiltonian cycle on the 120-cell

Throw

Once again, a Hamiltonian cycle on the vertices of a convex regular 4-polytope, stereographically projected to 3-dimensiona space. This time, it's the 120-cell, which has 600 vertices, which makes for a very long wait if you want to watch the entire cycle.

As usual, we need ProjectedSphere[], which stereographically projects a sphere inside the 3-sphere to 3-space; see Inside for the (long) definition of this function.

Now, inputting all 600 vertices is fairly annoying. First of all, the vertices of the 24-cell are also vertices of the 120-cell:

twenty4cellvertices = 
  Normalize /@ 
   DeleteDuplicates[
    Flatten[Permutations /@ ({-1, -1, 0, 0}^Join[#, {1, 1}] & /@ Tuples[{0, 1}, 2]), 1]];

Aside from that, there are six other classes of vertices (this was cribbed from the Wikipedia entry a couple of years ago, and could definitely be re-written in a nicer way):

one20cellvertices1 =
  DeleteDuplicates[
   Flatten[
    Permutations /@ ({1, 1, 1, Sqrt[5]}*{-1, -1, -1, -1}^# & /@ 
       Tuples[{0, 1}, 4]), 1]];
one20cellvertices2 =
  DeleteDuplicates[
   Flatten[
    Permutations /@ ({GoldenRatio^(-2), GoldenRatio, GoldenRatio, 
          GoldenRatio}*{-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4]), 1]];
one20cellvertices3 =
  DeleteDuplicates[
   Flatten[
    Permutations /@ ({GoldenRatio^(-1), GoldenRatio^(-1), 
          GoldenRatio^(-1), GoldenRatio^2}*{-1, -1, -1, -1}^# & /@ 
       Tuples[{0, 1}, 4]), 1]];
one20cellvertices4 =
  DeleteDuplicates[
   Flatten[
    Outer[
     Permute, ({0, GoldenRatio^(-2), 1, GoldenRatio^2}*{-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4]), 
     GroupElements[AlternatingGroup[4]], 1], 1]];
one20cellvertices5 =
  DeleteDuplicates[
   Flatten[
    Outer[
     Permute, ({0, GoldenRatio^(-1), GoldenRatio, Sqrt[5]}*{-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4]), 
     GroupElements[AlternatingGroup[4]], 1], 1]];
one20cellvertices6 =
  Flatten[
   Outer[Permute, ({GoldenRatio^(-1), 1, GoldenRatio, 2}*{-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4]), 
    GroupElements[AlternatingGroup[4]], 1], 1];

And so we combine them all into one long list:

one20cellvertices = 
  Join[2 Sqrt[2] twenty4cellvertices, one20cellvertices1, 
   one20cellvertices2, one20cellvertices3, one20cellvertices4, 
   one20cellvertices5, one20cellvertices6];

Now, as in the case of Touch ’Em All and All Day, the idea is to use FindHamiltonianCycle[] to find a Hamiltonian cycle. Unfortunately, if you just plug in the one20cellvertices without modification, this will just run for hours and never terminate. However, randomly permuting one20cellvertices and then running FindHamiltonianCycle[] seems to almost always work. Here's the code (of course, if you evaluate this, you will get a your own unique cycle, almost certainly different from the one shown in the animation):

sorted120CellVertices = 
  Module[{v = RandomSample[one20cellvertices], M, Γ, 
    cycle},
   M = ParallelTable[
     If[N[EuclideanDistance[v[[i]], v[[j]]]] == N[3 - Sqrt[5]], 1, 0],
     {i, 1, Length[v]}, {j, 1, Length[v]}];
   Γ = AdjacencyGraph[M];
   cycle = FindHamiltonianCycle[Γ];
   v[[#[[1]] & /@ (cycle[[1]] /. UndirectedEdge -> List)]]
   ];

Next, I wanted the motion to be not quite linear, but much closer to linear than what you get by applying Smoothstep or one of its variants. Of course, $\text{Smoothstep}(t) = a + bt + ct^2 + dt^2$, where the parameters $a,b,c,d$ are given by

Block[{f},
 f[t_] := a + b t + c t^2 + d t^3;
 Solve[f[0] == 0 && f[1] == 1 && f'[0] == 0 && f[1/2] == 1/2, {a, b, c, d}]
 ]

So for a less smooth function I just used the parameters which solve the similar system

Block[{f},
 f[t_] := a + b t + c t^2 + d t^3;
 Solve[f[0] == 0 && f[1] == 1 && f'[0] == 2/3 && f[1/2] == 1/2, {a, b, c, d}]
 ]

This gives my function unsmoothstep[]:

unsmoothstep[t_] := (2 t)/3 + t^2 - (2 t^3)/3;

Finally, then, we can put it all together (notice that Lighting is just the standard lighting, but with ambient light which isn't so dark):

DynamicModule[{n = 3, θ, viewpoint = 1/2 {-1, 1, 1},
  pts = N[Normalize /@ sorted120CellVertices],
  cols = RGBColor /@ {"#06BC40", "#F8B619", "#880085", "#E4F4FD"}}, 
 Manipulate[θ = 
   ArcCos[1/8 (1 + 3 Sqrt[5])] unsmoothstep[Mod[t, 1]];
  Graphics3D[
   {Specularity[.8, 30],
    Table[
     {cols[[Mod[i - Floor[t], n, 1]]],
      ProjectedSphere[
       RotationMatrix[θ, {pts[[i]], pts[[Mod[i + 1, Length[pts], 1]]]}].pts[[i]], .06]},
     {i, 1, Length[pts]}]},
   ViewPoint -> {Sin[(
      ArcCos[Sqrt[1/6 (3 - Sqrt[5])]] ArcCos[
        2 Sqrt[6/(27 + Sqrt[5])]])/
      ArcCos[Root[841 - 3512 #1^2 + 2896 #1^4 &, 3]]], 0, 
     Cos[(ArcCos[Sqrt[1/6 (3 - Sqrt[5])]] ArcCos[
        2 Sqrt[6/(27 + Sqrt[5])]])/
      ArcCos[Root[841 - 3512 #1^2 + 2896 #1^4 &, 3]]]},
   ViewVertical -> {1, 0, 0}, PlotRange -> 10, 
   SphericalRegion -> True, ViewAngle -> 2 π/9, Boxed -> False, 
   Background -> cols[[-1]], ImageSize -> 500,
   Lighting -> {{"Ambient", RGBColor[0.52, 0.36, 0.36]},
     {"Directional", RGBColor[0, 0.18, 0.5], ImageScaled[{2, 0, 2}]},
     {"Directional", RGBColor[0.18, 0.5, 0.18], ImageScaled[{2, 2, 3}]},
     {"Directional", RGBColor[0.5, 0.18, 0], ImageScaled[{0, 2, 2}]},
     {"Directional", RGBColor[0, 0, 0.18], ImageScaled[{0, 0, 2}]}}],
  {t, 0, n}]
 ]

The coefficient of unsmoothstep[t] in the definition of θ is just the angle between adjacent vertices of the 120-cell.

It's easy to use a different number of colors by adjusting n to be another divisor of 600 (and of course by adding more colors to cols).

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!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract