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

Posted 1 year ago
1923 Views
|
|
4 Total Likes
| ThrowOnce 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}*{-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], 1], 1]]; one20cellvertices5 = DeleteDuplicates[ Flatten[ Outer[ Permute, ({0, GoldenRatio^(-1), GoldenRatio, Sqrt}*{-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4]), GroupElements[AlternatingGroup], 1], 1]]; one20cellvertices6 = Flatten[ Outer[Permute, ({GoldenRatio^(-1), 1, GoldenRatio, 2}*{-1, -1, -1, -1}^# & /@ Tuples[{0, 1}, 4]), GroupElements[AlternatingGroup], 1], 1]; And so we combine them all into one long list: one20cellvertices = Join[2 Sqrt 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], 1, 0], {i, 1, Length[v]}, {j, 1, Length[v]}]; Γ = AdjacencyGraph[M]; cycle = FindHamiltonianCycle[Γ]; v[[#[] & /@ (cycle[] /. 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 && f == 1 && f' == 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 && f == 1 && f' == 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)] 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)]] ArcCos[ 2 Sqrt[6/(27 + Sqrt)]])/ ArcCos[Root[841 - 3512 #1^2 + 2896 #1^4 &, 3]]], 0, Cos[(ArcCos[Sqrt[1/6 (3 - Sqrt)]] ArcCos[ 2 Sqrt[6/(27 + Sqrt)]])/ 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). Answer - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming! Answer