Message Boards Message Boards

GROUPS:

[GIF] Omnitruncated (More permutohedra)

Posted 4 years ago
1323 Views
|
4 Replies
|
5 Total Likes
|

Omnitruncated 5-cells

Omnitruncated

Following 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

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!

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.

That works pretty well, thanks!

enter image description here -- you have earned Featured Contributor Badge enter image description here

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!

Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract