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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

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]=
Image

Version History

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

Related Resources

License Information