CantorMesh for a fat 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]
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}}]
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]