Алгорифм Маркова или нормальный алгоритм Маркова описывает формальную систему переписывания строк. Она снова и снова преобразует слова по упорядоченному списку правил, пока не закончатся правила или попадется специальная терминирующая последовательность. НАМ является полным по Тьюрингу и очень похож на его машину. Несмотря на название, к цепям Маркова это не относится: в классическом формализме нет вероятностей перехода

Эта крошечная модель может быть достаточно выразительна для генеративных (не ИИ!) алгоритмов при условии некоторых модификаций. Всё, что касается правил замен для меня сразу навевает мысли о ЯП, где вычисление устроено вокруг сопоставления выражений и замены их другими выражениями - Wolfram Language. Возможно кто-то из вас его знает по проприетарной системе Mathematica, но с 2019 года ему можно кушать как питон из консоли - Freeware Wolfram Engine, а с 2024 и сам интерфейс блокнотов в виде FOSS или расширения к VSCode.

На Хабре уже писали про алгорифмы, а также их стохастическое обобщение и очень хорошо

Собственно, этот материал и послужил вдохновением для этой статьи. ~А теперь мои 2 копейки~ Однако тема инференса и сопоставления правил не была достаточно раскрыта, поэтому здесь мы её отреверсим…

В конце 1940-х Марков (Младший) сформулировал нормальные алгоритмы (алгорифмы), исследуя формальные понятия вычислимости. У алгорифма есть алфавит (пусть будет ABC) и конечный упорядоченный набор правил замены:

A -> B
B -> C
End

На каждом шаге мы проверяем правила сверху вниз, выбираем первое применимое, заменяет его самое левое вхождение и начинаем проверку заново

ABBA
BBBA
BBBB
CBBB
CCBB
CCCB
CCCC

Просто, верно? Работа заканчивается после завершающего правила, либо когда подходящих правил не осталось. Но такая простая цепочка замен не показывает главного – такими правилами можно вычислять что-то содержательное. Возьмём алгоритм из одного правила:

BA -> AB

Тогда получаем

BBABA
BABBA
ABBBA
ABBAB
ABABB
AABBB

простейший алгоритм сортировки.

Возня со строчками

В Wolfram Language для строк уже есть удобные средства замены подстрок - StringReplace. Но его семантика отличается в одном существенном месте: марковский шаг выбирает первое применимое правило и выполняет ровно одну замену. Список правил в StringReplace - это набор альтернатив за один проход.

В первых примерах мы не используем завершающие правила и останавливаемся, когда не применимо ни одно.

StringReplace["AAA", {"A" -> "B", "B" -> "C"}]

"BBB"

Можно было ожидать, что сначала A превратятся в B, а затем эти B в том же вызове превратятся в C. Но новые B уже не рассматриваются вторым правилом. Нужна функция, которая находит первое подходящее правило, заменяет только его левое совпадение и затем повторяет процесс

ClearAll[markovStep];

markovStep[rules_][s_String] := Module[{rule},
  rule = SelectFirst[
    rules,
    StringContainsQ[s, First[#]] &,
    Missing["NotFound"]
  ];
  If[MissingQ[rule], s, StringReplace[s, rule, 1]]
];

rules = {"A" -> "B", "B" -> "C"};
NestWhileList[markovStep[rules], "AAA", UnsameQ, 2, 12]

Смотрим результат

{"BAA", "CAA", "CBA", "CCA", "CCB", "CCC", "CCC", "CCC"}

SelectFirst сохраняет приоритет правил, а третий аргумент StringReplace ограничивает замену одним левым совпадением. NestWhileList записывает промежуточные слова и прекращает работу, когда очередной шаг ничего не меняет. Последний числовой аргумент - предохранитель для систем, которые не останавливаются.

С единственным правилом BA → AB повторное переписывание ведёт себя как сортировка пузырьком: каждый шаг сдвигает одну B вправо.

rules = {"BA" -> "AB"};
NestWhileList[markovStep[rules], "BABABA", UnsameQ, 2, 20]

{"ABBABA", "ABABBA", "AABBBA", "AABBAB", "AABABB", "AAABBB"}

Три правила ниже уже образуют цикл, поэтому ограничение числа шагов приходит кстати

rules = {
  "BA" -> "AB",
  "BB" -> "AA",
  "A" -> "B"
};
NestList[markovStep[rules], "AAA", 12]

{"AAA","AAA","BAA","ABA","ABA","BBA","BAB","BAB","BBB"}

От строк к выражениям

Строки здесь нужны были только потому, что на них хорошо видно механику и близко к оригинальной трактовке алгорифмов. Правила Wolfram Language гораздо шире: они сопоставляют и преобразуют любые выражения: числа, списки, изображения, цвета, графы и любую другую структуру. В этом смысле данные и код - это одно и то же.

Например, классическое определение функции уже является правилом:

f[x_] := x + 1
DownValues[f]

{HoldPattern[f[x_]] :> x + 1}

В привычной терминологии это обычная функция

f[3]
f[Red]

4
1 + RGBColor[1,0,0]

Чтение же такое: когда выражение подходит под f[x_], заменить его на x + 1. Переменная образца x_ связывает найденный аргумент и делает его доступным справа.

Пример некоторых паттернов

_        (* одно произвольное выражение  aka any *)
__       (* одно или больше выражений *)
___      (* ноль или больше выражений *)
_Integer (* одно целочисленое выражение  *)
{_, _}   (* список ровно из двух выражений *)
3          (* только число 3 *)
_?(Mod[#,2]==0&).   (* все числа делимые на 2 без остатка *)

Прямые и отложенные определения могут работать как маленькое ассоциативное хранилище:

h[_] = Missing[];
setHash[key_, value_] := h[key] = value;
getHash[key_] := h[key];

getHash[31]
setHash[31, Red];
getHash[31]
getHash[32]

Missing[]
Red
Red
Missing[]

Определение h[31] автоматически имеет приоритет над общим h[_].

Машина замен на определениях

Вернёмся к сортировке, но заменим символы цветами (почему бы и нет). Правило Blue, Red → Red, Blue можно записать с последовательностями до и после первой сине-красной пары:

ClearAll[apply];

apply[{b___, Blue, Red, a___}] := {b, Red, Blue, a};
apply[any_] := any;

FixedPoint[apply, {Blue, Red, Blue, Red, Blue, Red}]

{Red,Red,Red,Blue,Blue,Blue}

FixedPoint повторяет apply, пока результат не перестанет изменяться. Отложенное определение (:=) apply[any_] := any одновременно задаёт условие остановки. Получается марковская машина, почти целиком собранная из системы аннотации типов языка. Похоже, здесь мы ненадолго обогнали TypeScript по выразительности.

За пределами одного измерения

В нормальном алгоритме Маркова неоднозначность выбора замен паттернов в строке разрешается просто: всегда берется самое левое из них по отношению к целой сроке. На двумерной сетке «самое левое» уже не является геометрически естественным понятием. Можно выбрать построчный обход, но это будет очень частным вариантом реализации (и несимметричным).

Именно эту проблему решает вдохновивший статью MarkovJunior. В нём есть два важных типа правил замены (или контейнера для нескольких правил):

exists: случайно применить одну подходящую замену;
forall: применить максимальное множество непересекающихся совпадений сразу.

Ниже я называю аналогичные режимы one или 1 и all. Как побочка: мы теряем детерминированность системы замены. Как отмечает сам автор MarkovJunior - Максим Гумин - это не обязательно означает потерю вычислительной универсальности. На практике такой формализм всё ещё может быть полезен для моделирования интересных случайных процессов.

Стохастический клеточный автомат на системе типов?

Мы не будем здесь строить или повторять язык, настолько же широкий, как MarkovJunior, но попробуем добиться какого-то близкого результата используя минимальный набор блоков. Давайте соберем свою маленькую стохастическую машину на базе pattern-matching WL.

Начнём с чёрного поля 20×20:

field = Table[Black, {20}, {20}];
field // ArrayPlot

Определим правило B → R: чёрная клетка становится красной.

ClearAll[r];
r[any_] := any;
r[{b___, Black, a___}] := {b, Red, a};

field // r // ArrayPlot

Упс. Все также черно. Этот паттерн {b___, Black, a___} работает только на одномерных списках/массивах. Но поле - это список списков, поэтому правило выше на всей сетке ничего не найдёт. Добавим внешнюю пару последовательностей, которая сохраняет строки до и после подходящей строки:

ClearAll[r];
r[any_] := any;
r[{beforeRows___, {before___, Black, after___}, afterRows___}] :=
  {beforeRows, {before, Red, after}, afterRows};

field // r // ArrayPlot

Ещё один вызов переписывает вторую клетку:

field // r // r // ArrayPlot

Результат пока детерминирован: последовательности снова приводят интерпретатор к первой подходящей клетке. Можно быстренько поправить это добавив случайный предикат

ClearAll[r];
r[any_] := any;
r[{beforeRows___, {before___, Black, after___}, afterRows___}] :=
  {beforeRows, {before, Red, after}, afterRows} /;
    RandomReal[] <= 1/20^2;

ArrayPlot[field = field // r // r // r // r]

или в виде анимации

Animate[
  ArrayPlot[field = field // r // r // r // r],
  {n, 1, 10},
  Appearance -> None
]

Условие проверяется во время обхода кандидатов, поэтому это ещё не равномерный выбор среди всех совпадений. Позже мы явно перечислим варианты и выберем один из них.

Одно правило - восемь направлений

Рассмотрим правило роста

RB → RR

field = Table[Black, {20}, {20}];
field[[15,15]] = Red; (*семя*)

ClearAll[r];
r[any_] := any;
r[{bf___, {b___, Black,Red, a___}, af___}] := {bf, {b, Red,Red, a}, af} /; RandomReal[]<=0.5;

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

rot[0][m_] := m;
rot[1][m_] := Transpose[Reverse[m]];
rot[2][m_] := Reverse[Reverse /@ m];
rot[3][m_] := Reverse[Transpose[m]];

mirror[m_] := Reverse /@ m;

symmetries = Join[
  Table[rot[k], {k, 0, 3}],
  Table[rot[k] @* mirror, {k, 0, 3}]
];

inverseSymmetries = Join[
  Table[rot[Mod[-k, 4]], {k, 0, 3}],
  Table[rot[Mod[-k, 4]] @* mirror, {k, 0, 3}]
];

applyInAllSymmetries[m_] :=
  Fold[
    #2[[2]][r[#2[[1]][#1]]] &,
    m,
    Transpose[{symmetries, inverseSymmetries}]
  ];

Тогда можно применять это правило в цикле так:

Animate[
  ArrayPlot[field = applyInAllSymmetries[field]], 
  {n, 1, 30},
  Appearance->None
]

По аналогии можно попробовать ещё такое правило:

RBB → GGR
R_G → G_R

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

ClearAll[r, n];
r[{before___, {a___, Red,Black,Black, b___}, after___}] := 
  {before, {a, Green,Green,Red, b}, after} /; (RandomReal[]<=0.5);
r[{before___, {a___, Red,n_,Green, b___}, after___}] := 
  {before, {a, Green,n,Red, b}, after} /; (RandomReal[]<=0.5);
r[any_] := any 

field = Table[Black, {20}, {20}];
field[[RandomInteger[{1,20}],RandomInteger[{1,20}]]] = Red;

Animate[
  ArrayPlot[field = applyInAllSymmetries[field]],
  {n, 1, 30}, Appearance->None
]

Круть?

Ограничения первой версии

Такое определение правил r через := неудобное, но в нём смешаны поиск совпадения, случайность и применение самого правила. Оно не умеет выразить упорядоченную программу из нескольких фаз: например, сначала вырастить путь, затем откатиться из тупика, затем преобразовать временные цвета в окончательные. Кроме того условное применение функции через /; (RandomReal[]<=0.5); это кошмарный костыль и тормоза.

Для полноты нужны также отдельные узлы правил с режимом применения и лимитом итераций. Режим one (или 1) должен перечислять все результаты одного шага и выбирать случайный. Режим all должен применять проход замен ко всему полю. Каждый узел либо делает ещё один шаг, либо передаёт управление следующему.

Явные объекты Rule (->) и RuleDelayed (:>) дают нам больше контроля, чем определения, привязанные к символу. Например, ReplaceAll выполняет обход выражения с заменой:

{Red, Blue, Blue, Blue} /. Blue -> Red

{Red, Red, Red, Red}

В этом примере за один обход заменяется каждый синий элемент. Это полезное приближение узла all: применить набор непересекающихся преобразований за один проход.

Для узла one - ReplaceList может перечислить различные результаты, получаемые заменой одного совпадения. Затем можно явно выбрать один из них:

ReplaceList[
  {Red, Blue, Blue, Blue},
  {a___, Blue, b___} -> {a, Red, b}
];
RandomChoice[%]

{Red, Blue, Red, Blue}

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

По умолчанию ReplaceList применяет правило ко всему выражению. Обёрточный шаблон {a___, ..., b___} делает каждую возможную замену на уровне элемента совпадением со всем списком, сохраняя окружающие элементы. Интерпретатор ниже обобщает этот шаг подъёма на двумерные сетки.

Маленький интерпретатор

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

one: перечислить возможные переписывания и случайно выбрать одно;
all: использовать ReplaceAll как детерминированный проход замен, применяемых одновременно.

У каждого узла также есть лимит итераций. Узел one с несколькими перекрывающимися правилами естественным образом создаёт взвешенный выбор среди сгенерированных результатов.

Управляющий поток:

Реализация использует чистую функцию перехода вместо генератора в как JavaScript. Каждый вызов получает текущую сетку и состояние интерпретатора, а затем возвращает следующую пару «сетка-состояние».

Мы по-прежнему применяем операторы симметрии, чтобы компактные горизонтальные правила могли работать в любой ориентации.

Функция перехода интерпретатора

ops = {symmetries, inverseSymmetries};
tops = Transpose[ops];

propagate[input_, state_] := With[{
  nodeNumber = state["nodeNumber"]
}, If[nodeNumber <= Length[state["nodes"]], With[{
  rl = state["nodes"][[nodeNumber]],
  step = state["step"]
}, Switch[rl[[1]],
  1,
    Module[{variants},
      variants = Join @@ MapThread[
        Map[#2, ReplaceList[rl[[3]]][#1[input]]] &,
        ops
      ];

      If[Length[variants] == 0, Return[{
        input, Join[state, <|"step" -> 0, "nodeNumber" -> nodeNumber + 1|>]
      }]];

      {
        RandomChoice[variants],
        Join[state, If[step < rl[[2]] - 1,
            <|"step" -> step + 1|>,
            <|"step" -> 0, "nodeNumber" -> nodeNumber + 1|>
          ]
        ]
      }
    ],

  All, Module[{},
    With[{transformed = Fold[
      #2[[2]][ReplaceAll[#2[[1]][#1], rl[[3]]]] &,
      input,
      tops
    ]},

      If[transformed === input, Return[{
        input, Join[state, <|"step" -> 0, "nodeNumber" -> nodeNumber + 1|>]
      }]];

      {
        transformed,
        Join[state, If[step < rl[[2]] - 1,
            <|"step" -> step + 1|>,
            <|"step" -> 0, "nodeNumber" -> nodeNumber + 1|>
        ]]
      }
    ]]
]], {input, state}]]

Внутри функция перехода всё ещё построена на двух встроенных операциях: ReplaceList для перечисления одношаговых альтернатив и ReplaceAll для проходов замен.

Для этого интерпретатора компактные 0-мерные (A->B) и 1-мерные (AB -> BA) правила нормализуются в шаблоны всей сетки в 2-мерные. Это позволяет хранить сопоставление, преобразования симметрии и переходы состояния в едином представлении.

Нормализация правил

levelUp[0][expr_] := expr;

levelUp[1][expr_] := Module[{lr, rl}, expr /. {
  (RuleDelayed | Rule)[a_, Verbatim[Condition][b_, c_]] :>
    RuleDelayed[{lr___, a, rl___}, Condition[{lr, b, rl}, c]],
  (RuleDelayed | Rule)[a_, b_] :>
    RuleDelayed[{lr___, a, rl___}, {lr, b, rl}]
}];

levelUp[2][expr_] := Module[{lr, rl, af, bf}, expr /. {
  (RuleDelayed | Rule)[a_, Verbatim[Condition][b_, c_]] :>
    RuleDelayed[{lr___, {af___, a, bf___}, rl___},
      Condition[{lr, {af, b, bf}, rl}, c]],
  (RuleDelayed | Rule)[a_, b_] :>
    RuleDelayed[{lr___, {af___, a, bf___}, rl___},
      {lr, {af, b, bf}, rl}],
  (RuleDelayed | Rule)[a_, Verbatim[Condition][b_, c_]] :>
    RuleDelayed[{lr___, {af___, a, bf___}, rl___},
      Condition[{lr, {af, b, bf}, rl}, c]],
  (RuleDelayed | Rule)[a_, b_] :>
    RuleDelayed[{lr___, {af___, a, bf___}, rl___},
      {lr, {af, b, bf}, rl}]
}];

correctRules[rl : {All, n_, rule_Rule | rule_RuleDelayed}] :=
  If[!MatchQ[rule[[1]], {___, List[__], ___}] &&
      MatchQ[rule[[1]], {___, expr_, ___}],
    {All, n, rule},
    {All, n, rule}
  ];

correctRules[rl : {All, n_, rules_List}] :=
  If[Or @@ Map[
      (!MatchQ[#[[1]], {___, List[__], ___}] &&
        MatchQ[#[[1]], {___, expr_, ___}]) &,
      rules
    ],
    {All, n, rules},
    {All, n, rules}
  ];

correctRules[rl : {All, n_, rules_}] := rl;

correctRules[rl : {1, n_, rule_Rule | rule_RuleDelayed}] :=
  If[!MatchQ[rule[[1]], {___, List[__], ___}] &&
      MatchQ[rule[[1]], {___, expr_, ___}],
    {1, n, levelUp@rule},
    {1, n, levelUp@rule}
  ];

correctRules[rl : {1, n_, rules_List}] :=
  If[Or @@ Map[
      (!MatchQ[#[[1]], {___, List[__], ___}] &&
        MatchQ[#[[1]], {___, expr_, ___}]) &,
      rules
    ],
    {1, n, levelUp /@ rules},
    {1, n, levelUp /@ rules}
  ];

correctRules[rl : {1, n_, rule_Rule | rule_RuleDelayed}] := {1, n, levelUp@rule};
correctRules[rl : {1, n_, rules_List}] := {1, n, levelUp /@ rules};

levelUp[testRl_Rule | testRl_RuleDelayed] := Which[
  MatchQ[testRl[[1]], {___, List[__], ___}],
    testRl,
  MatchQ[testRl[[1]], {___, expr_, ___}],
    levelUp[1][testRl],
  True,
    levelUp[2][testRl]
]

Например, правило уровня отдельной ячейки разворачивается в шаблон уровня сетки, который сохраняет окружающую строку и все остальные строки:

Black -> Orange // levelUp

{lr$___, {af$___, Black, bf$___}, rl$___} :>
  {lr$, {af$, Orange, bf$}, rl$}

Теперь можно вернуться к предыдущим примерам и повторить их, используя новый подход

Модель роста

Первый пример для интерпретатора: одна красная клетка создаёт соседнюю красную клетку

one
  1 раз: B → O
one
  крутим бесконечно: BO → OO

Первый узел создает семя (зародыш?), а второе правило уже моделирует случайный рост. Так оно выглядит в новой записи:

nodes = {};

AppendTo[nodes, {
  1, 1, {
    Black -> Orange
  }
}];

AppendTo[nodes, {
  1, Infinity, {
    {b___, Black,Orange, a___} -> {b, Orange,Orange, a}
  }
}];

Давайте запустим его:

state = <|
  "nodes" -> correctRules/@nodes,
  "nodeNumber"->1, "step"->0
|>;

field = Table[Black, {20}, {20}];
Animate[
  ArrayPlot[({field, state} = propagate[field, state])//First], 
  {n,1,30}, Appearance->None
]

Генератор лабиринта

Лабиринт строится двумя фазами. В первой активная клетка оставляет за собой след и выбирает свободное направление. Когда она застревает, следующая фаза проходит по следу назад, пока снова не появится место для “роста” клеток:

one
  1 раз: B → O
one
  пока есть совпадения: OBB → OYO
all
  пока есть совпадения: Y → O

Здесь O - активный фронт, B - неиспользованная клетка, Y - временная клетка

nodes = {};

AppendTo[nodes, {
  1, 1, {
    Black -> Orange
  }
}];

AppendTo[nodes, {
  1, Infinity, {
    {a___, Orange,Black,Black, b___} :> {a, Orange,Yellow,Orange, b}
  }
}];

AppendTo[nodes, {
  All, Infinity, {
    Yellow -> Orange
  }
}];

state = <|
  "nodes" -> correctRules/@nodes,
  "nodeNumber"->1,"step"->0
|>;

field = Table[Black, {20}, {20}];
Animate[
  ArrayPlot[(
    {field, state} = propagate[field, state];
    {field, state} = propagate[field, state];
    {field, state} = propagate[field, state]
  )//First], 
  {n,1,10}, Appearance->None
]

Интерференция правил

Набор перекрывающихся правил внутри одного узла one естественно задаёт взвешенный случайный выбор среди получившихся вариантов. Для примера так можно сделать самоизбегающую змейку

one
  пока есть совпадения:
    BW → WL
    BW → WO

Вероятности можно регулировать и условиями вида /;, как в ранней версии. Главное отличие теперь в том, что случайность задана явно на уровне списка всех правил

nodes = {};

AppendTo[nodes, {
  1, 1, {
    Black -> White
  }
}];

AppendTo[nodes, {
  1, Infinity, {
    {a___, Black,White, b___} :> {a, White,Blue, b},
    {a___, Black,White, b___} :> {a, White,Orange, b}
  }
}];


state = <|
  "nodes" -> correctRules/@nodes,
  "nodeNumber"->1,"step"->0
|>;

Animate[
  ArrayPlot[({field, state} = propagate[field, state])//First], 
  {n,1,30}, Appearance->None
]

Генератор реки

Более длинная программа композиционно собирает несколько локальных процессов. Сначала возникают два случайных конкурирующих региона. Их граница становится водой; временные цвета очищаются; река расширяется; оставшаяся земля заполняется двумя оттенками травы

nodes = {};

AppendTo[nodes, { 
  1, 1,  { 
    
    Black -> Yellow
  }
}];

AppendTo[nodes, {
  1, 1,  { 
    
    Black -> Red
  }
}];

AppendTo[nodes, {
  1, Infinity,  {
    
    {a___, Red,Black, b___} :> {a, Red,Red, b},
    {a___, Yellow,Black, b___} :> {a, Yellow,Yellow, b}
  }
}];

AppendTo[nodes, {
  All, Infinity,  {
    
    {a___, Red, Yellow, b___} :> {a, (RGBColor[1/3, 1/3, 1]),(RGBColor[1/3, 1/3, 1]), b}
  }
}];

AppendTo[nodes, {
  All, Infinity,  {
    
    Yellow -> Black,
    Red -> Black
  }
}];

AppendTo[nodes, {
  All, 1,  {
    
    {a___, (RGBColor[1/3, 1/3, 1]),Black, b___} :> {a, (RGBColor[1/3, 1/3, 1]),(RGBColor[1/3, 1/3, 1]), b}
  }
}];

AppendTo[nodes, {
  All, Infinity,  {
    
    {a___, (RGBColor[1/3, 1/3, 1]),Black, b___} :> {a, Green,Green, b}
  }
}];

AppendTo[nodes, {
  1, 13,  {
    
    Black -> (RGBColor[0, 2/3, 0])
  }
}];

AppendTo[nodes, {
  1, Infinity,  {
    
    {a___, (RGBColor[0, 2/3, 0]),Black, b___} :> {a, (RGBColor[0, 2/3, 0]),(RGBColor[0, 2/3, 0]), b},
    {a___, Green,Black, b___} :> {a, Green,Green, b}
  }
}];

Запускаем

state = <|
  "nodes" -> correctRules/@nodes,
  "nodeNumber"->1,"step"->0
|>;

field = Table[Black, {20}, {20}];
Animate[
  ArrayPlot[(
    Do[{field, state} = propagate[field, state];, {12}];
       {field, state} = propagate[field, state]
  )//First], 
  {n,1,220}, Appearance->None, RefreshRate->20
]

Полируем до библиотеки

Чего не хватает:

задавать симметрию для каждого узла
удобный интерфейс

Эта библиотека находится в открытом доступе: JerryI`MarkovJunior. Она совместима со всеми платформами Wolfram. Скачайте её и загрузите следующим образом:

PacletDirectoryLoad["MarkovJunior"]

Или, если вы используете WLJS Notebook:

LPMRepositories[{
  "Github" -> "https://github.com/JerryI/MarkovJunior" -> "master"
}]

Затем загрузите пакет в поле имен:

Needs["CoffeeLiqueur`Workshop`MarkovJunior`" -> "mj`"];

Определения узлов содержат дополнительную часть для указания симметрий:

{
  1 | All,
  _Integer | Infinity,
  Automatic | All | None | "Rotation" | "Mirror" | "MirrorX" | "MirrorY",
  {rules...}
}

Цветы

Сложная сцена тоже строится из локальных шагов. Сначала образуются небо и почва, затем на линии грунта высаживается стебель, потом ветви, листья и цветы. Временные цвета полезны именно потому, что правила могут различать «объект уже готов» и «объект ещё растёт».

Если смотреть в текстовом редакторе без синтаксического сахара, то выглядит ужасно, так как выражения цветов не превращаются в иконки. Впрочем можно было бы все просто заменить также на числа 1,2,3… без потери общности ;)

Правила выращивания цветов

nodes = {};

AppendTo[nodes, { 
  1, 1, Automatic, { 
    
    Black -> (RGBColor[1, 1, 0])
  }
}];

AppendTo[nodes, {
  1, 3, Automatic, { 
    
    Black -> (RGBColor[1, 0, 0])
  }
}];

AppendTo[nodes, {
  1, Infinity, Automatic, {
    
    {a___, (RGBColor[1, 0, 0]),Black, b___} :> {a, (RGBColor[1, 0, 0]),(RGBColor[1, 0, 0]), b},
    {a___, (RGBColor[1, 1, 0]),Black, b___} :> {a, (RGBColor[1, 1, 0]),(RGBColor[1, 1, 0]), b}
  }
}];

AppendTo[nodes, {
  All, Infinity, Automatic, {
    
    {a___, (RGBColor[1, 0, 0]), b___} :> {a, (RGBColor[0.87, 0.94, 1]), b},
    {a___, (RGBColor[1, 1, 0]), b___} :> {a, (RGBColor[0.6, 0.4, 0.2]), b}
  }
}];

AppendTo[nodes, {
  1, Infinity, All, {
    
    {
      bf___,
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b2___},
      {a3___, (RGBColor[0.6, 0.4, 0.2]),(RGBColor[0.6, 0.4, 0.2]),(RGBColor[0.6, 0.4, 0.2]), b3___},
      af___
    } :> {
      bf,
      {a1   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b2   },
      {a3   , (RGBColor[0.6, 0.4, 0.2]),(RGBColor[0.6, 0.4, 0.2]),(RGBColor[0.6, 0.4, 0.2]), b3   },
      af
    } /; Length[{a1}]==Length[{a2}]==Length[{a3}]  
  }
}];

AppendTo[nodes, {
  1, Infinity, "MirrorX", {
    

    {
      bf___,
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]), b2___},
      {a3___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b3___},
      af___
    } :> {
      bf,
      {a1   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0, 2/3, 0]), b2   },
      {a3   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b3   },
      af
    } /; Length[{a1}]==Length[{a2}]==Length[{a3}],

    {
      bf___,
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b2___},
      {a3___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0, 2/3, 0]), b3___},
      af___
    } :> {
      bf,
      {a1   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b2   },
      {a3   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0, 2/3, 0]), b3   },
      af
    } /; Length[{a1}]==Length[{a2}]==Length[{a3}],    
    
    {
      bf___,
      {a0___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b0___},
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b2___},
      {a3___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b3___},
      af___
    } :> {
      bf,
      {a0   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b0   },
      {a1   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b2   },
      {a3   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b3   },
      af
    } /; Length[{a1}]==Length[{a2}]==Length[{a3}]==Length[{a0}],
    
    {
      bf___,
      {a0___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b0___},
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b2___},
      {a3___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b3___},
      af___
    } :> {
      bf,
      {a0   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b0   },
      {a1   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b2   },
      {a3   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b3   },
      af
    } /; RandomReal[]<0.5 && Length[{a0}]==Length[{a1}]==Length[{a2}]==Length[{a3}],

    {
      bf___,
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b2___},
      {a3___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b3___},
      af___
    } :> {
      bf,
      {a1   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[1, 0, 0]),(RGBColor[0.87, 0.94, 1]), b2   },
      {a3   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b3   },
      af
    } /; RandomReal[]<0.2 && Length[{a1}]==Length[{a2}]==Length[{a3}]
  }
}];

AppendTo[nodes, {
  All, Infinity, All, {
    
    {
      bf___,
      {a0___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]),(RGBColor[0.87, 0.94, 1]), b0___},
      {a1___, (RGBColor[0.87, 0.94, 1]),(RGBColor[1, 0, 0]),(RGBColor[0.87, 0.94, 1]), b1___},
      {a2___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b2___},
      {a3___, (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b3___},
      af___
    } :> {
      bf,
      {a0   , (RGBColor[0.87, 0.94, 1]),(RGBColor[1, 0, 0]),(RGBColor[0.87, 0.94, 1]), b0   },
      {a1   , (RGBColor[1, 0, 0]),(RGBColor[1, 1, 0]),(RGBColor[1, 0, 0]), b1   },
      {a2   , (RGBColor[0.87, 0.94, 1]),(RGBColor[1, 0, 0]),(RGBColor[0.87, 0.94, 1]), b2   },
      {a3   , (RGBColor[0.87, 0.94, 1]),(RGBColor[0, 2/3, 0]),(RGBColor[0.87, 0.94, 1]), b3   },
      af
    } /; Length[{a0}]==Length[{a1}]==Length[{a2}]==Length[{a3}]  
  }
}];

Создаем начальное состояние

state = mj`MarkovState[Table[Black, {30}, {30}], nodes]

Запускаем интерпретатор

(state=mj`Propagate[state]) // mj`GetArray // ArrayPlot

Симуляция падающего песка

Для песка правило сначала пытается сдвинуть частицу вниз. Если клетка снизу занята, возможны диагональные ходы; если и они невозможны, песчинка остаётся на месте:

one
  пока есть совпадения:
    1       0
    0  →   1

    10     01
    1x →  1x

    01     10
    x1 →  x1

И вот как это выглядит в коде. Здесь мы используем двумерные правила и вынуждены ставить условие на то, что число рядов слева и справа совпадает

nodes = {};

AppendTo[nodes, {
  1, Infinity, None, {
    {
      bf___,
      {a1___, 1, b1___},
      {a2___, 0, b2___},
      af___
    } :> {
      bf,
      {a1   , 0, b1   },
      {a2   , 1, b2   },
      af
    } /; Length[{a1}]==Length[{a2}],
    
    {
      bf___,
      {a1___,    0,    1,  b1___},
      {a2___,    k_,    1,  b2___},
      af___
    } :> {
      bf,
      {a1   ,    1,    0,  b1   },
      {a2   ,    k,    1,  b2   },
      af
    } /; Length[{a1}]==Length[{a2}],

    {
      bf___,
      {a1___,    1,    0,  b1___},
      {a2___,    1,    k_,  b2___},
      af___
    } :> {
      bf,
      {a1   ,    0,    1,  b1   },
      {a2   ,    1,    k,  b2   },
      af
    } /; Length[{a1}]==Length[{a2}]
  }
}];

state = mj`MarkovState[Table[RandomChoice[{0,0,0,0,0,1}], {20}, {20}], nodes];

Как-то скучно… А что если добавить ландшафт и посмотреть, как он будет с ним взаимодействовать

Процедурный ландшафт

nodes = {};

AppendTo[nodes, {
  1, 2, None, {
    {bf___,
    {0, b1__}} :> {bf,
                    {5, b1}},

    {bf___,
    {b1__, 0}} :> {bf,
                    {b1, 5}}    
  } 
}];

AppendTo[nodes, {
  1, 13, None, {
    {
      bf___,
      {a1___, 0, b1___},
      {a2___, 5, b2___},
      af___
    } :> {
      bf,
      {a1,    5, b1},
      {a2,    5, b2},
      af
    }   /; Length[{a1}]==Length[{a2}] 
  } 
}];

AppendTo[nodes, {
  All, Infinity, None, {
    {
      bf___,
      {a1___, 5, 0, b1___},
      {a2___, k_, 0, b2___},
      af___
    } :> {
      bf,
      {a1,    5, 0, b1},
      {a2,    k, 5, b2},
      af
    }   /; Length[{a1}]==Length[{a2}],    
    
    {
      bf___,
      {a1___, 0, 5, b1___},
      {a2___, 0, k_, b2___},
      af___
    } :> {
      bf,
      {a1,    0, 5, b1},
      {a2,    5, k, b2},
      af
    }   /; Length[{a1}]==Length[{a2}]
    
  } 
}];

AppendTo[nodes, {
  All, Infinity, None, {
    {
      bf___,
      {a1___, 5, b1___},
      {a2___, 0, b2___},
      af___
    } :> {
      bf,
      {a1,    5, b1},
      {a2,    5, b2},
      af
    }   /; Length[{a1}]==Length[{a2}] 
  } 
}];

AppendTo[nodes, {
  All, Infinity, None, {
    {
      {a1___, 0, b1___},
      {a2___, 0, b2___},
      {a3___, 0, b3___},
      af___
    } :> {
      {a1,    1, b1},
      {a2,    1, b2},
      {a3,    1, b3},
      af
    }   /; Length[{a1}]==Length[{a2}]==Length[{a3}]  
  } 
}];


AppendTo[nodes, {
  1, Infinity, None, {
    {
      bf___,
      {a1___, 1, b1___},
      {a2___, 0, b2___},
      af___
    } :> {
      bf,
      {a1   , 0, b1   },
      {a2   , 1, b2   },
      af
    } /; Length[{a1}]==Length[{a2}],
    
    {
      bf___,
      {a1___,    0,    1,  b1___},
      {a2___,    k_,    1,  b2___},
      af___
    } :> {
      bf,
      {a1   ,    1,    0,  b1   },
      {a2   ,    k,    1,  b2   },
      af
    } /; Length[{a1}]==Length[{a2}],

    {
      bf___,
      {a1___,    1,    0,  b1___},
      {a2___,    1,    k_,  b2___},
      af___
    } :> {
      bf,
      {a1   ,    0,    1,  b1   },
      {a2   ,    1,    k,  b2   },
      af
    } /; Length[{a1}]==Length[{a2}]
  }
}];

state = mj`MarkovState[Table[0, {20}, {20}], nodes];

Мы тут не использовали физику сплошной среды, но получилось правдоподобно.

Ограничения

Этот интерпретатор намеренно мал. Он не претендует на полноту MarkovJunior. По своей сути этот подход строит сложные клеточные автоматы поверх универсальной системы паттернов Wolfram Language. За эту гибкость приходится платить: последовательностные паттерны вроде ___ могут сопоставляться с выражениями разной длины и в разных позициях. Когда правило даёт большое число совпадений, ReplaceList способен быстро сгенерировать множество вариантов сеток, включая дублирующиеся результаты. Часть этого дублирования можно было бы устранить, но вычисление условий (/;) и последовательностных паттернов всё равно оставалось бы вычислительно затратным. Тем не менее, WL оказывается очень удобен для исследования клеточных автоматов и систем правил замен.