Cellular Automata

This notebook gives examples of Stephen Wolfram's cellular automata programs.

Setting Up Initial Conditions

The state of a cellular automaton at each step is represented by a list of integers.  The cellular automaton starts from a list corresponding to its initial state.

RandomList[n_] := Table[Random[Integer], {n}]

RandomList[n_, k_] := Table[Random[Integer, {0, k - 1}], {n}]

CenterList[n_Integer, a_List] := 
      With[{len = ((n - Length[a] )/2)}, 
        Join[Table[0, {⌊len⌋}], a, 
          Table[0, {⌈len⌉}]]]

CenterList[20, {1, 1, 1}]

Implementing Evolution Rules

Elementary Cellular Automata

Introduced by Stephen Wolfram in 1982, the elementary cellular automata are the simplest class of one-dimensional cellular automata. They have two possible values for each cell, and rules that depend only on nearest neighbor values. There are a total of 256 distinct elementary cellular automata.

CAEvolveList[ElementaryRule[num_Integer], init_List, t_Integer] := 
      With[{rbits = IntegerDigits[num, 2, 8]}, 
        NestList[ElementaryCAStep[rbits, #1]&, init, t]]

ElementaryCAStep[rbits_List, a_List] := 
      rbits[[8 - 
          (RotateLeft[a] + 2 (a + 2 RotateRight[a]))
            ]]

ElementaryCAStep = 
      Compile[{{rbits, _Integer, 1}, {a, _Integer, 1}}, 
        rbits[[8 - 
            (RotateLeft[a] + 2 (a + 2 RotateRight[a]))
              ]]];

CAEvolveList[ElementaryRule[90], CenterList[11, {1}], 5]

Totalistic Cellular Automata

Introduced by Stephen Wolfram in 1983, the totalistic cellular automata are one-dimensional cellular automata in which the rules depend only on the total of the values of the cells in a neighborhood.

CAEvolveList[TotalisticRule[num_Integer, k_Integer], init_List, 
        t_Integer] := 
      With[{rbits = Reverse[IntegerDigits[num, k, 1 + 3 (k - 1)]]}, 
        NestList[TotalisticCAStep[rbits, #1]&, init, t]]

TotalisticCAStep[rbits_List, a_List] := 
      rbits[[1 + RotateLeft[a] + a + 
          RotateRight[a]]]

TotalisticCAStep = 
      Compile[{{rbits, _Integer, 1}, {a, _Integer, 1}}, 
        rbits[[1 + RotateLeft[a] + a + 
            RotateRight[a]]]];

CAEvolveList[TotalisticRule[num_Integer, k_Integer, r_Integer], 
        init_List, t_Integer] := 
      With[{rbits = 
            Reverse[IntegerDigits[num, k, 1 + (2  r + 1) (k - 1)]]}, 
        NestList[ExtendedTotalisticCAStep[rbits, r, #1]&, init, t]]

ExtendedTotalisticCAStep[rbits_List, a_List] := 
      rbits[[1 + 
          (∑_(i = -r)^r) RotateLeft[a, i]]]

ExtendedTotalisticCAStep = 
      Compile[{{rbits, _Integer, 1}, {r, _Integer}, {a, _Integer, 1}}, 
        rbits[[1 + 
            (∑_(i = -r)^r) RotateLeft[a, i]]]];

General Cellular Automata

One can use Mathematica transformation rules to set up general one-dimensional cellular automata. The rules specify how each neighborhood should be transformed by the evolution at each step.

CAEvolveList[GeneralRule[rules_, r_Integer], init_List, t_Integer] := 
      With[{dr = Dispatch[rules]}, 
        NestList[GeneralCAStep[dr, r, #1]&, init, t]]

GeneralCAStep[dr_, r_Integer,  a_List] := 
      Replace[#, dr]&/@
        Partition[Join[Take[a, -r], a, Take[a, r]], 2 r + 1, 1]

CAEvolveList[
      GeneralRule[{{1, _, 1} -> 0, {1, _, 0} -> 1, {0, _, 1} 
            -> 1, {0, _, 0} -> 0}, 1], CenterList[11, {1}], 5]

Visualization Functions

CAGraphics[history_List] := 
      Graphics[Raster[1 - Reverse[history]], AspectRatio -> Automatic]

CAGraphics[history_List, k_Integer] := 
      Graphics[Raster[1 - N[Reverse[history]]/(k - 1)], 
        AspectRatio -> Automatic]

ColorCAGraphics[history_List, k_Integer] := 
      Graphics[RasterArray[Map[Hue, N[Reverse[history]/k], {-1}]], 
        AspectRatio -> Automatic]

Examples of Cellular Automaton Behavior

Show[
        CAGraphics[
          CAEvolveList[ElementaryRule[250], CenterList[15, {1}], 7]]];

Show[
      CAGraphics[CAEvolveList[ElementaryRule[90], CenterList[15, {1}], 7]]];

Show[
      CAGraphics[
        CAEvolveList[ElementaryRule[90], CenterList[101, {1}], 50]]];

Show[
      CAGraphics[
        CAEvolveList[ElementaryRule[150], CenterList[101, {1}], 50]]];

Show[
      CAGraphics[CAEvolveList[ElementaryRule[30], CenterList[21, {1}], 10]]];

Show[
      CAGraphics[
        CAEvolveList[ElementaryRule[30], CenterList[101, {1}], 50]]];

Show[
      CAGraphics[
        CAEvolveList[ElementaryRule[73], CenterList[101, {1}], 50]]];

Show[
      CAGraphics[
        CAEvolveList[ElementaryRule[110], Join[Table[0, {200}], {1, 0}], 
          200]]];

Show[
      ColorCAGraphics[
        CAEvolveList[TotalisticRule[777, 3], CenterList[101, {1}], 50], 3]];

Show[
      ColorCAGraphics[
        CAEvolveList[TotalisticRule[1635, 3], CenterList[101, {2}], 50], 3]];

Show[
      ColorCAGraphics[
        CAEvolveList[TotalisticRule[1599, 3], CenterList[101, {1}], 400], 
        3]];

capix[i_] := 
      Graphics[Raster[
          1 - Reverse[
              CAEvolveList[ElementaryRule[i], CenterList[53, {1}], 25]]], 
        Frame -> True, FrameTicks -> False, 
        AspectRatio -> Automatic]

Show[GraphicsArray[Partition[Table[capix[i], {i, 0, 128, 2}], 4]]];

Sounds of Cellular Automata

PlayRow[list_] := 
      Play[Evaluate[
          Plus@@Flatten[
              (Sin[1000 #1 t]&)/@
                N[(2^(1/12))]^Position[list, 1]]], {t, 0, 0.2}]

PlayRow/@CAEvolveList[ElementaryRule[150], CenterList[43, {1}], 20];