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