Logo Questions Linux Laravel Mysql Ubuntu Git Menu
 

how to generate a plot of planar Cantor set in mathematica

I am wondering if anyone can help me to plot the Cantor dust on the plane in Mathematica. This is linked to the Cantor set.

Thanks a lot.

EDIT

I actually wanted to have something like this:

enter image description here

like image 269
Qiang Li Avatar asked Jan 19 '23 06:01

Qiang Li


2 Answers

Here's a naive and probably not very optimized way of reproducing the graphics for the ternary Cantor set construction:

cantorRule = Line[{{a_, n_}, {b_, n_}}] :> 
  With[{d = b - a, np = n - .1}, 
       {Line[{{a, np}, {a + d/3, np}}], Line[{{b - d/3, np}, {b, np}}]}]

Graphics[{CapForm["Butt"], Thickness[.05], 
  Flatten@NestList[#/.cantorRule&, Line[{{0., 0}, {1., 0}}], 6]}]

Ternary Cantor set

To make Cantor dust using the same replacement rules, we take the result at a particular level, e.g. 4:

dust4=Flatten@Nest[#/.cantorRule&,Line[{{0.,0},{1.,0}}],4]/.Line[{{a_,_},{b_,_}}]:>{a,b}

and take tuples of it

dust4 = Transpose /@ Tuples[dust4, 2];

Then we just plot the rectangles

Graphics[Rectangle @@@ dust4]

enter image description here


Edit: Cantor dust + squares

Changed specs -> New, but similar, solution (still not optimized).
Set n to be a positive integer and choice any subset of 1,...,n then

n = 3; choice = {1, 3};
CanDChoice = c:CanD[__]/;Length[c]===n :> CanD[c[[choice]]];
splitRange = {a_, b_} :> With[{d = (b - a + 0.)/n}, 
                              CanD@@NestList[# + d &, {a, a + d}, n - 1]];

cantLevToRect[lev_]:=Rectangle@@@(Transpose/@Tuples[{lev}/.CanD->Sequence,2])

dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 4] // Rest;

Graphics[{FaceForm[LightGray], EdgeForm[Black], 
  Table[cantLevToRect[lev], {lev, Most@dust}], 
  FaceForm[Black], cantLevToRect[Last@dust /. CanDChoice]}]

more dust

Here's the graphics for

n = 7; choice = {1, 2, 4, 6, 7};
dust = NestList[# /. CanDChoice /. splitRange &, {0, 1}, 2] // Rest;

and everything else the same:

enter image description here

like image 166
Simon Avatar answered Mar 14 '23 22:03

Simon


Once can use the following approach. Define cantor function:

cantorF[r:(0|1)] = r;
cantorF[r_Rational /; 0 < r < 1] := 
 Module[{digs, scale}, {digs, scale} = RealDigits[r, 3];
  If[! FreeQ[digs, 1], 
   digs = Append[TakeWhile[Most[digs]~Join~Last[digs], # != 1 &], 1];];
  FromDigits[{digs, scale}, 2]]

Then form the dust by computing differences of F[n/3^k]-F[(n+1/2)/3^k]:

With[{k = 4}, 
  Outer[Times, #, #] &[
   Table[(cantorF[(n + 1/2)/3^k] - cantorF[(n)/3^k]), {n, 0, 
     3^k - 1}]]] // ArrayPlot

enter image description here

like image 25
Sasha Avatar answered Mar 14 '23 20:03

Sasha