6
|
9897 Views
|
5 Replies
|
10 Total Likes
View groups...
Share
GROUPS:

# [GIF] The Flips of a Honeycomb

Posted 8 years ago
 (N.B. Since Vitaliy had asked me quite a while back to write something here on Community, I finally sat down and typed up a description of one of my old artwork. I'd normally post stuff like these on my blog, but I guess at least this one could use some exposure.) I had liked the old article by Arthur Ogawa on how to continuously deform a catenoid into a helicoid. I had also been fiddling with hexagonal meshes, thanks to inspiration from Mark McClure. Inevitably, both ideas eventually got blended in my head, and I set out a few years ago to tie those two together. The idea became more attractive when I figured out how to manipulate GraphicsComplex[] objects; the challenge was in writing a method to generate such an object corresponding to a hexagonal mesh. I eventually settled on this: (* http://mathematica.stackexchange.com/questions/975 *) multisegment[lst_List, scts : {__Integer?Positive}, offset : {__Integer?Positive}] := Module[{n = Length[lst], k, offs}, k = Ceiling[n/Mean[offset]]; offs = Prepend[Accumulate[PadRight[offset, k, offset]], 0]; Take[lst, #] & /@ TakeWhile[Transpose[{offs + 1, offs + PadRight[scts, k + 1, scts]}], Apply[And, Thread[# <= n]] &]] /; Length[scts] == Length[offset]; multisegment[lst_List, scts : {__Integer?Positive}] := multisegment[lst, scts, scts] /; Mod[Length[lst], Total[scts]] == 0 hexMesh[{uMin_, uMax_}, {vMin_, vMax_}, {n_Integer, m_Integer}, dirs___] := GraphicsComplex[ AffineTransform[{DiagonalMatrix[{uMax - uMin, vMax - vMin}/{3 n, Sqrt[3] m}], {uMin, vMin}}] @ Flatten[Delete[NestList[TranslationTransform[{0, Sqrt[3]}], FoldList[Plus, {-1/2, Sqrt[3]/2}, Table[Through[{Cos, Sin}[-? Sin[k ?/2]/3]], {k, 4 n + 1}]], m], {{1, -1}, {-1, 1}}], 1], {dirs, Polygon[Flatten[{multisegment[#1, {4, 2}, {3, 1}], Reverse /@ multisegment[Rest[#2], {2, 4}, {1, 3}]} & @@@ Partition[Join[{PadRight[Range[4 n + 1], 4 n + 2]}, Partition[Range[4 n + 2, m (4 n + 2) - 1], 4 n + 2], {PadLeft[m (4 n + 2) - 1 + Range[4 n + 1], 4 n + 2]}], 2, 1], {{1, 3}, {2, 4}}]]}]  From there, it was a simple matter of mapping the surface equations to the points: helicat[h_][{u_, v_}] := {Sin[h] Sin[u] Sinh[v] + Cos[h] Cos[u] Cosh[v], Cos[h] Sin[u] Cosh[v] - Sin[h] Cos[u] Sinh[v], u Sin[h] + v Cos[h]} Animate[Graphics3D[MapAt[Map[helicat[h], #] &, mesh, 1], Background -> ColorData["Legacy", "DarkSlateGray"], Boxed -> False, ViewPoint -> {1.3, -2.4, 1.5}, PlotRange -> {{-1, 1} Cosh[5/4], {-1, 1} Cosh[5/4], {-? - ?/20, ? + ?/20}}], {h, 0, 2 ? - ?/20, ?/20}, Initialization :> {mesh = N[hexMesh[{-?, ?}, {-5/4, 5/4}, {16, 12}, Directive[EdgeForm[Directive[AbsoluteThickness[2], ColorData["Legacy", "DeepSkyBlue"]]], FaceForm[]]], 20]}] 
5 Replies
Sort By:
Posted 8 years ago
 - another post of yours has been selected for the Staff Picks group, congratulations !We are happy to see you at the top of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!
Posted 8 years ago
 Beautiful, @J. M. ! Thanks for remembering and finding the time, looking forward to more of these.
Posted 8 years ago
 Very nice!
Posted 8 years ago
 Well, since you've been posting a lot of your fine stuff here, I finally decided to take up Vitaliy's invitation. :) I'll see if I can write more descriptions for stuff in my art vault.
Posted 8 years ago
 Thanks for sharing this animation!