Workshop on Computer Experiments

NKS 2003 conference, Saturday June 28

Øyvind Tafjord, Wolfram Research

In this workshop we'll take a look at the range-2 totalistic cellular automata and see if we can find something interesting. Try evaluating the code below to get some ideas, and then play around with modifying it to look at different rules, etc.

If you find something interesting along the way, stop and explore it, trying variations. Don't worry about going through the whole notebook.

First we need a function to show cellular automaton graphics, let's copy the one from the Help Browser (under CellularAutomaton, Further Examples). To evaluate each piece of code, put the cursor anywhere inside the cell and hit Shift-Enter  (or Shift-Return):

RasterGraphics[state_?MatrixQ, colors_Integer : 2, opts___] := 
      Graphics[Raster[Reverse[1 - (state/(colors - 1))]], 
        AspectRatio -> (AspectRatio /. {opts} /. 
              AspectRatio -> Automatic), opts]

The basic evolution of a range-2, 2-color totalistic CA, can then be done as follows.

Show[
      RasterGraphics[
        CellularAutomaton[{30, {2, 1}, 2}, {{1}, 0}, 
          20, {All, All}]]]

Feel free to play around with the rule number, initial condition and number of steps in the above code. (Extremely useful trick: Press CTRL-L when the cursor is between cells to automatically duplicate the last input cell, so that you can preserve your previous experiment).

A common NKS research method is to make a plot of all the rules (make sure to drag and resize the graphics so you can see what's going on):

Show[
      GraphicsArray[
        Partition[
          Table[RasterGraphics[
              CellularAutomaton[{i, {2, 1}, 2}, {{1}, 0}, 30, {All, All}], 
              PlotLabel -> i], {i, 0, 63}], 4]]]

Here's a different view where we zoom in on the middle part of the evolution:

Show[
      GraphicsArray[
        Partition[
          Table[RasterGraphics[
              CellularAutomaton[{i, {2, 1}, 2}, {{1}, 0}, 
                80, {All, {-20, 20}}], PlotLabel -> i], {i, 0, 63}], 
          16]]]

Here's a possible question to look at: Which of these have a random center column?

First of all, how do we get the just the center column of the CA:

Flatten[
      CellularAutomaton[{18, {2, 1}, 2}, {{1}, 0}, 
        80, {All, {0, 0}}]]

Let's make that a function that we can study:

CenterColumn[rule_, steps_] := 
      Flatten[CellularAutomaton[{rule, {2, 1}, 2}, {{1}, 0}, 
          steps, {All, {0, 0}}]]

CenterColumn[50, 20]

One way to test if it's random is to arrange it into an array of 1's and 0's and plot it. For instance:

Show[RasterGraphics[Partition[CenterColumn[18, 50^2], 50]]]

Looks pretty random. Let's try it for all the rules:

Show[
      GraphicsArray[
        Partition[
          Table[RasterGraphics[Partition[CenterColumn[i, 50^2], 50], 
              PlotLabel -> i], {i, 0, 63}], 8]]]

Many are clearly not random, but some are definitely random looking. Let's examine code 49 in some more detail:

Show[
      RasterGraphics[Partition[CenterColumn[49, 100^2], 100]]]

Looks fairly random to me... Can we plot this in another way? What about plotting the 0's and 1's in a ListPlot?

ListPlot[CenterColumn[49, 300], PlotJoined -> True]

Hmmm, not incredibly useful. Perhaps if we sum up the number of black cells as we go down... This can be done efficiently with FoldList:

CenterColumn[49, 10]

FoldList[Plus, 0, CenterColumn[49, 10]]

ListPlot[FoldList[Plus, 0, CenterColumn[49, 1000]], 
      PlotJoined -> True]

OK, that doesn't look all that random, but let's zoom in some:

ListPlot[FoldList[Plus, 0, CenterColumn[49, 100]], 
      PlotJoined -> True]

Perhaps we should get rid of the overall increase of the function. What is the slope of the line?

Fold[Plus, 0, CenterColumn[49, 10000]]/10000.

That sounds like 3/4 to me, indicating the 3/4 of the cells in the center column is black. So it's definitely not 50-50 black/white randomness, but perhaps something close to 75/25? The following code will subtract that overall steady increase of 3/4, leaving the residue for study:

With[{steps = 1000}, 
      ListPlot[FoldList[Plus, 0, CenterColumn[49, steps]] - 
          3/4 * Range[0, steps + 1], PlotJoined -> True]]

Aha! Now this definitely looks random... What about more steps?

With[{steps = 10000}, 
      ListPlot[FoldList[Plus, 0, CenterColumn[49, steps]] - 
          3/4 * Range[0, steps + 1], PlotJoined -> True]]

Interesting, it's still random looking, but somehow heading upwards. Will that continue?

With[{steps = 20000}, 
      ListPlot[FoldList[Plus, 0, CenterColumn[49, steps]] - 
          3/4 * Range[0, steps + 1], PlotJoined -> True]]

Hm, it seems to continue, although the effect is small. Is there really slightly more than 75% black cells in the center column if we keep going?

We might soon start to run out of memory though, so might need to be smarter about how to calculate the center column, perhaps by restricting to finite width:

With[{steps = 1000, width = 4000}, 
      ListPlot[FoldList[Plus, 0, 
            Flatten[CellularAutomaton[{49, {2, 1}, 2}, 
                ReplacePart[Table[0, {width}], 1, Ceiling[width/2]], 
                steps, {All, {Ceiling[width/2] - 1, 
                    Ceiling[width/2] - 1}}]]] - 3/4 Range[0, steps + 1], 
        PlotJoined -> True]]

This is the same as 1000 steps above, but if we increase the steps while keeping the width small, we will probably run into finite size effects as well:

With[{steps = 20000, width = 4000}, 
      ListPlot[FoldList[Plus, 0, 
            Flatten[CellularAutomaton[{49, {2, 1}, 2}, 
                ReplacePart[Table[0, {width}], 1, Ceiling[width/2]], 
                steps, {All, {Ceiling[width/2] - 1, 
                    Ceiling[width/2] - 1}}]]] - 3/4 Range[0, steps + 1], 
        PlotJoined -> True]]

With[{steps = 200000, width = 4000}, 
      ListPlot[FoldList[Plus, 0, 
            Flatten[CellularAutomaton[{49, {2, 1}, 2}, 
                ReplacePart[Table[0, {width}], 1, Ceiling[width/2]], 
                steps, {All, {Ceiling[width/2] - 1, 
                    Ceiling[width/2] - 1}}]]] - 3/4 Range[0, steps + 1], 
        PlotJoined -> True]]

Wow. Looks like a pretty persistent effect if we trust this plot (since it's finite width perhaps we shouldn't). According to this, there isn't exactly 75% black, the percentage is more like

75.  + 1750/200000

A very small, strange effect if it's really there...

Here's an extreme example of the finite width kicking in:

With[{steps = 2000, width = 100}, 
      ListPlot[FoldList[Plus, 0, 
            Flatten[CellularAutomaton[{49, {2, 1}, 2}, 
                ReplacePart[Table[0, {width}], 1, Ceiling[width/2]], 
                steps, {All, {Ceiling[width/2] - 1, 
                    Ceiling[width/2] - 1}}]]] - 3/4 Range[0, steps + 1], 
        PlotJoined -> True]]

What happened?

With[{steps = 2000, width = 100}, 
      Show[RasterGraphics[
          CellularAutomaton[{49, {2, 1}, 2}, 
            ReplacePart[Table[0, {width}], 1, Ceiling[width/2]], steps]], 
        ImageSize -> 100]]

Aha! It hit a repetitive state, definitely not random anymore!

More questions to be answered: When doing many steps, will on average 75% be black?. What about other rules?
What about other systems?