WOLFRAM NOTEBOOK

Tag Systems

Code

In[]:=

TagSystemStep[{dropCount_, appendSequences_}][init_] := Join[Drop[init, UpTo[dropCount]], Replace[First[init], appendSequences]];

In[]:=

TagSystemList[rule_, steps_][init_] := NestList[TagSystemStep[rule], init, steps];

In[]:=

TagSystemHistoryStep[{dropCount_, appendSequences_}][{startPosition_, history_}] := { startPosition + dropCount, Join[history, Replace[history[[startPosition]], appendSequences]]};

In[]:=

TagSystemHistory[rule_, steps_][init : {startPosition_Integer, history_List}] := NestWhile[TagSystemHistoryStep[rule], init, #[[1]] ≤ Length[#[[2]]] &, 1, steps];

In[]:=

$tagSystemSimpleRulesPattern = {({_Integer, _Integer}  {_Integer, {___Integer}})..};

In[]:=

TagSystemNextGeneration[rules : $tagSystemSimpleRulesPattern][initPhase_Integer, initState : {___Integer}] := {#[[-1, 1]], Catenate[#[[All, 2]]]} & @ FoldList[With[{ phase = #1[[1]], value = #2}, Replace[rules][{phase, value}] ] &, {initPhase, {}}, initState];

In[]:=

TagSystemGenerations[rules : $tagSystemSimpleRulesPattern, generations_Integer][ initPhase_Integer, initState : {___Integer}] := FixedPointList[TagSystemNextGeneration[rules] @@ # &, {initPhase, initState}, generations]

In[]:=

simpleRules = { (* {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[]:=

RecoverPhases[rules : $tagSystemSimpleRulesPattern][initPhase_, state_] := Most @ FoldList[Replace[rules][{##}][[1]] &, initPhase, state]

In[]:=

states=TagSystemGenerations[simpleRules,1000000][0,{1}][[All,2]]

Out[]=

{{1},{1,1},{0,1},{0,1}}

In[]:=

phases=Exp[2π(RecoverPhases[simpleRules]@@@TagSystemGenerations[simpleRules,1000000][0,{1}])/3]

Out[]=

{1},

2π



2π



,1,

2π



,1,

2π





In[]:=

simpleRules

Out[]=

{{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[]:=

TagSystemPlot[rules_, evolution_] := ModuleScope[ phases = RecoverPhases[rules] @@@ evolution; valuesToPlot = evolution[[All, 2]] + 2 phases; ArrayPlot[ valuesToPlot, ColorRules  value_ :> Nest[If[Mod[value, 2] === 0, Lighter, Darker], ColorData[97, Quotient[value, 2] + 1], 2]]]

In[]:=