# Frank Stella's Protractor Series - can we reproduce Lac Laronge IV?

## 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.

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

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.

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]


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


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"?

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


• 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 = RegionMeshSplitIntersectingSegments[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[{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}}]



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


## 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 = RegionMeshSplitIntersectingSegments[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],


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


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


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];
Image[Graphics[{Yellow, Opacity[.5], Disk[{0, 0}, 4, {0, Pi/2}]},
Background -> White], ImageResolution -> 600], {1, 1}];
Image[Graphics[{Blue, Opacity[.3], Disk[{4, 4}, 4, {-Pi, -Pi/2}]},
Background -> White], ImageResolution -> 600], {1, 1}];



cs = ColorSeparate[leaf]


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


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


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


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


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


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]


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


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