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

- John

---

请看 https://dev59.com/ZHVC5IYBdhLWcg3w21Mq - Dr. belisarius

当我在绘制这些图形时，我发现渲染图形所需的时间比计算三角形位置要长得多。我还采用了递归的方法（虽然有点不同）。 - Szabolcs

Answer 1

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

- Heike

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

- Dr. belisarius

Answer 3

如果您想得到一个高质量的Sierpinski三角近似，您可以使用一种称为混沌游戏的方法。其思路如下-选择三个点作为Sierpinski三角形的顶点，并随机选择其中一个点。然后，只要您愿意，就重复以下过程：

1. 选择三角形的一个随机顶点。
2. 从当前点移动到其当前位置和该三角形顶点之间的中点。
3. 在该点处绘制一个像素。

正如您可以在此动画中看到的那样，这个过程最终会描绘出三角形的高分辨率版本。如果您愿意，您可以将其多线程化，以便多个进程同时绘制像素，这将更快地绘制出三角形。

如果您只想将递归代码转换为迭代代码，则可以使用工作列表方法。维护一个包含记录的堆栈（或队列），每个记录都保存三角形的顶点和数字n。最初将主三角形和分形深度的顶点放入此工作列表中。然后：

- 只要工作列表不为空： - 从工作列表中删除第一个元素。 - 如果其n值不为零： - 绘制连接三角形中点的三角形。 - 对于每个子三角形，将具有n值n-1的该三角形添加到工作列表中。

这本质上是通过迭代模拟递归。

希望这能帮助您！

- templatetypedef

---

起初我只是想翻译代码，但混沌游戏方法似乎非常有趣！我回家后会尝试一下！非常感谢，这很有帮助！ - John

再次感谢，我是用混沌游戏的方法编写的！如果您有兴趣看看我的方法，请查看我的帖子。 - John

Answer 4

既然三角函数已经被充分讨论，那么这里提供一种基于光栅的方法。
该方法通过迭代构建帕斯卡三角形，然后取模2并绘制结果。

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

- Mr.Wizard

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

- chyanog