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[]:=
originalRule={3,{0{0,0},1{1,1,0,1}}};
In[]:=
postRules = { (* {phase, value} {newPhase, newValues} *) {0, 0} {1, {0}}, {1, 0} {2, {0}}, {2, 0} {0, {}}, {0, 1} {2, {1, 1}}, {1, 1} {0, {1}}, {2, 1} {1, {0}}};
In[]:=
With[{system = PostTagSystem[{0, {1, 1, 1}}]}, system["StateGraph", VertexLabels {index_ RenderState[system["State", index]]}]]
Out[]=
In[]:=
Get["~/git/PostTagSystem/Kernel/init.m"];
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[]:=
RenderState[{phase_, state_}] := Replace[phase, {0 "0", 1 "1", 2 "2"}] <> StringJoin[Replace[state, {0 "", 1 "■"}, 1]];
In[]:=
CycleLengths[maxInitSize_] := With[ {system = PostTagSystem[AllInits[0 ;; maxInitSize]]}, Union[Length /@ (VertexOutComponent[system["StateGraph"], #] &) /@ system["CycleSources"]]]
In[]:=
system = PostTagSystem[AllInits[3]];
In[]:=
system["State", #] & /@ system["InitStates"] === AllInits[3]
Out[]=
True
In[]:=
PostTagSystem[AllInits[3]]["InitStates"] // Length
Out[]=
24
In[]:=
With[{ system = PostTagSystem[AllInits[0 ;; 3]]}, system["StateGraph", VertexLabels {index_ RenderState[system["State", index]]}]]
Out[]=
In[]:=
PostTagSystem[AllInits[0 ;; 6]]["StateGraph"]
Out[]=
In[]:=
CycleLengths[4]
Out[]=
{2,4,6}
In[]:=
system4 = PostTagSystem[AllInits[4]];
In[]:=
stateGraph4 = PostTagSystem[AllInits[4]]["StateGraph"]
Out[]=
In[]:=
PostTagSystem[AllInits[4]]["CycleSources"]
Out[]=
{28,42,73,79}
In[]:=
VertexOutComponent[stateGraph4, 79]
Out[]=
{79,80,81,82}
In[]:=
system4["State", #] & /@ VertexOutComponent[stateGraph4, 79]
Out[]=
{{0,{1,1,0,0}},{2,{1,0,0,1,1}},{1,{0,0,1,1,0}},{2,{0,1,1,0,0}}}
In[]:=
RenderState /@ %
Out[]=
{0■■,2■■■,1■■,2■■}
In[]:=
TagSystemStep[{dropCount_, appendSequences_}][init_] := Join[Drop[init, UpTo[dropCount]], Replace[First[init], appendSequences]];
In[]:=
originalRule
Out[]=
{3,{0{0,0},1{1,1,0,1}}}
In[]:=
NestGraph[TagSystemStep[originalRule], {{0, 0, 0, 1, 1, 0, 1, 1, 1, 0, 1, 0, 0}}, 10, VertexLabels Automatic]
Out[]=