<<"MultiwaySystems/Multiway.m"
MWLoopbackGraphic[hist_,sep_:.4]:=Module{hh,rp,arrows,t1,t2,u={},v,hc,vbeforecount,vaftercount,hcount,k,g={GrayLevel[0],AbsoluteThickness[.25]},r=sep},hh=Sort[v=Complement[#,u];u=Join[u,v];v,MWStringSortQ]&/@Union/@Map[Last,hist,{2}];vaftercount=hcount=Table[0,{Length[hh]}];vbeforecount=Table[1,{Length[hh]}];rp=MapIndexed(#2〚2〛-1)1.2+
#2〚2〛-1
∑
i=1
StringLength[hh〚#2〚1〛,i〛],-4.4(#2〚1〛-1)&,hh,{2};arrows=FlattenTablet1=Position[hh〚y-1〛,hist〚y,x,1〛,1,1];Ift1=={},{},t1=t11,1;t2=Position[hh〚y〛,hist〚y,x,2〛,1,1];Ift2=={},{t2,k}=Catch[Do[If[(t2=Position[hh〚j〛,hist〚y,x,2〛,1,1])!={},Throw[{t2〚1,1〛,j}]],{j,y-1}]];vaftercounty-1++;vbeforecountk++;hc=Max[Take[hcount,{k,y-1}]]+1;Do[hcount〚j〛=hc,{j,k,y-1}];g=Joing,Linerpy-1,t1+
1
2
StringLength[hh〚y-1,t1〛],-.3,rpy-1,t1+
1
2
StringLength[hh〚y-1,t1〛],-.3-vaftercounty-1sep+r,Circlerpy-1,t1+
1
2
StringLength[hh〚y-1,t1〛]-r,-.3-vaftercounty-1sep+r,r,
-π
2
,0,Linerpy-1,t1+
1
2
StringLength[hh〚y-1,t1〛]-r,-.3-vaftercounty-1sep,{r-sephcount〚y-1〛,rp〚y-1,t1〛〚2〛-.3-vaftercount〚y-1〛sep},Circle{r-sephcount〚y-1〛,r+rp〚y-1,t1〛〚2〛-.3-vaftercount〚y-1〛sep},r,π,
3π
2
,Line[{{-sephcount〚y-1〛,r+rp〚y-1,t1〛〚2〛-.3-vaftercount〚y-1〛sep},{-sephcount〚y-1〛,rp〚k,t2〛〚2〛+1.3+vbeforecount〚k〛sep-r}}],Circle{r-sephcount〚y-1〛,rp〚k,t2〛〚2〛+1.3+vbeforecount〚k〛sep-r},r,
π
2
,π,Line{r-sephcount〚y-1〛,rp〚k,t2〛〚2〛+1.3+vbeforecount〚k〛sep},rpk,t2+
1
2
StringLength[hh〚k,t2〛]-r,1.3+vbeforecountksep,Circlerpk,t2+
1
2
StringLength[hh〚k,t2〛]-r,1.3+vbeforecountksep-r,r,0,
π
2
;rpk,t2+
1
2
StringLength[hh〚k,t2〛],1.3+vbeforecountksep-r,rpk,t2+
1
2
StringLength[hh〚k,t2〛],1.3,t2=t21,1;rpy-1,t1+
1
2
StringLength[hh〚y-1,t1〛],-.3,rpy,t2+
1
2
StringLength[hh〚y,t2〛],1.3,{y,2,Length[hist]},{x,1,Length[hist〚y〛]},2;Graphics[{MapThread[rowblock2,{Flatten[hh,1],Flatten[rp,1]}],(Arrow[#1,.5,ArrowStyle->AbsoluteThickness[.25]]&)/@arrows,g},AspectRatio->Automatic]
Show@MWLoopbackGraphic[MWEvolveListT[{"A"->"AB","AB"->"B","B"->"A"},{"A"},5]];
Show@MWLoopbackGraphic[MWEvolveListT[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABAB"},20]];
Show@MWLoopbackGraphic[MWEvolveListT[{"ABA""ABBAB","AB""","ABABBB""AAAAABA"},{"ABABAB"},25]];
Show@MWLoopbackGraphic[MWEvolveListT[{"A""A","A""AA"},{"A"},5]];
Show@MWLoopbackGraphic[MWEvolveListT[{"A""AB","B""A"},{"A"},5]];
Show@MWLoopbackGraphic[MWEvolveListT[{"AA""","BA""ABB","BB""A"},{"BBA"},10]];