Wolfram Computation Meets Knowledge

How Many Animals and Arp-imals Can One Find in a Random 3D Image?

And How Many Animals, Animal Heads, Human Faces, Aliens and Ghosts in Their 2D Projections?

Introduction

In my recent Wolfram Community post, “How many animals can one find in a random image?,” I looked into the pareidolia phenomenon from the viewpoints of pixel clusters in random (2D) black-and-white images. Here are some of the shapes I found, extracted, rotated, smoothed and colored from the connected black pixel clusters of a single 800×800 image of randomly chosen, uncorrelated black-and-white pixels.

arpimals

For an animation of such shapes arising, changing and disappearing in a random gray-level image with slowly time-dependent pixel values, see here. By looking carefully at a selected region of the image, at the slowly changing, appearing and disappearing shapes, one frequently can “see” animals and faces.

The human mind quickly sees faces, animals, animal heads and ghosts in these shapes. Human evolution has optimized our vision system to recognize predators and identify food. Our recognition of an eye (or a pair of eyes) in the above shapes is striking. For the neuropsychological basis of seeing faces in a variety of situations where actual faces are absent, see Martinez-Conde2016.

A natural question: is this feature of our vision specific to 2D silhouette shapes, or does the same thing happen for 3D shapes? So here, I will look at random shapes in 3D images and the 2D projections of these 3D shapes. Various of the region-related functions that were added in the last versions of the Wolfram Language make this task possible, straightforward and fun.

I should explain the word Arp-imals from the title. With the term “Arp-imals” I refer to objects in the style of the sculptures by Jean Arp, meaning smooth, round, randomly curved biomorphic forms. Here are some examples.

personOverview[person_] :=   With[{props = {"Entity", EntityProperty["Person", "Image"],       EntityProperty["Person", "BirthDate"],       EntityProperty["Person", "BirthPlace"],       EntityProperty["Person", "DeathDate"]}},   TextGrid[DeleteMissing[Transpose[{props, person[props]}], 1, 2],                      Dividers -> All, Background -> GrayLevel[0.9]]]

artworkOverview[art_] :=   With[{props = {"Entity", EntityProperty["Artwork", "Image"],       EntityProperty["Artwork", "Artist"],       EntityProperty["Artwork", "StartDate"],       EntityProperty["Artwork", "Owner"]}},   TextGrid[    DeleteMissing[     Transpose[{props, Item[#, ItemSize -> 15] & /@ art[props]}], 1, 2],                      Dividers -> All, Background -> GrayLevel[0.9]]]

Forms such as these hide frequently in 3D images made from random black-and-white voxels. Here is a quick preview of shapes we will extract from random images.

Quick Preview of Shapes

We will also encounter what I call Moore-iens, in the sense of the sculptures by the slightly later artist Henry Moore.

personOverview[Entity["Person", "HenryMoore::96psy"]]

artworkOverview /@ {Entity["Artwork",     "LargeInteriorForm::HenryMoore"],    Entity["Artwork", "KnifeEdgeTwoPiece::HenryMoore"],    Entity["Artwork", "OvalWithPointsPrinceton::HenryMoore"]}

With some imagination, one can also see forms of possible aliens in some of the following 2D shapes. (See Domagal-Goldman2016 for a discussion of possible features of alien life forms.)

As in the 2D case, we start with a random image: this time, a 3D image of voxels of values 0 and 1. For reproducibility, we will seed the random number generator. The Arp-imals are so common that virtually any seed produces them. And we start with a relatively small image. Larger images will contain many more Arp-imals.

Shapes from Random 3D Images

SeedRandom[1]; randomImage =   Image3D[Table[RandomChoice[{6, 1} -> {0, 1}], {20}, {20}, {20}]]

Hard to believe at first, but the blueprints of the above-shown 3D shapes are in the last 3D cube. In the following, we will extract them and make them more visible.

As in the 2D case, we again use ImageMesh to extract connected regions of white cells. The regions still look like a random set of connected polyhedra. After smoothing the boundaries, nicer shapes will arise.

Show[imesh = ImageMesh[randomImage, Method -> "MarchingSquares"],   ImageSize -> 400]

Here are the regions, separated into non-touching ones, using the function ConnectedMeshComponents. The function makeShapes3D combines the image creation, the finding of connected voxel regions, and the region separation.

makeShapes3D[{dimz_, dimy_, dimx_}, {black_, white_}] :=  Module[{randomImage, imesh},   randomImage =     Image3D[Table[      RandomChoice[{black, white} -> {0, 1}], {dimx}, {dimy}, {dimz}]];    imesh = ImageMesh[randomImage, Method -> "MarchingSquares"];                Select[ConnectedMeshComponents@imesh, 10 < Volume[#] < 200 &]]

For demonstration purposes, in the next example, we use a relatively low density of white voxels to avoid the buildup of a single large connected region that spans the whole cube.

SeedRandom[333]; shapes = makeShapes3D[{20, 20, 20}, {7, 1}]

Here are the found regions individually colored in their original positions in the 3D image.

Show[HighlightMesh[#, Style[2, RandomColor[]]] & /@ shapes,   Boxed -> True]

To smooth the outer boundaries, thereby making the shapes more animal-, Arp-imal- and alien-like, the function smooth3D (defined in the accompanying notebook) is a quick-and-dirty implementation of the Loop subdivision algorithm. (As the 3D shapes might have a higher genus, we cannot use BSplineSurface directly, which would have been the direct equivalent to the 2D case.) Here are successive smoothings of the third of the above-extracted regions.

{sampleRegion,    Graphics3D[{EdgeForm[],     sampleRegionSmooth1 = smooth3D[sampleRegion, 1]},                         ImageSize -> {{320}, {320}}]}  {Graphics3D[{EdgeForm[],     sampleRegionSmooth2 = smooth3D[sampleRegion, 2]},                           ImageSize -> {{320}, {320}}],  Graphics3D[{EdgeForm[],     sampleRegionSmooth3 = smooth3D[sampleRegion, 3]},                         ImageSize -> {{320}, {320}}]}

Using the region plot theme "SmoothShading" of the function BoundaryMeshRegion, we can add normals to get the feeling of a genuinely smooth boundary.

shapeF = With[{sr = sampleRegionSmooth3},   BoundaryMeshRegion[sr[[1]],     Style[sr[[2, 1]] ,      Directive[GrayLevel[0.4],       Specularity[RGBColor[0.71, 0.65, 0.26], 12]]],     PlotTheme -> "SmoothShading"]]

And for less than $320 one can obtain this Arp-inspired piece in brass. A perfect, unique, stunning post-Valentine’s gift. For hundreds of alternative shapes to print, see below. We use ShellRegion to reduce the price and save some internal material by building a hollow region.

thinreg = ShellRegion[shapeF]; Printout3D[thinreg, "IMaterialise",   RegionSize -> Quantity[10, "Centimeters"]]

Here is the smoothing procedure shown for another of the above regions.

sampleRegion2 = {sampleRegion2,   Graphics3D[{EdgeForm[],     sampleRegionSmooth21 = smooth3D[sampleRegion2, 1]},                           ImageSize -> {{360}, {360}}],  Graphics3D[{EdgeForm[],     sampleRegionSmooth22 = smooth3D[sampleRegion2, 2]},                          ImageSize -> {{360}, {360}}]}

And for three more.

With[{sf = Directive[#, Specularity[ColorNegate[#], 10]] &},  Row[{Graphics3D[{EdgeForm[], sf[Red], smooth3D[shapes[[4]], 3]},      ImageSize -> {{360}, {360}},                                 ViewPoint -> {0.08, -3.31, 0.67},      ViewVertical -> {0.00, -0.85, 0.90}],    Graphics3D[{EdgeForm[], sf[Blue], smooth3D[shapes[[8]], 3]},      ImageSize -> {{360}, {360}},                    ViewPoint -> {2.99, 0.66, 1.43},      ViewVertical -> {1.07, 0.90, 0.23}],    Graphics3D[{EdgeForm[], sf[Green], smooth3D[shapes[[13]], 3]},      ImageSize -> {{360}, {360}},                    ViewPoint -> {-2.53, 2.18, 0.49},      ViewVertical -> {-0.93, 0.598, 0.76}]}]]

Many 3D shapes can now be extracted from random and nonrandom 3D images. The next input calculates the region corresponding to lattice points with coprime coordinates.

Graphics3D[{EdgeForm[], Directive[Gray, Specularity[Pink, 12]],             smooth3D[ConnectedMeshComponents[ImageMesh[       Image3D[        Table[Boole@CoprimeQ[x, y, z], {x, -6, 6}, {y, -6, 6}, {z, -6,           6}]],       Method -> "MarchingSquares"]][[1]], 2]},  ViewPoint -> {2, -3, 2}, ViewVertical -> {1, 0, 1}, Boxed -> False]

The Importance of Coarse Rasterization and Smoothing

In the above example, we start with a coarse 3D region, which feels polyhedral due to the obvious triangular boundary faces. It is only after the smoothing procedure that we obtain “interesting-looking” 3D shapes. The details of the applied smoothing procedure do not matter, as long as sharp edges and corners are softened.

Human perception is optimized for smooth shapes, and most plants and animals have smooth boundaries. This is why we don’t see anything interesting in the collection of regions returned from ImageMesh applied to a 3D image. This is quite similar to the 2D case. In the following visualization of the 2D case, we start with a set of randomly selected points. Then we connect these points through a curve. Filling the curve yields a deformed checkerboard-like pattern that does not remind us of a living being. Rasterizing the filled curve in a coarse-grained manner still does not remind us of organic shapes. The connected region, and especially the smoothed region, do remind most humans of living beings.

Smoothed Region

The following Manipulate (available in the notebook) allows us to explore the steps and parameters involved in an interactive session.

smooth2D[reg_, col_, d_] :=   Graphics[{col, (ToExpression[ToString[InputForm@reg], StandardForm,         Hold] /.       HoldPattern[BoundaryMeshRegion[v_, b__, ___Rule]] :>         GraphicsComplex[v,         FilledCurve[{b} /. Line[l_] :>                         BSplineCurve[DeleteDuplicates[Flatten[l, 1]],              SplineClosed -> True, SplineDegree -> d]]])[[1]]}]

Manipulate[  Module[{randomFunction, f1, f2, filledPolygon, ras, im, imesh,     shapes, toShow, map},   Block[{$PerformanceGoal = "Quality"},    randomFunction[m_] :=      Interpolation[      MapIndexed[{(#2[[1]] - 1)/(m + 1), #} &,        Join[#, Take[#, 2]] &@ RandomReal[{0, 1}, {m, 2}]],       InterpolationOrder -> 3];    SeedRandom[seed]; f1 = randomFunction[deg];       f2 = randomFunction[deg];    pp = ParametricPlot[Evaluate[(1 - s) f1[t] + s f2[t]], {t, 0, 1},       PlotStyle -> Directive[Opacity[1], Black], Axes -> False,       PlotRange -> {{-0, 1}, {-0, 1}}] ;    filledPolygon = pp /. Line :> Polygon;    ras = Rasterize[filledPolygon, RasterSize -> {rs, rs},       ImageSize -> {rs, rs}];      im = Image[ras];                   imesh = ImageMesh[ColorNegate[im], Method -> m];     II = imesh;     shapes =      Reverse[SortBy[ConnectedMeshComponents@imesh,        Length[MeshCells[#, 1]] &]];    map[{x_, y_}] := rs {x, y} + {1/2, -1/2};    toShow = {If[sI, Graphics[ras], {}],      If[sP,        Graphics[{Opacity[0.8],          filledPolygon[[1]] /.           Polygon[l_] :> Polygon[Map[map, l, {-2}]]}], {}],      If[sO, Graphics[{Opacity[0.8], Blue, Show[imesh][[1]]}], {}],      If[sR,        Table[smooth2D[shapes[[k]], Directive[Opacity[0.7], rC],          d], {k, Length[shapes]}], {}],      If[sC,        pp /. Line[l_] :> {ColorNegate[rC],           Line[Map[map, l, {-2}]]}, {}],      If[sIP,        Graphics[{ Gray, PointSize[Medium],          Point[map /@ ((1 - s) f1[[4, All, 1]] +              s  f2[[4, All, 1]])]}], {}]};    If[toShow === {{}, {}, {}, {}, {}}, Text["nothing to show" ] ,         Graphics[ Rotate[First /@ Flatten[toShow], \[CurlyPhi]],      PlotRangePadding -> 0, ImagePadding -> 0,       PlotRange -> {{-0.05 rs, 1.05 rs}, {-0.05 rs, 1.05 rs}},       ImageSize -> 400]]]],   {{seed, 595}, 1, 10000, 1},  {{deg, 24, "curve degree"}, 2, 36, 1},  {{s, 0.961, "transition"}, 0, 1},  Delimiter,  {{rs, 24, "raster size"}, 10, 60, 1},  Row[{"show: ",     Control[{{sR, True,        "smoothed region" <> FromCharacterCode[62340]}, {True,        False}}], "|  ",                       Control[{{sO, False, "region" <> FromCharacterCode[62340]}, {True,        False}}], "|  ",                      Control[{{sI, False, "raster" <> FromCharacterCode[62340]}, {True,        False}}], "|\n          ",                         Control[{{sP, False,        "polygon" <> FromCharacterCode[62340]}, {True, False}}],     "|  ",                        Control[{{sC, False, "curve" <> FromCharacterCode[62340]}, {True,        False}}], "|  ",                        Control[{{sIP, False,        "points" <> FromCharacterCode[62340]}, {True, False}}]}],  Delimiter,  {{d, 3, "smoothness"}, 0, 8, 1, SetterBar},   {{m, "DualMarchingSquares", "method"}, {"MarchingSquares",     "DualMarchingSquares", "Exact"}},   {{rC, Darker[Green, 0.6], "region color"}, Red, ImageSize -> Small},  Delimiter,  {{\[CurlyPhi], -2.06, "rotation"}, -Pi, Pi},  Delimiter,  Button["random shape", seed = RandomInteger[{1, 1000}];                                                         deg = RandomInteger[{2, 36}];                                                        s = RandomReal[{0, 1}]],  ControlPlacement -> Left,  TrackedSymbols :> True,   SaveDefinitions -> True]
3D Manipulate

And here is a corresponding 3D example.

SeedRandom[1]; Module[{deg = 3, pp = 16, L = 3, \[Delta], p, pts, sol, p1, cp,    pointsGraphic3D, pointsAndSurface, im2,               imesh, sm, ccs, bmr},   \[Delta] = 2 L/pp;  p[x_, y_, z_] = (x^2 + y^2 + z^2)^(2 deg) +     Sum[c[i, j, k] x^i y^j z^k, {i, 0, deg}, {j, 0, deg}, {k, 0, deg}];   pts = RandomReal[{-1, 1}, {Length@Cases[p[x, y, z], _c, \[Infinity]],      3}];    sol = Solve[(p @@@ pts) == 0, Cases[p[x, y, z], _c, \[Infinity]]];    p1 = p[x, y, z] /. sol[[1]];     cp = ContourPlot3D[    Evaluate[p1], {x, -L, L}, {y, -L, L}, {z, -L, L}, Contours -> {0}];  L = Ceiling[    Max[Abs[Transpose[       Cases[cp, _GraphicsComplex, \[Infinity]][[1, 1]]]]], 0.2];    pointsGraphic3D =    Graphics3D[{Red, Sphere[#, 0.05] & /@ pts}, PlotRange -> L];   pointsAndSurface =    Show[{cp =       ContourPlot3D[Evaluate[p1], {x, -L, L}, {y, -L, L}, {z, -L, L},        Contours -> {0},       ContourStyle -> Gray, Lighting -> "Neutral",        MeshFunctions -> {Norm[{#1, #2, #3}] & }], pointsGraphic3D},     Axes -> False];  im2 = Graphics3D[    Table[If[p1 < 0, {Opacity[0.3], EdgeForm[Blue], Gray, Opacity[0.3],                                                                       \  Cuboid[{x, y, z}/\[Delta] + pp/2, {x, y, z}/\[Delta] + pp/2 +          1]}, {}],                                                  {x, -L, L,       2 L/pp}, {y, L, -L, -2 L/pp}, {z, L, -L, -2 L/pp}],                   Lighting -> "Neutral", Axes -> False];   imesh = ImageMesh[Image3D[Table[Boole[p1 < 0],                                                          {x, -L, L,        2 L/pp}, {y, L, -L, -2 L/pp}, {z, L, -L, -2 L/pp}]],                                                     Method -> "MarchingCubes"];  ccs = Reverse[    SortBy[ConnectedMeshComponents[imesh], Length[MeshCells[#, 2]] &]];    sm = smooth3D[ccs[[1]], 2];   bmr = BoundaryMeshRegion[sm[[1]],     Style[Cases[sm, _Polygon, \[Infinity]],      Directive[Opacity[0.5], Darker[Green]]]];     Column[{Row[{pointsGraphic3D, " \[DoubleLongRightArrow] ",        pointsAndSurface, " \[DoubleLongRightArrow] "}],                     Row[{im2, " \[DoubleLongRightArrow] " ,        Show[{im2, imesh}, Boxed -> True], " \[DoubleLongRightArrow] "}],                      Row[{Show[{im2, bmr}, Boxed -> True],        " \[DoubleLongRightArrow] ",  Show[bmr, Boxed -> True]}]} /.                                                                       \                  gr_Graphics3D :> Show[gr, ImageSize -> 200]]]
3D Example

Shadows of the 3D Shapes

In her reply to my community post, Marina Shchitova showed some examples of faces and animals in shadows of hands and fingers. Some classic examples from the Cassel1896 book are shown here.

Hand shadows

So, what do projections/shadows of the above two 3D shapes look like? (For a good overview of the use of shadows in art at the time and place of the young Arp, see Forgione1999.)

The projections of these 3D shapes are exactly the types of shapes I encountered in the connected smoothed components of 2D images. The function projectTo2D takes a 3D graphic complex and projects it into a thin slice parallel to the three coordinate planes. The result is still a Graphics3D object.

projectTo2D[GraphicsComplex[vs_, r__]] :=   Module[{f = 0.2, \[CurlyEpsilon] = 10^-2, t = Developer`ToPackedArray,    xMin, xMax, yMin, yMax, zMin,     zMax, \[Delta]x, \[Delta]y, \[Delta]z},   {{xMin, xMax}, {yMin, yMax}, {zMin, zMax}} = MinMax /@ Transpose[vs];   {\[Delta]x, \[Delta]y, \[Delta]z} = {xMax - xMin, yMax - yMin,      zMax - zMin};   {EdgeForm[],    {Darker[Red],      GraphicsComplex[      t[{xMin -            f \[Delta]x + \[CurlyEpsilon] (#1 -                xMin)/\[Delta]x, #2, #3} & @@@ vs], r]},     {Darker[Blue],      GraphicsComplex[      t[{#1, yMax +            f \[Delta]y + \[CurlyEpsilon] (#2 - yMin)/\[Delta]y, #3} & @@@         vs], r]},    {Darker[Green, 0.6],      GraphicsComplex[      t[{#1, #2,           zMin - f \[Delta]z + \[CurlyEpsilon] (#3 -                zMin)/\[Delta]z} & @@@ vs], r]}} ]

These are the 2×3 projections of the above two 2D shapes. Most people recognize animal shapes in the projections.

We get exactly these projections if we just look at the 3D shape from a larger distance with a viewpoint and direction parallel to the coordinate axes.

{Graphics3D[{Darker[Blue], EdgeForm[], sampleRegionSmooth2},    ViewPoint -> {1, -20, 0}],   Graphics3D[{Darker[Green, 0.6], EdgeForm[], sampleRegionSmooth2},    ViewPoint -> {1, 0, 20}, ViewVertical -> {0, 1, 0}],  Graphics3D[{Darker[Red, 0.6], EdgeForm[], sampleRegionSmooth2},    ViewPoint -> {20, 0, 1}]}

For comparison, here are three views of the first object from very far away, effectively showing the projections.

By rotating the 3D shapes, we can generate a large variety of different shapes in the 2D projections. The following Manipulate allows us to explore the space of projections’ shapes interactively. Because we need the actual rotated coordinates, we define a function rotate, rather than using the built-in function Rotate.

rotationMatrix3D[{\[Alpha]1_, \[Alpha]2_, \[Alpha]3_}] :=   Module[{c1, s1, c2, s2, c3, s3},   {c3, s3, c2, s2, c1, s1} =     N@{Cos[\[Alpha]3], Sin[\[Alpha]3], Cos[\[Alpha]2], Sin[\[Alpha]2],       Cos[\[Alpha]1], Sin[\[Alpha]1]};   {{c3, s3, 0}, {-s3, c3, 0}, {0, 0, 1}}.           {{c2, 0, s2}, {0, 1, 0}, {-s2, 0, c2}}.           {{1, 0, 0}, {0, c1, s1}, {0, -s1, c1}}]

Here is an array of 16 projections into the x-z plane for random orientations of the 3D shape.

projectToXZImage[GraphicsComplex[vs_, r__]] :=   Module[{f = 0.2, \[CurlyEpsilon] = 10^-2,     t = Developer`ToPackedArray, yMin, yMax, \[Delta]y },   {yMin, yMax} = MinMax@ Transpose[vs][[2]]; \[Delta]y = yMax - yMin;   ImageCrop@Image[Rasterize[      Graphics3D[{EdgeForm[], Darker[Blue],         GraphicsComplex[         t[{#1, yMax +               f \[Delta]y + \[CurlyEpsilon] (#2 -                   yMin)/\[Delta]y, #3} & @@@ vs], r]},       ViewPoint -> {0, -5, 0}, Boxed -> False]]]]

GraphicsGrid[Partition[Show[#, ImageSize -> 120] & /@    Table[projectToXZImage[      rotate[sampleRegionSmooth2, RandomReal[{-Pi, Pi}, 3]]], 16], 4],  Spacings -> {0, 0}]

The initial 3D image does not have to be completely random. In the next example, we randomly place circles in 3D and color a voxel white if the circle intersects the voxel. As a result, the 3D shapes corresponding to the connected voxel regions have a more network-like shape.

randomCircle[   l : {{xml : in_, xmax_}, {ymin_, ymax_}, {zmin_, zmax_}}]  :=    Module[{mp = RandomReal /@ l, \[Delta] = Mean[Abs[Subtract @@@ l]],     dir1, dir2, \[Rho]1, \[Rho]2},    {dir1, dir2} = Orthogonalize[RandomReal[{-1, 1}, {2, 3}]];     {\[Rho]1, \[Rho]2} = RandomReal[\[Delta]/2 {0, 1}, 2];   Circle3D[mp, {\[Rho]1, \[Rho]2}, {dir1, dir2}]]

3D Shapes with Bilateral Symmetry

2D projection shapes of 3D animals typically have no symmetry. Even if an animal has a symmetry, the visible shape from a given viewpoint and a given animal posture does not have a symmetry. But most animals have a bilateral symmetry. I will now use random images that have a bilateral symmetry. As a result, many of the resulting shapes will also have a bilateral symmetry. Not all of the shapes, because some regions do not intersect the symmetry plane. Bilateral symmetry is important for the classic Rorschach inkblot test: “The mid-line appears to attract the patient’s attention with a sort of magical power,” noted Rorschach (Schott2013). The function makeSymmetricShapes3D will generate regions with bilateral symmetry.

makeSymmetricShapes3D[{dimz_, dimy_, dimx_}, {black_, white_}] :=    Module[{ii, randomImage, imesh},    ii[x_, y_,      z_] := (ii[x, y, z] =       ii[x, 1 + dimy - y, z] =        RandomChoice[{black, white} -> {0, 1}]);   randomImage =     Image3D[Table[ii[x, y, z], {x, dimx}, {y, dimy}, {z, dimz}]];    imesh =     ImageMesh[randomImage, Method -> "MarchingCubes",      CornerNeighbors -> False];        Select[ConnectedMeshComponents@imesh, 10 < Volume[#] &]]

Here are some examples.

makeSymmetricShapes3D[{dimz_, dimy_, dimx_}, {black_, white_}] :=    Module[{ii, randomImage, imesh},    ii[x_, y_,      z_] := (ii[x, y, z] =       ii[x, 1 + dimy - y, z] =        RandomChoice[{black, white} -> {0, 1}]);   randomImage =     Image3D[Table[ii[x, y, z], {x, dimx}, {y, dimy}, {z, dimz}]];    imesh =     ImageMesh[randomImage, Method -> "MarchingCubes",      CornerNeighbors -> False];        Select[ConnectedMeshComponents@imesh, 10 < Volume[#] &]]

Here are some examples.

SeedRandom[888]; symmShapes =   Table[makeSymmetricShapes3D[{d, d, d}, {3, 1}], {d, 5, 8}]

And here are smoothed and colored versions of these regions. The viewpoint is selected in such a way as to make the bilateral symmetry most obvious.

displaySmoothedRegion[reg_BoundaryMeshRegion, color_Directive,    opts___] :=   With[{sm = smooth3D[reg, 2]},   Show[BoundaryMeshRegion[sm[[1]], Style[sm[[2, 1]] , color],      PlotTheme -> "SmoothShading"], opts]]

To get a better feeling for the connection between the pixel values of the 3D image and the resulting smoothed shape, the next Manipulate allows us to specify each pixel value for a small-sized 3D image. The grids/matrices of checkboxes represent the voxel values of one-half of a 3D image with bilateral symmetry.

Manipulate[  DynamicModule[{v = v0, T, imesh, sb, reg, gList},    Column[{Column[{Text[Style["voxel values", Gray, Italic]],        Row[Join[Riffle[          Table[           With[{j = j},             Underscript[Grid[Table[With[{iL = i, jL = j, kL = k},                Checkbox[Dynamic[v[[iL, jL, kL]]]]], {k, kz}, {i, ix}],               Spacings -> 0],                                                                  Text[Style[Row[{"y", "=", j, If[j == jy + 1 - j, "",                                                         Row[{" | y", "=", jy + 1 - j}]]}], Gray,                Italic]]]], {j, Ceiling[jy/2]}],           "\[VerticalSeparator]"], {" "},         {Dynamic[           If[imesh =!= EmptyRegion[3],             Show[reg, ImageSize -> {{140}, {140}},              ViewPoint -> {-3, 1, 1}], ""],           TrackedSymbols :> {reg, imesh}]}]]}],                      Dynamic[T =        Table[Boole@v[[i, Min[j, jy + 1 - j], k]], {k, kz}, {j, jy}, {i,          ix}];                    imesh = ImageMesh[Image3D[T], Method -> "MarchingSquares"];                 If[imesh =!= EmptyRegion[3],        sb = SortBy[ConnectedMeshComponents@imesh, Volume];            Column[{reg = sb[[-1]];         Graphics3D[smooth3D[reg, sm], ImageSize -> 400,           ViewPoint -> {-3, 1, 1},                               Ticks -> None, Axes -> True,           AxesLabel -> {"x", "y", "z"}]}], "empty region"],      TrackedSymbols :> {v}]}, Dividers -> All]],  Row[{Underscript[Control[{{ix, 5, ""}, 3, 10, 1, SetterBar}],      Style["(x)", Gray]], "\[Times]",          Underscript[Control[{{jy, 5, ""}, 3, 10, 1, SetterBar}],      Style["(y)", Gray]], "\[Times]",               Underscript[Control[{{kz, 6, ""}, 3, 10, 1, SetterBar}],      Style["(z)", Gray]]}],      Delimiter,  {{sm, 1, "smoothness"}, 1, 3, 1, SetterBar},  {{v0, MapAt[True &, Table[False, {10}, {10}, {10}],     {{1, 1, 2}, {2, 1, 2}, {3, 1, 2}, {3, 2, 2}, {3, 3, 2}, {3, 4,        2}, {1, 5, 2},      {2, 5, 2}, {3, 5, 2}, {3, 2, 3}, {3, 4, 3}, {3, 1, 4}, {3, 3,        4}, {3, 5, 4},      {2, 1, 5}, {3, 3, 5}, {2, 5, 5}, {1, 1, 6}, {1, 3, 6}, {2, 3,        6}, {3, 3, 6}, {1, 5, 6}} ]}, None},  TrackedSymbols :> {ix, jy, kz, sm}, SaveDefinitions -> True]

Manipulate[ DynamicModule[{v = v0, T, imesh, sb, reg, gList}, Column[{Column[{Text[Style["voxel values", Gray, Italic]], Row[Join[Riffle[ Table[ With[{j = j}, Underscript[Grid[Table[With[{iL = i, jL = j, kL = k}, Checkbox[Dynamic[v[[iL, jL, kL]]]]], {k, kz}, {i, ix}], Spacings -> 0], Text[Style[Row[{"y", "=", j, If[j == jy + 1 - j, "", Row[{" | y", "=", jy + 1 - j}]]}], Gray, Italic]]]], {j, Ceiling[jy/2]}], "[VerticalSeparator]"], {" "}, {Dynamic[ If[imesh =!= EmptyRegion[3], Show[reg, ImageSize -> {{140}, {140}}, ViewPoint -> {-3, 1, 1}], ""], TrackedSymbols :> {reg, imesh}]}]]}], Dynamic[T = Table[Boole@v[[i, Min[j, jy + 1 - j], k]], {k, kz}, {j, jy}, {i, ix}]; imesh = ImageMesh[Image3D[T], Method -> "MarchingSquares"]; If[imesh =!= EmptyRegion[3], sb = SortBy[ConnectedMeshComponents@imesh, Volume]; Column[{reg = sb[[-1]]; Graphics3D[smooth3D[reg, sm], ImageSize -> 400, ViewPoint -> {-3, 1, 1}, Ticks -> None, Axes -> True, AxesLabel -> {"x", "y", "z"}]}], "empty region"], TrackedSymbols :> {v}]}, Dividers -> All]], Row[{Underscript[Control[{{ix, 5, ""}, 3, 10, 1, SetterBar}], Style["(x)", Gray]], "[Times]", Underscript[Control[{{jy, 5, ""}, 3, 10, 1, SetterBar}], Style["(y)", Gray]], "[Times]", Underscript[Control[{{kz, 6, ""}, 3, 10, 1, SetterBar}], Style["(z)", Gray]]}], Delimiter, {{sm, 1, "smoothness"}, 1, 3, 1, SetterBar}, {{v0, MapAt[True &, Table[False, {10}, {10}, {10}], {{1, 1, 2}, {2, 1, 2}, {3, 1, 2}, {3, 2, 2}, {3, 3, 2}, {3, 4, 2}, {1, 5, 2}, {2, 5, 2}, {3, 5, 2}, {3, 2, 3}, {3, 4, 3}, {3, 1, 4}, {3, 3, 4}, {3, 5, 4}, {2, 1, 5}, {3, 3, 5}, {2, 5, 5}, {1, 1, 6}, {1, 3, 6}, {2, 3, 6}, {3, 3, 6}, {1, 5, 6}} ]}, None}, TrackedSymbols :> {ix, jy, kz, sm}, SaveDefinitions -> True]

Randomly and independently selecting the voxel value of a 3D image makes it improbable that very large connected components without many holes form. Using instead random functions and deriving voxel values from these random continuous functions yields different-looking types of 3D shapes that have a larger uniformity over the voxel range. Effectively, the voxel values are no longer totally uncorrelated.

makeSymmetricShapes3DFunctionBased[{dimz_, dimy_, dimx_}, G_] :=  Module[{fun, randomImage, imesh, M = 2 Max[{dimx, dimy, dimz}], x, y,     z},  fun[x_, y_, z_] =      Sum[Cos[RandomReal[{-M, M}] (y - (dimy + 1)/2)]                                                          Cos[RandomReal[{-M, M}] x + 2 Pi RandomReal[]]                                                                    Cos[RandomReal[{-M, M}] z + 2 Pi RandomReal[]], {4}];   randomImage =     Image3D[Table[      If[fun[x, y, z] > G, 0, 1], {x, dimx}, {y, dimy}, {z, dimz}]] ;    imesh = ImageMesh[randomImage, Method -> "MarchingSquares"];        Select[ConnectedMeshComponents@imesh, 10 < Volume[#] &]]

Here are some examples of the resulting regions, as well as their smoothed versions.

SeedRandom[55]; symmFunctionShapes =   Table[makeSymmetricShapes3DFunctionBased[{d, d, d}, -0.3], {d, 5, 8}]

symmFunctionShapes /. bmr_BoundaryMeshRegion :>    displaySmoothedRegion[bmr,     Directive[Blend[{GrayLevel[0.5], Orange}, 0.1],      Specularity[Purple, 10]], ViewPoint -> {-3, -0.5, 1.2}]

Selected Examples of 3D Shapes

Our notebook contains in the initialization section more than 400 selected regions of “interesting” shapes classified into five types (mostly arbitrarily, but based on human feedback).

types = <|"asymmetric general shapes" -> aymmetricGeneralShapes,                 "asymmetric animal shapes" -> asymmetricAnimalShapes,                 "symmetric general shapes"  -> symmetricGeneralShapes,                 "symmetric animal shapes" -> symmetricAnimalShapes,                  "symmetric alien shapes" -> symmetricAlienShapes,                     "asymmetric function animal shapes" ->      asymmetricFunctionAnimalShapes,                     "symmetric function animal shapes" ->      symmetricFunctionAnimalShapes|>;

Let’s look at some examples of these regions. Here is a list of some selected ones. Many of these shapes found in random 3D images could be candidates for Generation 8 Pokémon or even some new creatures, tentatively dubbed Mathtubbies.

selections = <|    "asymmetric general shapes" ->       {1, 4, 7, 8, 9, 10, 11, 13, 18, 20, 32, 35, 39, 43, 48, 49},     "asymmetric animal shapes" ->       {3, 4, 5, 6, 7, 10, 11, 13, 14, 15, 16, 17, 18, 24, 25, 28},     "symmetric general shapes"  ->  {1, 4, 7, 12, 15, 16, 18, 20, 22,       25, 26, 27, 28, 29, 33, 35, 36, 39, 41, 42} ,       "symmetric animal shapes" ->  {2, 3, 5, 6, 7, 8, 9, 10, 11, 12,       14, 15, 20, 22, 23, 25, 26, 31, 32, 35},       "symmetric alien shapes" ->      {2, 4, 5, 6, 8, 9, 13, 15, 17, 18, 19, 20, 26, 30, 38, 39},         "asymmetric function animal shapes" -> {4, 5, 6, 9, 10, 11,       13, 15, 18, 22, 29, 30, 34, 39, 41, 54, 58, 66, 69, 76},         "symmetric function animal shapes" -> {1, 4, 5, 6, 10, 13, 16,       20, 21, 26, 29, 32, 34, 35, 36, 41, 78, 88, 90, 92}|>;

Many of the shapes are reminiscent of animals, even if the number of legs and heads is not always the expected number.

Do[Print[Framed[Style[t, Bold, Gray], FrameStyle -> Gray]];   Print /@ Partition[    Show[Rasterize[#], ImageSize -> {{200}, {200}}] & /@ (makeRegion /@        types[t][[selections[[t]]]]), 4],  {t, Keys[types]}]

asymmetrical general shapes

asymmetrical general shapes 1

asymmetrical general shapes 2

asymmetrical general shapes 3

asymmetrical general shapes 4

asymmetric animal shapes

asymmetric animal shapes 1

asymmetric animal shapes 2

asymmetric animal shapes 3

asymmetric animal shapes 4

symmetric general shapes

symmetric general shapes 1

symmetric general shapes 2

symmetric general shapes 3

symmetric general shapes 4

symmetric general shapes 5

symmetric animal shapes

symmetric animal shapes 1

symmetric animal shapes 2

symmetric animal shapes 3

symmetric animal shapes 4

symmetric animal shapes 5

symmetric alien shapes

symmetric alien shapes 1

symmetric alien shapes 2

symmetric alien shapes 3

symmetric alien shapes 4

asymmetric functional animal shapes

assymetric functional animal shapes 1

assymetric functional animal shapes 2

assymetric functional animal shapes 3

assymetric functional animal shapes 4

assymetric functional animal shapes 5

symmetric function animal shapes

symmetric function animal shapes 1

symmetric function animal shapes 2

symmetric function animal shapes 3

symmetric function animal shapes 4

symmetric function animal shapes 5

To see all of the 400+ shapes from the initialization cells, one could carry out the following.

Do[Print[Framed[Style[t, Bold, Gray], FrameStyle -> Gray]];
Do[Print[Rasterize @ makeRegion @ r], {r, types[t]}], {t,Keys[types]}]

The shapes in the list above were manually selected. One could now go ahead and partially automate the finding of interesting animal-looking shapes and “natural” orientations using machine learning techniques. In the simplest case, we could just use ImageIdentify.

ImageIdentify[ , "animal", 5, "Probability"]

This seems to be a stegosaurus-poodle crossbreed. But we will not pursue this direction here and now, but rather return to the 2D projections. (For using software to find faces in architecture and general equipment, see Hong2014.)

Modifying the 3D Shapes

Before returning to the 2D projections, we will play for a moment with the 3D shapes generated and modify them for a different visual appearance.

For instance, we could tetrahedralize the regions and fill the tetrahedra with spheres.

makeRegion[reg_, n_] :=   With[{sr = smooth3D[reg[[1]], n]},    BoundaryMeshRegion[sr[[1]], sr[[2, 1]]]]

Or with smaller tetrahedra.

dualTetrahedron[Tetrahedron[l_]] :=   Tetrahedron[ Mean /@ Subsets[l, {3}]]

Or add some spikes.

addPrickle[Polygon[{p1_, p2_, p3_}], \[Alpha]_: 1 ] :=   Module[{mp = Mean[{p1, p2, p3}], normal, \[Lambda]},   normal = Normalize[Cross[p1 - mp, p2 - mp]];   \[Lambda] = Mean[EuclideanDistance[#, mp] & /@ {p1, p2, p3}];   Tetrahedron[{p1, p2, p3, mp + \[Alpha] \[Lambda] normal}] ]

Or fill the shapes with cubes.

makeRandomPoints[d_, n_] := RandomPoint[makeRegion[d, 2], n]

Or thicken or thin the shapes.

thickenThinnen[gr_, d_] :=   Show[gr] /.    GraphicsComplex[vs_, b_, VertexNormals -> ns_] :>     GraphicsComplex[ vs + d Normalize /@ ns, b, VertexNormals -> ns]

Or thicken and add thin bands.

Module[{ob = symmetricAlienShapes[[43]], dr, dd},  dr = SignedRegionDistance[ob[[1]]];  dd[{x_Real, y_Real, z_Real}] := dr[{x, y, z}];  Row[{Show[makeRegion[ob], ImageSize -> 240],       ContourPlot3D[dd[{x, y, z}], {x, 0, 9}, {y, -1, 9}, {z, -1, 8},      Contours -> {0.33}, PlotPoints -> 80, MaxRecursion -> 0,     MeshFunctions -> {#3 &}, Mesh -> 40,      MeshShading -> {ob[[2]], None},     Evaluate[makeOptions[ob]], Boxed -> False, Axes -> False,      ImageSize -> 320]}]]

Or just add a few stripes as camouflage.

tigerize[{reg_, col_, {vp_, vd_}}, {col1_, col2_}, {stripes_, xyz_}] :=   Module[{sm = smooth3D[reg, 3], g, size},   g = Show[     BoundaryMeshRegion[sm[[1]], sm[[2, 1]],       PlotTheme -> "SmoothShading"], ViewPoint -> vp,      ViewVertical -> vd];           size = Abs[Subtract @@ MinMax[Transpose[sm[[1]]][[xyz]]]];   g /. GraphicsComplex[vs_, rest__] :> GraphicsComplex[vs, rest,                                             VertexColors -> (         Blend[{col1, col2}, Sin[2 Pi stripes #[[xyz]]/size]^2] & /@ vs

Or model the inside through a wireframe of cylinders.

makeCylinders[pts_, m_, \[Rho]_] := Module[{nf = Nearest[pts]},     {Union[Flatten[      Function[p,         Cylinder[Sort@{#, p}, \[Rho]] & /@  Rest[ nf[p, m + 1]]] /@        pts]],     Sphere[#, \[Rho]] & /@ pts} ]

Or build a stick figure.

toStickFigure[ob_, \[Delta]_] :=   Module[{pts, nf, gr, ccs, modCol,                      f = RandomChoice[{Lighter, Darker}][#, RandomReal[{0, 0.2}]] &},     nf = Nearest[     pts = Cases[makeRegion[ob], _GraphicsComplex, \[Infinity]][[1,        1]]];   gr = Graph[     UndirectedEdge[#, nf[#, {Infinity, \[Delta]}][[-1]]] & /@ pts];   ccs = WeaklyConnectedGraphComponents[gr];   modCol[] := ob[[2]] /. Directive[col1_, Specularity[col2_, e2_]] :>                                                         Directive[f[col1],        Specularity[f[col2], RandomReal[{0.75, 1.25}] e2]];   Graphics3D[{EdgeForm[], CapForm[None],      {modCol[],         Cylinder[Union[Sort /@ List @@@ EdgeList[#]], 0.05]} & /@       Take[ccs, All],       ob[[2]], Sphere[#, 0.05] & /@ pts}, makeOptions[ob],     Boxed -> False,     Method -> {"TubePoints" -> 6, "SpherePoints" -> 6}]]

Or fill the surface with a tube.

makeTube[ob_, n_, \[Rho]_] :=  Module[{dr = makeRegion[ob, 1], pairs, neighbors, nl, mcs},   pairs = {#[[1, 1]], Last /@ #} & /@ Split[Sort[Flatten[{First[#],            Reverse[First[#]]} & /@ MeshCells[dr, 1],         1]], #1[[1]] == #2[[1]] &];   (neighbors[#1] = #2) & @@@ pairs;   nl = NestList[RandomChoice[DeleteCases[neighbors[#], #]] &, 1, n];   mcs = MeshCoordinates[dr];   Tube[BSplineCurve[mcs[[nl]]], \[Rho]]]

Or a Kelvin inversion.

With[{g = With[{o = aymmetricGeneralShapes[[50]]},     With[{sm = smooth3D[o[[1]], 3]},      Show[BoundaryMeshRegion[sm[[1]], Style[sm[[2, 1]], o[[2]]],        PlotTheme -> "SmoothShading"]]]]},  {Row[{Show[g, ImageSize -> 240],                 Show[invert3D[g, {4, 4, 4}], ViewPoint -> {2.62, -2.06, -0.52},                       ViewVertical -> {-0.04, -0.92, -0.42},       ImageSize -> 280]}]}]

Shadows of the Selected Examples

If we look at the 2D projections of some of these 3D shapes, we can see again (with some imagination) a fair number of faces, witches, kobolds, birds and other animals. Here are some selected examples. We show the 3D shape in the original orientation, a randomly oriented version of the 3D shape, and the three coordinate-plane projections of the randomly rotated 3D shape.

projectionPair[{{type_, n_}, angles_}] :=  Module[{opts, col, sr},   opts = Sequence[ImageSize -> {{220}, {220}}, BoxRatios -> {1, 1, 1},      ViewPoint -> {3, -3, 3}, Axes -> False, Boxed -> False];   col = types[type][[n, 2]];   sr = smooth3D[types[type][[n, 1]], 3];   Row[Riffle[Framed /@ Rasterize /@        {Graphics3D[{EdgeForm[], col, sr},          ViewPoint -> types[type][[n]][[3, 1]],                                           ViewVertical -> types[type][[n]][[3, 2]],          ImageSize -> {{220}, {220}}, Axes -> False, Boxed -> False],         Graphics3D[{EdgeForm[], col, rotate[sr, angles]}, opts],         Graphics3D[projectTo2D[rotate[sr, angles]], opts]}, " "]]]

Unsurprisingly, some are recognizable 3D shapes, like these projections that look like bird heads.

projectionPair[{{"asymmetric animal shapes", 15}, {-2.8, 3.05, 2.35}}]

Others are much more surprising, like the two heads in the projections of the two-legged-two-finned frog-dolphin.

projectionPair[{{"symmetric general shapes", 34}, {2.8, -1.4, 1.4}}]

Different orientations of the 3D shape can yield quite different projections.

projectionPair[{{"asymmetric general shapes",     49}, {-3.05, -0.75, -1.3}}]

For the reader’s amusement, here are some more projections.

projectionPair[{{"symmetric alien shapes", 3}, {-0.4, -0.25, 0.85}}]

projectionPair[{{"symmetric alien shapes", 7}, {0., 2.55, 0.6}}]

projectionPair[{{"asymmetric general shapes", 11}, {-1.25,     0.05, -1.6}}]

projectionPair[{{"asymmetric general shapes",     9}, {-0.15, -0.85, -0.55}}]

projectionPair[{{"symmetric general shapes", 26}, {1.8, -2.6, -2.3}}]

projectionPair[{{"asymmetric animal shapes", 5}, {2.65, 2.1, -2.85}}]

projectionPair[{{"asymmetric general shapes",     34}, {-3.1, -2.95, -1.}}]

Shapes from 4D Images

Now that we have looked at 2D projections of 3D shapes, the next natural step would be to look at 3D projections of 4D shapes. And while there is currently no built-in function Image4D, it is not too difficult to implement for finding the connected components of white 4D voxels. We implement this through the graph theory function ConnectedComponents and consider two 4D voxels as being connected by an edge if they share a common 3D cube face. As an example, we use a 10*10*10*10 voxel 4D image. makeVoxels4D makes the 4D image data and whitePositionQ marks the position of the white voxels for quick lookup.

makeVoxels4D[{dimw_, dimz_, dimy_, dimx_}, {black_, white_}] :=  Table[RandomChoice[{black, white} -> {0,       1}], {dimw}, {dimz}, {dimy}, {dimx}]

The 4D image contains quite a few connected components.

ccs = ConnectedComponents[gr];

Here are the four canonical projections of the 4D complex.

With[{cc = ccs[[1]]},  {Graphics3D[(Cuboid[# - 1/2, # + 1/2] &@{#1, #2, #3}) & @@@ cc,                       AxesLabel -> {"x", "y", "z"}, Axes -> True,     Ticks -> False],   Graphics3D[(Cuboid[# - 1/2, # + 1/2] &@{#1, #2, #4}) & @@@ cc,                           AxesLabel -> {"x", "y", "w"}, Axes -> True,     Ticks -> False],   Graphics3D[(Cuboid[# - 1/2, # + 1/2] &@{#1, #3, #4}) & @@@ cc,                           AxesLabel -> {"x", "z", "w"}, Axes -> True,     Ticks -> False],   Graphics3D[(Cuboid[# - 1/2, # + 1/2] &@{#2, #3, #4}) & @@@ cc,                           AxesLabel -> {"y", "z", "w"}, Axes -> True,     Ticks -> False]}]

We package the finding of the connected components into a function getConnected4DVoxels.

getConnected4DVoxels[Image4D[l_], n_] :=   Module[{posis, blackPos, edges, gr, v = UnitVector[4, #] &},   posis =     DeleteCases[     Level[MapIndexed[If[# === 0, #2, Nothing] &, l, {-1}], {-2}], {}];   (blackPos[#] = True) & /@ posis;    edges = Union[Flatten[Table[If[TrueQ[blackPos[# + v[j]]],                Sort@ UndirectedEdge[#, # + v[j]], {}] & /@ posis, {j,         4}]]];   gr = Graph[edges];   Take[Reverse[SortBy[ConnectedComponents[gr], Length]], UpTo[n]]]

We also define a function rotationMatrix4D for conveniently carrying rotations in the six 2D planes of the 4D space.

rotationMatrix4D[{\[Omega]xy_, \[Omega]xz_, \[Omega]xw_, \[Omega]yz_, \ \[Omega]yw_, \[Omega]zw_}] :=    With[{u = UnitVector[4, #] &, c = Cos, s = Sin},     Fold[Dot, IdentityMatrix[4],        {{{c[\[Omega]xy], s[\[Omega]xy], 0, 0}, {-s[\[Omega]xy],         c[\[Omega]xy], 0, 0},  u[3], u[4]},          {{c[\[Omega]xz], 0, s[\[Omega]xz], 0},        u[2], {-s[\[Omega]xz], 0, c[\[Omega]xz], 0}, u[4]},          {{c[\[Omega]xw], 0, 0, s[\[Omega]xw]}, u[2],        u[3], {-s[\[Omega]xw], 0, 0, c[\[Omega]xw]}},          {u[1], {0, c[\[Omega]yz], s[\[Omega]yz],         0}, {0, -s[\[Omega]yz], c[\[Omega]yz], 0}, u[4]},          {u[1], {0, c[\[Omega]yw], 0, s[\[Omega]yw]},        u[3], {0, -s[\[Omega]yw], 0, c[\[Omega]yw]}},          {u[1],        u[2], {0, 0, c[\[Omega]zw], s[\[Omega]zw]}, {0,         0, -s[\[Omega]zw], c[\[Omega]zw]}}}]];

Once we have the 3D projections, we can again use the above function to smooth the corresponding 3D shapes.

to3DImage[l_] :=   With[{mins = Min /@ Transpose[l]}, (# - mins) + 1 & /@ l]

In the absence of Tralfamadorian vision, we can visualize a 4D connected voxel complex, rotate this complex in 4D, then project into 3D, smooth the shapes and then project into 2D. For a single 4D shape, this yields a large variety of possible 2D projections. The function projectionGrid3DAnd2D projects the four 3D projections canonically into 2D. This means we get 12 projections. Depending on the shape of the body, some might be identical.

extractRegion[vs_] := Last[SortBy[ConnectedMeshComponents[     ImageMesh[Image3D[SparseArray[vs -> 1]],       Method -> "MarchingSquares"]], Volume]]

We show the 3D shape in a separate graphic so as not to cover up the projections. Again, many of the 2D projections, and also some of the 3D projections, remind us of animal shapes.

projectionGrid3DAnd2D[ccs[[1]], {1, 2, 3, 4, 5, 6}, 2,   Directive[GrayLevel[0.4], Specularity[Yellow, 12]]]

The following Manipulate allows us to rotate the 4D shape. The human mind sees many animal shapes and faces.

Manipulate[  projectionGrid3DAnd2D[   ccs[[c]], {\[Omega]xy, \[Omega]xz, \[Omega]xw, \[Omega]yz, \ \[Omega]yw, \[Omega]zw},                                                     1,    Directive[GrayLevel[0.4], Specularity[Yellow, 12]]],  {{c, 2, "component"}, 1, 12, 1, SetterBar},   Delimiter,  {{s, 1, "smoothness"}, {0, 1, 2}},   Delimiter,  {{\[Omega]xy, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]xz, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]xw, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]yz, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]yw, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]zw, 0}, -Pi, Pi, ImageSize -> Small},  TrackedSymbols :> True, ControlPlacement -> Left,  SaveDefinitions -> True]

Manipulate[  projectionGrid3DAnd2D[   ccs[[c]], {\[Omega]xy, \[Omega]xz, \[Omega]xw, \[Omega]yz, \ \[Omega]yw, \[Omega]zw},                                                     1,    Directive[GrayLevel[0.4], Specularity[Yellow, 12]]],  {{c, 2, "component"}, 1, 12, 1, SetterBar},   Delimiter,  {{s, 1, "smoothness"}, {0, 1, 2}},   Delimiter,  {{\[Omega]xy, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]xz, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]xw, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]yz, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]yw, 0}, -Pi, Pi, ImageSize -> Small},  {{\[Omega]zw, 0}, -Pi, Pi, ImageSize -> Small},  TrackedSymbols :> True, ControlPlacement -> Left,  SaveDefinitions -> True]

Here is another example, with some more scary animal heads.

SeedRandom[8]; projectionGrid3DAnd2D[          getConnected4DVoxels[    Image4D[makeVoxels4D[{10, 10, 10, 10}, {4, 1}]], 5][[1]],     {-1.8, 2.6, 1., 2.2, -2.7, -1.5}, 3,   Directive[Darker[Yellow, 0.4], Specularity[Red, 10]]]

SeedRandom[8]; projectionGrid3DAnd2D[          getConnected4DVoxels[    Image4D[makeVoxels4D[{10, 10, 10, 10}, {4, 1}]], 5][[1]],     {-1.8, 2.6, 1., 2.2, -2.7, -1.5}, 3,   Directive[Darker[Yellow, 0.4], Specularity[Red, 10]]]

We could now go to 5D images, but this will very probably bring no new insights. To summarize some of the findings: After rotation and smoothing, a few percent of the connected regions of black voxels in random 3D images have an animal-like shape, or an artistic rendering of an animal-like shape. A large fraction (~10%) of the projections of these 3D shapes into 2D pronouncedly show the pareidolia phenomenon, in the sense that we believe we can recognize animals and faces in these projections. 4D images, due to the voxel count that increases exponentially with dimension, yield an even larger number of possible animal and face shapes.

To download this post as a CDF, click here. New to CDF? Get your copy for free with this one-time download.

Comments

Join the discussion

!Please enter your comment (at least 5 characters).

!Please enter your name.

!Please enter a valid email address.

5 comments

  1. This seems perfect for 3D-printing an army of pterodactyl-donkeys and whale-rabbits! Love it!

    Reply
  2. really fantastic! I need a 3d printer :)

    Reply
  3. I think the scale/size of an object helps determine much of what we think that object is. For example, if it were as big as a fridge, we would think, “Furniture.” But with some reference indicated it’s as small as a grape, we might think, “Insect”. On a side note, Input 81 looks to me like Gromit and an albatross had a baby.

    Reply
  4. Sorry about that! All functions released in the M11.1 update should be working just fine now.

    Reply