MathGroup Archive 2007

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Sierpinski's thing

  • To: mathgroup at smc.vnet.net
  • Subject: [mg76758] Re: Sierpinski's thing
  • From: Szabolcs <szhorvat at gmail.com>
  • Date: Sun, 27 May 2007 04:45:20 -0400 (EDT)
  • Organization: University of Bergen
  • References: <f38qg9$hq4$1@smc.vnet.net>

Anolethron wrote:
> What I'm trying to do is basically constructing a Sierpinski's carpet with 
> an algorithm that can be generalized to the construction of a Menger Sponge.
> 
> e1 = {1, 0}; e2 = {0, 1}; p1 = {0, 0}; p2 = {1, 0}; p3 = {1, 1}; p4 = {0, 
> 1};
> 
> Sierpinski[{p1_, p2_, p3_, p4_}] :=
> Delete[Flatten[
> Table[{p1 + m e1 + n e2, p2 + m e1 + n e2, p3 + n e2 + m e1,
> p4 + m e1 + n e2}, {n, 0, 2}, {m, 0, 2}], 1], 5];
> 
> 
> Sierpinski1 = Sierpinski[{p1, p2, p3, p4}]
> 
> 
> Sierpinski2[ls_] := Flatten[Map[Sierpinski, ls], 1]
> 
> 
> S2 = Sierpinski2[Sierpinski1]
> 
> 
> Sierpinski3[n_] := Nest[Sierpinski2, {{p1, p2, p3, p4}}, n]
> 
> 
> Sierpinski3[3]
> 
> 
> Now, I'm not good enough to think of a much more complicated construction 
> and the problem is that with this algorithm the lengths of the squares I 
> construct at each step does not scale down with the level of the carpet I'm 
> constructing: e.g. He builds 9 squares from the big one at the beginning and 
> deletes the central one, it's ok. But as I Iterate the process at each 
> smaller square It builds squares of the same size, so what I get is just a 
> big black figure. It obviously does this way because in the algorithm 
> there's no instruction to decrease the size of the base vectors (e1,e2). 
> Thing is I can't think of a way to give mathematica that instruction inside 
> the Nest or in the definition of  the basic "Sierpinski" function. I need 
> some help. Thanks in advance. This is the expected result: 
> http://mathworld.wolfram.com/SierpinskiCarpet.html

I don't understand completely what you were doing above, but here's a 
function that constructs a Sierpinski carpet:

In[1]:= pieces = Complement[
   Join@@Table[{i, j}, {i, 0, 2}, {j, 0, 2}],
   {{1, 1}}]

Out[1]= {{0,0},{0,1},{0,2},{1,0},{1,2},{2,0},{2,1},{2,2}}

In[2]:= sierp[cornerPt_, sideLen_, n_] :=
   sierp[cornerPt + #1*(sideLen/3), sideLen/3, n-1] & /@ pieces

In[3]:= sierp[cornerPt_, sideLen_, 0] :=
   Rectangle[cornerPt, cornerPt + sideLen*{1, 1}]

In[4]:= Graphics[sierp[{0, 0}, 1, 5], AspectRatio -> Automatic]//Show


Could someone please explain why is this SO MUCH slower in Mathematica 6 
than in Mathematica 5.2?

Szabolcs


  • Prev by Date: Re: wrong limit ?
  • Next by Date: Re: wrong limit ?
  • Previous by thread: Re: Sierpinski's thing
  • Next by thread: Re: Sierpinski's thing