Message Boards Message Boards

GROUPS:

[GIF] Coalesce (Deforming an isometric pattern)

Posted 2 years ago
5541 Views
|
9 Replies
|
20 Total Likes
|

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 π}]
 ]
9 Replies

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!

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

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

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π}]]

@John Fultz Ah, smart! That's way faster. Thanks!

Posted 2 years ago

Very nicely done! I was so impressed that I felt compelled to simplify the code slightly:

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]];)]

tho unfortunately it is only slightly faster than the original.

POSTED BY: J. M.
Answer

@J. M. Oh, right, Haversine[Clip[#,{0,π}]]& is definitely much nicer than my f. Thanks!

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

@Vitaliy Kaurov Oh wow. Impressive!

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