Generare il triangolo Sierpinski in modo iterativo in Mathematica?

Question

Ho scritto codice che disegna il frattale di Sierpinski. È molto lento poiché utilizza la ricorsione. Qualcuno di voi sa come potrei scrivere lo stesso codice senza ricorsione per essere più veloce? Qui è il mio codice:

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:

ho scritto con l'approccio del Caos gioco nel caso in cui qualcuno è interessato. Grazie per le tue fantastiche risposte! ecco il codice:

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

Se desiderate un'approssimazione di alta qualità del triangolo di Sierpinski, è possibile utilizzare un approccio chiamato chaos game. L'idea è la seguente: scegli tre punti che desideri definire come i vertici del triangolo di Sierpinski e scegli uno di questi punti a caso. Quindi, ripeti la procedura seguente per tutto il tempo che desideri:

1. Scegli un vertice casuale del trangle.
2. Sposta dal punto corrente al punto intermedio tra la posizione corrente e il vertice del triangolo.
3. Stampa un pixel in quel punto.

Come si può vedere at this animation, questa procedura rintraccia una versione ad alta risoluzione del triangolo. Se lo desideri, puoi multithread per avere più processi che tracciano pixel in una volta, il che finirà per disegnare il triangolo più rapidamente.

In alternativa, se si desidera solo convertire il codice ricorsivo in codice iterativo, un'opzione potrebbe essere l'utilizzo di un approccio di lista di lavoro. Mantieni uno stack (o una coda) che contiene una raccolta di record, ognuno dei quali contiene i vertici del triangolo e il numero n. Inizialmente inserite in questa lista di lavoro i vertici del triangolo principale e la profondità del frattale. Poi:

• Mentre la lista di lavoro non è vuoto:
  • rimuovere il primo elemento della lista di lavoro.
  • Se il suo valore n è diverso da zero:
    • Disegnate il triangolo che collega i punti medi del triangolo.
    • Per ogni sottotrama, aggiungere quel triangolo con n-valore n - 1 alla lista di lavoro.

Questo simula essenzialmente la ricorsione iterativamente.

Spero che questo aiuti!

Answer 2

Puoi provare

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

e quindi sostituire il appendTo da qualcosa di più efficiente.Si veda ad esempio https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile

Modifica

veloce:

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

Questo utilizza Scale e Translate in combinazione con Nest per creare l'elenco di triangoli.

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

Poiché le funzioni triangolo a base di sono già ben coperto, ecco un approccio basato raster.
Questo costruisce iterativamente il triangolo di pascal, quindi prende il modulo 2 e traccia il risultato.

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

Ecco una versione 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"] 
]