Elementary Cellular Automaton

Author

Eric W. Weisstein
January 25, 2009

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

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

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

Code

ElementaryCellularAutomaton[r_,n_]:=CellularAutomaton[r,{{1},0},n]

Usage

CellularAutomaton[30,{{1},0},10]

CellularAutomaton[30,{{1},0},{10,All}]

ArrayPlot[%]

Rule Planel

Show[Graphics[Panel[{0,1,0},0,1],AspectRatio->Automatic,PlotRange->All]]

Show[Graphics[ElementaryCARules[0,{-2,21},1.3]],AspectRatio->Automatic,PlotRange->All,ImageSize->450]

Invariant

Amphichiral

First/@Select[{#,ElementaryCAVariants[#][[1]]}&/@Range[0,255],Equal@@#&]

Self-Complement

First/@Select[{#,ElementaryCAVariants[#][[2]]}&/@Range[0,255],Equal@@#&]

Complemented Mirror Image

First/@Select[{#,ElementaryCAVariants[#][[3]]}&/@Range[0,255],Equal@@#&]

Encoding as an Integer Sequence

FromDigits[#,2]&/@With[{n=10},MapIndexed[Take[#1,n+#2[[1]]{-1,1}+{2,0}]&,ElementaryCellularAutomaton[30,n]]]

IntegerDigits[#,2]&/@%

All

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"
],DisplayFunction->Identity
]&/@Range[0,255],5,5,{1,1},{}
]
]
]

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"],DisplayFunction->Identity
]&/@Range[0,49],5,5,{1,1},{}
]
]
]

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"],DisplayFunction->Identity
]&/@Range[50,99],5,5,{1,1},{}
]
]
]

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"],DisplayFunction->Identity
]&/@Range[100,149],5,5,{1,1},{}
]
]
]

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"],DisplayFunction->Identity
]&/@Range[150,199],5,5,{1,1},{}
]
]
]

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"],DisplayFunction->Identity
]&/@Range[200,255],5,5,{1,1},{}
]
]
]

Examples

rules=Flatten[Transpose[Partition[l={30,54,60,62,90,94,102,110,122,126,150,158,182,188,190,220,222,250},Ceiling[Length[l]/2],Ceiling[Length[l]/2],{1,1},{{}}]]]

V5

Show[GraphicsArray[Partition[
Graphics[{ElementaryCARules[#,{3,2.2},1.3],Text["rule "<>ToString[#],{-3,1},
TextStyle->{FontFamily->"Times",FontSlant->"Italic"}]},
AspectRatio->Automatic,PlotRange->All]&/@rules,2,2,{1,1},{}]
],ImageSize->500,GraphicsSpacing->{-.15,0}
]

Show[GraphicsArray[
Partition[
ArrayPlot[
ElementaryCellularAutomaton[#,15],
Mesh->True,
PlotLabel->StyleForm["rule "<>ToString[#],FontFamily->"Times",FontSlant->"Italic"],DisplayFunction->Identity
]&/@l,3,3,{1,1},{}
]
],ImageSize->500
]

V7

Graphics[ElementaryCARules[30]]

GraphicsGrid[Partition[
Graphics[{ElementaryCARules[#,{3,2.2},1.3],Text["rule "<>ToString[#],{-3,1},
BaseStyle->Italic]},
AspectRatio->Automatic,PlotRange->All]&/@rules,2,2,{1,1},{}],ImageSize->400,Spacings ->{-100,10}]

Particular Rules

Rule 0

IntegerDigits[0,2,8]

Show[Graphics[ElementaryCARules[0],AspectRatio->Automatic],PlotRange->All]

Show[ArrayPlot[ElementaryCellularAutomaton[0,10],Mesh->True]]

Rule 1

IntegerDigits[1,2,8]

Show[Graphics[ElementaryCARules[1],AspectRatio->Automatic]]

Show[ArrayPlot[ElementaryCellularAutomaton[1,10],Mesh->True]]

Rule 7

IntegerDigits[8,2,8]

Show[Graphics[ElementaryCARules[7],AspectRatio->Automatic]]

Show[ArrayPlot[ElementaryCellularAutomaton[7,10],Mesh->True]]

Rule 20

IntegerDigits[20,2,8]

Show[Graphics[ElementaryCARules[20],AspectRatio->Automatic]]

Show[ArrayPlot[ElementaryCellularAutomaton[20,10],Mesh->True]]

Rule 30

IntegerDigits[30,2,8]

Show[Graphics[ElementaryCARules[30],AspectRatio->Automatic],PlotRange->All]

Show[ArrayPlot[ElementaryCellularAutomaton[30,20]]]

Show[ArrayPlot[ElementaryCellularAutomaton[30]]]

Rule 90

IntegerDigits[90,2,8]

Show[Graphics[ElementaryCARules[90],AspectRatio->Automatic]]

Show[ArrayPlot[ElementaryCellularAutomaton[90]]]

Rule 250

IntegerDigits[250,2,8]

Show[Graphics[ElementaryCARules[250],AspectRatio->Automatic]]

Show[ArrayPlot[ElementaryCellularAutomaton[250,5],Mesh->True]]

Rule 254

IntegerDigits[254,2,8]

Show[Graphics[ElementaryCARules[254],AspectRatio->Automatic]]

Show[ArrayPlot[ElementaryCellularAutomaton[254,5],Mesh->True]]

Diagrams

Table[
Export["/Volumes/Data/Troves/MathOzTeX/neweps/ElementaryCARule"<>StringJoin[ToString/@PadLeft[IntegerDigits[n],3]]<>".eps",
ElementaryCARules[n]
]//Timing,
{n,0,255}]

As logic functions

NKS Notes, p. 869

Rule 30

ArrayPlot[ElementaryCellularAutomaton[30,10],Mesh->True]

Clear[a]
a[0,0]=True;
a[0,_]=False;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]]
f[p_,q_,r_]:=Xor[p,Or[q,r]]
ArrayPlot[Boole[Table[a[t,i],{t,0,10},{i,-10,10}]],Mesh->True]

Rule 90

ArrayPlot[ElementaryCellularAutomaton[90,10],Mesh->True]

Clear[a]
a[0,0]=True;
a[0,_]=False;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]]
f[p_,q_,r_]:=Xor[p,r]
ArrayPlot[Boole[Table[a[t,i],{t,0,10},{i,-10,10}]],Mesh->True]

Rule 110

ArrayPlot[ElementaryCellularAutomaton[110,10],Mesh->True]

Clear[a]
a[0,0]=True;
a[0,_]=False;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]]
f[p_,q_,r_]:=Xor[Or[p,q],And[p,q,r]]
ArrayPlot[Boole[Table[a[t,i],{t,0,10},{i,-10,10}]],Mesh->True]

Rule 250

ArrayPlot[ElementaryCellularAutomaton[250,10],Mesh->True]

Clear[a]
a[0,0]=True;
a[0,_]=False;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]]
f[p_,q_,r_]:=Or[p,r]
ArrayPlot[Boole[Table[a[t,i],{t,0,10},{i,-10,10}]],Mesh->True]

Rule 254

ArrayPlot[ElementaryCellularAutomaton[254,10],Mesh->True]

Clear[a]
a[0,0]=True;
a[0,_]=False;
a[t_,i_]:=a[t,i]=f[a[t-1,i-1],a[t-1,i],a[t-1,i+1]]
f[p_,q_,r_]:=Or[p,q,r]
ArrayPlot[Boole[Table[a[t,i],{t,0,10},{i,-10,10}]],Mesh->True]