Diploria labyrinthiformis - can we reproduce Ernst Haeckel's drawing of a brain coral?

Ernst Haeckel (1834 - 1919) was a German philosopher, physician, artist and professor of zoology at the University of Jena. He promoted and popularised Charles Darwin's work in Germany.

Haeckel (left) with Nicholai Miklukho - Maklai, his assistant, in the Canaries, 1866

The published artwork of Haeckel includes over 100 detailed, multi-colour illustrations of animals and sea creatures, collected in his famous "Art Forms of Nature", which is still published in various languages. As I was recently browsing through the book, I was struck by his depiction of Scleratina corals, because their beautiful structures are so "mathematical".

The middle one, a "Diploria labyrinthiformis", also called "brain coral", seemed to be a good start for a "Mathematica replica".

From my collection of mathematical surfaces I picked up this Gyroid - like structure which looks like a coral skeleton:

gyro =
10 (Cos[x] Sin[y] + Cos[y] Sin[z] + Cos[z] Sin[x]) -
0.5 (Cos[2 x] Cos[2 y] + Cos[2 y] Cos[2 z] + Cos[2 z] Cos[2 x]) - 12;

n = 8;
ContourPlot3D[gyro == 0, {x, -n, n}, {y, -n, n}, {z, -n, n},
Axes -> False,
Background -> GrayLevel[0],
Boxed -> False,
ContourStyle -> White,
Lighting -> "Accent",
Mesh -> 0,
PlotPoints -> 15]


I was curious to see what it would look like if I gave him a rounded form:

ContourPlot3D[gyro, {x, y, z} \[Element] Ball[{0, 0, 0}, 8],
Axes -> False,
Background -> GrayLevel[0],
Boxed -> False,
ContourStyle -> White,
Lighting -> "Accent",
Mesh -> 0,
PlotPoints -> 5,
PlotRange -> All]


Disappointing, and certainly not the way to go!

Robert Fathauer, one of the leading mathematical artists, took a different way when he produced this ceramic brain coral sculpture:

His explanation:

"This sculpture, created in 2014, is based on the first three generations of a fractal curve that develops radially outward. The starting point is a simple saddle, and the final form has an envelope that is roughly hemispherical. The space curves were created by fitting a series of planar fractal curves to the surface of an octahedron. This fractal structure possesses two-fold rotational symmetry. The sculpture, which was partly inspired by brain coral, measures 21" in width and 11" in height."

Sounds frightening complicated to me, and so I would like to ask:

How would you create a brain coral?

Similar to Silvia's comment:

American Mathematical Society

Please also have a look at Repulsive Curves by Henrik Schumacher et al. (see his comment), especially 14:50, page 41, where the authors show Hilbert-curve-like patterns meandering on a sphere. Also interesting:

Interpolating the Hilbert Curve with a B-Spline

• Well, my collaborators and I played a bit with the idea to maximize the length of the curve inscribed into a sphere under some self-avoidance constraint (which we built in via using the so-called tangent-point energy). See, e.g., Fig. 24 in dl.acm.org/doi/abs/10.1145/3439429. The numerics of solving this problem is quite involved. But I have some Mathematica code for it. (It is just to long to post it here, I am afraid.) Dec 6, 2023 at 15:27
• Might be of interest for OP: Crocheting Adventures with Hyperbolic Planes. Dec 6, 2023 at 18:08
• Thank you, Silvia, I added a similar thing to the question :)
– eldo
Dec 7, 2023 at 10:34
• Interesting and challenging question. I hope you will get some nice answers. But, please, do not close the question soon, some people may need time to produce good solutions. Dec 7, 2023 at 11:30
– eldo
Dec 7, 2023 at 17:58

Not quite there, but this could be a basis for a better answer that does a line sweep along the B-Spline.

Remove["Global*"];
SeedRandom[1];
n = 1000;
pts = Normalize /@ (SpherePoints[n] + RandomPoint[Sphere[{0, 0, 0}, 0.025], n]);
st = pts[[Last@FindShortestTour[pts]]];
Graphics3D[Tube[BSplineCurve[st], .08], Boxed -> False]


• Still not so good.
ContourPlot3D[ (Cos[x] Sin[y] + Cos[y] Sin[z] + Cos[z] Sin[x] ==
0 /. {x -> 2 x, y -> 2 y, z -> 2 z}) // Evaluate, {x, -8,
8}, {y, -8, 8}, {z, -8, 8},
RegionFunction ->
Function[{x, y, z}, x^2 + y^2 + z^2 <= 8^2 && z >= 0],
ContourStyle -> White, Mesh -> None, Boxed -> False, Axes -> False,
BoxRatios -> Automatic, RegionBoundaryStyle -> None,
PlotTheme -> {"ThickSurface"}, Method -> {"Extrusion" -> .2}]


An attempt at a coral like brain:

I have 8GB of RAM so choosing better settings for PlotPoints and MaxRecursion hangs up my system.

uhemi = RegionIntersection[Ellipsoid[{0, 0, 0}, {6, 8, 8}],
Cuboid[{-6, -8, 0}, {6, 8, 8}]];

ContourPlot3D[Cos[2 x  y] + Sin[2 y  z] + Sin[2 z x] == 0
, {x, y, z} \[Element] uhemi
, Boxed -> False
, BoxRatios -> Automatic
, Axes -> False
, Mesh -> None
, ContourStyle -> Directive[
Lighter@ColorData["HTML"]["Chocolate"]
, Opacity[0.5]
, Specularity[1, 20]
]
, PlotPoints -> 15
, Extrusion -> 0.2
, MaxRecursion -> 1
, RegionBoundaryStyle -> None
, BoundaryStyle -> Lighter@Brown
, NormalsFunction -> None
, Lighting -> "Neutral"
, ImageSize -> 800
]
`

• You're surely worthy of and deserve more than 8 GiB, @Syed :) Dec 7, 2023 at 14:17