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 »
WOLFRAM NOTEBOOK
In[]:=
Module{deep=5000,cut=200,ru,life,evo,all,data,res},all=MapSeedRandom[#];evo=NestListCompoundExpressionru=[First[#]],life=[ru,cut],If[life>=Last[#],{ru,life},#]&,{{0,3,1},1},deep;evo=First/@SplitBy[evo,Last];evo&,{426888,426788};AppendTo[all,MapAt[{#,3,1}&,#,1]&/@{{0,1},{54,1},{1699400088108,2},{4670237948820,5},{2722323165603,6},{4463167165719,11},{4464329427186,17},{4464458626398,29},{2906889909000,38},{2905727647290,67},{2602407332391,121},{3606720814104,134},{2759432204661,244},{4359737104557,444},{4359737106744,723}}];res=MapCompoundExpressiondata=CellularAutomaton[First[#],{{1},0},Last[#]+4],data=ArrayPad[#,2]&/@data,ArrayPlotdata,ColorRules->["Colors"],FrameStyle->GrayLevel[.65],ImageSize->{Automatic,20Sqrt[Length[data]+1]}&,#&/@all;Column[Map[Row[#,Spacer[.2]]&,res],Dividers->{False,Thread[Range[2,3]->LightGray]},Spacings->2]
In[]:=
Module{deep=5000,cut=200,ru,life,evo,all,data,res},all=ParallelMapSeedRandom[#];evo=NestListCompoundExpressionru=[First[#]],life=[ru,cut],If[life>=Last[#],{ru,life},#]&,{{0,3,1},1},deep;evo=First/@SplitBy[evo,Last];evo&,{426888,426788}
(kernel 2)
(kernel 2)
(kernel 2)
(kernel 2)
Out[]=
{{{{0,3,1},1},{{5046703516296,3,1},2},{{4734179948004,3,1},4},{{4734181365261,3,1},5},{{6491533871292,3,1},6},{{3949668082329,3,1},9},{{1214867086188,3,1},11},{{6298598742846,3,1},16},{{5639596491543,3,1},24},{{5545453312716,3,1},34},{{5548940097117,3,1},47},{{6396228706560,3,1},97}},{{{0,3,1},1},{{353849838693,3,1},4},{{3298093917531,3,1},5},{{5683070390829,3,1},6},{{5682803076006,3,1},7},{{5874552362427,3,1},9},{{5875847070801,3,1},19},{{5844454496637,3,1},25},{{5844338111058,3,1},162}}}
In[]:=
MapCompoundExpressiondata=CellularAutomaton[First[#],{{1},0},Last[#]+4],data=ArrayPad[#,2]&/@data,ArrayPlotdata,ColorRules->["Colors"],FrameStyle->GrayLevel[.65],ImageSize->{Automatic,20Sqrt[Length[data]+1]}&,#&/@%99
Out[]=
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
,
In[]:=
Length/@(Counts/@(Partition[#,3,1]&/@CellularAutomaton[{6396228706560,3,1},{{1},0},100]))
Out[]=
{4,6,6,8,8,10,8,9,9,11,8,10,9,12,11,10,10,11,12,11,10,13,12,10,10,13,12,11,11,15,13,13,10,13,12,15,14,14,14,15,13,13,11,14,15,15,13,15,15,16,16,15,12,12,11,13,13,18,14,14,14,15,12,11,10,13,15,13,13,9,10,12,13,12,11,11,13,13,9,11,10,12,12,11,11,11,12,9,10,7,7,8,8,8,5,7,4,1,1,1,1}
In[]:=
ListLinePlot[%]
Out[]=
In[]:=
Partition[#,3,1]&/@CellularAutomaton[{6396228706560,3,1},{{1},0},5]
Out[]=
{{{0,0,0},{0,0,1},{0,1,0},{1,0,0},{0,0,0}},{{0,0,2},{0,2,2},{2,2,2},{2,2,0},{2,0,0}},{{0,0,1},{0,1,2},{1,2,1},{2,1,0},{1,0,0}},{{0,2,2},{2,2,1},{2,1,2},{1,2,2},{2,2,0}},{{0,1,1},{1,1,1},{1,1,2},{1,2,1},{2,1,0}},{{2,1,1},{1,1,0},{1,0,1},{0,1,2},{1,2,2}}}
In[]:=
FoldList[Union,%110]
Out[]=
{{{0,0,0},{0,0,1},{0,1,0},{1,0,0},{0,0,0}},{{0,0,0},{0,0,1},{0,0,2},{0,1,0},{0,2,2},{1,0,0},{2,0,0},{2,2,0},{2,2,2}},{{0,0,0},{0,0,1},{0,0,2},{0,1,0},{0,1,2},{0,2,2},{1,0,0},{1,2,1},{2,0,0},{2,1,0},{2,2,0},{2,2,2}},{{0,0,0},{0,0,1},{0,0,2},{0,1,0},{0,1,2},{0,2,2},{1,0,0},{1,2,1},{1,2,2},{2,0,0},{2,1,0},{2,1,2},{2,2,0},{2,2,1},{2,2,2}},{{0,0,0},{0,0,1},{0,0,2},{0,1,0},{0,1,1},{0,1,2},{0,2,2},{1,0,0},{1,1,1},{1,1,2},{1,2,1},{1,2,2},{2,0,0},{2,1,0},{2,1,2},{2,2,0},{2,2,1},{2,2,2}},{{0,0,0},{0,0,1},{0,0,2},{0,1,0},{0,1,1},{0,1,2},{0,2,2},{1,0,0},{1,0,1},{1,1,0},{1,1,1},{1,1,2},{1,2,1},{1,2,2},{2,0,0},{2,1,0},{2,1,1},{2,1,2},{2,2,0},{2,2,1},{2,2,2}}}
Want to get counts of each case......
[[ Some patterns might repeat, but offset ]]
[[ At least at the beginning, it always has to use the same rule elements to get to the same pattern of bits ]]
More rules
More rules
All the rules: