# CantorMesh for a fat cantor set

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?

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]


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]


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]


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]


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]


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]


• 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? Dec 10 '20 at 17:26
• @Cantor, please see the updated version.
– kglr
Dec 10 '20 at 19:21
• Thanks, but the fat cantor set doesn't look correct. Dec 10 '20 at 21:27
• @Cantor, please see the new version.
– kglr
Dec 11 '20 at 0:49

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


• 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. Dec 10 '20 at 16:54
• 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...) Dec 10 '20 at 17:28
s = 1/3;

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


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


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]*)