Rule 30

Author

Eric W. Weisstein
August 31, 2016

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

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

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

Initialization

rule=30;

Plot

V5

ElementaryCADiagram[rule]

V6

ElementaryCADiagram[rule]

V11

RulePlot[CellularAutomaton[30]]

RulePlot[CellularAutomaton[30],{{1},0},15,Mesh->True,PlotLegends->"Icon"]

Variants

ElementaryCAVariants[rule]

Evolution

Show[PixelPerfect[
ElementaryCellularAutomaton[30,250],Mesh->False]]//Timing

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

With[{n=10},MapIndexed[Take[#1,n+{2-#2[[1]],#2[[1]]}]&,CellularAutomaton[30,{{1},0},n]]]

Different Implementations

WhiteGaps1[n_,rule_:30]:=Join[
{0,0},
Drop[
Max[(Length/@DeleteCases[Split[#],{1,___}])]&/@(MapIndexed[Take[#1,n+{2-#2[[1]],#2[[1]]}]&,CellularAutomaton[rule,{{1},0},n]]),
2]
]

Take[gaps=WhiteGaps1[10000],100]//Timing

WhiteGaps2[n_,rule_:30]:=Join[
{0,0},
Drop[
Max[Length/@DeleteCases[Take[Split[#],{2,-2}],{1,___}]]&/@CellularAutomaton[rule,{{1},0},n],
2]
]

Take[gaps=WhiteGaps2[10000],100]//Timing

WhiteGaps3[n_,rule_:30]:=Join[
{0,0},
Drop[
Max[Length/@DeleteCases[Take[Split[#],{2,-2}],_?(First[#]==1&)]]&/@CellularAutomaton[rule,{{1},0},n],
2]
]

Take[gaps=WhiteGaps3[10000],100]//Timing

WhiteGaps4[n_,rule_:30]:=Join[
{0,0},
Drop[
Max[(Length/@DeleteCases[Split[#],_?(First[#]==1&)])]&/@(MapIndexed[Take[#1,n+{2-#2[[1]],#2[[1]]}]&,CellularAutomaton[rule,{{1},0},n]]),
2]
]

Take[gaps=WhiteGaps4[10000],100]//Timing

Best Implementation

WhiteGaps[n_,rule_:30]:=Join[
{0,0},
Drop[
Max[(Length/@DeleteCases[Split[#],{1,___}])]&/@(MapIndexed[Take[#1,n+{2-#2[[1]],#2[[1]]}]&,CellularAutomaton[rule,{{1},0},n]]),
2]
]

Take[gaps=WhiteGaps[10000],100]//Timing

Take[gaps=WhiteGaps[15000],100]//Timing

hwm={First[#],Last[#]-1}&[HighWaterMarks[gaps]]

Table[2^n,{n,13}]

Kovas

l=Map[Max[Total/@Split[#]]&,CellularAutomaton[30,{{1},0},1024]];//Timing

ListPlot[l]

l3=Module[{themax=0},Position[l,x_/;If[x>themax,themax=x;True,False]]]

v5.1

ArrayPlot[MapAt[Flatten@With[{split=Split[#]},With[{t=Max[Total/@split]},split/.{l___,y_/;Total[y]===t,r___}:>{l,y+1,r}]]&,CellularAutomaton[30,{{1},0},257],{{1},{2},{4},{8},{16},{32},{43},{46},{64},{128},{256}}],ColorRules->{1->Black,2->Red}]

Rowland Sequence

RightBlacks[n_,rule_:30]:=
Flatten[Position[#,0,1,1]&/@Reverse/@(MapIndexed[Take[#1,n+{1-#2[[1]],#2[[1]]}]&,CellularAutomaton[rule,{{1},0},n]])]-1

l=RightBlacks[100]

{First[#],Last[#]-1}&@HighWaterMarks[RightBlacks[1024]]

Union[RightBlacks[1000]]

Take[RightBlacks[100],{2,-1,2}]

<<Graphics`Colors`

ListPlot[RightBlacks[64],PlotRange->All,PlotStyle->{PointSize[.02],Red},AxesOrigin->{0,0},AxesLabel->TraditionalForm/@{n,b[n]}]

v5.1

ArrayPlot[ElementaryCellularAutomaton[225,100]]

Union[l]

Position[l,1]//Flatten

2

Position[l,3]//Flatten

2^2

Position[l,4]//Flatten

2^3

Position[l,6]//Flatten

2^4

Position[l,7]//Flatten

2^5

Position[l,9]//Flatten

2^6

Triangle of Values

ColumnForm[t=ElementaryCATriangle[rule,5],Center]

FromDigits/@t

Flatten[t]

Represented in Decimal

ElementaryCATriangle[rule,10]

FromDigits[#,2]&/@%

FindSequenceFunction[%,n]

Central Column

l1=CellularAutomaton[30,{{1},0},101,{All,{0}}]//Flatten

l=Flatten[CellularAutomaton[30,{{1},0},1001,{All,{0}}]];//Timing

Take[nums=FromDigits[#,2]&/@Reverse[NestList[Most,l,Length[l]]],20]//Timing

Select[nums,PrimeQ]//Timing

Number of Black Cells

Plus@@@ElementaryCATriangle[rule,50]

Fit[Plus@@@ElementaryCATriangle[rule,5000],{1,x},x]//Timing

Fit[Plus@@@ElementaryCATriangle[rule,7500],{1,x},x]//Timing

<<Utilities`Plot`

IntegerListPlot[Plus@@@ElementaryCATriangle[rule,100],AxesLabel->TraditionalForm/@{n,b[n]}]

ListPlot[Plus@@@ElementaryCATriangle[rule,1000]-Range[1001],PlotStyle->Red]