在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

这使用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 2

如果你想要一个高质量的Sierpinski三角形近似,你可以使用一种称为混沌游戏的方法.这个想法如下 - 选择你想要定义的三个点作为Sierpinski三角形的顶点,并随机选择其中一个点.然后,只要您愿意,请重复以下步骤:

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

正如您在此动画中看到的,此过程最终将跟踪三角形的高分辨率版本.如果您愿意,可以多线程处理它以使多个进程一次绘制像素,最终将更快地绘制三角形.

或者,如果您只想将递归代码转换为迭代代码,则可以选择使用工作列表方法.维护包含记录集合的堆栈(或队列),每个记录都包含三角形的顶点和数字n.最初将主要三角形的顶点和分形深度放入此工作列表中.然后:

• 虽然工作清单不是空的:
  • 从工作清单中删除第一个元素.
  • 如果其n值不为零:
    • 绘制连接三角形中点的三角形.
    • 对于每个子三角形,将具有n值n - 1的三角形添加到工作清单中.

这基本上迭代地模拟递归.

希望这可以帮助!

Answer 3

你可以试试

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