7
$\begingroup$

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

enter image description here

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

enter image description here

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.

enter image description here

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

enter image description here

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?
$\endgroup$
3
  • $\begingroup$ Interesting, do you know the material of these objects? $\endgroup$
    – yarchik
    Nov 26, 2023 at 13:42
  • 1
    $\begingroup$ Try ClipPlanes instead of adjusting bounding box. $\endgroup$
    – yarchik
    Nov 26, 2023 at 13:49
  • $\begingroup$ Thanks, Yarchik, ClipPlanes might be a good idea. Will try later. The objects are made of high fired unglazed porcelain. $\endgroup$
    – eldo
    Nov 26, 2023 at 14:53

3 Answers 3

6
$\begingroup$
  • 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 = 
  Graphics3D[MapThread[InfiniteLine, {pts, dirs}], 
    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]

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
8
$\begingroup$
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
  ]

enter image description here

$\endgroup$
2
  • 1
    $\begingroup$ Excellent, thank you very much! $\endgroup$
    – eldo
    Nov 27, 2023 at 17:00
  • $\begingroup$ You are welcome. @eldo $\endgroup$
    – Syed
    Nov 27, 2023 at 17:02
5
$\begingroup$
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]]

enter image description here

$\endgroup$

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.