2
$\begingroup$

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]

Cantor meshes of order 0, 1, 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?

$\endgroup$
2
$\begingroup$

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]]
    ];
| improve this answer | |
$\endgroup$
  • $\begingroup$ Nice for CantorMesh, but not general enough to work, too, for MengerMesh. $\endgroup$ – murray Nov 30 '17 at 20:48
2
$\begingroup$

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}}}}

| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.