In[]:=
foliationLine[coordinates_,style_:Red][extraPoints_,chosenVertices_]:=Module[{chosenCoordinates=Join[coordinates/@chosenVertices,extraPoints],nearest1,nearest2,coordinateBounds=CoordinateBounds[coordinates]},{nearest1,nearest2}=Nearest/@{chosenCoordinates,Complement[Values[coordinates],chosenCoordinates]};{ContourPlot[EuclideanDistance[nearest1[{x,y}]〚1〛,{x,y}]-EuclideanDistance[nearest2[{x,y}]〚1〛,{x,y}]0,{x,coordinateBounds〚1,1〛,coordinateBounds〚1,2〛},{y,coordinateBounds〚2,1〛,coordinateBounds〚2,2〛},ContourStylestyle,FrameFalse],Table[With[{x=x},Module[{func},func[y_?NumericQ]:=EuclideanDistance[nearest1[{x,y}]〚1〛,{x,y}]-EuclideanDistance[nearest2[{x,y}]〚1〛,{x,y}];{x,y/.FindRoot[func[y]0,{y,coordinateBounds〚2,1〛,coordinateBounds〚2,2〛}]}]],{x,coordinateBounds〚1,1〛,coordinateBounds〚1,2〛,1}];{}}]
In[]:=
foliationGraphics[graph_,vertexList_]:=foliationGraphics[graph,vertexList,{0,0}]
In[]:=
foliationGraphics[graph_,vertexLists_,{yGap_,xGap_}]:=Quiet[Module[{vertexCoordinates=Association[Thread[VertexList[graph](VertexCoordinates/.AbsoluteOptions[graph,VertexCoordinates]〚1〛)]],lines},FoldPairList[foliationLine[Function[{x,y},{Sign[x]Max[Abs[x]-xGap(#2〚1〛-(Length[vertexLists]+1)/2),0],y-yGap(#2〚1〛-(Length[vertexLists]+1)/2)}]@@@vertexCoordinates][#,#2〚2〛]&,{},Transpose@{Range[Length[vertexLists]],vertexLists}]],{NearestFunction::neard,FindRoot::cvmit}]
In[]:=
drawFoliation[graph_,vertexLists_,gapSpec___]:=Show[graph,foliationGraphics[graph,vertexLists,gapSpec]]
In[]:=
With[{rules={"A""AB","A""BC","B""A","C""A"},steps=4},VertexList@GenerationalMultiwaySystem[rules,{"A"},steps,"StatesGraph"]]
Out[]=
{A,AB,BC,AA,ABA,BCA,AAAB,AABC,ABAAB,ABAB,ABABC,ABBC,BCAAB,BCAB,BCABC,BCBC,AAAA,AAABA,AAABAA,AAABABA,AAABBCA,AABCA,AABCAA,AABCABA,AABCBCA,ABAAA,ABAABA,ABAABAA,ABAABABA,ABAABBCA,ABABAA,ABABABA,ABABBCA,ABABCA,ABABCAA,ABABCABA,ABABCBCA,ABBCAA,ABBCABA,ABBCBCA,BCAAA,BCAABA,BCAABAA,BCAABABA,BCAABBCA,BCABAA,BCABABA,BCABBCA,BCABCA,BCABCAA,BCABCABA,BCABCBCA,BCBCAA,BCBCABA,BCBCBCA}
In[]:=
With[{rules={"A""AB","A""BC","B""A","C""A"},steps=4},GenerationalMultiwaySystem[rules,{"A"},steps,"AllStatesList"]]
Out[]=
{{A},{AB,BC},{AA,ABA,BCA},{AAAB,AABC,ABAAB,ABAB,ABABC,ABBC,BCAAB,BCAB,BCABC,BCBC},{AAAA,AAABA,AAABAA,AAABABA,AAABBCA,AABCA,AABCAA,AABCABA,AABCBCA,ABAAA,ABAABA,ABAABAA,ABAABABA,ABAABBCA,ABABAA,ABABABA,ABABBCA,ABABCA,ABABCAA,ABABCABA,ABABCBCA,ABBCAA,ABBCABA,ABBCBCA,BCAAA,BCAABA,BCAABAA,BCAABABA,BCAABBCA,BCABAA,BCABABA,BCABBCA,BCABCA,BCABCAA,BCABCABA,BCABCBCA,BCBCAA,BCBCABA,BCBCBCA}}
In[]:=
With[{rules={"A""AB","A""BC","B""A","C""A"},steps=4},VertexList[GenerationalMultiwaySystem[rules,{"A"},steps,"StatesList"]]]
Out[]=
VertexList[GenerationalMultiwaySystem[{AAB,ABC,BA,CA},{A},4,StatesList]]
In[]:=
With[{rules={"A""AB","A""BC","B""A","C""A"},steps=4},Graph[MultiwaySystem[rules,{"A"},steps,"StatesGraph"],VertexStyle{_Directive[Opacity[0.6`],Hue[0.62`,0.45`,0.87`],EdgeForm[Hue[0.62`,1,0.48`]]],Alternatives@@Catenate@GenerationalMultiwaySystem[rules,{"A"},steps,"AllStatesList"]Directive[Opacity[0.6`],Hue[0,0.45,0.87],EdgeForm[Hue[0,1,0.48]]]},VertexShapeFunction"Circle"]]
Out[]=
In[]:=
With[{rules={"A""AB","A""CA","B""C"},steps=5},Graph[MultiwaySystem[rules,{"A"},steps,"StatesGraph"],VertexStyle{_Directive[Opacity[0.2`],Gray,EdgeForm[Gray]]}~Join~MapIndexed[Alternatives@@#Directive[Opacity[0.6`],Hue[#2〚1〛/6,0.45,0.87],EdgeForm[Hue[#2〚1〛/6,1,0.48]]]&,GenerationalMultiwaySystem[rules,{"A"},steps,"AllStatesList"]],VertexShapeFunction"Circle",GraphLayout"LayeredDigraphEmbedding",VertexLabelsAutomatic]]
Out[]=
In[]:=
drawFoliation[With[{rules={"A""AB","A""CA","B""C"},steps=5},Graph[MultiwaySystem[rules,{"A"},steps,"StatesGraph"],VertexStyle{_Directive[Opacity[0.2`],Gray,EdgeForm[Gray]]}~Join~MapIndexed[Alternatives@@#Directive[Opacity[0.6`],Hue[#2〚1〛/6,0.45,0.87],EdgeForm[Hue[#2〚1〛/6,1,0.48]]]&,GenerationalMultiwaySystem[rules,{"A"},steps,"AllStatesList"]],VertexShapeFunction"Circle",GraphLayout"LayeredDigraphEmbedding"]],{{"A"},{"A","AB","CA"},{"A","AB","CA","ABB","AC","CAB","CCA"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC","ABBB","ACB"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC","ABBB","ACB","ABBBB","ACBB","ABCB"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC","ABBB","ACB","ABBBB","ACBB","ABCB","ABBBBB","ACBBB","ABCBB","ABBCB","ACCB"}},{0.12,0}]
Out[]=
In[]:=
drawFoliation[Graph[MultiwaySystem[{"A""AB","A""CA","B""C"},{"A"},5,"StatesGraph"],VertexShapeFunctionAlternatives@@VertexList[GenerationalMultiwaySystem[{"A""AB","A""CA","B""C"},{"A"},5,"StatesGraph"]]Text[Framed[Style[stripMetadata[#2],Hue[0,1,0.48]],Background->Directive[Opacity[.2],Hue[0,0.45,0.87]], FrameMargins->{{2,2},{0,0}},RoundingRadius->0,FrameStyle->Directive[Opacity[0.5],Hue[0,0.52,0.8200000000000001]]],#1,{0,0}]&],{{"A"},{"A","AB","CA"},{"A","AB","CA","ABB","AC","CAB","CCA"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC","ABBB","ACB"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC","ABBB","ACB","ABBBB","ACBB","ABCB"},{"A","AB","CA","ABB","AC","CAB","CCA","ABC","CAC","ABBB","ACB","ABBBB","ACBB","ABCB","ABBBBB","ACBBB","ABCBB","ABBCB","ACCB"}},{0.12,0}]
Out[]=