# [GIF] Omnitruncated (More permutohedra)

Posted 4 years ago
1323 Views
|
4 Replies
|
5 Total Likes
| OmnitruncatedFollowing up on my earlier permutohedron GIF, the key elements of this GIF are two projections of the permutohedron of order 5, which is a 4-dimensional polytope (in fact, it's the omnitruncated 5-cell...hence the title), which are being linearly interpolated between. Here's a function for producing the edges of the permutohedron of order n, which naturally sits in the hyperplane in $\mathbb{R}^n$ given by $x_1 + \ldots + x_n = \frac{n(n+1)}{2}$, together with the matrix for projecting out the perpendicular direction: permutohedronEdges[n_] := Select[Subsets[Permutations[Range[n]], {2}], Or @@ Table[ Position[#[], i] == Position[#[], i + 1] && Position[#[], i + 1] == Position[#[], i] && And @@ Table[ Position[#[], Mod[i + j, n, 1]] == Position[#[], Mod[i + j, n, 1]], {j, 2, n - 1}], {i, 1, n - 1}] &]; permutohedronProjectionMatrix[n_] := Orthogonalize[NullSpace[Transpose[#].#]] &[{ConstantArray[1, n]}]; And the slightly gross Manipulate for the animation (the use of angles like $\pi/2 + .0001$ is a really inelegant way of avoiding zero-length edges, which gunk up the image with unwanted dots): Manipulate[Module[{t, cols, rotproj1, rotproj2}, t = 1/2 - (-1)^Floor[s] Cos[π s]/2 + Floor[s]; cols = RGBColor /@ {"#D8FFF1", "#5B73A7"}; rotproj1 = RotationMatrix[π/2 - ArcTan[Sqrt[3/5]]].({{Cos[θ], 0, 0, -Sin[θ]}, {0, 0, 1, 0}} /. θ -> π/ 2 + .0001).permutohedronProjectionMatrix; rotproj2 = ({{Cos[θ], 0, 0, -Sin[θ]}, {0, 1, 0, 0}} /. θ -> π/ 2 - .0001).permutohedronProjectionMatrix; Graphics[{Thickness[.01], cols[], CapForm["Round"], JoinForm["Round"], Line /@ ((1 - Min[t, 1]) (rotproj1.# & /@ # & /@ permutohedronEdges) + (1 - Abs[t - 1]) (rotproj2.# & /@ # & /@ permutohedronEdges) + (Max[t, 1] - 1) ({#[], -#[]} & /@ # & /@ (rotproj1.# & /@ # & /@ permutohedronEdges)))}, PlotRange -> 5, ImageSize -> 540, Background -> cols[]]], {s, 0, 2}] Answer
4 Replies
Sort By:
Posted 23 days ago
 I think you meant to have Pi instead of ? on the second set of code. Manipulate[ Module[{t, cols, rotproj1, rotproj2}, t = 1/2 - (-1)^Floor[s] Cos[Pi s]/2 + Floor[s]; cols = RGBColor /@ {"#D8FFF1", "#5B73A7"}; rotproj1 = RotationMatrix[ Pi/2 - ArcTan[ Sqrt[3/5]]].({{Cos[Pi], 0, 0, -Sin[Pi]}, {0, 0, 1, 0}} /. Pi -> Pi/ 2 + .0001).permutohedronProjectionMatrix; rotproj2 = ({{Cos[Pi], 0, 0, -Sin[Pi]}, {0, 1, 0, 0}} /. Pi -> Pi/ 2 - .0001).permutohedronProjectionMatrix; Graphics[{Thickness[.01], cols[], CapForm["Round"], JoinForm["Round"], Line /@ ((1 - Min[t, 1]) (rotproj1.# & /@ # & /@ permutohedronEdges) + (1 - Abs[t - 1]) (rotproj2.# & /@ # & /@ permutohedronEdges) + (Max[t, 1] - 1) ({#[], -#[]} & /@ # & /@ (rotproj1.# & /@ # & /@ permutohedronEdges)))}, PlotRange -> 5, ImageSize -> 540, Background -> cols[]]], {s, 0, 2}] But other than that, pretty cool! Answer
Posted 22 days ago
 Some were Pi and some were \[Theta]. This is a Wolfram Community bug that seems to occasionally replace special characters with question marks. I think I just fixed it, but let me know if there are still problems. Answer
Posted 22 days ago
 That works pretty well, thanks! Answer
Posted 22 days ago -- you have earned Featured Contributor Badge Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you! Answer