Extract cell indicators from MeshRegion?

Question

As of version 11.1, one can create successive steps of such objects as the Cantor ternary set and a Menger carpet (aka Sierpinski carpet) directly. For example:

     CantorMesh /@ Range[0, 2]

(Aside: To create a suitable image to insert here, the code I actually used was GraphicsColumn[ CantorMesh[#, MeshCellStyle -> {Thick, Red}] & /@ Range[0, 2], AspectRatio -> 0.25].)

What I would like, instead of the several mesh pictures, are Boolean indicators of which sections of the original interval and, at each step, its subintervals, are retained and which are deleted. That is, I want to obtain the output:

{{1}, {1, 0, 1}, {1, 0, 1, 0, 0, 0, 1, 0, 1}}

That is easy to do by using the built-in function SubstitutionSystem:

    SubstitutionSystem[{1 -> {1, 0, 1}, 0 -> {0, 0, 0}}, 1, 2]

Or, going back to more basic functions, by:

    cStep[lis_] := Flatten[lis /. {1 -> {1, 0, 1}, 0 -> {0, 0, 0}}]
    NestList[cStep, {1}, 2]

Question Is there a way to extract the same binary information directly from the result of CantorMesh?

And similarly for higher-level steps of the Cantor set and for the steps of forming the Menger carpet?

Answer 1

Try to map the following function. It tests wether the interval midpoints are contained in the MeshRegion R, where R is assumed to be a CantorMesh.

find = R \[Function] Boole[RegionMember[R, MovingAverage[
 Transpose[{Range[0., 1., 3^-Log2[MeshCellCount[R, 1]]]}], 2]]]

PS.: For those of you who are not working on a Mathematica version 11.1 or above (just like me), here an implementation of CantorMesh using the function cStep from the OP.

cantorMesh = n \[Function] Module[{edges, cStep},
    cStep[lis_] := Flatten[lis /. {1 -> {1, 0, 1}, 0 -> {0, 0, 0}}];
    edges = 
     Transpose[{Range[1, 3^n], Range[2, 3^n + 1]}][[
      Flatten@Position[Nest[cStep, {1}, n], 1]]];
    MeshRegion[Transpose[{Range[0., 1., 3^-n]}], Line[edges]]
    ];

Answer 2

Using the similar idea that Henrik did:

iStep[r_?MeshRegionQ] :=
 Block[{n, dx, pts, grid, f, d, l, i, ind},
  l = First[Differences@RegionBounds[r][[1]]];
  dx = RegionMeasure[MeshPrimitives[r, {1, 1}]];
  n = l/dx;
  pts = N@Table[i dx + dx/2, {i, 0, n - 1, 1}];
  d = RegionEmbeddingDimension[r];
  ind = Table[{i[j], pts}, {j, d}];
  grid = Table[ind[[All, 1]], ##] & @@ ind;
  f = RegionMember[r];
  Boole[Map[f, grid, {d - 1}]]
  ]

iStep /@ Table[CantorMesh[i], {i, 0, 2}]

{{1}, {1, 0, 1}, {1, 0, 1, 0, 0, 0, 1, 0, 1}}

iStep /@ Table[MengerMesh[i], {i, 0, 2}]

{{{1}}, {{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, {{1, 1, 1, 1, 1, 1, 1, 1,
1}, {1, 0, 1, 1, 0, 1, 1, 0, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1}, {1,
1, 1, 0, 0, 0, 1, 1, 1}, {1, 0, 1, 0, 0, 0, 1, 0, 1}, {1, 1, 1, 0,
0, 0, 1, 1, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1}, {1, 0, 1, 1, 0, 1, 1,
0, 1}, {1, 1, 1, 1, 1, 1, 1, 1, 1}}}

iStep /@ Table[MengerMesh[i, 3], {i, 0, 1}]

{{{{1}}}, {{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, {{1, 0, 1}, {0, 0, 0}, {1, 0, 1}}, {{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}}}