[Date Index]
[Thread Index]
[Author Index]
Re: Sierpinski's carpet
*To*: mathgroup at smc.vnet.net
*Subject*: [mg76790] Re: Sierpinski's carpet
*From*: Jean-Marc Gulliet <jeanmarc.gulliet at gmail.com>
*Date*: Sun, 27 May 2007 05:01:56 -0400 (EDT)
*Organization*: The Open University, Milton Keynes, UK
*References*: <f38tsr$j1j$1@smc.vnet.net>
theverybastard at tin.it 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
This newsgroup, MathGroup, is a moderated newsgroup. It might take up to
24 hours before you and the rest of the world can see your message.
Usually, there is no need to post several time the same message within
this 24-hour window.
Under version 6.0, the following code will draw some nice Sierpinski
Carpets that can be controlled thanks to the Manipulate function.
rules = {0 -> {{0, 0, 0}, {0, 0, 0}, {0, 0, 0}},
1 -> {{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}};
f[m_: 1] := ArrayFlatten[m /. rules]
drawSerp[n_] := MatrixPlot[Nest[f, 1, n], FrameTicks -> None]
Manipulate[drawSerp[n], {n, 1, 6, 1}]
You can check directly the files at
http://homepages.nyu.edu/~jmg336/mathematica/SierpinskiCarpet.nb
http://homepages.nyu.edu/~jmg336/mathematica/SierpinskiCarpet.pdf
http://homepages.nyu.edu/~jmg336/mathematica/SierpinskiCarpet.png
Regards,
Jean-Marc
Prev by Date:
**Re: Re: drawing**
Next by Date:
**Re: Re: drawing**
Previous by thread:
**Sierpinski's carpet**
Next by thread:
**Re: Sierpinski's carpet**
| |