Wolfram Function Repository

Instant-use add-on functions for the Wolfram Language

Function Repository Resource:

 BlockCellularAutomaton

Source Notebook

Evolve a block cellular automaton

Contributed by: Wolfram Research

ResourceFunction["BlockCellularAutomaton"][rule,{init,phase},t]

generates a list of states and phases representing the evolution of the block cellular automaton with the specified rule from initial state init and initial phase for t steps.

ResourceFunction["BlockCellularAutomaton"][rule,{init,phase}]

gives the result of evolving {init,phase} for one step.

ResourceFunction["BlockCellularAutomaton"][rule]

is an operator form of BlockCellularAutomaton that affects one step of evolution.

ResourceFunction["BlockCellularAutomaton"][rule,init,t]

provides legacy support for previous input/output format, assuming phase=0, and returning a flat list of states with no phase information.

ResourceFunction["BlockCellularAutomaton"][rule,init,t,phase]

provides legacy support with an initial phase.

ResourceFunction["BlockCellularAutomaton"][rule,init]

provides legacy support for one-step evolution, assuming phase=0.

Details

Possible forms for rule are:
{in1→out1,in2→out2,…}a list of rules
Dispatch[{in1→out1,…}]an optimized list of rules
Association[in1→out1,…]a lookup dictionary
{rule, dim}with rule any of the above, and dim equals block length
Specification by Association may lead to the fastest calculations, but it requires a comprehensive list of inputs without any usage of pattern matching or RuleDelayed. Lists of rules may lead to slightly slower calculations, but are more flexible by allowing for pattern matching. The Dispatch usage should not be much slower than the Association usage.
ResourceFunction["BlockCellularAutomaton"] allows one extra rule specification {rule,{2,2}} for evolutions through two spatial dimensions, which alternate between phase values 0 and 1 with {2,2} block offset along the diagonal. This is sometimes referred to as the "Margolus neighborhood". More algorithm design regarding phases and offsets remains to be done to implement full dimensional generalization of ResourceFunction["BlockCellularAutomaton"].
Possible forms for time t are:
tall steps 0 through t
{t}a list containing only step t
{{t}}step t alone
{t1,t2}steps t1 through t2
{t1,t2,dt}steps t1,t1+dt, …
List items in the output of ResourceFunction["BlockCellularAutomaton"] take the form {statei, phasei}, where phase goes from 0,1,…,dim-1 and dim is the fixed block length. To obtain an ArrayPlot of a time evolution, simply discard phase information by combining Map and First, as in examples given below.
The length of init should be commensurate with the block size dim.
Previous versions of this code used a different phase convention, phase ∈{1,2,…, dim}. Backward-compatible usage expects a phase in the previous convention and automatically subtracts one to convert to the present convention.

Examples

Basic Examples (4) 

Evolve a block cellular automaton for three steps:

In[1]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{0, 0} -> {0, 0}, {0, 1} -> {1, 0}, {1, 0} -> {0, 1}, {1, 1} -> {1, 1}}, {Normal[ SparseArray[{2 -> 1, 7 -> 1}, 10]], 0}, 3]
Out[1]=

Plot the same block cellular automaton evolving over 20 steps:

In[2]:=
ArrayPlot[ Map[First, ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{ {0, 0} -> {0, 0}, {0, 1} -> {1, 0}, {1, 0} -> {0, 1}, {1, 1} -> {1, 1} }, {Normal[SparseArray[{2 -> 1, 7 -> 1}, 10]], 0}, 10]], ImageSize -> 100]
Out[2]=

Evolve a block cellular automaton for one step:

In[3]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{0, 0, 0} -> {0, 0, 1}, {0, 0, 1} -> {0, 1, 1}, {0, 1, 0} -> {1, 0, 1}, {0, 1, 1} -> {0, 0, 0}, {1, 0, 0} -> {1, 1, 0}, {1, 0, 1} -> {1, 0, 0}, {1, 1, 0} -> {0, 1, 0}, {1, 1, 1} -> {1, 1, 1}}, {Normal[SparseArray[{2 -> 1, 7 -> 1}, 12]], 0}]
Out[3]=

Find the state of a block cellular automaton after 100 time steps:

In[4]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][ Dispatch[{{1, 1} -> {2, 0}, {1, 2} -> {2, 1}, {2, 0} -> {1, 1}, {2, 1} -> {1, 2}, {0, 0} -> {0, 0}, {0, 2} -> {0, 2}, {1, 0} -> {1, 0}, {2, 2} -> {2, 2}, {0, 1} -> {1, 1}}], {CenterArray[{2, 2}, 100], 0}, {{100}}]
Out[4]=

Use the operator form to evolve a block cellular automaton by one step:

In[5]:=
Apply[ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][Association[ {{1, 1} -> {0, 0}, {1, 0} -> {1, 0}, {0, 1} -> {0, 1}, {0, 0} -> {1, 1}}]], {{1, 1, 0, 1, 0, 0}, 0}]
Out[5]=

Apply the same operator to all possible length-6 inputs and produce a state transition Graph:

In[6]:=
With[{caOperator = ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][ {{1, 1} -> {0, 0}, {1, 0} -> {1, 0}, {0, 1} -> {0, 1}, {0, 0} -> {1, 1}}]}, Graph[Map[# -> caOperator @@ # &, Tuples[{Tuples[{1, 0}, 6], {0, 1}}]]]]
Out[6]=

Scope (2) 

BlockCellularAutomaton allows block lengths greater than 2 and variable rules:

In[7]:=
ArrayPlot[Map[RotateRight[First[#], 30] &, ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{{x_, y_, z_} :> { Mod[(x - z), 3], Mod[(y - x), 3], Mod[(z - y), 3] }}, 3}, {CenterArray[{1}, 201], 3}, 120]]]
Out[7]=

BlockCellularAutomaton has a special use case for rules on the Margolus neighborhood such as this "billiards" example:

In[8]:=
With[{config = ArrayPad[ReplacePart[ ConstantArray[0, {6, 6}], {2, 3} -> 1], 1, 2]}, ArrayPlot[First[#], ColorRules -> {0 -> White, 1 -> Red, 2 -> LightGray}, Frame -> None, Mesh -> True, ImageSize -> 80] & /@ ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{ Dispatch[{Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, Or[Count[{a, b, c, d}, 2] == 3, And[Count[{a, b, c, d}, 2] == 2, Count[{a, b, c, d}, 1] != 1]]] :> {{a, b}, {c, d}}, Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, And[Count[{a, b, c, d}, 2] == 2, Count[{a, b, c, d}, 1] == 1]] :> ReplaceAll[{{a, b}, {c, d}}, {1 -> 0, 0 -> 1}], Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, And[Count[{a, d}, 2] == 1, Count[{b, c}, 2] == 0]] :> {{a, c}, {b, d}}, Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, And[Count[{a, d}, 2] == 0, Count[{b, c}, 2] == 1]] :> {{d, b}, {c, a}}, {{0, 0}, {0, 0}} -> {{0, 0}, {0, 0}}, {{1, 0}, {0, 0}} -> {{0, 0}, {0, 1}}, {{0, 1}, {0, 0}} -> {{0, 0}, {1, 0}}, {{0, 0}, {1, 0}} -> {{0, 1}, {0, 0}}, {{0, 0}, {0, 1}} -> {{1, 0}, {0, 0}}, {{1, 1}, {0, 0}} -> {{0, 0}, {1, 1}}, {{1, 0}, {1, 0}} -> {{0, 1}, {0, 1}}, {{1, 0}, {0, 1}} -> {{0, 1}, {1, 0}}, {{0, 1}, {1, 0}} -> {{1, 0}, {0, 1}}, {{0, 1}, {0, 1}} -> {{1, 0}, {1, 0}}, {{0, 0}, {1, 1}} -> {{1, 1}, {0, 0}}, {{1, 1}, {1, 0}} -> {{0, 1}, {1, 1}}, {{1, 1}, {0, 1}} -> {{1, 0}, {1, 1}}, {{1, 0}, {1, 1}} -> {{1, 1}, {0, 1}}, {{0, 1}, {1, 1}} -> {{1, 1}, {1, 0}}, {{1, 1}, {1, 1}} -> {{1, 1}, {1, 1}}}], {2, 2}}, {config, 0}, 8]]
Out[8]=

Applications (1) 

Plot a block cellular automaton from A New Kind of Science:

In[9]:=
ArrayPlot[ First /@ ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{2, 2} -> {1, 1}, {1, 1} -> {2, 2}, {1, 2} -> {1, 2}, {2, 1} -> {2, 1}, {2, 0} -> {0, 2}, {1, 0} -> {1, 0}, {0, 2} -> {2, 0}, {0, 1} -> {0, 1}, {0, 0} -> {0, 0}}, {CenterArray[Table[2, 38], 100], 0}, 300]]
Out[9]=

Properties and Relations (3) 

BlockCellularAutomaton is backward compatible with previous input/output forms:

In[10]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{1, 1} -> {0, 0}, {1, 0} -> {1, 0}, {0, 1} -> {0, 1}, {0, 0} -> {1, 1}}, {1, 0, 0, 1, 0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1, 1, 1, 0, 0, 0}, 20] // ArrayPlot
Out[10]=

Backward compatibility also allows initializing with a phase:

In[11]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][ # -> CellularAutomaton[110][#] & /@ Tuples[{1, 0}, 3], RotateLeft@CenterArray[{1}, 201], 100, 3] // ArrayPlot
Out[11]=

Backward compatibility also allows one-step evolution, assuming initial phase=0:

In[12]:=
FromDigits[ ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{x_, y_} :> {y, x} /; x > y}, IntegerDigits[1009401, 2]], 2]
Out[12]=

Possible Issues (2) 

Block size must divide the length of the initial condition:

In[13]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{{{x_, y_} /; x > y :> {y, x}}, 2}, {IntegerDigits[1009400/2, 2], 0}, 20]
Out[13]=

Rules must have equal block size:

In[14]:=
ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{ {x_, y_} :> {y, x}, {x_, y_, z_} :> {z, y, x} }, {IntegerDigits[1009400, 2], 0}, 20]
Out[14]=

Neat Examples (2) 

Find a periodic solution of the "billiards" block cellular automaton shown above and plot the cycle:

In[15]:=
With[{data = Map[First, Last[ ResourceFunction["FindNestedTransientRepeat"][ ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][{ Dispatch[{Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, Or[Count[{a, b, c, d}, 2] == 3, And[Count[{a, b, c, d}, 2] == 2, Count[{a, b, c, d}, 1] != 1]]] :> {{a, b}, {c, d}}, Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, And[Count[{a, b, c, d}, 2] == 2, Count[{a, b, c, d}, 1] == 1]] :> ReplaceAll[{{a, b}, {c, d}}, {1 -> 0, 0 -> 1}], Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, And[Count[{a, d}, 2] == 1, Count[{b, c}, 2] == 0]] :> {{a, c}, {b, d}}, Condition[{{ Pattern[a, Blank[]], Pattern[b, Blank[]]}, { Pattern[c, Blank[]], Pattern[d, Blank[]]}}, And[Count[{a, d}, 2] == 0, Count[{b, c}, 2] == 1]] :> {{d, b}, {c, a}}, {{0, 0}, {0, 0}} -> {{0, 0}, {0, 0}}, {{1, 0}, {0, 0}} -> {{0, 0}, {0, 1}}, {{0, 1}, {0, 0}} -> {{0, 0}, { 1, 0}}, {{0, 0}, {1, 0}} -> {{0, 1}, {0, 0}}, {{0, 0}, { 0, 1}} -> {{1, 0}, {0, 0}}, {{1, 1}, {0, 0}} -> {{0, 0}, {1, 1}}, {{1, 0}, {1, 0}} -> {{0, 1}, {0, 1}}, {{1, 0}, {0, 1}} -> {{0, 1}, {1, 0}}, {{0, 1}, {1, 0}} -> {{1, 0}, {0, 1}}, {{0, 1}, {0, 1}} -> {{1, 0}, {1, 0}}, {{0, 0}, {1, 1}} -> {{1, 1}, {0, 0}}, {{1, 1}, {1, 0}} -> {{0, 1}, {1, 1}}, {{1, 1}, {0, 1}} -> {{1, 0}, {1, 1}}, {{1, 0}, {1, 1}} -> {{1, 1}, {0, 1}}, {{0, 1}, {1, 1}} -> {{1, 1}, {1, 0}}, {{1, 1}, {1, 1}} -> {{1, 1}, {1, 1}}}], {2, 2}}] @@ # &, {ArrayPad[ReplacePart[ConstantArray[0, {6, 6}], {2, 3} -> 1], 1, 2], 0}, 5]]]}, Grid[Partition[Map[ArrayPlot[ReplacePart[Last[#], Position[First[#], 1][[1]] -> -1], ColorRules -> {0 -> White, 1 -> Red, -1 -> LightRed, 2 -> LightGray}, Frame -> None, Mesh -> True, ImageSize -> 80] &, Partition[data, 2, 1, 1]], 6], Frame -> All, FrameStyle -> LightGray, Spacings -> {1, 1}]]
Out[15]=

Plot a block cellular automaton that seems to do something prime-like along its right edge:

In[16]:=
ArrayPlot[Map[RotateRight[First[#], 100] &, ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][ Association[{{0, 0} -> {0, 0}, {0, 1} -> {1, 1}, {0, 2} -> {0, 2}, {1, 0} -> {1, 0}, {1, 1} -> {2, 0}, {1, 2} -> {2, 1}, {2, 0} -> {1, 1}, {2, 1} -> {1, 2}, {2, 2} -> {2, 2}}], {CenterArray[{2, 2}, 500], 0}, 300]], ImageSize -> 300, ColorRules -> {0 -> White, 1 -> Lighter[Orange], 2 -> Darker[Orange]}]
Out[16]=

Plot first differences of the semi-hypotenuse lengths:

In[17]:=
With[ {data = Map[First, ResourceFunction[ "BlockCellularAutomaton", ResourceSystemBase -> "https://www.wolframcloud.com/obj/resourcesystem/api/1.0"][ Association[{{0, 0} -> {0, 0}, {0, 1} -> {1, 1}, {0, 2} -> {0, 2}, {1, 0} -> {1, 0}, {1, 1} -> {2, 0}, {1, 2} -> {2, 1}, {2, 0} -> {1, 1}, {2, 1} -> {1, 2}, {2, 2} -> {2, 2}}], {CenterArray[{2, 2}, 2 #], 0}, #]] &@1000}, ListPlot[Differences[MapIndexed[If[ MatchQ[#1, {__, 1, 1, 1, 1, 0 ..}], #2[[1]], Nothing] &, data]]]]
Out[17]=

Compare continuation of the integer sequence (not in OEIS!) with the primes (the icon contains a two-minute data run computed using the code above):

In[18]:=
Grid[{Show[#, ImageSize -> 250] & /@ { ListPlot[{9, 66, 44, 47, 53, 56, 68, 71, 77, 83, 92, 110, 113, 116, 122, 131, 143, 158, 170, 173, 176, 179, 185, 197, 203, 209, 242, 245, 251, 281, 287, 290, 317, 320, 323, 326, 344, 356, 359, 377, 383, 398, 416, 422, 425, 443}], ListPlot[Prime /@ Range[45]]}, Text[Style[#, Gray]] & /@ { "Data From BlockCellularAutomaton", "Data From Prime"}}, Spacings -> {3, 0}]
Out[18]=

Version History

  • 2.0.0 – 07 November 2022
  • 1.0.0 – 12 August 2020

Related Resources

License Information