# How can we produce sliceforms?

Sliceforms are models made from intersecting sets of planes which slot together to generate intersecting three-dimensional surfaces. Here are some of them made by Nadja Vohradsky for the

university of oxford mathematics-online-exhibition 2020

Sliceforms sit happily on the border between art and mathematics, as we can see in this graphic by Victor Vasarely:

My request

I think it is very difficult to reproduce some of the three-dimensional forms (certainly too difficult for me). I would therefore also accept two-dimensional, Vasarely-like solutions.

• The 2D case is too difficult for me. I would like to know how to product it. I add graphics to the tags. Jan 28 at 23:17
• No problem - the main question concerns the 3D case
– eldo
Jan 29 at 0:21

Turns out SliceContourPlot3D provides almost everything we need:

ClearAll[sliceForm]

SetAttributes[sliceForm, HoldAll]

sliceForm[reg_, f_ : x + y, nx_ : 7, ny_ : 7, opts : OptionsPattern[]] :=
SliceContourPlot3D[f,
{{"XStackedPlanes", nx}, {"YStackedPlanes", ny}},
{x, y, z} ∈ reg,
opts,
PlotTheme -> "ThickSurface",
Axes -> False, ContourStyle -> None,
Boxed -> False, BoundaryStyle -> None,
ImageSize -> Medium, Background -> Black, SphericalRegion -> True]

sliceForm[reg_, opts : OptionsPattern[]] := sliceForm[reg, x + y, 7, 7, opts]


Examples:

Row[{sliceForm[#],
sliceForm[#, x + y, 10, 10, ColorFunction -> "Rainbow"],
sliceForm[#, x + y, 10, 10, PlotTheme -> None]}, Spacer[5]]& @ Ball[]


Replace Ball[] with Cube[] to get

Use Cone[] to get

Use Cylinder[] to get

Use Pyramid[{{-1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {-1, 1, -1}, {0, 0, 1}}] to get

Define a solid region as

reg = ImplicitRegion[{x^2 + y^2 <= 1 && z <= Sin[x  y]},
{{x, -1, 1}, {y, -1, 1}, {z, -1, 1}}];


Row[{sliceForm[#],
sliceForm[#, x + y, 10, 10, ColorFunction -> "Rainbow"],
sliceForm[#, x + y, 10, 10, PlotTheme -> None]}, Spacer[5]] & @ reg


Row[{sliceForm[#, BoxRatios -> Automatic],
sliceForm[#, x^2 + y^2, 10, 10, ColorFunction -> "Rainbow",
BoxRatios -> Automatic],
sliceForm[#, x^2 + y^2, 10, 10, PlotTheme -> None,
BoxRatios -> Automatic]}, Spacer[5]] & @ FilledTorus[]


plot = Plot3D[Sin[x*y], {x, y} ∈ Disk[], Boxed -> False,
Axes -> False, PlotStyle -> None, BoundaryStyle -> None];
Graphics3D[
Cases[Normal@plot,
Line[pts_] :>
Polygon[Join[{{pts[[1, 1]], pts[[1, 2]], -1}},
pts, {{pts[[-1, 1]], pts[[-1, 2]], -1}}]], -1], Boxed -> False]


• Apple
Clear[plot];
plot = ParametricPlot3D[{(1 + Cos[v]) Cos[u] + .1 Cos[5 u], (1 +
Cos[v]) Sin[u],
1.5 Sin[v] + .5 Cos[v] - .2 Log[1 - v/π]}, {u, 0,
2 π}, {v, -π, π}, MeshFunctions -> {#1 &, #2 &},
Mesh -> 15, Boxed -> False, AspectRatio -> Automatic,
Axes -> False, PlotStyle -> None];
Graphics3D[{Green,
Cases[Normal@plot, Line[pts_] :> Polygon[pts], -1]}, Boxed -> False]


• Stanford Bunny
Clear[reg];
reg = ResourceData["Stanford Bunny"];
plot = RegionPlot3D[reg, Mesh -> 15, MeshFunctions -> {#1 &, #2 &},
PlotStyle -> None, BoundaryStyle -> None, Boxed -> False];
Graphics3D[{Green,
Cases[Normal@plot, Line[pts_] :> Polygon[pts], -1]}, Boxed -> False]


• For the thick surface.(Too slow)
Clear["Global*"];
reg = ResourceData["Stanford Bunny"];
plot = RegionPlot3D[reg, Mesh -> 15, MeshFunctions -> {#1 &, #2 &},
PlotStyle -> None, BoundaryStyle -> None, Boxed -> False];
Show[Cases[Normal@plot,
Line[pts_] :>
RegionPlot3D[Polygon[pts], {"Extrusion" -> .002},
BoundaryStyle -> None, ColorFunction -> Hue], -1], Boxed -> False]


Clear[g, image];
g = Graphics[
Table[{FaceForm[Darker@Red], Rectangle[{i, j}, {i + 1, j + 1}],
FaceForm[],
Rectangle[{i, j} + {.1, .1}, {i + 1, j + 1} - {.1, .1}],
FaceForm[Black],
Triangle[{{i, j} + {.1, .1}, {i, j} + {.1, .9}, {i,
j} + {.9, .9}}], FaceForm[White],
Triangle[{{i, j} + {.1, .1}, {i, j} + {.9, .1}, {i,
j} + {.9, .9}}]}, {i, 1, 20}, {j, 1, 20}]]
image = Image[g];


center = {0.5, 0.5};
radius = .5; scale = 2.5; twist = 1;
transformationFunction =
Function[{pt},
Module[{dist, angle, newPt}, dist = EuclideanDistance[pt, center];
newPt =
pt + scale  (pt - center)  (1 - dist/radius)^2  {Cos[angle],
Sin[angle]}, newPt = pt];
newPt]];
distortedImage =
ImageForwardTransformation[image, transformationFunction]


• Thank you, cvgmt, your reproduction is really astonishing in its faithfulness to Vasarely's work.
– eldo
Jan 29 at 9:27

An attempt, where I have hollowed out the ball. This can save material.

hx = Hyperplane[{1, 0, 0}, #] & /@ Range[-5, 5, 2];
hy = Hyperplane[{0, 1, 0}, #] & /@ Range[-5, 5, 2];
hz = Hyperplane[{0, 0, 1}, #] & /@ Range[-5, 5, 2];

RegionDifference[
RegionIntersection[Ball[{0, 0, 0}, 10], #] & /@ hx~Join~hy~Join~hz //
RegionUnion,
Ball[{0, 0, 0}, 8]
] // DiscretizeRegion


RegionIntersection[Ellipsoid[{0, 0, 0}, {4, 4, 8}], #] & /@
hx~Join~hy~Join~hz // RegionUnion // Region


We use CSGRegion to construct a CSGRegion object using scaled/translated/possibly-rotated versions of Cube[] and use it to slice 3D solids:

ClearAll[csgSlicer]

Options[csgSlicer] =
"RotationAngle" -> 0,
"Length" -> 2,
"Width" -> 2};

csgSlicer[OptionsPattern[]] := Module[{$$tr,$$dir, $$ra,$$bt, $$bp,$$l, $$w,$$t},
{$$ra,$$bt, $$bp,$$l, $$w} = OptionValue @ {"RotationAngle", "BladeThickness", "BladePositions", "Length", "Width"}; CSGRegion["Union", Join[Map[Rotate[Translate[Scale[Cube[], {bt, l, w}], {#, 0, 0}],$$ra, {0, 1, 0}] &] @ $$bp, Map[Rotate[Translate[Scale[Cube[], {l, bt, w}], {0, #, 0}],$$ra, {1, 0, 0}] &] @ \$bp]]]


Examples:

csgSlicer[]


csgSlicer["BladeThickness" -> .1]


csgSlicer["RotationAngle" -> 45  Degree,
BaseStyle -> {EdgeForm[], Specularity[White, 20], Red}]


Using csgSlicer to slice 3D solids:

{ball, cube, cone, cylinder, dodecahedron, pyramid} =
{Ball[], Cube[2], Cone[], Cylinder[], Dodecahedron[],
Pyramid[{{-1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {-1, 1, -1}, {0, 0, 1}}]};

Grid[Partition[#, 3] & @
Map[CSGRegion["Intersection", {ToExpression @ #, csgSlicer[]},
ImageSize -> Medium, PlotLabel -> Style[#, White],
Lighting -> "Neutral", Background -> Black,
BaseStyle -> {EdgeForm[None], Specularity[White, 20], Orange}] &] @
{"cube", "ball", "cylinder", "cone", "pyramid", "dodecahedron"},
Dividers -> All]


Replace csgSlicer[] with csgSlicer["BladeThickness" -> .05, "RotationAngle" -> 60 Degree] to get

Replace csgSlicer[] with

csgSlicer["BladeThickness" -> .01,
"BladePositions" -> (Join[#, -#] &@Most@Rest[Subdivide[-1, 1, 9]])]


to get

Replace "Intersection" with "Difference" and use csgSlicer["BladeThickness" -> .1, "Length" -> 10, "Width" -> 10]` to get