Generando el triángulo de Sierpinski iterativamente en Mathematica?

Question

He escrito un código que dibuja el fractal de Sierpinski. Es muy lento ya que usa recursividad. ¿Alguno de ustedes sabe cómo podría escribir el mismo código sin recurrencia para que sea más rápido? Aquí está mi código:

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] 
] 

edición:

lo he escrito con el enfoque Caos juego por si alguien está interesado. ¡Gracias por tus excelentes respuestas! Aquí está el código:

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]]] 

Answer 1

Si desea una aproximación de alta calidad del triángulo de Sierpinski, se puede utilizar un método llamado el chaos game. La idea es la siguiente: elija tres puntos que desee definir como los vértices del triángulo de Sierpinski y elija uno de esos puntos aleatoriamente. Luego, repita el siguiente procedimiento todo el tiempo que desee:

1. Elija un vértice aleatorio del trangle.
2. Mueva del punto actual al punto intermedio entre su ubicación actual y el vértice del triángulo.
3. Trace un píxel en ese punto.

Como puede ver at this animation, este procedimiento eventualmente trazará una versión de alta resolución del triángulo. Si lo desea, puede multiprocesarlo para que tenga múltiples procesos trazando píxeles a la vez, lo que terminará dibujando el triángulo más rápidamente.

Alternativamente, si solo quiere traducir su código recursivo a código iterativo, una opción sería usar un enfoque de lista de trabajo. Mantenga una pila (o cola) que contenga una colección de registros, cada uno de los cuales contiene los vértices del triángulo y el número n. Inicialmente coloque en esta lista de trabajo los vértices del triángulo principal y la profundidad fractal. Entonces:

• Mientras que la lista de trabajo no está vacío:
  • quitar el primer elemento de la lista de trabajo.
  • Si su valor de n no es cero es:
    • dibujar el triángulo que conecta los puntos medios de triángulo.
    • Para cada sub-triángulo, agregue ese triángulo con n-valor n-1 a la lista de trabajo.

Esto simula esencialmente la recursión de forma iterativa.

Espero que esto ayude!

Answer 2

Puede intentar

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}] 

Y luego vuelva a colocar la AppendTo por algo más eficiente.Véase, por ejemplo https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile

Editar

más rápido:

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}] 

Answer 3

Este utiliza Scale y Translate en combinación con Nest para crear la lista de triángulos.

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]}] 

Answer 4

Dado que las funciones basadas en triángulo ya han sido bien cubierto, aquí es un enfoque basado en la trama.
Esto construye iterativamente el triángulo de Pascal, luego toma el módulo 2 y traza el resultado.

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

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}]&;*) 

He aquí una versión en 3D, 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"] 
]