# [GIF] Small Changes (Hamiltonian cycle on the great rhombicosidodecahedron)

Posted 1 year ago
1907 Views
|
3 Replies
|
4 Total Likes
| Small ChangesThis is the same idea as what I've been doing recently with Touch ’Em All, All Day, How Does That Work?, and Throw, but one dimension down: find a Hamiltonian cycle on the 1-skeleton of the great rhombicosidodecahedron, normalize to get everything happening on the unit sphere, then stereographically project down to the plane.First of all, we can extract the vertex coordinates from PolyhedronData[], find a Hamiltonian cycle using FindHamiltonianCycle[], and then re-order the vertices to be in the order they appear in the cycle: sortedGRVertices = Module[ {v = N[PolyhedronData["GreatRhombicosidodecahedron", "VertexCoordinates"]], M, Γ, cycle}, Γ = PolyhedronData["GreatRhombicosidodecahedron", "SkeletonGraph"]; cycle = FindHamiltonianCycle[Γ]; v[[#[] & /@ (cycle[] /. UndirectedEdge -> List)]] ]; Now, I'm going to form spherical circles of radius $1/4$ the spherical distance between adjacent vertices and then stereographically project them down to the plane. Stereographic projection takes circles to circles, but unfortunately the stereographic image of the center is not the center of the stereographic image of the circle, which makes things complicated. Nonetheless, the function ProjectedSphericalCircle[] (defined below) inputs the center and radius of the circle up in the sphere and outputs a Disk[] object with the correct center and radius. With that in hand, then, here's the code for an interactive version of the above animation: DynamicModule[{r, θ, n, pts = Normalize /@ sortedGRVertices, cols = RGBColor /@ {"#1DCED8", "#FAF9F0", "#F6490D", "#000249"}}, r = Min[DeleteCases[Flatten@Outer[VectorAngle, pts, pts, 1], 0.]]; n = Length[pts]; Manipulate[ θ = r unsmoothstep[t]; Graphics[ Table[ {Blend[cols[[;; -2]], Mod[i + 27 + t, n, 1]/(n - 1)], ProjectedSphericalCircle[ RotationMatrix[-π/2, {0, 0, 1}]. RotationMatrix[θ, {pts[[i]], pts[[Mod[i + 1, Length[pts], 1]]]}]. pts[[i]], r/4]}, {i, 1, Length[pts]}], PlotRange -> 5, ImageSize -> 540, Background -> cols[[-1]]], {t, 0, 1}] ] Finally, then, is the definition of ProjectedSphericalCircle[], which is quite ugly. I don't want to say too much about where it came from, other than that it was essentially the same procedure is described in the post on Inside: stereographically project an arbitrary circle on the sphere down to the plane and solve for the point where the normals to two distinct points intersect to find the center, and then of course the distance from either of those points to the center is the radius. Here's the definition: ProjectedSphericalCircle[{x_, y_, z_}, r_] := If[Chop[x] == Chop[y] == 0. && Chop[z + 1] == 0, Disk[{0, 0}, Tan[r/2]], Disk[{(x Cos[r] + (x z Sin[r])/Sqrt[1 - z^2])/( 1 - z Cos[r] - ((-x^2 - y^2) Sin[r])/Sqrt[ 1 - z^2]) + (Sqrt Sin[r] (x Sqrt[1 - z^2] (-1 + z Cos[r]) + x (-1 + z^2) Sin[r]) (( x Cos[r] - (y Sin[r])/Sqrt[1 - z^2])/(1 - z Cos[r]) - ( x Cos[r] + (x z Sin[r])/Sqrt[1 - z^2])/( 1 - z Cos[r] - ((-x^2 - y^2) Sin[r])/Sqrt[ 1 - z^2])))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[ r])^2 √(((-1 + z^2)^2 Sin[ r]^2 (3 - 4 z Cos[r] - Cos[2 r] + 2 z^2 Cos[2 r] + 4 Sqrt[1 - z^2] Sin[r] - 2 z Sqrt[1 - z^2] Sin[2 r]))/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[r])^4) (-((2 Sqrt Sin[r] (y Sqrt[1 - z^2] (z - Cos[r]) + x (-1 + z^2) Sin[r]))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r])^2 √(1/(-1 + z Cos[r])^4 (8 + 4 z^2 - 16 z Cos[r] - Cos[2 r] + 5 z^2 Cos[2 r] - Cos[2 (π/2 + r)] + z^2 Cos[2 (π/2 + r)]) Sin[r]^2))) + (Sqrt Sin[r] (x Sqrt[1 - z^2] (-1 + z Cos[r]) + x (-1 + z^2) Sin[r]))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[ r])^2 √(((-1 + z^2)^2 Sin[ r]^2 (3 - 4 z Cos[r] - Cos[2 r] + 2 z^2 Cos[2 r] + 4 Sqrt[1 - z^2] Sin[r] - 2 z Sqrt[1 - z^2] Sin[2 r]))/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[r])^4)))), ( y Cos[r] + (y z Sin[r])/Sqrt[1 - z^2])/( 1 - z Cos[r] - ((-x^2 - y^2) Sin[r])/Sqrt[ 1 - z^2]) + (2 Sqrt Sin[r] (y Sqrt[1 - z^2] (-1 + z Cos[r]) + y (-1 + z^2) Sin[r]) (( x Cos[r] - (y Sin[r])/Sqrt[1 - z^2])/(1 - z Cos[r]) - ( x Cos[r] + (x z Sin[r])/Sqrt[1 - z^2])/( 1 - z Cos[r] - ((-x^2 - y^2) Sin[r])/Sqrt[ 1 - z^2])))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[ r])^2 √(((-1 + z^2)^2 Sin[ r]^2 (12 - 16 z Cos[r] - 2 Cos[2 r] + 2 z^2 Cos[2 r] + (-2 + 6 z^2) Cos[2 r] + 16 Sqrt[1 - z^2] Sin[r] - 8 z Sqrt[1 - z^2] Sin[2 r]))/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[r])^4) (-((2 Sqrt Sin[r] (y Sqrt[1 - z^2] (z - Cos[r]) + x (-1 + z^2) Sin[r]))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r])^2 √(((-1 + z^2)^2 (8 - 16 z Cos[r] + Cos[2 r] + (-2 + 6 z^2) Cos[2 r] - Cos[2 (π/2 + r)] + z^2 (4 - Cos[2 r] + Cos[2 (π/2 + r)])) Sin[ r]^2)/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r])^4))) + (2 Sqrt Sin[r] (x Sqrt[1 - z^2] (-1 + z Cos[r]) + x (-1 + z^2) Sin[r]))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[ r])^2 √(((-1 + z^2)^2 Sin[ r]^2 (12 - 16 z Cos[r] - 2 Cos[2 r] + 2 z^2 Cos[2 r] + (-2 + 6 z^2) Cos[2 r] + 16 Sqrt[1 - z^2] Sin[r] - 8 z Sqrt[1 - z^2] Sin[2 r]))/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[r])^4))))}, Abs[((x Cos[r] - (y Sin[r])/Sqrt[1 - z^2])/(1 - z Cos[r]) - ( x Cos[r] + (x z Sin[r])/Sqrt[1 - z^2])/( 1 - z Cos[r] - ((-x^2 - y^2) Sin[r])/Sqrt[ 1 - z^2]))/(-((2 Sqrt Sin[r] (y Sqrt[1 - z^2] (z - Cos[r]) + x (-1 + z^2) Sin[r]))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r])^2 √(((-1 + z^2)^2 (8 - 16 z Cos[r] + Cos[2 r] + (-2 + 6 z^2) Cos[2 r] - Cos[2 (π/2 + r)] + z^2 (4 - Cos[2 r] + Cos[2 (π/2 + r)])) Sin[ r]^2)/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r])^4))) + (2 Sqrt Sin[r] (x Sqrt[1 - z^2] (-1 + z Cos[r]) + x (-1 + z^2) Sin[r]))/((-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[ r])^2 √(((-1 + z^2)^2 Sin[ r]^2 (12 - 16 z Cos[r] - 2 Cos[2 r] + 2 z^2 Cos[2 r] + (-2 + 6 z^2) Cos[2 r] + 16 Sqrt[1 - z^2] Sin[r] - 8 z Sqrt[1 - z^2] Sin[2 r]))/(-Sqrt[1 - z^2] + z Sqrt[1 - z^2] Cos[r] + (-1 + z^2) Sin[r])^4)))]]] Answer
3 Replies
Sort By:
Posted 1 year ago - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming! Answer
 This is just great!Jesus Rico Answer
Posted 1 year ago
 Thanks! Answer
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.