Message Boards

WOLFRAM COMMUNITY

21100 Views

9 Replies

24 Total Likes

View groups...

Follow this post

Share this post:

GROUPS:

Staff Picks Visual Arts Geometry Graphics and Visualization Wolfram Language Computational Humanities

[GIF] Coalesce (Deforming an isometric pattern)

Clayton Shonkwiler

Clayton Shonkwiler, Colorado State University

Posted 9 years ago

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

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:

EDITORIAL BOARD

EDITORIAL BOARD, WOLFRAM

Posted 9 years ago

- 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

Marina Shchitova

Marina Shchitova, Consulting

Posted 9 years ago

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

POSTED BY: Marina Shchitova

Clayton Shonkwiler

Clayton Shonkwiler, Colorado State University

Posted 9 years ago

@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

John Fultz

John Fultz, Wolfram Research, Inc.

Posted 9 years ago

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

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

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

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.