# [GIF] Touch Em All (Hamiltonian cycle on the hypercube)

Posted 2 years ago
2883 Views
|
|
4 Total Likes
|
 Touch Em AllConsider the vertices of the hypercube as points on the 3-sphere. If we center a sphere of radius 0.2 at each vertex and stereographically project to $\mathbb{R}^3$, the result is the first frame in this animation.Of course, to accomplish that we need a stereographic projection function: Stereo[{x1_, y1_, x2_, y2_}] := {x1/(1 - y2), y1/(1 - y2), x2/(1 - y2)} As well as the ProjectedSphere[] function from Inside (which I won't reproduce here due to its length and unpleasantness, but which produces the stereographic image of a given sphere in the 3-sphere).Now, the animation shows a Hamiltonian cycle of the 1-skeleton of the hypercube (a.k.a., the hypercube graph). Now one can extract such a Hamiltonian cycle using FindHamiltonianCycle[HypercubeGraph[4]], but the coordinates of the vertices of HypercubeGraph[4] are only given in 2-D, so this doesn't help so much with actual visualization. So instead I construct the 1-skeleton of the hypercube, find a Hamiltonian cycle using FindHamiltonianCycle[], and then sort the vertices to appear in the order from the given cycle (by semi-coincidence, this actually turns out to be exactly the same Hamiltonian cycle as one gets from evaluating FindHamiltonianCycle[HypercubeGraph[4]]): sortedHypercubeVertices = Module[{v = Tuples[{1/2, -1/2}, {4}], M, ?, cycle}, M = Table[ If[HammingDistance[v[[i]], v[[j]]] == 1, 1, 0], {i, 1, Length[v]}, {j, 1, Length[v]}]; ? = AdjacencyGraph[M]; cycle = FindHamiltonianCycle[?]; v[[#[[1]] & /@ (cycle[[1]] /. UndirectedEdge -> List)]] ]; With that all in place, then, we just need to rotate the $i$th vertex to the $(i+1)$st vertex (mod 16) up in the 3-sphere and then stereographically project (with a little help from the smoothstep function, which makes the transitions less jarring): smoothstep[t_] := 3 t^2 - 2 t^3; DynamicModule[{?, pts = N[sortedHypercubeVertices], cols = RGBColor /@ {"#41EAD4", "#B91372", "#011627"}}, Manipulate[ ? = ?/3 smoothstep[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 -> 3, Boxed -> False, ViewPoint -> 1/2 {2, 1, 0}, ViewAngle -> ?/4, Lighting -> {{"Directional", cols[[1]], {0, 0, 50}}, {"Directional", cols[[2]], {0, 0, -50}}, {"Ambient", cols[[-1]]}}, Background -> cols[[-1]], ImageSize -> 540], {t, 0, 1} ] ]