12
$\begingroup$

Frank Stella

Frank Stella, one of the most fanous contemporary American artists, died on May 4 at the age of 87 at his home in Manhattan. I learnt this from our colleague Yarchik, who, a few days ago, brought Frank Stella's geometric works to my attention.

enter image description here

Frank Stella in front of one of his large "Protractor" paintings, ca. 1970

enter image description here

Frank Stella, Abra Variation I, 1969, MoMA, New York"

"Abstraction didn't have to be limited to a kind of rectilinear geometry or even a simple curve geometry. It could have a geometry that had a narrative impact. In other words, you could tell a story with the shapes."

Stella once remarked (source).

Lac Laronge

I particularly like "Lac Laronge IV", a nested, elegant composition of an Enneper minimal surface, an Astroid and translated circle segments.

enter image description here

Frank Stella, Lac Laronge IV, 1969, Toledo Museum of Art

Reproduction attempt

The structure on the left of "Lac Laronge" bears a striking resemblance to the top view of an Enneper surface:

enneper = {u - (u^3/3) + u v^2, v - (v^3/3) + u^2 v, u^2 - v^2};

GraphicsRow[{
  ParametricPlot3D[enneper, {u, -2, 2}, {v, -2, 2}],
  ParametricPlot[Most @ enneper, {u, -2, 2}, {v, -2, 2}]},
 Alignment -> Center,
 Dividers -> All,
 FrameStyle -> LightGray]

enter image description here

(* Top view of Enneper surface *)
pa = ParametricPlot[Most @ enneper, {u, -2, 2}, {v, -2, 2}];

(* Translated and rescaled Astroid *)
pb = ParametricPlot[7.5 {1 + Cos[t]^3, Sin[t]^3}, {t, 0, 2 Pi}, PlotStyle -> ColorData[97][2]]

(* Translated and rescaled Circle *)
pc = ParametricPlot[7.5 {1 + Cos[t], Sin[t]}, {t, 0, 2 Pi}, PlotStyle -> ColorData[97][3]]

Skeleton of Lac Laronge

Show[pa, pb, pc, PlotRange -> All]

enter image description here

Next I tried to colour the four leaves of the Enneper surface differently, using cvgmt's and kglr's answers to Colouring the "leaves" (self-intersections) of parametric curves. But this and other attempts (MeshShading - options) only produced ugly results.

Question

How can we reproduce / approximate "Lac Laronge IV"?

$\endgroup$

2 Answers 2

12
$\begingroup$
Clear["Global`*"];
r = 1; d = .25; 
reg = 
 RegionDifference[
  BoundaryDiscretizeRegion[Disk[{0, 0}, r, {0, π}]], 
  RegionDifference[
   BoundaryDiscretizeRegion[Disk[{0, 0}, r - d, {0, π}]], 
   Rectangle[{-(r - d), 0}, {r - d, d}]]]

enter image description here

  • Needs Version >=13.0 to use PlanarFaceList.
pts = MeshCoordinates[reg];
closedlines = 
  MeshCells[reg, 1, "Multicells" -> True] /. 
   Line[indexs_] :> {Line[
      pts[[Append[#, First@#] &@indexs[[;; , 1]]]]]};
lines = Join[closedlines, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[-(π/2), {0, r}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[π/2, {0, r}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[π, {0, r}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[-(π/2), {r, 0}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     ReflectionTransform[{r, 0}, {r, 0}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[π, {r, r}]@{x, y}];
data = Region`Mesh`SplitIntersectingSegments[lines];
pts = data[[1]];
splits = data[[2]];
segments = Flatten[Partition[#, 2, 1] & /@ splits, 1];
g = Graph[Range@Length@pts, UndirectedEdge @@@ segments, 
   VertexCoordinates -> pts];
faces = PlanarFaceList[g];
polys = Polygon[pts[[#]]] & /@ faces;
polys = Delete[polys, First@Ordering[Area@polys, -1]];
colors = ColorData[97] /@ Range@Length@polys;
GraphicsRow[{Graphics[{RandomColor[], #} & /@ lines], 
  Graphics[Thread[{colors, polys}]]}]

enter image description here

Graphics[{MapIndexed[Text[Style[First@#2, 14], RegionCentroid@#1] &, 
   polys], EdgeForm[Black], FaceForm[], polys}]
Graphics[{{Darker@Red, 
   RegionUnion@polys[[{7, 9, 5, 14, 15}]]}, {Yellow, 
   RegionUnion@polys[[{8}]]}, {Brown, 
   RegionUnion@polys[[{6, 3, 2}]]}, {Blue, 
   RegionUnion@polys[[{16, 18, 25}]]}, {Green, 
   RegionUnion@polys[[{17}]]}, {Cyan, 
   RegionUnion@polys[[{22, 21, 23, 4}]]}, {Red, 
   RegionUnion@polys[[{11, 12}]]}, {Green, 
   RegionUnion@polys[[{34, 31}]]}, {Red, 
   RegionUnion@polys[[{37, 35}]]}, {Gray, 
   RegionUnion@polys[[{34, 36}]]}, {Purple, 
   RegionUnion@polys[[{33, 32, 31, 30}]]}, {Orange, 
   RegionUnion@polys[[{39}]]}, {Yellow, RegionUnion@polys[[{40}]]}}, 
 Background -> Black, PlotRange -> {{-r, 2 r}, {0, 2 r}}]

enter image description here

  • Add the three extra regions.
reg1 = RegionIntersection[
   RegionDifference[
    RegionIntersection[
     BoundaryDiscretizeRegion@Annulus[{0, 2   r}, {r, r + d}], 
     BoundaryDiscretizeRegion@Disk[{-r, r}, r]], 
    BoundaryDiscretizeRegion@Disk[{0, 0}, r]], 
   Rectangle[{-r, 0}, {0, 2   r}]];
reg2 = RegionDifference[
   RegionDifference[
    RegionIntersection[
     BoundaryDiscretizeRegion@Annulus[{0, 0}, {r, r + d}], 
     BoundaryDiscretizeRegion@Disk[{r, r}, r]], 
    BoundaryDiscretizeRegion@Disk[{2   r, 0}, r]], 
   BoundaryDiscretizeRegion@Disk[{0, 2   r}, r]];
Graphics[{EdgeForm[White], {Darker@Red, 
   RegionUnion@polys[[{7, 9, 5, 14, 15}]]}, {Yellow, 
   RegionUnion@polys[[{8}]]}, {Brown, 
   RegionUnion@polys[[{6, 3, 2}]]}, {Blue, 
   RegionUnion@polys[[{16, 18, 25}]]}, {Green, 
   RegionUnion@polys[[{17}]]}, {Cyan, 
   RegionUnion@polys[[{22, 21, 23, 4}]]}, {Red, 
   RegionUnion@polys[[{11, 12}]]}, {Green, 
   RegionUnion@polys[[{34, 31}]]}, {Red, 
   RegionUnion@polys[[{37, 35}]]}, {Gray, 
   RegionUnion@polys[[{34, 36}]]}, {Purple, 
   RegionUnion@polys[[{33, 32, 31, 30}]]}, {Orange, 
   RegionUnion@polys[[{39}]]}, {Yellow, 
   RegionUnion@polys[[{40}]]}, {LightYellow, reg1, Orange, 
   RotationTransform[-(π/2), {0, r}]@reg1, Gray, reg2}}, 
 Background -> Black, PlotRange -> {{-r, 2 r}, {0, 2 r}}]

enter image description here

Try to reproduce the first picture.

Clear["Global`*"];
r = 1;
d = .13;
line[i_] := 
 DiscretizeGraphics@
  RegionIntersection[Circle[{0, 0}, r - i*d], 
   HalfPlane[{0, i*d}, {1, 0}, {0, 1}]]
closedlines = 
  Append[#, Line[{#[[-1, 1, -1]], #[[1, 1, 1]]}]] &@
     MeshPrimitives[#, 1] & /@ {line[-1], line[0], line[1], line[2]};
lines = Join[closedlines[[{2, 3, 4}]], 
   closedlines[[{2, 3, 4}]] /. {x_Real, y_Real} :> 
     RotationTransform[-(π/2), {0, r}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[π/2, {0, r}]@{x, y}, 
   closedlines /. {x_Real, y_Real} :> 
     RotationTransform[π, {0, r}]@{x, y}];
data = Region`Mesh`SplitIntersectingSegments[lines];
pts = data[[1]];
splits = data[[2]];
segments = Flatten[Partition[#, 2, 1] & /@ splits, 1];
g = Graph[Range@Length@pts, UndirectedEdge @@@ segments, 
   VertexCoordinates -> pts];
faces = PlanarFaceList[g];
polys = Polygon[pts[[#]]] & /@ faces;
polys = Delete[polys, First@Ordering[Area@polys, -1]];
colors = ColorData[97] /@ Range@Length@polys;
{Graphics[{RandomColor[], #} & /@ lines], 
 Graphics[Thread[{colors, polys}]]}

enter image description here

  • It seems that we need to find a dynamic mode to add the colors. At the begining level, we use the Mouseover in the left side to get the indexs of the polygons of the right side.
{Graphics[{Table[
    Mouseover[{EdgeForm[Cyan], FaceForm[LightRed], polys[[i]]}, {Red, 
      polys[[i]], Text[Style[i, Red, 25], {1.2 r, 1}, {-1, 0}]}], {i, 
     1, Length@polys}], {FaceForm[], EdgeForm[Thick], 
    Rectangle[{-r, 0}, {r, 2 r}]}}, ImageSize -> 400, 
  PlotRange -> {{-r - .2 r, 1.5 r}, {-.2 r, 2.3 r}}], 
 Graphics[{{Orange, 
    RegionUnion@
     polys[[{14, 15, 12, 11, 84, 3, 2, 10, 11, 50, 4, 62}]]}, {Yellow,
     RegionUnion@polys[[{58, 57, 13, 27, 37, 53, 54}]]}, {Cyan, 
    RegionUnion@polys[[{34, 30, 44, 16, 22, 66, 68, 97, 94}]]}, {Blue,
     RegionUnion@
     polys[[{29, 17, 18, 19, 26, 25, 24, 23}]]}, {LightPink, 
    RegionUnion@polys[[{48, 59, 51, 6, 5, 83, 74}]]}, {Darker@Green, 
    RegionUnion@
     polys[[{76, 1, 17, 33, 75, 21, 70, 71, 69, 72}]]}, {Pink, 
    RegionUnion@polys[[{63, 85, 81, 31, 20}]]}, {Purple, 
    RegionUnion@
     polys[[{28, 36, 35, 8, 9, 93, 41, 42, 43, 40, 93, 103, 
        96}]]}, {Brown, 
    RegionUnion@polys[[{98, 67, 55, 61, 46, 78, 87, 79}]]}, {Darker@
     Brown, RegionUnion@
     polys[[{95, 47, 56, 60, 49, 89, 78, 82, 73}]]}, {Lighter@Yellow, 
    RegionUnion@polys[[{86, 77}]]}, {Darker@Brown, 
    RegionUnion@polys[[{91, 90}]]}, {Darker@Blue, 
    RegionUnion@polys[[{39}]]}, {LightYellow, 
    RegionUnion@polys[[{99, 80, 88, 45}]]}, {Darker@Green, 
    RegionUnion@polys[[{38, 32}]]}}, 
  PlotRange -> {{-r, r}, {0, 2  r}}, ImageSize -> 300]}

enter image description here

$\endgroup$
2
11
$\begingroup$

Starting out from a graphics skeleton in order to cut out the base forms (leafs) and putting all together through image processing:

skeleton  = Graphics[{
     Black, Opacity[.2], Rectangle[{0, 0}, {4, 4}]
   , Blue, Opacity[.8], Rectangle[{0, 0}, {3, 3}]
   , Red, Opacity[.5], Annulus[{0, 0}, {3, 4}, {0, Pi/4}]
   , Green, Opacity[.5], Annulus[{0, 0}, {3, 4}, {Pi/4, Pi/2}]
   , Yellow, Opacity[.8], Annulus[{4, 4}, {3, 4}, {-Pi, -Pi/2}]
   }]

enter image description here

image = Image[Graphics[{
   Black, Opacity[.2], Rectangle[{0, 0}, {4, 4}]
 , Blue, Opacity[.8], Rectangle[{0, 0}, {3, 3}]
 , Red, Opacity[.5], Annulus[{0, 0}, {3, 4}, {0, Pi/4}]
 , Green, Opacity[.5], Annulus[{0, 0}, {3, 4}, {Pi/4, Pi/2}]
 , Yellow, Opacity[.8], Annulus[{4, 4}, {3, 4}, {-Pi, -Pi/2}]
 }], ImageResolution -> 600];
ymask = Binarize[
   Image[Graphics[{Yellow, Opacity[.5], Disk[{0, 0}, 4, {0, Pi/2}]}, 
     Background -> White], ImageResolution -> 600], {1, 1}];
bmask = Binarize[
   Image[Graphics[{Blue, Opacity[.3], Disk[{4, 4}, 4, {-Pi, -Pi/2}]}, 
     Background -> White], ImageResolution -> 600], {1, 1}];
ybmask = ImageAdd[ymask, bmask];

leaf = RemoveBackground@ImageMultiply[image, ColorNegate@ybmask]

enter image description here

cs = ColorSeparate[leaf]

enter image description here

comp1 = Binarize[#, .9] & /@ cs;
comp2 = Binarize[#, .7] & /@ cs;
Grid[{comp1, comp2}, Frame -> All]

enter image description here

elem[1] = ColorReplace[comp2[[1]], White -> Blue];
elem[2] = 
  ImageAdd[comp1[[2]], ColorReplace[comp2[[1]], White -> Blue]] // 
   ColorReplace[#, White -> Red] &;
elem[3] = 
  ImageAdd[elem[2], ColorReplace[comp2[[3]], White -> Green]];
elem[4] = 
  ImageAdd[elem[3], ColorNegate@comp2[[4]]] // 
   ColorReplace[#, {Black -> Yellow, White -> Black}] &;
elem[5] = 
  ImageAdd[elem[1], ColorReplace[comp2[[3]], White -> Green]];
elem[6] = 
  ImageAdd[elem[5], ColorNegate@comp2[[4]]] // 
   ColorReplace[#, {Black -> Yellow, White -> Black}] &;
elem[7] = 
  ImageAdd[ImageAdd[elem[1], ColorReplace[comp2[[3]], White -> Gray]]
    , ColorNegate@comp2[[4]]] // 
   ColorReplace[#, {Black -> Gray, White -> Black}] &;
Grid[{elem /@ Range[7]}]

enter image description here

leafs = ImageResize[ImageCrop@#, {2000, 2000}] & /@
 RotateLeft[NestList[ImageRotate[#, -270 °] &
   , ImageAdd[#, Dilation[EdgeDetect[#, 1], 5]] &@#, 3], 1] & /@ 
{elem[4], elem[6], elem[7]} // Transpose

enter image description here

 colors = ColorData[97, "ColorList"];

colleafs = Map[ColorReplace[#
    , {Blue -> RandomChoice[colors], Green -> Darker@RandomChoice[colors] 
    , Gray -> Lighter@RandomChoice[colors], Red -> Lighter@RandomChoice[colors]
, Yellow -> RandomChoice[colors]}] &, leafs, {2}]

enter image description here

assembly = 
 ImageAssemble[
      Transpose@{Transpose@#[[1]], Reverse@#[[2]], Transpose@#[[2]]}
      , PaddingSize -> 5] &@Partition[RandomChoice /@ colleafs, 2] // 
   ImageRotate[#, 180 °] & // RemoveBackground[#, Black] &

enter image description here

background = Image[Graphics[{
    EdgeForm[{White, Thickness[.002]}], GrayLevel[.8], 
Opacity[1], Annulus[{0, 1}, {4, 5}, {0.04, Pi/2}]
, EdgeForm[{White, Thickness[.002]}], Lighter[Orange, .8], 
Opacity[1], Annulus[{4, 5}, {4, 5}, {Pi/2, Pi}]
, EdgeForm[{White, Thickness[.002]}], Lighter[Pink, .8], 
Opacity[1], Annulus[{0, 9}, {4, 5}, { Pi, 3 Pi/2 - 0.04 }]
, EdgeForm[], Gray, Opacity[.0], 
Annulus[{9, 0}, {4, 5}, { Pi/2, Pi }]
}, Background -> Black], ImageResolution -> 600] 

enter image description here

ll = ImageCompose[ImageResize[background, Scaled[2.4]] , assembly] //
  ImageTrim[#, {{600, 600}, {6600, 4600}}] &

enter image description here

$\endgroup$
4
  • 2
    $\begingroup$ Stellar work! (pun intended). I love this answer. $\endgroup$ Commented May 14 at 12:03
  • $\begingroup$ @GiuseppeNegro Thank you, very encouraging feedback :) $\endgroup$
    – vindobona
    Commented May 16 at 16:53
  • $\begingroup$ Thank you, vindobona, there is nothing to add to Giuseppe's comment :) $\endgroup$
    – eldo
    Commented May 17 at 6:33
  • $\begingroup$ Thank you, eldo, for another wonderful question! There are always numerous insights to be gained from these posts and the related answers. $\endgroup$
    – vindobona
    Commented May 17 at 7:42

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.