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 (Update: See @Ed Pegg’s reply below for a much cleaner solution). 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, g,
cycle},
M = ParallelTable[
If[N[EuclideanDistance[v[[i]], v[[j]]]] == N[3 - Sqrt[5]], 1, 0],
{i, 1, Length[v]}, {j, 1, Length[v]}];
g = AdjacencyGraph[M];
cycle = FindHamiltonianCycle[g];
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 Pi/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
).