在Mathematica中迭代生成Sierpinski三角？

Question

我寫了代碼，它繪製了Sierpinski分形。這是因爲它使用遞歸非常緩慢。你們中的任何一個人都知道如何不用遞歸來編寫相同的代碼，以便它更快？這裏是我的代碼：

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

編輯：

我已經與混沌遊戲方法的情況下，有人願意寫的。謝謝你的偉大答案！ 下面是代碼：

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

如果您想謝爾賓斯基三角形的高品質的逼近，你可以使用的方法稱爲chaos game。這個想法如下 - 選擇你希望定義爲Sierpinski三角形頂點的三個點，並隨機選擇其中一個點。然後，只要你喜歡，重複以下步驟：

1. 選擇一個隨機的trangle頂點。
2. 從當前點移動到其當前位置和三角形頂點之間的中點。
3. 繪製一個像素點。

正如你所看到的at this animation，這個程序最終將追蹤到一個高分辨率的三角形版本。如果你願意，你可以對它進行多線程處理，讓多個進程一次繪製像素，最終將更快地繪製三角形。

或者，如果您只是想將遞歸代碼翻譯爲迭代代碼，則一種選擇是使用工作列表方法。維護一個包含記錄集合的棧（或隊列），每個記錄都包含三角形的頂點和數字n。最初將這個主要三角形的頂點和分形深度放入這個工作表中。然後：

• 雖然工作列表不爲空：
  • 取下工作列表的第一個元素。
  • 如果它的n值不爲零：
    • 繪製連接三角形中點的三角形。
    • 對於每個子三角，將該三角形的n值n - 1添加到工作清單。

這實質上模擬遞歸迭代。

希望這會有所幫助！

Answer 2

您可以嘗試

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

然後通過一些更有效的替代AppendTo。例如見https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile

編輯

更快：

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

這使用Scale和Translate結合Nest創建三角形的列表。

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

由於基於三角形的功能已經得到了很好的覆蓋，這裏是一個基於光柵的方法。
這反覆構造帕斯卡的三角形，然後取模2並繪製結果。

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

這裏是一個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"] 
]