4
$\begingroup$

Update (to clarify)

My end goal is to generate Menger alike 3D cubes, as stated in the title.

OP

While reading the Menger cube, I found something called Jerusalem cube. On the same page, there are also many other similar cubes, like

enter image description here

and many more towards the end on the page (2nd link above).

I looked at the MengerMesh but it does not seem to provide this kind of variation.

$\endgroup$

1 Answer 1

10
$\begingroup$

It seems the logic is if there's a square of certain size (dependent on the level) available, then punch out the shape. I did not notice a nice pattern for this, so I took a brute force approach which means this solution most likely suboptimal.

First let's get the shape we'd like to punch out. To get the connectivity, I'll import the image and turn it to a mesh. To get the correct coordinates, I'll map the pixel approximations to the appropriate values.

The connectivity:

im = Import["https://i.stack.imgur.com/9uvoz.png"];

mesh = RegionResize[ConnectedMeshComponents[ImageMesh[ColorNegate[im]]][[1]], {{0, 1}, {0, 1}}];

Find the correct coordinates:

s = Last[x /. NSolve[x + x^4 + x^3 + x^2 + x == 1, x, Reals]];

nf = Nearest[Union[#, 1 - #] &[{0., s^4, s^3, s^2, s, s + s^4, s + s^4 + s^3}]];

seed = RegionDifference[
  BoundaryDiscretizeGraphics[Rectangle[]],
  BoundaryMeshRegion[Map[First@*nf, MeshCoordinates[mesh], {2}], MeshCells[mesh, 1]]
]

enter image description here

Now for the code that looks for valid squares of with side lengths s^lev and punches out the shape. Note that I didn't take the time to refine makeRects or to make it readable.

iJerusalemCube[mr_, lev_] := 
  Block[{coords, nn, rects, sub},
    coords = MeshCoordinates[mr];
    nn = Nearest[coords];
    rects = Union @@ makeRects[mr, s^lev] /@ coords;
    sub = RegionUnion @@ (RegionResize[seed, Transpose[#] + s^(4+lev){{1, -1}, {1, -1}}]& /@ rects);
    RegionDifference[mr, sub]
]

makeRects[mr_, lev_][p:{x_, y_}] := 
  First[Reap[
    If[Or[Count[Max[Chop[Abs[First[nn[#]]-#]]]& /@ Tuples[Transpose@{p, p+lev}], 0] > 1, Nor @@ RegionMember[mr, {p + {lev/2, -s^(6+lev)}, p + {-s^(6+lev), lev/2}}]] && RegionWithin[mr, Rectangle[p, p+lev]], Sow[{p, p+lev}]];
    If[Or[Count[Max[Chop[Abs[First[nn[#]]-#]]]& /@ Tuples[Transpose@{{x, y-lev}, {x+lev, y}}], 0] > 1, Nor @@ RegionMember[mr, {p + {lev/2, s^(6+lev)}, p + {-s^(6+lev), -lev/2}}]] && RegionWithin[mr, Rectangle[{x, y-lev}, {x+lev, y}]], Sow[{{x, y-lev}, {x+lev, y}}]];
    If[Or[Count[Max[Chop[Abs[First[nn[#]]-#]]]& /@ Tuples[Transpose@{{x-lev, y}, {x, y+lev}}], 0] > 1, Nor @@ RegionMember[mr, {p + {-lev/2, -s^(6+lev)}, p + {s^(6+lev), lev/2}}]] && RegionWithin[mr, Rectangle[{x-lev, y}, {x, y+lev}]], Sow[{{x-lev, y}, {x, y+lev}}]];
    If[Or[Count[Max[Chop[Abs[First[nn[#]]-#]]]& /@ Tuples[Transpose@{p-lev, p}], 0] > 1, Nor @@ RegionMember[mr, {p + {-lev/2, s^(6+lev)}, p + {s^(6+lev), -lev/2}}]] && RegionWithin[mr, Rectangle[p-lev, p]], Sow[{p-lev, p}]];
  ][[-1]], {}]

Here, iJerusalemCube finds all rectangles that

  • have side lengths s^lev
  • have a corner that's a coordinate of mr
  • either
    • has multiple corners that are a coordinate of mr (the nn part)
    • is tucked into a corner, i.e. does not just meet the boundary at a single point (the Nor @@ RegionMember part)
  • is fully contained within mr (the RegionWithin part).

Then it punches out the shape in all valid rectangles.

The main function will iterate this:

JerusalemCubeList[lev_Integer?NonNegative] := 
  FoldList[
    iJerusalemCube, 
    BoundaryDiscretizeGraphics[Rectangle[]], 
    Range[0, lev-1]
  ]

JerusalemCubeList[4]

enter image description here

Multicolumn[MapIndexed[
  BoundaryMeshRegion[#1, MeshCellStyle -> {1 -> Black, 2 -> ColorData[112][First[#2]]}] &, 
  JerusalemCubeList[5]], 3, Appearance -> "Horizontal"]

enter image description here

And unsurprising that the number of boundary edges grows exponentially:

cnts = MeshCellCount[#, 1] & /@ JerusalemCubeList[5]
{4, 32, 144, 704, 3504, 17504}
FindSequenceFunction[Rest@cnts, n]
4/5 (5 + 7 5^n)

To get a cube in 3D, we can intersect the 2D mesh extruded in 3 different directions:

mr = Last[JerusalemCubeList[3]];

bmr = BoundaryMesh[RegionProduct[mr, Line[{{0.}, {1.}}]]];

RegionIntersection @@ (
  BoundaryMeshRegion[MeshCoordinates[bmr][[All, #]], MeshCells[bmr, 2]] & /@ 
  {{1, 2, 3}, {3, 2, 1}, {1, 3, 2}})

enter image description here

$\endgroup$
5
  • $\begingroup$ Could these 2D images be turned into the 3D "cube"? $\endgroup$ Jul 29, 2018 at 15:17
  • 1
    $\begingroup$ @ChenStatsYu It's annoying and rude to move the goalpost. This answer does solve your question. If now you have another problem for which you need help, even if related, you should post another question. $\endgroup$
    – rhermans
    Jul 29, 2018 at 15:25
  • $\begingroup$ @rhermans Sorry if that is not clear. I did say in the title that I am hoping to generate the 3D of these cubes too. I don't think the goal has changed at all. I do appreciate the answer and I have already voted an up too. $\endgroup$ Jul 29, 2018 at 15:28
  • $\begingroup$ @ChenStatsYu See my edit. It wasn't clear to me in the question you were looking for a 3D version. $\endgroup$
    – Greg Hurst
    Jul 29, 2018 at 15:30
  • $\begingroup$ @ChipHurst Sorry about that. Thanks! $\endgroup$ Jul 29, 2018 at 15:32

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.