Main version
Main version
Sequential multiway system (resort the StringPosition to get other updating schedules)
In[]:=
SMWEvolveList[rule_,s_,n_]:=NestList[SMWStep[rule,#]&,s,n]
In[]:=
SMWStep[rule_,s_]:=SMWStep1[rule,s,SMWFilter[StringPosition[s,First/@rule]]]
In[]:=
SMWFilter[s_]:=Fold[If[Last[Last[#1]]>=First[#2],#,Append[#,#2]]&,{First[s]},Rest[s]]
In[]:=
SMWFilter[{}]={};
In[]:=
SMWStep1[rule_,s_,pos_]:=StringReplacePart[s,(StringTake[s,#]&/@pos)/.rule,pos]
In[]:=
SMWStep1[rule_,s_,{}]:=s
Evolution with backward scanning of rules
In[]:=
SMWEvolveList[rule_,s_,n_,Backward]:=NestList[SMWStepBackward[rule,#]&,s,n]
In[]:=
SMWStepBackward[rule_,s_]:=SMWStep1[rule,s,Reverse[SMWFilterBackward[Reverse[StringPosition[s,First/@rule]]]]]
In[]:=
SMWFilterBackward[s_]:=Fold[If[First[Last[#1]]<=Last[#2],#,Append[#,#2]]&,{First[s]},Rest[s]]
In[]:=
SMWFilterBackward[{}]={};
Evolution with first position only (absolute first position, picking any rule)
In[]:=
SMWEvolveList[rule_,s_,n_,First]:=NestList[SMWStepFirst[rule,#]&,s,n]
In[]:=
SMWStepFirst[rule_,s_]:=SMWStep1[rule,s,StringPosition[s,First/@rule,1]]
Evolution like sequential substitution system
In[]:=
SMWEvolveList[rule_,s_,n_,SSS]:=NestList[SMWStepSSS[rule,#]&,s,n]
In[]:=
SMWStepSSS[rule_,s_]:=SMWStep1[rule,s,If[#==={},{},{First[#]}]&[Flatten[StringPosition[s,First[#],1]&/@rule,1]]]
Version set up to be able to see replacements
Version set up to be able to see replacements
In[]:=
SMWEvolveListX[rule_,s_,n_]:=NestList[SMWStepX[rule,First[#]]&,{s},n]
In[]:=
SMWStepX[rule_,s_]:=Module[{q,z},z=SMWStep1X[rule,s,q=SMWFilter[StringPosition[s,First/@rule]]];{StringReplace[z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}]
In[]:=
SMWStep1X[rule_,s_,pos_]:=StringReplacePart[s,(StringTake[s,#]&/@pos)/.ModRules[rule],pos]
In[]:=
SMWStep1X[rule_,s_,{}]:=s
In[]:=
ModRules[rule_]:=(First[#]->StringJoin["<",Last[#],">"])&/@rule
In[]:=
FinalPositions[s_]:=(#-2(Range[Length[#]]-1))&[Transpose[{First/@StringPosition[s,"<"],First/@StringPosition[s,">"]-2}]]
In[]:=
SMWEvolveListX[rule_,s_,n_,Backward]:=NestList[SMWStepXBackward[rule,First[#]]&,{s},n]
In[]:=
SMWStepXBackward[rule_,s_]:=Module[{q,z},z=SMWStep1X[rule,s,q=Reverse[SMWFilterBackward[Reverse[StringPosition[s,First/@rule]]]]];{StringReplace[z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}]
In[]:=
SMWEvolveListX[rule_,s_,n_,First]:=NestList[SMWStepXFirst[rule,First[#]]&,{s},n]
In[]:=
SMWStepXFirst[rule_,s_]:=Module[{q,z},z=SMWStep1X[rule,s,q=StringPosition[s,First/@rule,1]];{StringReplace[z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}]
In[]:=
SMWEvolveListX[rule_,s_,n_,SSS]:=NestList[SMWStepXSSS[rule,First[#]]&,{s},n]
In[]:=
SMWStepXSSS[rule_,s_]:=Module[{q,z},z=SMWStep1X[rule,s,q=If[#==={},{},{First[#]}]&[Flatten[StringPosition[s,First[#],1]&/@rule,1]]];{StringReplace[z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}]
Random updates
Random updates
In[]:=
SMWEvolveListRandomX[rule_,s_,n_,max_:1]:=NestList[SMWStepRandomX[rule,First[#],max]&,{s},n]
In[]:=
SMWStepRandomX[rule_,s_,max_]:=Module[{q,z},z=SMWStep1X[rule,s,q=SMWFilterRandom[StringPosition[s,First/@rule],max]];{StringReplace[z,{"<"->"",">"->""}],MapThread[Rule,{q,FinalPositions[z]}]}]
In[]:=
SMWFilterRandom[{},_]={};
In[]:=
SMWFilterRandom[s_,max_]:=Sort[Block[{used={}},Nest[SFR0,s,max];used]]
In[]:=
SFR0[{}]={};
In[]:=
SFR0[s_]:=Module[{i=Random[Integer,{1,Length[s]}],s0,s1},{s0,s1}=s[[i]];If[Select[used,((s0<=First[#]&&s1>=First[#])||(s0<=Last[#]&&s1>=Last[#])||(s0>=First[#]&&s1<=Last[#])||(s0<=First[#]&&s1>=Last[#]))&]==={},AppendTo[used,s[[i]]];Drop[s,{i}],s]]
Graphics
Graphics
In[]:=
SMWSimpleGraphics[history_]:=RPadGraphics[ToCharacterCode/@history-First[ToCharacterCode["A"]]]
In[]:=
SMWSimpleGraphicsCW[history_]:=Surround[Graphics[MapIndexed[sgcw0[#,-First[#2]]&,ToCharacterCode/@history-First[ToCharacterCode["A"]]],AspectRatio->1]]
In[]:=
SMWXGraphics[history_,fac_:2.5]:=Graphics[{MapIndexed[frx[Last[#1],-facFirst[#2],-fac(First[#2]+1)+1,0]&,Rest[history]],MapIndexed[erx[First[#1],-facFirst[#2]]&,history]},PlotRange->All,AspectRatio->Automatic]
In[]:=
SMWXGraphicsStreamed[history_,opts___?OptionQ]:=Block[{colortable,graphicsoptions,fac,wedgenumber,numbersize,n},{colortable,graphicsoptions,fac,wedgenumber,numbersize}={ColorTable,GraphicsOptions,YFactor,WedgeNumber,NumberSize}/.{opts}/.Options[SMWXGraphicsStreamed];n[1]=0;Do[n[i]=n[i-1]+Length[history〚i,2〛],{i,2,Length[history]-1}];Graphics[{MapIndexed[erxp[First[#1],-facFirst[#2]]&,history],MapIndexed[qrx[#1,-facFirst[#2],-fac(First[#2]+1)+1,StringLength[history[[First[#2],1]]]]&,Rest[history]],MapIndexed[frx[Last[#1],-facFirst[#2],-fac(First[#2]+1)+1,0,wedgenumber,n[First[#2]]]&,Rest[history]]},graphicsoptions,PlotRange->All,AspectRatio->Automatic]]
In[]:=
Options[SMWXGraphicsStreamed]={ColorTable->{{.85},{0},{.5,0,0},{0,.5,0},{0,0,.5},{.5,.5,0},{.5,0,.5},{0,.5,.5},{.25,.75,0}},GraphicsOptions->{},YFactor->2.5,WedgeNumber->False,NumberSize->$DefaultFont〚2〛};
In[]:=
SMWXGraphicsStreamedCW[history_,fac_:2.5]:=MakeConstantWidth[SMWXGraphicsStreamed[history,YFactor->2,AspectRatio->1],StringLength[First[#]]&/@history,fac/2]
In[]:=
SMWXGraphicsNetwork[history_,opts___?OptionQ]:=Block[{colortable,graphicsoptions,fac,thinwedge,ribbonwidth,wedgenumber,numbersize,n},{colortable,graphicsoptions,fac,thinwedge,ribbonwidth,wedgenumber,numbersize}={ColorTable,GraphicsOptions,YFactor,ThinWedge,RibbonWidth,WedgeNumber,NumberSize}/.{opts}/.Options[SMWXGraphicsNetwork]; n[1]=0;Do[n[i]=n[i-1]+Length[history〚i,2〛],{i,2,Length[history]-1}];Graphics[{MapIndexed[erxp[First[#1],-facFirst[#2],"nw"]&,history],MapIndexed[qrx[#1,-facFirst[#2],-fac(First[#2]+1)+1,StringLength[history[[First[#2],1]]],"nw"]&,Rest[history]],MapIndexed[frx[Last[#1],-facFirst[#2],-fac(First[#2]+1)+1,thinwedge,wedgenumber,n[First[#2]]]&,Rest[history]]},graphicsoptions,PlotRange->All,AspectRatio->Automatic]]
In[]:=
Options[SMWXGraphicsNetwork]={ColorTable->{{.85},{0},{.5,0,0},{0,.5,0},{0,0,.5},{.5,.5,0},{.5,0,.5},{0,.5,.5},{.25,.75,0}},GraphicsOptions->{},YFactor->2.5,ThinWedge->.3,RibbonWidth->.15,WedgeNumber->False,NumberSize->$DefaultFont〚2〛};
In[]:=
sgcw0[a_,y_]:=MapIndexed[{GrayLevel[1-#],Rectangle[{(First[#2]-1)/Length[a],y},{First[#2]/Length[a],y+1}]}&,a]
In[]:=
erx[s_,y_]:=MapIndexed[EdgedRectangle[{First[#2],y},{First[#2]+1,y+1},GrayLevel[#/.{"A"->.85,"B"->0}],GrayStyle]&,Characters[s]]
SMW Rule Graphics
SMW Rule Graphics
Try out
Try out