17
$\begingroup$

A few days ago I asked how to slice three-dimensional surfaces:

How can we produce sliceforms?

The three outstanding answers make me believe that dicing parametric surfaces should also be possible. Blender - Python has a modifier called Remesh that does this automatically and iteratively.

We take a Catenoid as an example:

ParametricPlot3D[{
 Cos[u] Cosh[v], Sin[u] Cosh[v], v}, 
 {u, 0, 2 Pi}, {v, -Pi/2, Pi/2}, 
 BoxRatios -> {1, 1, 0.6}]

enter image description here

A screenshot from my Blender-application after two nested cube operations (with a checker texture):

enter image description here

After three nestings (perforated):

enter image description here

After five nestings (colored by height):

enter image description here

A Ding-Dong surface as another example

ParametricPlot3D[{
 Cos[u] Sqrt[1 - v] v, Sin[u] Sqrt[1 - v] v, v}, 
 {u, 0, 2 Pi}, {v, -1, 1}]

enter image description here

After four nestings:

enter image description here

My request

I know how to dice with Blender and Lego bricks, but would prefer to see a solution with Mathematica. Thank you in advance for your answers and ideas.

enter image description here

Improve this question
$\endgroup$

3 Answers 3

Reset to default
17
$\begingroup$
  • Reply to comment.( perforated )
Clear["Global`*"];
plot = ParametricPlot3D[{Cos[u]  Cosh[v], Sin[u]  Cosh[v], v}, {u, 0, 
    2  Pi}, {v, -Pi/2, Pi/2}, BoxRatios -> {1, 1, 0.6}];
reg = DiscretizeGraphics[plot];
bd = RegionBounds[reg];
diagonalpts = Transpose@bd;
n = 10;
delta = EuclideanDistance @@ diagonalpts/n;
gridpoints = CoordinateBoundingBoxArray[diagonalpts, delta];
dist = RegionDistance@reg;
cubes = Cube[#, delta] & /@ 
   Flatten[Map[Select[#, dist@# < delta &] &, gridpoints, {2}], 2];
(* Graphics3D[cubes]; *)
 (* https://mathematica.stackexchange.com/questions/293884/\
replicating-sol-lewitts-skeletal-geometries *)
Perforate[width_ : .3, thickness_ : .05][bmesh_] := 
 MeshPrimitives[bmesh, 2] /. 
  Polygon[x_] :> 
   Module[{c = Mean@x, p1 = Partition[x, 2, 1, {1, 1}], p2}, 
    p2 = Map[Reverse]@
      Partition[Map[(c + (1 - width)  (# - c)) &, x], 2, 1, {1, 1}];
    ReplaceAll[
      Polygon[y_] :> ConvexHullMesh[Join[y, (1 + thickness)  y]]]@
     MapThread[Polygon@*Join]@{p1, p2}]
Graphics3D[{MaterialShading[<|"BaseColor" -> White, 
    "MetallicCoefficient" -> 1, "RoughnessCoefficient" -> 0.5|>], 
  Perforate[.2] /@ cubes}, Background -> GrayLevel[0.4], 
 Lighting -> {"Standard", GrayLevel[0.9]}, Boxed -> False]

enter image description here

  • Since RegionPlot3D is too slow, here we use VertexColor for BoundaryMeshRegion ( $Version >=13.2 ) or Graphics3D.
Clear["Global`*"];
im = ImageMesh@
   RegionImage[
    DiscretizeGraphics@
     PolyhedronData["GreatRhombicosidodecahedron", "Lines"], 
    Method -> {"Thickness" -> 4}];
v = MeshCoordinates[im];
i = MeshCells[im, 2];
Graphics3D[{EdgeForm[], 
  GraphicsComplex[v, i, 
   VertexColors -> 
    ColorData["BrightBands"] /@ Subdivide[2 Length@i]]}, 
 Boxed -> False]

(*$Version>=13.2*)
Clear["Global`*"];
im = ImageMesh@
   RegionImage[
    DiscretizeGraphics@
     PolyhedronData["GreatRhombicosidodecahedron", "Lines"], 
    RasterSize -> 150, Method -> {"Thickness" -> 8}];
v = MeshCoordinates[im];
i = MeshCells[im, 2];
BoundaryMeshRegion[v, i, 
 VertexColors -> ColorData["BrightBands"] /@ Subdivide[2 Length@i]]

enter image description here

Clear["Global`*"]; reg = 
 ParametricPlot3D[{Cos[u] Cosh[v], Sin[u] Cosh[v], v}, {u, 0, 
    2 Pi}, {v, -Pi/2, Pi/2}, BoxRatios -> {1, 1, 0.6}, 
   Method -> {"Extrusion" -> .2}] // DiscretizeGraphics;
im = ImageMesh[RegionImage[reg, RasterSize -> 100]];
v = MeshCoordinates[im];
i = MeshCells[im, 2];
BoundaryMeshRegion[v, i, 
 VertexColors -> ColorData["BrightBands"] /@ Subdivide[2 Length@i]]

enter image description here

Original

reg = ParametricPlot3D[{Cos[u]   Cosh[v], Sin[u]   Cosh[v], v}, {u, 0,
      2   Pi}, {v, -Pi/2, Pi/2}, BoxRatios -> {1, 1, 0.6}, 
    Method -> {"Extrusion" -> .2}] // DiscretizeGraphics;
im = ImageMesh[RegionImage[reg, RasterSize -> 30]];
RegionPlot3D[im, ColorFunction -> (Hue[#1 + #2 + #3] &), 
 MaxRecursion -> 0]

enter image description here

reg = ParametricPlot3D[{Cos[u]  Sqrt[1 - v]  v, 
     Sin[u]  Sqrt[1 - v]  v, v}, {u, 0, 2  Pi}, {v, -1, 1}, 
    Method -> {"Extrusion" -> .2}] // DiscretizeGraphics;
im = ImageMesh[RegionImage[reg, RasterSize -> 20]];
RegionPlot3D[im, ColorFunction -> (Hue[#1 + #2 + #3] &), 
 MaxRecursion -> 0, Boxed -> False]

enter image description here

  • Make a hold in a region is more complex since RegionDifference not work for many complex region. We use OpenCascade for region difference instead.
Clear["Global`*"];
Needs["NDSolve`FEM`"];
Needs["OpenCascadeLink`"];
reg = ResourceData["Stanford Bunny"];
reg = RepairMesh[reg];
bmesh = ToBoundaryMesh[reg];
meshregion = BoundaryMeshRegion[bmesh];
ireg = ImageMesh@RegionImage[meshregion, RasterSize -> 20];
{{x1, x2}, {y1, y2}, {z1, z2}} = RegionBounds[ireg];
cylinder = 
  Cylinder[{{Mean[{x1, x2}], y1 - 1.2 (y2 - y1), 
     Mean[{z1, z2}]}, {Mean[{x1, x2}], y1 + 1.2 (y2 - y1), 
     Mean[{z1, z2}]}}, 1/4 Min[x2 - x1, y2 - y1, z2 - z1]];
shape1 = OpenCascadeShape[ToBoundaryMesh[ireg]];
shape2 = OpenCascadeShape[cylinder];
bmesh = OpenCascadeShapeSurfaceMeshToBoundaryMesh[
   OpenCascadeShapeDifference[shape1, shape2]];
mg = MeshRegion[bmesh];
ireg2 = ImageMesh@RegionImage[mg, RasterSize -> 20];
RegionPlot3D[ireg2, ColorFunction -> Hue, MaxRecursion -> 0, 
 Boxed -> False]

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ Excellent - and it also functions with Cone[] // DiscretizeGraphics. Is there an easy way to perforate (like shown in my question?) $\endgroup$ Commented Feb 1, 2024 at 9:54
  • $\begingroup$ I used your answer to Replicating Sol LeWitt's skeletal geometries to get a perforation. It's better than nothing, but not perfect. $\endgroup$ Commented Feb 1, 2024 at 17:00
  • $\begingroup$ Thank you, cvgmt, your latest update (perforation) works perfectly $\endgroup$ Commented Feb 2, 2024 at 14:53
12
$\begingroup$

Use small numbers for MaxRecursion and PlotPoints, and post-process to round GraphicsComplex coordinates and replace polygon primitives with Cuboidss:

roundCoordinates[r_ : .2] := ReplaceAll[
   GraphicsComplex[c_, p___] :> GraphicsComplex[Round[c, r], p ]];

polygonToCuboid = ReplaceAll[
   Polygon[x_, ___, VertexColors -> vc_, ___] :> 
    {RGBColor @ Mean[vc], Cuboid @@ Transpose[CoordinateBounds @ x]}];

displayFunction[r_ : .2] := polygonToCuboid @* Normal @* roundCoordinates[r];

Examples:

PP3D = Labeled[
    ParametricPlot3D[{Cos[u]   Cosh[v], Sin[u]   Cosh[v], v}, 
      {u, 0, 2   Pi}, {v, -Pi/2, Pi/2}, 
      MaxRecursion -> #, 
      PlotPoints -> #2, 
      DisplayFunction -> displayFunction[], 
      ColorFunction -> "Rainbow", 
      Lighting -> "Neutral", 
      Background -> Black, 
      Mesh -> None, BoxRatios -> 1, 
      PlotRange -> All, Boxed -> False, 
      SphericalRegion -> True, 
      Axes -> False, 
      ImageSize -> Medium], 
    Column[Style[#, 16] & /@ {MaxRecursion -> #, PlotPoints -> #2}, Center],
    Top] &;

Grid[#, Dividers -> All] & @
 Table[PP3D[m, p], {m, 0, 2}, {p, {5, 10, {15, 10}}}]

enter image description here

Replace displayFunction[] in the definition of PP3D with displayFunction[.025] to get

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ Thank you, kglr, very neat. Can we apply a modified df to a simple Cone[]? (see my comment to cvgmt's answer) $\endgroup$ Commented Feb 1, 2024 at 10:34
4
$\begingroup$

ApproximatedSurface by Enrique Zeleny offers many interesting options to style parametric surfaces. For dicing we can use its Cuboid option:

ApproximatedSurface = ResourceFunction["ApproximatedSurface"];

dingdong = {Cos[u]*v Sqrt[1 - v], Sin[u]*v Sqrt[1 - v], v};

Graphics3D[{
  MaterialShading[{"Glazed", Red}],
  ApproximatedSurface[dingdong, {u, 0, 2 Pi, 25}, {v, -1, 1, 15}, {"Cuboid", .3}]},
 Background -> Gray,
 Boxed -> False,
 Lighting -> "Neutral"]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ (+1) Interesting find, @eldo! ;) $\endgroup$ Commented Jul 23, 2024 at 19:23

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.