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
NewScience > FollowOnInitiatives > SummerSchool > 2007 >
[ Old bulletin had the rule transcribed wrong! ]
[ Old bulletin had the rule transcribed wrong! ]
In[]:=
TSPatternEvolve2[init_,t_]:=With[{ru=Dispatch[{{0,_,s___}{s,1},{1,_,s___}{s,1,1,0}}]},NestList[Replace[#,ru]&,init,t]]
In[]:=
ListStepPlot[Length/@TSPatternEvolve2[{1,0},100]]
Out[]=
In[]:=
ListStepPlot[Differences[Length/@TSPatternEvolve2[{1,0},100]]]
Out[]=
Note: it cannot eliminate 1s.....
In[]:=
ListStepPlot[MapIndexed[#1-(Sqrt[2]-1)First[#2]&,Length/@TSPatternEvolve2[{1,0},100]]]
Out[]=
In[]:=
ListStepPlot[MapIndexed[#1-(Sqrt[2]-1)First[#2]&,Length/@TSPatternEvolve2[{1,0},1000]]]
Out[]=
In[]:=
ListStepPlot[MapIndexed[#1-(Sqrt[2]-1)First[#2]&,Length/@TSPatternEvolve2[{1,0},10000]]]
Out[]=
In[]:=
TSPatternEvolve2[{1,0},100]//Last
Out[]=
{0,1,1,1,0,1,1,0,1,1,0,1,1,0,1,1,0,1,1,0,1,1,1,0,1,1,0,1,1,1,0,1,1,1,0,1,1,1,0,1,1,0,1,1,0,1,1,0}
No 1 is isolated.... Every 0 is isolated.
Does this ever terminate? Any time you have a 1, it always produces another....
From 2007:
From 2007:
In[]:=
TagStepX[list_]:=If[Length[list]<2,{},Join[Drop[list,2],{{0,1},{1,0,0}}[[list[[1]]+1]]]]
TagLengthFunction[{2,{{1},{1,1,0}}}]
CompiledFunction[{init,steps},Module[{len$,state$,lengths$=Table[0,{steps}]},state$=init;Do[len$=Length[state$];lengths$〚i〛=len$;If[len$<2,state$={1},If[state$〚1〛===0,state$=Join[Drop[state$,2],{1}],state$=Join[Drop[state$,2],{1,1,0}]]],{i,steps}];lengths$],-CompiledCode-]
In[]:=
NestList[TagStepX,{1,0,0},20]
Out[]=
{{1,0,0},{0,1,0,0},{0,0,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1},{0,1,0,1}}