Consider constructing a Jerusalem Cube Fractal. 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]]
]
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]
Multicolumn[MapIndexed[
BoundaryMeshRegion[#1, MeshCellStyle -> {1 -> Black, 2 -> ColorData[112][First[#2]]}] &,
JerusalemCubeList[5]], 3, Appearance -> "Horizontal"]
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}})
Original post can be found HERE.
