Tạo tam giác Sierpinski lặp lại trong Mathematica?

Question

Tôi đã viết mã để vẽ Sierpinski fractal. Nó thực sự chậm vì nó sử dụng đệ quy. Có ai trong số các bạn biết tôi có thể viết cùng một mã mà không cần đệ quy để nó nhanh hơn không? Đây là mã của tôi:

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

chỉnh sửa:

Tôi đã viết nó với cách tiếp cận Chaos Game trong trường hợp ai đó đang quan tâm. Cảm ơn bạn vì câu trả lời tuyệt vời của bạn! Đây là mã:

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

Nếu bạn muốn một xấp xỉ chất lượng cao của tam giác Sierpinski, bạn có thể sử dụng một cách tiếp cận gọi là chaos game. Ý tưởng là như sau - chọn ba điểm mà bạn muốn xác định là đỉnh của tam giác Sierpinski và chọn một trong những điểm ngẫu nhiên. Sau đó, lặp lại quy trình sau đây miễn là bạn muốn:

1. Chọn một đỉnh ngẫu nhiên của trang.
2. Di chuyển từ điểm hiện tại đến nửa điểm giữa vị trí hiện tại của nó và đỉnh đó của hình tam giác.
3. Vẽ một điểm ảnh tại điểm đó.

Như bạn có thể thấy at this animation, quy trình này cuối cùng sẽ tìm ra phiên bản có độ phân giải cao của hình tam giác. Nếu bạn muốn, bạn có thể đa luồng nó để có nhiều quy trình vẽ các pixel cùng một lúc, điều này sẽ kết thúc vẽ hình tam giác nhanh hơn.

Ngoài ra, nếu bạn chỉ muốn dịch mã đệ quy của bạn thành mã lặp lại, một tùy chọn sẽ là sử dụng cách tiếp cận danh sách công việc. Duy trì một chồng (hoặc hàng đợi) có chứa một tập hợp các bản ghi, mỗi bản ghi giữ các đỉnh của tam giác và số n. Ban đầu đưa vào danh sách công việc này các đỉnh của tam giác chính và độ sâu fractal. Sau đó:

• Trong khi worklist là không rỗng:
  • Hủy bỏ phần tử đầu tiên từ worklist.
  • Nếu giá trị n của nó không bằng không là:
    • Vẽ tam giác kết nối trung điểm của tam giác.
    • Đối với mỗi subtriangle, thêm tam giác đó với n-giá trị n-1 vào danh sách công việc.

này về cơ bản mô phỏng đệ quy lặp đi lặp lại.

Hy vọng điều này sẽ hữu ích!

Answer 2

Bạn có thể thử

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

Và sau đó thay thế AppendTo bởi một cái gì đó hiệu quả hơn.Xem ví dụ https://mathematica.stackexchange.com/questions/845/internalbag-inside-compile

Sửa

nhanh hơn:

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

này sử dụng Scale và Translate kết hợp với Nest để tạo ra danh sách các hình tam giác.

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

Kể từ khi chức năng tam giác dựa trên đã được che phủ tốt, đây là một cách tiếp cận dựa raster.
Việc này lặp lại cấu trúc tam giác của pascal, sau đó lấy modulo 2 và vẽ kết quả.

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

Đây là một phiên bản 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"] 
]