In[]:=
rulelist={{"A"->"A","A"->"AA"},{"A"->"AA","AA"->"A"},{"ABA"->"BBAA","BAA"->"AAB"},{"AA"->"BABBBBA","BAB"->"A"},{"AB"->"","ABA"->"ABBAB","ABABBB"->"AAAAABA"},{"AA"->"","BA"->"ABB","BB"->"A"}};
In[]:=
initiallist={{{"A"},{}},{{"A"},{}},{{"BABBAAB"},{}},{{"ABAAB"},{}},{{"ABABAB"},{}},{{"BBA"},{}}};
In[]:=
IconBit[rule_,height_,bit_]:=Module[{strungout},​​strungout=Table[{StringSplit[#,""]&@rule[[i]][[1]],StringSplit[#,""]&@rule[[i]][[2]]},{i,1,Length[rule]}];​​​​Graphics[Join[{EdgeForm[Darker[Gray]]},Riffle[Flatten@strungout[[bit]]/.{"A"->LightGray,"B"->Black},Flatten@Table[Rectangle[{i-1,2-2*j},{i,3-2*j}],{j,1,Length[strungout[[bit]]]},{i,1,Length[strungout[[bit]][[j]]]}]],{Black,Line[{{0,0},{0,-1}}],Line[{{Length[strungout[[bit]][[1]]],0},{Length[strungout[[bit]][[2]]],-1}}]}],ImageSize->{Automatic,height}]​​]
In[]:=
RuleIcon[rule_,height_]:=Grid[{#},Frame->All]&@Table[IconBit[rule,height,i],{i,1,Length[rule]}]
In[]:=
Step[rule_,initlist_]:=Module[{states},​​states=​​DeleteCases[Table[If[StringPosition[#,First@rule[[i]]]!={},StringReplaceList[#,rule[[i]]]],{i,1,Length[rule]}]&/@initlist[[1]],Null,2];​​​​{DeleteDuplicates[Flatten@states],DeleteDuplicates[First/@Position[states,#]]&/@DeleteDuplicates[Flatten@(states)]}​​]
In[]:=
Evolve[rule_,initlist_,steps_]:=NestList[Step[rule,#]&,initlist,steps]
In[]:=
RowIntervals[row_List]:=Module[{intervals0,intervals1},​​intervals0=Partition[FoldList[Plus,0,Riffle[Length[row[[#]]]&/@Range[Length[row]],1]],2];​​intervals1=intervals0/.Thread[First/@intervals0->(First/@intervals0)+1];​​​​If[row[[1]]=={},Drop[intervals1,1],intervals1]​​]
In[]:=
Skelly[evolved_,height_]:=Module[{evolvedsplit,intervals,centerpoints,arroworigins},​​evolvedsplit=StringSplit[#,""]&/@(First/@evolved);​​intervals=Table[If[Length[RowIntervals[evolvedsplit[[i]]]]!=Length[evolvedsplit[[i]]],Join[{{0,0}},RowIntervals[evolvedsplit[[i]]]],RowIntervals[evolvedsplit[[i]]]],{i,1,Length[evolvedsplit]}];​​centerpoints=Table[Mean/@N[intervals[[i]]],{i,1,Length[intervals]}];​​arroworigins=arroworigins=Last/@evolved;​​​​Arrow/@(Flatten[#,2]&@Table[Table[{{centerpoints[[j-1]][[arroworigins[[j]][[i]][[#]]]],height*(2-j)},{centerpoints[[j]][[i]],height*(1-j)+1}}&/@Range[Length[arroworigins[[j]][[i]]]],{i,1,Length[arroworigins[[j]]]}],{j,1,Length[arroworigins]}])​​]
In[]:=
RowGraphics[row_List,rownum_,height_]:=Riffle[Flatten@row,Flatten@(Flatten@Table[Rectangle[{i-1,height*(1-rownum)},{i,height*(1-rownum)+1}],#]&/@(Flatten@{{i},#}&/@RowIntervals[row]))]/.{"A"->LightGray,"B"->Black}
In[]:=
BlocksEvolve[evolved_,height_]:=Module[{evolvedsplit},​​evolvedsplit=StringSplit[#,""]&/@(First/@evolved);​​​​RowGraphics[evolvedsplit[[#]],#,height]&/@Range[Length[evolvedsplit]]​​]
In[]:=
GraphicsEvolve[rule_,initlist_,height_,steps_]:=Module[{evolved},​​evolved=Evolve[rule,initlist,steps];​​​​Graphics[Join[{EdgeForm[Darker[Gray]]},{Arrowheads[Small]},Skelly[evolved,height],BlocksEvolve[evolved,height]],ImageSize->350]​​]
Manipulate[​​Grid[{​​{RuleIcon[rulelist[[rule]],26]},​​{GraphicsEvolve[rulelist[[rule]],initiallist[[rule]],4,steps]}​​},Alignment->Left],​​{{rule,6,"rule set"},Range[6],ControlType->Setter},​​{{steps,14},2,25,1,Appearance->"Labeled"},​​SaveDefinitions->True,ContentSize->{400,400}]
​
rule set
1
2
3
4
5
6
steps
14
In[]:=
Evolve[{"ABA"->"BBAA","BAA"->"AAB"},{{"BABBAAB"},{}},5]
Out[]=
{{{BABBAAB},{}},{{BABAABB},{{1}}},{{BBBAAABB,BAAABBB},{{1},{1}}},{{BBAABABB,AABABBB},{{1},{2}}},{{BBABBAABB,BAABBABB,ABBAABBB},{{1},{1},{2}}},{{BBABAABBB,AABBBABB,ABAABBBB},{{1},{2},{3}}}}
In[]:=
GraphicsEvolve[{"ABA"->"BBAA","BAA"->"AAB"},{{"BABBAAB"},{}},5,5]
Out[]=