Message Boards Message Boards

[GIF] Coalesce (Deforming an isometric pattern)

Deforming an isometric pattern

Coalesce

Continuing with the theme of selectively breaking and re-forming a tiling pattern (1, 2, 3), though this time without any rotation.

Here's the (very slow) code:

DynamicModule[{BasicTileCoords, f, cols, centerpoint, ψ, layering}, 
 BasicTileCoords = {{0, -1}, {0, 0}, {Sqrt[3]/2, 1/2}, {Sqrt[3]/2, 0}, {Sqrt[3]/4, -1/4}, {Sqrt[3]/4, -3/4}};
 cols = ColorData["BlueGreenYellow"] /@ Range[1, 0, -1/4];
 f = 3 Piecewise[{{0, # < 0}, {1/2 - 1/2 Cos[#], 0 <= # < π}, {1, # >= π}}] &;
 layering = Append[Riffle[Reverse[Range[5]], -Reverse[Range[5]]], 0];
 Manipulate[
  Graphics[{EdgeForm[Directive[JoinForm["Round"], cols[[4]], Thickness[.006]]], 
    Table[
     {centerpoint = {3 Sqrt[3]/4 i, 3/2 j + (-1)^i*3/8};
      ψ = f[θ - π/(3 Sqrt[7]) Norm[centerpoint - {0, 3/8}]];
      FaceForm[Directive[cols[[t]]]], 
      Polygon[centerpoint + # & /@ (RotationMatrix[2 π t/3].(ψ {Sqrt[3]/4, -1/4} + #) & /@ BasicTileCoords)]}, 
      {j, layering}, {i, layering}, {t, 1, 3}]}, 
   PlotRange -> {{-5, 5}, {-5 + 3/8, 5 + 3/8}}, Background -> cols[[5]], ImageSize -> 540],
{θ, 0., 2 π}]
 ]
POSTED BY: Clayton Shonkwiler
9 Replies
Sort By:

@Vitaliy Kaurov Oh wow. Impressive!
POSTED BY: Clayton Shonkwiler

Clayton, Wolfram Facebook post with this art currently got 120 shares and almost 300 likes, - very popular! Very lovely!
POSTED BY: Vitaliy Kaurov

@J. M. Oh, right, Haversine[Clip[#,{0,?}]]& is definitely much nicer than my f. Thanks!
POSTED BY: Clayton Shonkwiler

@John Fultz Ah, smart! That's way faster. Thanks!
POSTED BY: Clayton Shonkwiler
J. M.
J. M.
Posted 9 years ago

Very nicely done! I was so impressed that I felt compelled to simplify the code slightly (though unfortunately it is only slightly faster than the original.):

Manipulate[Graphics[{EdgeForm[Directive[JoinForm["Round"], cols[[4]], Thickness[.006]]],
                     Flatten[Table[Block[{centerpoint = {3 Sqrt[3]/4 i, 3/2 j + (-1)^i 3/8}, ψ, tr},
                                          ψ = 3 Haversine[Clip[θ - π/(3 Sqrt[7]) EuclideanDistance[centerpoint, {0, 3/8}], {0, π}]];
                                          tr = Composition[TranslationTransform[centerpoint],
                                                           RotationTransform[2 π t/3], 
                                                           TranslationTransform[ψ {Sqrt[3]/4, -1/4}]];
                                         {FaceForm[cols[[t]]], Polygon[tr[BasicTileCoords]]}],
                                   {j, layering}, {i, layering}, {t, 1, 3}], 2]},
                    Background -> cols[[5]], ImageSize -> 540, PlotRange -> {{-5, 5}, {-5 + 3/8, 5 + 3/8}}],
           {θ, 0, 2 π}, Initialization :> (BasicTileCoords = 
                                           N[{{0, -1}, {0, 0}, {Sqrt[3]/2, 1/2}, {Sqrt[3]/2, 0}, {Sqrt[3]/4, -1/4}, {Sqrt[3]/4, -3/4}}, 20]; 
                                           cols = ColorData[{"BlueGreenYellow", "Reverse"}] /@ Subdivide[4]; 
                                           layering = Flatten[Append[Outer[Times, Range[5, 1, -1], {1, -1}], 0]];)]
POSTED BY: J. M.

If you pre-compute everything except for the bits that depend upon the Manipulate variable, it gets much faster. This code is not so pretty. I didn't try to make the most elegant refactoring that does precomputation...just one that I could easily refactor starting from your code. But, on my computer, the slider pretty much works in real time.

DynamicModule[{BasicTileCoords, f, cols, centerpoint, ψ, 
  layering, pts1, pts2, pts3, n}, 
 BasicTileCoords = {{0, -1}, {0, 0}, {Sqrt[3]/2, 1/2}, {Sqrt[3]/2, 
    0}, {Sqrt[3]/4, -1/4}, {Sqrt[3]/4, -3/4}};
 cols = ColorData["BlueGreenYellow"] /@ Range[1, 0, -1/4];
 f = 3 Piecewise[{{0, # < 0}, {1/2 - 1/2 Cos[#], 
       0 <= # < π}, {1, # >= π}}] &;
 layering = Append[Riffle[Reverse[Range[5]], -Reverse[Range[5]]], 0];
 {pts1, pts2, pts3} = 
  Table[centerpoint = {3 Sqrt[3]/4 i, 3/2 j + (-1)^i*3/8};
   ψ = f[n - π/(3 Sqrt[7]) Norm[centerpoint - {0, 3/8}]];
   N[centerpoint + # & /@ (RotationMatrix[
          2 t π /3].(ψ {Sqrt[3]/4, -1/4} + #) & /@ 
       BasicTileCoords)], {t, 1, 3}, {j, layering}, {i, layering}];
 Manipulate[
  Graphics[{EdgeForm[
     Directive[JoinForm["Round"], cols[[4]], Thickness[.006]]],
    {{FaceForm[Directive[cols[[1]]]], Polygon[Dynamic[Flatten[pts1 /. n -> θ, 1]]]},
       {FaceForm[Directive[cols[[2]]]], Polygon[Dynamic[Flatten[pts2 /. n -> θ, 1]]]},
       {FaceForm[Directive[cols[[3]]]], Polygon[Dynamic[Flatten[pts3 /. n -> θ, 1]]]}}}, 
   PlotRange -> {{-5, 5}, {-5 + 3/8, 5 + 3/8}}, 
   Background -> cols[[5]], ImageSize -> 540], {θ, 0., 
   2π}]]
POSTED BY: John Fultz

@Marina Shchitova Thanks. It took me forever to come up with the idea for this, so I'm glad you think it works.
POSTED BY: Clayton Shonkwiler

Very beautiful! The simplicity of underlying translation contrasts so much the visual complexity, contrasts are dramatic elements in art!

POSTED BY: Marina Shchitova

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the tops of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!
POSTED BY: EDITORIAL BOARD
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract