# [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[#[[1]], i] == Position[#[[2]], i + 1] && Position[#[[1]], i + 1] == Position[#[[2]], i] && And @@ Table[ Position[#[[1]], Mod[i + j, n, 1]] == Position[#[[2]], 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[5]; rotproj2 = ({{Cos[θ], 0, 0, -Sin[θ]}, {0, 1, 0, 0}} /. θ -> π/ 2 - .0001).permutohedronProjectionMatrix[5]; Graphics[{Thickness[.01], cols[[1]], CapForm["Round"], JoinForm["Round"], Line /@ ((1 - Min[t, 1]) (rotproj1.# & /@ # & /@ permutohedronEdges[5]) + (1 - Abs[t - 1]) (rotproj2.# & /@ # & /@ permutohedronEdges[5]) + (Max[t, 1] - 1) ({#[[1]], -#[[2]]} & /@ # & /@ (rotproj1.# & /@ # & /@ permutohedronEdges[5])))}, PlotRange -> 5, ImageSize -> 540, Background -> cols[[2]]]], {s, 0, 2}] 
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[5]; rotproj2 = ({{Cos[Pi], 0, 0, -Sin[Pi]}, {0, 1, 0, 0}} /. Pi -> Pi/ 2 - .0001).permutohedronProjectionMatrix[5]; Graphics[{Thickness[.01], cols[[1]], CapForm["Round"], JoinForm["Round"], Line /@ ((1 - Min[t, 1]) (rotproj1.# & /@ # & /@ permutohedronEdges[5]) + (1 - Abs[t - 1]) (rotproj2.# & /@ # & /@ permutohedronEdges[5]) + (Max[t, 1] - 1) ({#[[1]], -#[[2]]} & /@ # & /@ (rotproj1.# & /@ # & /@ permutohedronEdges[5])))}, PlotRange -> 5, ImageSize -> 540, Background -> cols[[2]]]], {s, 0, 2}] But other than that, pretty cool!
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.