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}]
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[]=