# Sum of its parts - replicating a porcelain sculpture of Nuala O’Donovan

1. Introduction

Nuala O’Donovan is an Irish Artist, living and working in Cork. According to her website her research areas are "Irregularities in Patterns in Nature" and "The Geometry of Natural Forms".

Radiolaria Grid series, High fired porcelain, unglazed. Nuala O’Donovan 2015

Radiolaria Grid series – interior detail –

2. Question

I would like to replicate with Mathematica Nuala's sculpture pictured below. It is made of small porcelain tubes and called "The sum of its parts". A rectangular exterior turns into a mikado-like chaos as we move inside.

Nuala O’Donovan, The sum of its parts

I began with the interior:

Graphics3D[
Table[{
MaterialShading[<|"BaseColor" -> White, "RoughnessCoefficient" -> 0.1 |>],
Cylinder[RandomReal[40, {2, 3}]]}, {60}],
Boxed -> False,
BoxRatios -> {1, 1, 2},
Background -> GrayLevel[0],
Lighting -> "ThreePoint"]


and immediately (as usual) got a problem:

• Due to the changed BoxRatios, the tubes appear to be oval rather than round, and I don't know how to fix this distortion.
• The next question is how we can "surround" the inner randomly scattered "mikados" with a rectangular outside structure. How to get the "sum of its parts", so to say.
• And a third (non-essential) question: Would it be possible to give the background a grayish gradient-like appearance like in the above photo?
• Interesting, do you know the material of these objects? Nov 26, 2023 at 13:42
• Try ClipPlanes instead of adjusting bounding box. Nov 26, 2023 at 13:49
• Thanks, Yarchik, ClipPlanes might be a good idea. Will try later. The objects are made of high fired unglazed porcelain.
– eldo
Nov 26, 2023 at 14:53

• We select random points in the cube and select random directions to draw infinitelines and cut their by the PlotRange.
• We use DiscretizeRegion to the boundary of cube and extend the lines to infinitelines, after that we also cut it by PlotRange.
• Finally we use DiscretizeGraphics to get all the lines.
reg = Cuboid[{0, 0, 0}, {4, 3, 5}];
n = 60;
pts = RandomPoint[reg, n];
dirs= RandomPoint[Sphere[], n];
interior =
PlotRange -> RegionBounds[reg], Boxed -> False] //
DiscretizeGraphics;
δ = 1.2;
faces = Graphics3D[
MeshPrimitives[#,
1] & /@ (DiscretizeRegion[#,
MaxCellMeasure -> "Area" -> δ] & /@
MeshPrimitives[RegionBoundary@reg, 2]) /.
Line -> InfiniteLine, PlotRange -> RegionBounds[reg],
Boxed -> False] // DiscretizeGraphics;
Graphics3D[{MeshPrimitives[faces, 1] /. Line -> Tube,
MeshPrimitives[interior, 1] /. Line -> Tube}, Boxed -> False]


• For non convex region.
Clear["Global*"];
reg = RegionProduct[Annulus[{0, 0}, {1/2, 1}, {0, 3 Pi/2}],
Line[{{0}, {1.}}]];
n = 60;
pts = RandomPoint[reg, n];
dirs = RandomPoint[Sphere[], n];
interior =
Table[Tube[{pts[[i]] + #[[1]]*dirs[[i]],
pts[[i]] + #[[-1]]*dirs[[i]]}] & /@
Flatten@List[
Reduce[Rationalize[pts[[i]] + s*dirs[[i]] ∈ reg, 0],
s] /. Or -> List], {i, 1, n}];
lines = MeshPrimitives[
BoundaryDiscretizeRegion[reg, MaxCellMeasure -> ∞],
1][[;; , 1]];
faces = Table[
Tube[{line[[1]] + #[[1]]*(line[[2]] - line[[1]]),
line[[1]] + #[[-1]]*(line[[2]] - line[[1]])}] & /@
Flatten[List[
Reduce[Rationalize[
line[[1]] + s*(line[[2]] - line[[1]]) ∈ reg, 0],
s] /. Or -> List] /. s == 0 -> Nothing /.
False -> Nothing], {line, lines}];
Graphics3D[{interior, faces}, Boxed -> False]


• Another non convex regions.
Clear["Global*"];
reg = ConcaveHullMesh[{{0, 0, 0}, {0, 1, 0}, {0, 0, 1}, {0, 1, 1}, {1,
1/3, 1/3}, {1, 2/3, 1/3}, {1, 1/3, 2/3}, {1, 2/3, 2/3}, {2, 0,
0}, {2, 1, 0}, {2, 0, 1}, {2, 1, 1}}];
bd = RegionBounds[reg];
n = 50;
pts = RandomPoint[reg, n];
dirs = RandomPoint[Sphere[], n];
interior =
ParametricPlot3D[
Table[pts[[i]] + s*dirs[[i]], {i, 1, n}] // Evaluate, {s, -10, 10},
PlotPoints -> 400, MaxRecursion -> 0,
RegionFunction -> Function[{x, y, z, t}, Element[{x, y, z}, reg]],
PlotRange -> bd];
faces = MeshPrimitives[RegionBoundary@reg, 2];
m = 8;
boundary = Table[
With[{pts = RandomPoint[face, m]},
ParametricPlot3D[
Table[{1 - s, s} . {pts[[i]], pts[[j]]}, {i, 1, m}, {j, 1, i}] //
Flatten, {s, -2, 2},
RegionFunction ->
Function[{x, y, z, s}, {x, y, z} \[Element] reg],
PlotRange -> RegionBounds[reg], PlotRange -> bd]], {face, faces}];
Graphics3D[
MeshPrimitives[
Show[interior, boundary, Boxed -> False, Axes -> False] //
DiscretizeGraphics, 1] /. Line -> Tube, Boxed -> False]


Clear["Global*"];
SeedRandom[4];
cba = Flatten[#, 2] &@
CoordinateBoundsArray[{{0, 3}, {0, 3}, {0, 5}}, 1] ;
{f1a, f1b} = GatherBy[cba, {#[[1]]} &][[{1, -1}]];
{f2a, f2b} = GatherBy[cba, {#[[2]]} &][[{1, -1}]];
{f3a, f3b} = GatherBy[cba, {#[[3]]} &][[{1, -1}]];
chm = ConvexHullMesh[cba + RandomReal[{-0.3, 0.3}, {96, 3}]];
cpts = RandomPoint[chm, 400] // Partition[#, 2] &;
cyls = Cylinder[#, RandomReal[{0.02, 0.05}]] & /@ cpts;

cyls1a = Cylinder[#,
RandomReal[{0.02, 0.05}]] & /@ (Tuples[f1a, 2] //
MaximalBy[#, Apply[EuclideanDistance], Length@#] &)[[1 ;; ;;
7]];

cyls1b = Cylinder[#,
RandomReal[{0.02, 0.05}]] & /@ (Tuples[f1b, 2] //
MaximalBy[#, Apply[EuclideanDistance], Length@#] &)[[1 ;; ;;
9]];

cyls2a = Cylinder[#,
RandomReal[{0.02, 0.05}]] & /@ (Tuples[f2a, 2] //
MaximalBy[#, Apply[EuclideanDistance], Length@#] &)[[1 ;; ;;
5]];

cyls2b = Cylinder[#,
RandomReal[{0.02, 0.05}]] & /@ (Tuples[f2b, 2] //
MaximalBy[#, Apply[EuclideanDistance], Length@#] &)[[1 ;; ;;
9]];

cyls3a = Cylinder[#,
RandomReal[{0.02, 0.05}]] & /@ (Tuples[f3a, 2] //
MaximalBy[#, Apply[EuclideanDistance], Length@#] &)[[1 ;; ;;
7]];

cyls3b = Cylinder[#,
RandomReal[{0.02, 0.05}]] & /@ (Tuples[f3b, 2] //
MaximalBy[#, Apply[EuclideanDistance], Length@#] &)[[1 ;; ;;
7]];

art = Graphics3D[{
EdgeForm[None]
, RGBColor[0.85, 0.83, 0.79] (* #FFF6E5 , RGBColor["#E3DAC9"]*)
, cyls1a , cyls1b
, cyls2a, cyls2b
, cyls3a, cyls3b
, cyls
, AbsolutePointSize[6], Ball[#, RandomReal[{0.03, 0.07}]] &@cba
}
, SphericalRegion -> True
, Lighting -> "Neutral"
, Boxed -> False
, ImageSize -> 600
]


• Excellent, thank you very much!
– eldo
Nov 27, 2023 at 17:00
• You are welcome. @eldo
– Syed
Nov 27, 2023 at 17:02
Clear["Global*"]
tube[l : {a : {x_, y_, z_}, b : {u_, v_, w_}}, s_ : 1] := Module[{}
, {Tube[BSplineCurve[Subdivide[a, b, 30]]
, RotateLeft[RandomReal[{.02, .048}, 30], RandomInteger[3]]]}];

slice[grid_ : {6, 4}, size_ : .15, deltaEdges_ : 100] :=
Module[{gg, edges, vcoord, mesh},
gg = GridGraph[grid];
vcoord = VertexCoordinates /. AbsoluteOptions[gg, VertexCoordinates];
edges = RandomSample[
Complement[UndirectedEdge @@@ Subsets[VertexList@gg, {2}], EdgeList@gg]
, deltaEdges];
mesh = MeshRegion[vcoord, Line[List @@@ edges]];
tube[#] & /@ Map[# /. {x_, y_} :> {x - 1, y, RandomReal[size]} &, Sequence @@@ MeshPrimitives[mesh, 1], {2}]
];

SeedRandom[312];
Graphics3D[{
MaterialShading[<|"BaseColor" -> White, "SheenColor" -> LightBlue
, "SheenRoughnessCoefficient" -> .9, "RoughnessCoefficient" -> 0.9, "SpecularColor" -> Yellow|>]
, slice[{6, 4}, 3., 140] (*Interior*)
, FoldList[Rotate[#,  - 90  °, {0, 1, 0}, #2] &
, slice[{6, 4}, .185, 65], {{0, 0, 0}, {0, 0, 3}, {3, 0, 3}}] (*Sides*)
, Rotate[slice[{4, 4}, .075, 55], 90 °, {1, 0, 0}, {0, 1, 0}] (*Top*)
, Rotate[slice[{4, 4}, .075, 55], 90 °, {1, 0, 0}, {0,  3.56, 2.54}] (*Bottom*)
}
, Axes -> False, Boxed -> False, SphericalRegion -> True
, ViewPoint -> {-2.8, 1.3, 2.5}, ViewVertical -> {0, -1, 0}
, Lighting -> "ThreePoint", ImageSize -> Large,
Background -> GrayLevel[0]]