Generating the Sierpinski triangle iteratively in Mathematica?

Question

I have written code which draws the Sierpinski fractal. It is really slow since it uses recursion. Do any of you know how I could write the same code without recursion in order for it to be quicker? Here is my code:

 midpoint[p1_, p2_] := Mean[{p1, p2}]
 trianglesurface[A_, B_, C_] :=  Graphics[Polygon[{A, B, C}]]
 sierpinski[A_, B_, C_, 0] := trianglesurface[A, B, C]
 sierpinski[A_, B_, C_, n_Integer] :=
 Show[
 sierpinski[A, midpoint[A, B], midpoint[C, A], n - 1],
 sierpinski[B, midpoint[A, B], midpoint[B, C], n - 1],
 sierpinski[C, midpoint[C, A], midpoint[C, B], n - 1]
 ]

edit:

I have written it with the Chaos Game approach in case someone is interested. Thank you for your great answers! Here is the code:

 random[A_, B_, C_] := Module[{a, result},
 a = RandomInteger[2];
 Which[a == 0, result = A,
 a == 1, result = B,
 a == 2, result = C]]

 Chaos[A_List, B_List, C_List, S_List, n_Integer] :=
 Module[{list},
 list = NestList[Mean[{random[A, B, C], #}] &, 
 Mean[{random[A, B, C], S}], n];
 ListPlot[list, Axes -> False, PlotStyle -> PointSize[0.001]]]

Welcome

Take a look at #160090 – Gavette

When I was drawing such things I found that rendering the graphic can take much longer than computing the triangle locations. I also used a recursive approach (if a little different). – Clingfish

Answer 1

This uses Scale and Translate in combination with Nest to create the list of triangles.

Manipulate[
  Graphics[{Nest[
    Translate[Scale[#, 1/2, {0, 0}], pts/2] &, {Polygon[pts]}, depth]}, 
   PlotRange -> {{0, 1}, {0, 1}}, PlotRangePadding -> .2],
  {{pts, {{0, 0}, {1, 0}, {1/2, 1}}}, Locator},
  {{depth, 4}, Range[7]}]

Bowing

Answer 2

If you would like a high-quality approximation of the Sierpinski triangle, you can use an approach called the chaos game. The idea is as follows - pick three points that you wish to define as the vertices of the Sierpinski triangle and choose one of those points randomly. Then, repeat the following procedure as long as you'd like:

1. Choose a random vertex of the trangle.
2. Move from the current point to the halfway point between its current location and that vertex of the triangle.
3. Plot a pixel at that point.

As you can see at this animation, this procedure will eventually trace out a high-resolution version of the triangle. If you'd like, you can multithread it to have multiple processes plotting pixels at once, which will end up drawing the triangle more quickly.

Alternatively, if you just want to translate your recursive code into iterative code, one option would be to use a worklist approach. Maintain a stack (or queue) that contains a collection of records, each of which holds the vertices of the triangle and the number n. Initially put into this worklist the vertices of the main triangle and the fractal depth. Then:

• While the worklist is not empty:
  • Remove the first element from the worklist.
  • If its n value is not zero:
    • Draw the triangle connecting the midpoints of the triangle.
    • For each subtriangle, add that triangle with n-value n - 1 to the worklist.

This essentially simulates the recursion iteratively.

Hope this helps!

Vitric

At first I simply wanted to translate the code but the chaos game approach seems really interesting!! I will try it out when I get home! Thank you very much, this was very helpful! – Welcome

Thanks again, I wrote it with the Chaos Game approach! I have added it to my post in case you are interested in seeing how approached it. – Welcome

Answer 3

You may try

l = {{{{0, 1}, {1, 0}, {0, 0}}, 8}};
g = {};
While [l != {},
 k = l[[1, 1]];
 n = l[[1, 2]];
 l = Rest[l];
 If[n != 0,
  AppendTo[g, k];
  (AppendTo[l, {{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1}] & @@ #) & /@
                                                 NestList[RotateLeft, k, 2]
  ]]
Show@Graphics[{EdgeForm[Thin], Pink,Polygon@g}]

And then replace the AppendTo by something more efficient. See for example https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile

Edit

Faster:

f[1] = {{{0, 1}, {1, 0}, {0, 0}}, 8};
i = 1;
g = {};
While[i != 0,
 k = f[i][[1]];
 n = f[i][[2]];
 i--;
 If[n != 0,
  g = Join[g, k];
  {f[i + 1], f[i + 2], f[i + 3]} =
    ({{#1, Mean[{#1, #2}], Mean[{#1, #3}]}, n - 1} & @@ #) & /@ 
                                                 NestList[RotateLeft, k, 2];
  i = i + 3
  ]]
Show@Graphics[{EdgeForm[Thin], Pink, Polygon@g}]

Gavette

Answer 4

Since the triangle-based functions have already been well covered, here is a raster based approach.
This iteratively constructs pascal's triangle, then takes modulo 2 and plots the result.

NestList[{0, ##} + {##, 0} & @@ # &, {1}, 511] ~Mod~ 2 // ArrayPlot

Blankbook

Answer 5

Clear["`*"];
sierpinski[{a_, b_, c_}] := 
  With[{ab = (a + b)/2, bc = (b + c)/2,  ca = (a + c)/2}, 
   {{a, ab, ca}, {ab, b, bc}, {ca, bc, c}}];

pts = {{0, 0}, {1, 0}, {1/2, Sqrt[3]/2}} // N;
n = 5;
d = Nest[Join @@ sierpinski /@ # &, {pts}, n]; // AbsoluteTiming
Graphics[{EdgeForm@Black, Polygon@d}]

(*sierpinski=Map[Mean, Tuples[#,2]~Partition~3 ,{2}]&;*)

Here is a 3D version,https://mathematica.stackexchange.com/questions/22256/how-can-i-compile-this-function

ListPlot@NestList[(# + RandomChoice[{{0, 0}, {2, 0}, {1, 2}}])/2 &,
 N@{0, 0}, 10^4]

With[{data = 
   NestList[(# + RandomChoice@{{0, 0}, {1, 0}, {.5, .8}})/2 &, 
    N@{0, 0}, 10^4]}, 
 Graphics[Point[data, 
   VertexColors -> ({1, #[[1]], #[[2]]} & /@ Rescale@data)]]
 ]

With[{v = {{0, 0, 0.6}, {-0.3, -0.5, -0.2}, {-0.3, 0.5, -0.2}, {0.6, 
     0, -0.2}}}, 
 ListPointPlot3D[
  NestList[(# + RandomChoice[v])/2 &, N@{0, 0, 0}, 10^4], 
  BoxRatios -> 1, ColorFunction -> "Pastel"]
 ]

Cashier