Message Boards Message Boards

GROUPS:

[GIF] Coalesce (Deforming an isometric pattern)

Posted 3 years ago
6739 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

@Vitaliy Kaurov Oh wow. Impressive!

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

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

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

Posted 3 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

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

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

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

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!

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