Message Boards Message Boards

[GIF] Cross Sections (Slices of the cuboctahedron)

Slices of the cuboctahedron

Cross Sections

A classic @beesandbombs-style foreground/background mixup, this time with slices of the cuboctahedron in a chessboard pattern.

To define this, first we need a function I wrote more than five years ago (to make Quarter Turn) giving horizontal slices of the cuboctahedron (whose vertices I found using PolyhedronData["Cuboctahedron", "VertexCoordinates"]):

cubocta[t_] := Flatten[
   If[t < 1/2,
    Table[
     {(1 - 2 t) 1/2 {Cos[\[Theta]], Sin[\[Theta]]} + 2 t/Sqrt[2] {Cos[\[Theta] + \[Pi]/4], Sin[\[Theta] + \[Pi]/4]},
      (1 - 2 t) 1/2 {Cos[\[Theta]], Sin[\[Theta]]} + 2 t/Sqrt[2] {Cos[\[Theta] - \[Pi]/4], Sin[\[Theta] - \[Pi]/4]}},
     {\[Theta], \[Pi]/4, -2 \[Pi] + \[Pi]/2, -\[Pi]/2}],
    Table[
     {(1 - 2 (t - 1/2)) 1/Sqrt[2] {Cos[\[Theta] + \[Pi]/4], Sin[\[Theta] + \[Pi]/4]} + 2 (t - 1/2)/2 {Cos[\[Theta]], Sin[\[Theta]]},
      (1 - 2 (t - 1/2)) 1/Sqrt[2] {Cos[\[Theta] - \[Pi]/4], Sin[\[Theta] - \[Pi]/4]} + 2 (t - 1/2)/2 {Cos[\[Theta]], Sin[\[Theta]]}},
     {\[Theta], \[Pi]/4, -2 \[Pi] + \[Pi]/2, -\[Pi]/2}]],
   1];

We also need the trusty smootheststep function:

smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;

So now here's a Manipulate of the first half:

DynamicModule[{t, cols = RGBColor /@ {"#fdb827", "#21209c"}},
 Manipulate[
  t = smootheststep[s];
  Graphics[
   {cols[[-1]],
    Table[
     Polygon[
      TranslationTransform[{x, y}][
       RotationTransform[3 \[Pi]/4 t][
        (Sqrt[2] (1 - t) + t) cubocta[t/2]]]],
     {x, -6, 6, 2}, {y, -6, 6, 2}],
    Table[
     Polygon[
      TranslationTransform[{x, y}][
       RotationTransform[3 \[Pi]/4 t][
        (Sqrt[2] (1 - t) + t) cubocta[t/2]]]],
     {x, -5, 5, 2}, {y, -5, 5, 2}]},
   PlotRange -> {{-4.5, 3.5}, {-4.5, 3.5}}, Background -> cols[[1]], 
   ImageSize -> 540, PlotRangePadding -> -.01],
  {s, 0, 1}]
 ]

And the second half:

DynamicModule[{t, cols = RGBColor /@ {"#fdb827", "#21209c"}},
 Manipulate[
  t = smootheststep[s];
  Graphics[
   {cols[[1]],
    Table[
     Polygon[
      TranslationTransform[{x, y}][
       RotationTransform[\[Pi]/4 - 3 \[Pi]/4 t][
        (Sqrt[2] t + (1 - t)) cubocta[t/2 + 1/2]]]],
     {x, -5, 5, 2}, {y, -6, 6, 2}],
    Table[
     Polygon[
      TranslationTransform[{x, y}][
       RotationTransform[\[Pi]/4 - 3 \[Pi]/4 t][
        (Sqrt[2] t + (1 - t)) cubocta[t/2 + 1/2]]]],
     {x, -6, 6, 2}, {y, -5, 5, 2}]},
   PlotRange -> {{-4.5, 3.5}, {-4.5, 3.5}}, Background -> cols[[-1]], 
   ImageSize -> 540, PlotRangePadding -> -.01],
  {s, 0, 1}]
 ]
2 Replies

Very satisfying to watch! Thanks for sharing!

POSTED BY: Sander Huisman

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!

POSTED BY: EDITORIAL BOARD
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