WOLFRAM NOTEBOOK

{k=3, r=1}

In[]:=
3^3^3
Out[]=
7625597484987

{k=2, r=2}

In[]:=
2^2^5
Out[]=
4294967296

{k=2, r=3/2}

In[]:=
2^2^4
Out[]=
65536

{k=3, r=3/2}

In[]:=
3^3^4
Out[]=
443426488243037769948249630619149892803

k=2, r=1

In[]:=
Table[n->FirstPosition[Total/@CellularAutomaton[n,{{1},0},{20,All}],0],{n,0,255,2}]
Out[]=
{0{2},2Missing[NotFound],4Missing[NotFound],6Missing[NotFound],8{2},10Missing[NotFound],12Missing[NotFound],14Missing[NotFound],16Missing[NotFound],18Missing[NotFound],20Missing[NotFound],22Missing[NotFound],24Missing[NotFound],26Missing[NotFound],28Missing[NotFound],30Missing[NotFound],32{2},34Missing[NotFound],36Missing[NotFound],38Missing[NotFound],40{2},42Missing[NotFound],44Missing[NotFound],46Missing[NotFound],48Missing[NotFound],50Missing[NotFound],52Missing[NotFound],54Missing[NotFound],56Missing[NotFound],58Missing[NotFound],60Missing[NotFound],62Missing[NotFound],64{2},66Missing[NotFound],68Missing[NotFound],70Missing[NotFound],72{2},74Missing[NotFound],76Missing[NotFound],78Missing[NotFound],80Missing[NotFound],82Missing[NotFound],84Missing[NotFound],86Missing[NotFound],88Missing[NotFound],90Missing[NotFound],92Missing[NotFound],94Missing[NotFound],96{2},98Missing[NotFound],100Missing[NotFound],102Missing[NotFound],104{2},106Missing[NotFound],108Missing[NotFound],110Missing[NotFound],112Missing[NotFound],114Missing[NotFound],116Missing[NotFound],118Missing[NotFound],120Missing[NotFound],122Missing[NotFound],124Missing[NotFound],126Missing[NotFound],128{2},130Missing[NotFound],132Missing[NotFound],134Missing[NotFound],136{2},138Missing[NotFound],140Missing[NotFound],142Missing[NotFound],144Missing[NotFound],146Missing[NotFound],148Missing[NotFound],150Missing[NotFound],152Missing[NotFound],154Missing[NotFound],156Missing[NotFound],158Missing[NotFound],160{2},162Missing[NotFound],164Missing[NotFound],166Missing[NotFound],168{2},170Missing[NotFound],172Missing[NotFound],174Missing[NotFound],176Missing[NotFound],178Missing[NotFound],180Missing[NotFound],182Missing[NotFound],184Missing[NotFound],186Missing[NotFound],188Missing[NotFound],190Missing[NotFound],192{2},194Missing[NotFound],196Missing[NotFound],198Missing[NotFound],200{2},202Missing[NotFound],204Missing[NotFound],206Missing[NotFound],208Missing[NotFound],210Missing[NotFound],212Missing[NotFound],214Missing[NotFound],216Missing[NotFound],218Missing[NotFound],220Missing[NotFound],222Missing[NotFound],224{2},226Missing[NotFound],228Missing[NotFound],230Missing[NotFound],232{2},234Missing[NotFound],236Missing[NotFound],238Missing[NotFound],240Missing[NotFound],242Missing[NotFound],244Missing[NotFound],246Missing[NotFound],248Missing[NotFound],250Missing[NotFound],252Missing[NotFound],254Missing[NotFound]}
In[]:=
Table[If[MissingQ[#[[2]]],Nothing,#]&[n->FirstPosition[Total/@CellularAutomaton[n,{{1},0},{20,All}],0]],{n,0,255,2}]
Out[]=
{0{2},8{2},32{2},40{2},64{2},72{2},96{2},104{2},128{2},136{2},160{2},168{2},192{2},200{2},224{2},232{2}}
In[]:=
Monitor[Table[IntegerDigits[2i-1,2]->Counts[ParallelTable[If[MissingQ[#],Nothing,#]&[FirstPosition[Total/@CellularAutomaton[{n,2,1},{IntegerDigits[2i-1,2],0},{20,All}],0]],{n,0,2^2^3-1,2}]],{i,100}],i]
Out[]=
In[]:=
Max[Keys[#]]&/@Values[%]
Out[]=
{2,3,3,4,2,5,5,5,2,3,4,6,3,5,6,6,2,3,3,4,3,7,5,6,3,3,7,6,4,6,6,7,2,3,3,4,2,5,5,5,3,3,5,6,5,6,6,7,3,3,3,4,5,7,6,7,4,4,6,7,5,7,7,8,2,3,3,4,2,5,5,5,2,3,4,6,3,5,6,6,3,3,3,4,4,6,6,7,5,4,6,7,6,7,7,8,3,3,3,4}
In[]:=
ListLinePlot[%]
Out[]=
In[]:=
Position[%8,8]
Out[]=
{{64},{96}}
In[]:=
Extract[%7,%]
Out[]=
{{1,1,1,1,1,1,1}{2}4,{3}6,{5}2,{8}4,{1,0,1,1,1,1,1,1}{2}1,{3}6,{4}2,{7}2,{5}2,{8}2}
In[]:=
Table[If[MissingQ[#[[2]]],Nothing,#]&[n->FirstPosition[Total/@CellularAutomaton[n,{{1,1,1,1,1,1,1},0},{20,All}],0]],{n,0,255,2}]
Out[]=
{0{2},4{2},8{3},32{2},36{2},40{3},64{3},72{3},96{3},104{3},128{5},136{8},160{5},168{8},192{8},224{8}}
In[]:=
ArrayPlot[CellularAutomaton[#,{{1,1,1,1,1,1,1},0},{10,All}],Mesh->True,ImageSize->Tiny]&/@Keys[%]
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,

k=2, r=3/2

In[]:=
2^2^4
Out[]=
65536
In[]:=
ParallelTable[If[MissingQ[#[[2]]],Nothing,#]&[n->FirstPosition[Total/@CellularAutomaton[{n,2,3/2},{{1},0},{20,All}],0]],{n,0,2^2^4-1,2}]
In[]:=
ReverseSortBy[%,Last]
In[]:=
CountsBy[%22,Last]
Out[]=
{3}256,{2}2048
In[]:=
Select[%22,#[[2]]=={3}&]
Out[]=
In[]:=
First/@Take[%22,10]
Out[]=
{61108,61076,60980,60948,60596,60564,60468,60436,60084,60052}
In[]:=
ArrayPlot[CellularAutomaton[{#,2,3/2},{{1},0},{5,All}],Mesh->True]&/@{20,52}
Out[]=
,
These are r=3/2 rules, so they should shown as bricks.... otherwise they’re asymmetric.
In[]:=
RulePlot[CellularAutomaton[{20,2,3/2}],{{1},0},5,Appearance->"Bricks",Mesh->True]
Out[]=
In[]:=
ParallelTable[If[MissingQ[#[[2]]],Nothing,#]&[n->FirstPosition[Total/@CellularAutomaton[{n,2,3/2},{{1,1},0},{20,All}],0]],{n,0,2^2^4-1,2}]
In[]:=
CountsBy[%,Last]

k=2, r=2

NOTE: the above were cut off too early

Widths

All monotonic:
Check for increase, and that variance remains bounded

k=2, r=5/2

k=3, r=1/2

k=4, r=1/2

This isn’t everything:::

k=5, r=1/2

k=6, r=1/2

k=3, r=1

k=4, r=1

Undecidability

Given a certain number of steps, will there be a rule that achieves it?
Wolfram Cloud

You are using a browser not supported by the Wolfram Cloud

Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.


I understand and wish to continue anyway »

You are using a browser not supported by the Wolfram Cloud. Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.