TransWikia.com

CantorMesh for a fat cantor set

Mathematica Asked by Cantor on January 12, 2021

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?

mesh

4 Answers

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

Correct answer by kglr on January 12, 2021

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

Answered by chyanog on January 12, 2021

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

Answered by cvgmt on January 12, 2021

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

Answered by Anton Antonov on January 12, 2021

Add your own answers!

Ask a Question

Get help from others!

Recent Answers

Recent Questions

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP