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[]:=
AllInits[count_] := Tuples[{Range[0, 2], IntegerDigits[#, 2, count] & /@ Range[0, 2^count - 1]}]
In[]:=
AllInits[min_ ;; max_] := Catenate[AllInits /@ Range[min, max]]
In[]:=
system8 = PostTagSystem[AllInits[0 ;; 8]]
Out[]=
PostTagSystemEvolution
In[]:=
20858032 - 8
Out[]=
20858024
In[]:=
? NestList
Out[]=
In[]:=
With[{stride=10000},ListPlot[Length/@Last/@NestList[PostTagSystemFinalState[#,stride]&,{0,{0,1,1,1,1,1,1,1,1,0,1,1,0,1,0}},Round[20858024/stride,8]]]]
Out[]=
In[]:=
RasterizePreviousInputOutputAndExportToMarkdown["Test.png", "DryRun" True]
Image would be written to: /Users/maxitg/git/SetReplace/Documentation/Images/Test.png
Out[]=
```wlIn[] := With[{stride = 10000}, ListPlot[ Length /@ Last /@ NestList[PostTagSystemFinalState[#, stride] &, {0, {0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0}}, Round[20858024 / stride, 8]]] ]```<img src="/Documentation/Images/Test.png" width="478.2">
In[]:=
AbsoluteTiming[PostTagSystemFinalState[{0, {0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, 0}}, 20858024]]
Out[]=
{0.0456,{2,{0,0,0,0,0,0,1,0,0,0,0,0,0,0,0}}}
In[]:=
randomInit[seed_] := ModuleScope[BlockRandom[ phase = RandomInteger[{0, 2}]; length = RandomInteger[{9, 14}]; tape = RandomInteger[1, length]; {phase, tape} , RandomSeeding -> seed]];
In[]:=
? FirstPosition
Out[]=
In[]:=
stateList[init_, stride_, minSize_] := ModuleScope[ system = PostTagSystem[init]; statesOfAnySize = system["State", #] & /@ Range[1, system["StateCount"], stride]; firstSmallState = FirstPosition[statesOfAnySize, {_, _ ? (Length[#] <= minSize &)}, {Length[statesOfAnySize]}, {1}][[1]]; statesOfAnySize[[1 ;; firstSmallState]] ];
In[]:=
stateList[randomInit[724], 8, 8]
Out[]=
{{2,{0,1,1,0,0,1,1,0,0,0,1}},{2,{0,0,1,1,1,0,0,1,1,0,0}}}
In[]:=
randomInit[1]
Out[]=
{1,{1,0,1,0,0,0,0,0,0}}
In[]:=
? FirstPosition
Out[]=
FirstPosition[]
In[]:=
stateList[randomInit[2], 8, 8]
Out[]=
{{2,{1,1,1,0,0,1,0,0,1}},{2,{1,0,1,1,1,0,1,0,0}},{0,{0,0,0,0,1,1,1,1,1}},{0,{1,0,0,0,1,1,1,0,1}},{0,{1,1,1,0,0,0,1,1,1}},{1,{1,1,1,0,1,0,0,1,1,0}},{2,{1,0,1,1,1,0,0,0,0,1,1}},{2,{0,1,1,0,0,0,1,1,1,0,0}},{2,{1,0,0,1,1,0,0,0,1,1,1}}}
In[]:=
randomInit[724]
Out[]=
{2,{0,1,1,0,0,1,1,0,0,0,1}}
In[]:=
stateList[randomInit[724], 8, 8]
Out[]=
{{2,{0,1,1,0,0,1,1,0,0,0,1}},{2,{0,0,1,1,1,0,0,1,1,0,0}}}〚1;;{}〚1〛〛
In[]:=
KeySort @ Counts[Length /@ (stateList[#, 8, 8] &) /@ randomInit /@ Range[724]]
Out[]=
12,241,365,456,550,657,734,836,932,1019,1115,1217,1312,1410,157,167,1712,187,192,207,223,234,251,268,278,283,295,303,313,333,343,352,363,371,385,393,402,441,461,472,482,491,512,551,562,571,601,631,651,701,781,791,821,941,952,962,971,981,1011,1022,1033,1044,1056,1066,1076,1082,1094,1105,1112,1125,1136,1146,1155,11610,11710,1184,1191,1201,1211,1261,1271,1311,1671,1693,1702,1721,1913,1926,1934,1947,2621,2641,2652,2662,2672,2681,3221,3241,3262,3272,3301,3391,3512,3521,3571,5121,6741,15941,30671,30681,30691,30702
In[]:=
PostTagSystemFinalState[{1,{1,0,1,0,0,0,0,0,0}},0]
Out[]=
{1,{1,0,1,0,0,0,0,0,0}}