5
$\begingroup$

CantorMesh[n] gives the $n$-th level approximation to the standard no-middle-(1/3)-Cantor set.

Is there a quick way to obtain a similar mesh region for the no-middle-(1/4)-Cantor set?

$\endgroup$
4
$\begingroup$

Using generalizations of the functions cantor, CantorRegion and CantorDust from documentation page RegionProduct >> Applications:

ClearAll[cantorrule, cantorRegion, cantorDust]

cantorrule[s_: 1/3] :=  ReplaceAll[{a_, b_} :> 
   {{a, a + (b - a) (1 - s)/2}, {a + (b - a) (1 + s)/2, b}}]

cantorRegion[s_: 1/3][t_Integer?NonNegative] := MeshRegion[
  List /@ Flatten[Nest[Apply[Join]@*Map[cantorrule[s]], {{0, 1}}, t]],
   Line @ Partition[Range[2^(t + 1)], 2]]

cantorDust[s_: 1/3][t_Integer?NonNegative, dim_: 1] := 
 RegionProduct @@ Table[cantorRegion[s][t], dim]

Examples:

Labeled[Grid[Transpose @
   {Show[cantorDust[][#, 1], ImageSize -> Medium] & /@  Range[3], 
    Show[cantorDust[][#, 2], ImageSize -> Medium] & /@ Range[3], 
    Show[cantorDust[][#, 3], ImageSize -> Medium] & /@ Range[3]}, 
  Dividers -> All], Style["s = 1/3", 36], Top]

enter image description here

Labeled[Grid[Transpose @
   {Show[cantorDust[1/4][#, 1], ImageSize -> Medium] & /@ Range[3], 
    Show[cantorDust[1/4][#, 2], ImageSize -> Medium] & /@ Range[3], 
    Show[cantorDust[1/4][#, 3], ImageSize -> Medium] & /@ Range[3]}, 
  Dividers -> All], Style["s = 1/4", 36], Top]

enter image description here

Labeled[Grid[Transpose@
 {Show[cantorDust[5/12][#, 1], ImageSize -> Medium] & /@ Range[3], 
    Show[cantorDust[5/12][#, 2], ImageSize -> Medium] & /@ Range[3], 
    Show[cantorDust[5/12][#, 3], ImageSize -> Medium] & /@ Range[3]}, 
  Dividers -> All], Style["s = 5/12", 36], Top]

enter image description here

Labeled[Grid[{Prepend[Style["s", 24]][Style["t = " <> ToString@#, 16] & /@ {1, 2, 3}], 
   Prepend[Style["1/4", 16]][
    Show[cantorDust[1/4][#, 1], ImageSize -> Medium] & /@ Range[3]], 
   Prepend[Style["1/3", 16]][
    Show[cantorDust[1/3][#, 1], ImageSize -> Medium] & /@ Range[3]], 
   Prepend[Style["5/12", 16]][
    Show[cantorDust[5/12][#, 1], ImageSize -> Medium] & /@ 
     Range[3]]}, Dividers -> All], Style["dim=1", 36], Top]

enter image description here

Labeled[Grid[{Prepend[Style["s", 24]][
    Style["t = " <> ToString@#, 16] & /@ {1, 2, 3}], 
   Prepend[Style["1/4", 16]][
    Show[cantorDust[1/4][#, 2], ImageSize -> Medium] & /@ Range[3]], 
   Prepend[Style["1/3", 16]][
    Show[cantorDust[1/3][#, 2], ImageSize -> Medium] & /@ Range[3]], 
   Prepend[Style["5/12", 16]][
    Show[cantorDust[5/12][#, 2], ImageSize -> Medium] & /@ 
     Range[3]]}, Dividers -> All], Style["dim=2", 36], Top]

enter image description here

Labeled[Grid[{Prepend[Style["s", 24]][
    Style["t = " <> ToString@#, 16] & /@ {1, 2, 3}], 
   Prepend[Style["1/4", 16]][
    Show[cantorDust[1/4][#, 3], ImageSize -> Medium] & /@ Range[3]], 
   Prepend[Style["1/3", 16]][
    Show[cantorDust[1/3][#, 3], ImageSize -> Medium] & /@ Range[3]], 
   Prepend[Style["5/12", 16]][
    Show[cantorDust[5/12][#, 3], ImageSize -> Medium] & /@ 
     Range[3]]}, Dividers -> All], Style["dim=3", 36], Top]

enter image description here

$\endgroup$
4
  • $\begingroup$ Some explanation for the code would be nice. In the first case how can I get intervals? In general is it possible to get the same kind of "mesh region" output as CantorMesh? $\endgroup$ – Cantor Dec 10 '20 at 17:26
  • 1
    $\begingroup$ @Cantor, please see the updated version. $\endgroup$ – kglr Dec 10 '20 at 19:21
  • $\begingroup$ Thanks, but the fat cantor set doesn't look correct. $\endgroup$ – Cantor Dec 10 '20 at 21:27
  • $\begingroup$ @Cantor, please see the new version. $\endgroup$ – kglr Dec 11 '20 at 0:49
3
$\begingroup$

Does this do what you expect / want?

Do you want mesh objects to be generated?

I took and modified the code from this demonstration: https://demonstrations.wolfram.com/CantorSet/ .

I added the control gapFraction.

Manipulate[
 With[{horizontalRange = 
    Which[c - E^r < 0, {0, Min[2 E^r, 1]}, 
     c + E^r > 1, {Max[1 - 2 E^r, 0], 1}, True, {c - E^r, c + E^r}]}, 
  Graphics[{Red, Antialiasing -> True, 
    Rectangle @@ {{#[[1]], 0}, {#[[2]], 1}} &[#] & /@ 
     Select[Nest[
       Flatten[({{#1[[1]], #1[[1]] + 
               gapFraction (#1[[2]] - #1[[1]])}, {#1[[2]] - 
               gapFraction (#1[[2]] - #1[[1]]), #1[[2]]}} &) /@ #1, 
         1] &, {{0, 1}}, n], 
      Last@Union[{#[[1]] < horizontalRange[[2]], #[[2]] > 
           horizontalRange[[1]]}] &]},
   PlotRange -> {horizontalRange, {0, 1}},
   AspectRatio -> Full, ImageSize -> {478, 200}, 
   Axes -> If[a, {True, False}, None], 
   Ticks -> 
    If[a, {Join[
       Nest[#[[1 ;; -1 ;; 2]] &, 
        Flatten[Nest[
          Flatten[({{#1[[1]], #1[[1]] + 
                  gapFraction (#1[[2]] - #1[[1]])}, {#1[[2]] - 
                  gapFraction (#1[[2]] - #1[[1]]), #1[[2]]}} &) /@ #1,
             1] &, {{0, 1}}, n]], 
        If[# < 0, 0, #] &[
         Round[1/Log[(Subtract @@ Reverse@horizontalRange/11)/(3^-n), 
            3]]]], {{c, Invisible[1/6]}}], Automatic}, None]]],
 {{gapFraction, 1/3, "gap fraction"}, 1./100, 1. - 1/100, 1./100},
 {{n, 5, "number of iterations"}, 0, 9, 1, Appearance -> "Labeled"},
 {{c, N[8/27], "pan"}, 0, 1, Appearance -> "Labeled"},
 {{r, -2/3, "zoom"}, -2/3, -10},
 {{a, True, "show number line"}, {True, False}}, 
 AutorunSequencing -> {{1, 10}, {2, 5}, {3, 5}}]

enter image description here

$\endgroup$
2
  • $\begingroup$ Thank you, but I was hoping for something simple in the one-dimensional case similar to what CantorMesh[n] produces, with the only difference being the size of the gap removed. $\endgroup$ – Cantor Dec 10 '20 at 16:54
  • $\begingroup$ Welcome! (BTW, for me it was very easy to take the code from demonstrations.wolfram.com and change it. Obviously, you might prefer something different...) $\endgroup$ – Anton Antonov Dec 10 '20 at 17:28
3
$\begingroup$
s = 1/3;

Graphics /@ 
 NestList[GeometricTransformation[#, 
    ScalingTransform[(1 - s)/2 {1, 1}, #] & /@ Tuples[{0, 1}, 2]] &, Rectangle[], 3]

enter image description here

Graphics3D /@ 
 NestList[GeometricTransformation[#, 
    ScalingTransform[(1 - s)/2 {1, 1, 1}, #] & /@ Tuples[{0, 1}, 3]] &, Cuboid[], 3]

enter image description here

$\endgroup$
2
$\begingroup$
Clear[cantor];
cantor[n_, d_ : 1, c_ : 1/4] := 
 Module[{t, cut, intervals, reg}, t = (1 - c)/2;
  cut[{a_, b_}] := {{a, a + t (b - a)}, {b - t (b - a), b}};
  intervals = Nest[Flatten[Map[cut, #], 1] &, {{0, 1}}, n];
  reg = MeshRegion[Map[List, #], {Line[{1, 2}]}] & /@ intervals // 
    RegionUnion;
  RegionProduct @@ ConstantArray[reg, d]]
cantor[2]
cantor[2, 2]
cantor[2, 3]
(*cantor[6,3]*)

enter image description here

enter image description here

$\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.