Function Repository Resource:

PerturbedCellularAutomaton

Source Notebook

Evolve a cellular automaton with changes to certain cells

Contributed by: Willem Nielsen, Stephen Wolfram and Dugan Hammock

ResourceFunction["PerturbedCellularAutomaton"][rule,init,txspec]

finds one random location within the body of the automaton and flips the color randomly.

ResourceFunction["PerturbedCellularAutomaton"][rule,init,txspec,n]

finds n random locations within the body of the automaton and flips the color randomly.

ResourceFunction["PerturbedCellularAutomaton"][rule,init,txspec,{tpert,xpert}]

flips the cell specified by {tpert, xpert} to a random bit within the number of colors.

ResourceFunction["PerturbedCellularAutomaton"][rule,init,txspec,{{tpert1,xpert1}...}]

flips all cells in the list of perturbations specifications to a random bit within the number of colors.

ResourceFunction["PerturbedCellularAutomaton"][rule,init,txspec,{tpert,xpert}newbit]

flips the cell at indexes specified by {tpert, xpert} to the bit specified by newbit.

ResourceFunction["PerturbedCellularAutomaton"][rule,init,txspec,{{tpert1,xpert1}newbit1...}]

flips the cell at indexes {{tpertn, xpertn}...} to bit specified by newbitn.

Details and Options

Expressions rule and init are interpreted just as in the CellularAutomaton function, however, only one-dimensional cellular automata are currently supported.
Because the automaton are stitched together, using All or Automatic within txspec is not allowed. If no xspec, All or Automatic are provided, the xspec defaults to {-25,25}.
Expression tpert can be any integer between 0 and the specified number of steps.
Expression tpert and xpert can take the form:
tperturbs at position t
{t1}perturbs at position tn in sorted order
ts;;teperturbs at position specified by span in sorted order
fperturbs at indices given by the result running f on the list of possible indices
Expression newbit can take the form:
bsets value of cell to integer b
{"AddValue", b}adds previous value of cell with integer b, modulo the number of colors
fsets value of cell to the result of running f[prev, k] for k colors
PerturbedCellularAutomaton takes the following options:
"Body"Falsewhether the indexes given refer to indexes within the body, the body is defined by
"ReturnPerturbations"Truewhether to return the performed perturbations, if False, just a list of lists will be returned
The body of the automaton is represented by the non-zero range at each row:

Examples

Basic Examples (2) 

Run a cellular automaton with a random perturbation for 2 steps, here the first cell of the second row is flipped to 0:

In[1]:=
ResourceFunction[
 "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}]
Out[1]=

Specify that same perturbation:

In[2]:=
ResourceFunction[
 "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {2, 1} -> 0]
Out[2]=

Scope (7) 

See the differences based on the perturbation above:

In[3]:=
ArrayPlot /@ {CellularAutomaton[30, {{1}, 0}, {2, {-2, 2}}], First[ResourceFunction[
    "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {2, 1} -> 0]]}
Out[3]=

Draw an arrow to the perturbed cell:

In[4]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {2, 1} -> 0]]
Out[4]=

Do two random perturbations:

In[5]:=
data = ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, 2]
Out[5]=

Visualize it:

In[6]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ data]
Out[6]=

Use those same perturbation locations but set them both to white:

In[7]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][
  30, {{1}, 0}, {2, {-2, 2}}, {{1, 2}, {2, 4}} -> 0]]
Out[7]=

Do a range of three perturbations at timestep two:

In[8]:=
data = ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {2, 2 ;; 4}]
Out[8]=

Visualize it:

In[9]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ data]
Out[9]=

Perturb the third cell at timestep one and two:

In[10]:=
data = ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {1 ;; 2, 3}]
Out[10]=

Visualize it:

In[11]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ data]
Out[11]=

Perturb a random sample of three at the second timestep:

In[12]:=
data = ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][
  30, {{1}, 0}, {2, {-2, 2}}, {2, RandomSample[#, 3] &}]
Out[12]=

Visualize it:

In[13]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ data]
Out[13]=

Perturb the last cell at every timestep:

In[14]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {;; All, Last}]]
Out[14]=

With larger k-values, you can use "AddValue" for the bit specification to make a deterministic change. Here yellow always gets flipped to white:

In[15]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}, Epilog -> {Arrowheads[Large], Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}] & @@@ Keys[pert]}]] &[
 ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{297413946807002990892857386679107573048, 4, 1}, {{1}, 0}, {30, {-10, 10}}, {{20, 10}, {18, 10}} -> {"AddValue", 1}]]
Out[15]=

Options (2) 

Setting "ReturnPerturbations" to False makes it so that only evolution of the automata is returned:

In[16]:=
ResourceFunction[
 "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, "ReturnPerturbations" -> False]
Out[16]=

Setting "Body" to true makes it so that the specified index is interpreted as the index within the non-zero range of the automata:

In[17]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, Epilog -> {Arrowheads[Large], Style[Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}], Red] & @@@ Keys[pert]}]] &[ ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {1, 1} -> 0, "Body" -> True]]
Out[17]=

Applications (5) 

Evolve a rule with perturbations:

In[18]:=
robustru = Module[{ru, ca, lt, pcas, fitness, testcalifetime = Function[ca, If[# == 0, -Infinity, Length[ca] - #] &[
        LengthWhile[Reverse[ca], Total[#] == 0 &]]]},
    SeedRandom[511114];
    Nest[CompoundExpression[
       ru = ResourceFunction[
ResourceObject[<|"Name" -> "RandomRuleMutation", "UUID" -> "05a45225-5be5-46bd-9833-9ef3be361333", "ResourceType" -> "Function", "ResourceLocations" -> {
CloudObject[
              "https://www.wolframcloud.com/obj/sw-writings0/Resources/05a/05a45225-5be5-46bd-9833-9ef3be361333"]}, "Version" -> None, "DocumentationLink" -> URL[
             "https://www.wolframcloud.com/obj/sw-writings0/BiologicalEvolution/RandomRuleMutation"], "ExampleNotebookData" -> Automatic, "FunctionLocation" -> CloudObject[
             "https://www.wolframcloud.com/obj/sw-writings0/Resources/05a/05a45225-5be5-46bd-9833-9ef3be361333/download/DefinitionData"], "ShortName" -> "RandomRuleMutation", "SymbolName" -> "FunctionRepository`$05a452255be546bd98339ef3be361333`RandomRuleMutation", "PageHeaderClickToCopy" -> "ResourceObject[CloudObject[\"https://www.wolframcloud.com/obj/sw-writings0/BiologicalEvolution/RandomRuleMutation\"]]"|>]][First[#]],
       ca = CellularAutomaton[ru, {{1}, 0}, {200, {-50, 50}}];
       lt = testcalifetime[ca];
       If[lt == -Infinity, #,
        pcas = Table[ResourceFunction[
           "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][ru, {{1}, 0}, {200, {-50, 50}}, "ReturnPerturbations" -> False], Ceiling[lt/20]];
        fitness = Min[Join[{lt}, testcalifetime /@ pcas]];
        If[fitness >= Last[#], {ru, fitness}, #]
        ]] &, {{0, 4, 1}, 0}, 1000]
    ] // First;

Plotting our robust automaton:

In[19]:=
ArrayPlot[CellularAutomaton[robustru, {{1}, 0}, {60, {-15, 15}}], ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}]
Out[19]=

Ten sample perturbations:

In[20]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}, Epilog -> {Arrowheads[Large], Arrow[{{0, Length[ca] - #1 - .5}, {#2 - .5 , Length[ca] - #1 - .5}}] & @@@ Keys[pert]}]] & /@ Table[ResourceFunction[
   "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][robustru, {{1}, 0}, {200, {-20, 20}}], 10]
Out[20]=

Plot the lifetime distribution of one thousand different random single perturbations:

In[21]:=
lts = Function[ca, If[# == 0, 202, Length[ca] - #] &[
     LengthWhile[Reverse[ca], Total[#] == 0 &]]] /@ Table[ResourceFunction[
     "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][robustru, {{1}, 0}, {200, {-20, 20}}, "ReturnPerturbations" -> False], 1000];
Histogram[lts, PlotRange -> All]
Out[22]=

Obtain the mortality curve:

In[23]:=
Histogram[lts, {10}, "CDF"]
Out[23]=

Possible Issues (3) 

When you specify an index outside the range of the body, an empty perturbation is returned:

In[24]:=
ResourceFunction[
 "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {1, 4}, "Body" -> True]
Out[24]=

The tspec uses the same indexing as in CellularAutomaton, so the initial row is perturbed using zero:

In[25]:=
ResourceFunction[
 "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, {0, 1}]
Out[25]=

Because the automata are stitched together, using All or Automatic as an xspec is not allowed. If no xspec is given, or All or Automatic are given, xspec defaults to {-25,25}:

In[26]:=
ArrayPlot[
 First[ResourceFunction[
   "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{297413946807002990892857386679107573048, 4, 1}, {{1}, 0}, 65]], ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}]
Out[26]=

Doing many perturbations sometimes results in the body dying out, with no perturbations left to perform:

In[27]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}, Epilog -> {Arrowheads[Large], Arrow[{{0, Length[ca] - #1 + .5}, {#2 - .5 , Length[ca] - #1 + .5}}] & @@@ Keys[pert]}]] &[
 ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{180311482541120044137557119353943331376, 4, 1}, {{1}, 0}, {65, {-10, 10}}, 10]]
Out[27]=

Running the function on an empty list or association returns the unperturbed cellular automaton:

In[28]:=
ResourceFunction[
 "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][30, {{1}, 0}, {2, {-2, 2}}, <||>]
Out[28]=

Neat Examples (3) 

Rules that "age" are particularly robust to perturbations:

In[29]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}, Epilog -> {Arrowheads[Large], Arrow[{{0, Length[ca] - #1 + .5}, {#2 - .5 , Length[ca] - #1 + .5}}] & @@@ Keys[pert]}]] &[
 ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{297413946807002990892857386679107573048, 4, 1}, {{1}, 0}, {65, {-10, 10}}]]
Out[29]=

They can also be healed easily. Here we apply a therapeutic perturbation:

In[30]:=
Module[{ca = First[#], pert = Last[#]}, ArrayPlot[ca, ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}, Epilog -> {Arrowheads[Large], Arrow[{{0, Length[ca] - #1 + .5}, {#2 - .5 , Length[ca] - #1 + .5}}] & @@@ Keys[pert]}]] & /@ (ResourceFunction[
     "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{297413946807002990892857386679107573048, 4, 1}, {{1}, 0}, {65, {-10, 10}}, #] & /@ {{10, 10} -> 3, {{10, 10} -> 3, {15, 8} -> 2}})
Out[30]=

With random perturbations you can see the beginning of self-reproduction in very simple rules:

In[31]:=
coords = Transpose@{RandomInteger[{1, 1000}, 500], RandomInteger[{1, 50}, 500]} -> 2;
ArrayPlot[#, ColorRules -> {0 -> GrayLevel[1], 1 -> Hue[0.06, 1, 1], 2 -> Hue[0.73, 1, 1], 3 -> Hue[0.14, 0.81, 0.99]}] &[
 ResourceFunction[
  "PerturbedCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{3019941697641, 3, 1}, {{1}, 0}, {{900, 1000}, {-25, 25}}, coords, "ReturnPerturbations" -> False]]
Out[32]=

Publisher

Willem Nielsen

Requirements

Wolfram Language 13.0 (December 2021) or above

Version History

  • 2.0.0 – 21 April 2025
  • 1.0.0 – 30 January 2025

Related Resources

License Information