Генерация треугольника Серпинского итеративно в Mathematica?

Это использует 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]}]

Если вам нужна качественная аппроксимация треугольника Серпинского, вы можете использовать подход, называемый игра хаоса. Идея заключается в следующем: выберите три точки, которые вы хотите определить как вершины треугольника Серпинского, и выберите одну из этих точек случайным образом. Затем повторите следующую процедуру столько раз, сколько хотите:

Как вы можете видеть на этой анимации, эта процедура вариант разрешения треугольника. Если вы хотите, вы можете использовать многопоточность, чтобы несколько процессов отображали пиксели одновременно, что в конечном итоге приведет к более быстрому рисованию треугольника.

В качестве альтернативы, если вы просто хотите преобразовать свой рекурсивный код в итеративный код, одним из вариантов может быть использование подхода с рабочим списком. Поддерживайте стек (или очередь), содержащий набор записей, каждая из которых содержит вершины треугольника и число n. Изначально занесите в этот рабочий список вершины основного треугольника и фрактальную глубину. Затем:

• While the worklist is not empty:
  • Remove the first element from the worklist.
  • If its n value is not zero:
    • Draw the triangle connecting the midpoints of the triangle.
    • Для каждого подтреугольника добавьте этот треугольник со значением n n - 1 в рабочий список.

По сути, это итеративно моделирует рекурсию.

Надеюсь это поможет!

Вы можете попробовать

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

Поскольку функции, основанные на треугольниках, уже были хорошо изучены, вот подход, основанный на растре.
Он итеративно строит треугольник Паскаля, затем берет по модулю 2 и отображает результат.

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

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