Additive Cellular Automaton

Author

Eric W. Weisstein
April 15, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/CellularAutomata/AdditiveCellularAutomaton.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/AdditiveCellularAutomaton.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Code

Shift[c_,n_,0]:=Table[0,Evaluate[Sequence@@(List/@Dimensions[c])]]
Shift[c_,n_,steps_]:=Module[{d=Dimensions[c]},
PadRight[PadLeft[Drop[#,-n],d[[2]]]&/@Take[c,steps],d]
]

Additive Cases

rules=Flatten[Outer[List,Sequence@@Table[{1,0},{3}]],2]

Number of rules with k colors and range r

With[{k=2,r=1},k^(k^(2 r+1))]

The rules corresponding to sums of neighbors (mod 2)

addlist=Map[FromDigits[#,2]&,
Table[Mod[k#[[1]]+l#[[2]]+m#[[3]],2]&/@rules,{k,0,1},{l,0,1},{m,0,1}],
{3}]

Table[{i,j,k},{i,0,1},{j,0,1},{k,0,1}]

additive=Sort[Flatten[addlist]]

There should be (k^(2r+1))of these

Length[additive]

With[{k=2,r=1},k^(2 r+1)]

Check them

{#2@@Array[c,3,-1],#1,IntegerDigits[#1,2,8],
#2@@@rules,FromDigits[#2@@@rules,2]}&@@@{
{0,0&},
{60,Mod[#1+#2,2]&},
{90,Mod[#1+#3,2]&},
{102,Mod[#2+#3,2]&},
{150,Mod[#1+#2+#3,2]&},
{170,Mod[#3,2]&},
{204,Mod[#2,2]&},
{240,Mod[#1,2]&}
}/.c[x_]:>Subscript[c,x]//ColumnForm

Timing[all=Show/@With[{g=32},
Table[
GraphicsArray[
Partition[
RasterGraphics[
CellularAutomaton[#,{
ReplacePart[
Table[0,{2g+1}],1,{{g+1},{s+g+1}}
],0},g,{All,{0,2g+1}}
],
PlotLabel->#
]&/@additive,
4]
],
{s,-g,g}]
]]

Export[gifs<>"addcell.gif",all,ImageSize->600]//Timing

Rule 90

Rule Panel

Show[Graphics[ElementaryCADiagram[90]],AspectRatio->Automatic,PlotRange->All]

Shifted One Generation at a Time

(add90its=With[{g=31,maxshift=3},
c=CellularAutomaton[90,{{1} ,0},g,{All,All}];
Table[Show[GraphicsArray[
Prepend[
Table[
RasterGraphics[Mod[c+Shift[c,s,k],2],PlotLabel->TraditionalForm["\!\(\*
StyleBox[\(Δ\*
StyleBox[\"x\",\nFontSlant->\"Italic\"]\)]\) = "<>ToString[s]]],
{s,maxshift}
],
RasterGraphics[c,PlotLabel->"base"]
],GraphicsSpacing->-.15
]],{k,0,g+1}]
])//Timing

Export[gifs<>"add90its.gif",add90its,ImageSize->600]//Timing

Show[GraphicsArray[List/@Take[add90its,{1,20,5}]]]

As a Function of Shift

Timing[
add90sh=With[{g=32},
c=CellularAutomaton[90,{{1} ,0},g,{All,All}];
Show/@Prepend[
Table[RasterGraphics[c+Shift[c,s,g]],{s,64}],
Show[RasterGraphics[c]]
]
]
]

Export[gifs<>"add90sh.gif",add90sh]//Timing

Show[GraphicsArray[Partition[Take[add90sh,20],5]]]

Rule 250

Rule Panel

Show[Graphics[ElementaryCADiagram[250]],AspectRatio->Automatic,PlotRange->All]

Shifted One Generation at a Time

(add250its=With[{g=31,maxshift=3},
c=CellularAutomaton[250,{{1} ,0},g,{All,All}];
Table[Show[GraphicsArray[
Prepend[
Table[
RasterGraphics[
MapThread[BitOr,{c,Shift[c,s,k]}],PlotLabel->TraditionalForm["\!\(\*
StyleBox[\(Δ\*
StyleBox[\"x\",\nFontSlant->\"Italic\"]\)]\) = "<>ToString[s]]
],
{s,maxshift}
],
RasterGraphics[c,PlotLabel->"base"]
],GraphicsSpacing->-.15
]],{k,0,g+1}]
])//Timing

Export[gifs<>"add250its.gif",add250its,ImageSize->600]//Timing

Show[GraphicsArray[List/@Take[add250its,{1,20,5}]]]

As a Function of Shift

Timing[
add250sh=With[{g=32},
Show[#,AspectRatio->Automatic]&/@RasterGraphics/@Table[CellularAutomaton[250,{Join[{1},Table[0,{s}],{1}] ,0},g,{All,{-32,32}}],{s,64}]
]
]

Export[gifs<>"add250sh.gif",add250sh]//Timing

Show[GraphicsArray[Partition[Take[add250sh,20],5]]]