[JAM] CellularAutomaton Code Jam Wolfram Summer School 2015

[Vitaliyk (Vitaliy Kaurov)]

Wolfram Science Summer School and Wolfram Innovation Summer School are happening now in Boston at Bentley University. The goal of this Code Jam is to post interesting code snippets that fit the Wolfram Language functionality described in detail below. By “interesting” I mean simple programs that generate complex patterns. We will be jamming with our students, but everyone is welcome to join. Let’s have some fun!

In this Code Jam we will take a look at the CellularAutomaton (CA) function and its syntax for rules defined as functions. This may sound a bit confusing, so let’s take a look at some examples. First, if you haven’t yet, you have to make yourself familiar with the CellularAutomaton function. The most well known cases are integer Wolfram indexes for CA rules, for instance for the celebrated rule 30:

ArrayPlot[CellularAutomaton[30, RandomInteger[1, 100], 50]]

But CellularAutomaton can take a function as a rule. Below are some examples. Use an arbitrary symbolic function f as the rule to apply to range-1 neighbors:

CellularAutomaton[{f[#] &, {}, 1}, {a, b, c}, 1]

{{a, b, c}, {f[{c, a, b}], f[{a, b, c}], f[{b, c, a}]}}

Set up a “Pascal’s triangle cellular automaton”:

CellularAutomaton[{f[#] &, {}, 1/2}, {a, b, c}, 1]

{{a, b, c}, {f[{c, a}], f[{a, b}], f[{b, c}]}}

CellularAutomaton[{Total[#] &, {}, 1/2}, {{1}, 0}, 3] 

{{1, 0, 0, 0}, {1, 1, 0, 0}, {1, 2, 1, 0}, {1, 3, 3, 1}}

Additive cellular automaton modulo 4:

ArrayPlot[
 CellularAutomaton[{Mod[Total[#], 4] &, {}, 1}, {{1}, 0}, 50], 
 ColorFunction -> "Rainbow"]

The second argument to the function is the step number:

CellularAutomaton[{f[#1, #2] &, {}, 1}, {a, b, c}, 1]

{{a, b, c}, {f[{c, a, b}, 1], f[{a, b, c}, 1], f[{b, c, a}, 1]}}

CellularAutomaton[{f, {}, 1}, {a, b, c}, 1]

{{a, b, c}, {f[{c, a, b}, 1], f[{a, b, c}, 1], f[{b, c, a}, 1]}}

Change the rule at successive steps; #2 gives the step number:

ArrayPlot[
 CellularAutomaton[{Mod[Total[#] + #2, 4] &, {}, 1}, {{1}, 0}, 30], 
 ColorFunction -> "Rainbow"]

Use continuous values for cells:

ArrayPlot[CellularAutomaton[{Mod[Total[#]/2, 1] &, {}, 1}, {{1}, 0}, 50]]

Manipulate[
 ArrayPlot[
  CellularAutomaton[{Mod[s Total[#], 1] &, {}, 2}, {{1}, 0}, 50],
  ColorFunction -> "Rainbow", PixelConstrained -> 3]
 , {s, .01, .99}]

Try different functions and different initial conditions. They can be strings, numbers, graphics or expressions. Try ArrayPlot but also try other visualization tools like Grid. Try them out. Post code, images, and text comments. You can also comment on other people’s code.

[Vitaliyk (Vitaliy Kaurov)]

If you take a very slowly growing continuous value CA but look very far in its future evolution you can find something interesting

ArrayPlot[
 CellularAutomaton[{Mod[Total[#]/2.96, 1] &, {}, 1}, {{1}, 0}, 
{{1000, 1300}, {-90, 90}}], PixelConstrained -> 2]

[akbariyeh (Ashkan Akbariyeh)]

ArrayPlot[ CellularAutomaton[{Mod[Total[#1]/N[E], #2] &, {}, 1}, {{1}, 0}, {{1000, 1300}, {0, 300}}], PixelConstrained → 1]

[carlogico (Carlo Giacometti)]

Simple function involving the sum of two cosines whose frequencies ratio is the golden ratio.

g[x_] := Abs[Cos[x] + Cos[N[GoldenRatio] x]];
ArrayPlot[CellularAutomaton[{g[Total[#]] &, {}, 1}, {{1}, 0}, 200],ColorFunction -> GrayLevel]

[a00249594 (Juan Arturo Silva-Ordaz)]

Here’s a nested structure from the Standard Deviation of the Square Root of the argument

ArrayPlot[
 CellularAutomaton[{StandardDeviation[#^.5] &, {}, 1}, {{1}, 0}, 25], 
 ColorFunction -> "Rainbow"]

[wenzhenz (Wenzhen Zhu)]

Graphics3D[{Opacity[0.7], RandomColor, Sphere[#]} & /@
Position[CellularAutomaton[{604419492, {3, 1}, {1, 1}}, {{{1}},
0}, {10, All, All}], 1], ViewVertical → {-1, 0, 0}]

[wenzhenz (Wenzhen Zhu)]

NearestNeighborGraph[
Position[CellularAutomaton[{604419492, {3, 1}, {1, 1}}, {{{1}},
0}, {10, All, All}], 1]]

[victorphanvp (Victor Phan)]

ArrayPlot[
CellularAutomaton[{Mod[
Total[FactorInteger[FromDigits[#, 3]][[All, 1]]], 4] &, {},
1}, {{4}, 1}, 400], ColorRules → {1 → White}, ImageSize → Full]

[thuanghjz (Tingting Huang)]

ArrayPlot[CellularAutomaton[{Sin[Total[N@#]] &, {}, 1}, {{1}, 0}, 50],
ColorFunction → “Rainbow”]

[kevinandrewjames (K. James)]

Here are a few I looked at.

ArrayPlot[CellularAutomaton[{Mod[Total[#]^2, 10] &, {}, 1}, {{1}, 0}, 100]]

ArrayPlot@
 CellularAutomaton[{Mod[Total[#] + RandomInteger[{0, 1}],4] /. {0 -> 0, 1 -> 0, 2 -> 1, 3 -> 1} &, {}, 1}, 
                   {{1, 1, 1}, 0}, 200]

ArrayPlot@
 CellularAutomaton[{Sqrt@StandardDeviation[#] &, {}, 1}, {{1.}, 0}, 200]

ImageAdjust@Image[
 CellularAutomaton[{Mod[Tr[#] + Tr[Reverse[#]], 7] &, {},
                   {1, 1}}, {{{1}}, 0}, {{{20}}}]]

[jldohmann (Jesse Dohmann)]

Graphics3D[
Cuboid /@
Position[CellularAutomaton[{123214, {7, 1}, {1, 1}}, {{{1}}, 0},
10], 1],
ViewVertical → {-1, 0, 0}, Background → RGBColor[0.84, 0.92, 1.]]

[Vitaliyk (Vitaliy Kaurov)]

An awesome idea to use a quasi-periodic function ! This is how the function looks plotted:

g[x_] := Abs[Cos[x] + Cos[N[GoldenRatio] x]]
Plot[g[x], {x, 0, 200}, AspectRatio -> 1/5, PlotTheme -> "Scientific", Filling -> Bottom]

[carlogico (Carlo Giacometti)]

If anyone wants more quasiperiodic awesomeness, here’s a superposition of five cosines whose wave vectors form a pentagon (this gives a ten fold symmetry, but if you take any direction you will find no repeating pattern):

PlaneWave[x_List, k_List] := Cos[k.x];
c1 = 1/4*(Sqrt[5] - 1);
c2 = 1/4*(Sqrt[5] + 1);
s1 = 1/4*(Sqrt[10 + 2*Sqrt[5]]);
s2 = 1/4*(Sqrt[10 - 2*Sqrt[5]]);
kvectors = {{0, 1}, {s1, c1}, {s2, -c2}, {-s2, -c2}, {-s1, c1}};
DensityPlot[
 Abs[Total@Map[PlaneWave[{x, y}, #] &, kvectors]], {x, -40, 40}, {y, -40, 40}, 
ColorFunction -> GrayLevel, PlotPoints -> 50]

[Vitaliyk (Vitaliy Kaurov)]

Yes, this is neat. Have you seen this:

Quasicrystal Animation with Mathematica

[sibesh96 (Sibesh Kar)]

Slicing the evolution of 2D Totallistic 3-Color Rule 344373765 across the y-axis and animating the slices resembles a Kraken rising from the sea.

[Vitaliyk (Vitaliy Kaurov)]

You can upload GIFs - I fixed it for you. Very nice. But the point of this Code Jam is to use not integer rule specification — we are using functions as rules — see some code above. Some folks also misunderstood this and there area a few posts with integer rule specification. It is OK - they all look great. But it would be nice to find some cool looking CAs with functions as rules. You should also post code not only the output.

[rowland (Todd Rowland)]

These are all really great. Everyone can keep posting.

I enjoy the expressions like

f[{x_, y_}] := Table[x, {Max[y]}]
Grid[CellularAutomaton[{f[#] &, {}, 1/2}, Range[4], 3]]

which gives

[rowland (Todd Rowland)]

This reminds me of the similar rules from the book, like adding a constant .9 to the mean on p.243

[rowland (Todd Rowland)]

These numerical rules are interesting because they depend on the precision. It appears that the general effect is valid, of having a detailed inner structure. However the exact details are difficult to compute numerically.

Compare with increased precision

g2[x_] := Abs[Cos[x] + Cos[SetPrecision[GoldenRatio, 100]* x]];
ArrayPlot[CellularAutomaton[{g[Total[#]] &, {}, 1}, {{1}, 0}, 200], 
 ColorFunction -> GrayLevel]

[rowland (Todd Rowland)]

This one starts off as nested and then becomes complex, after step 25 it is all complex. Not sure if it has localized structures or not.