<<Graphics`Spline`
Show@Graphics[{AbsolutePointSize[5],Point[{0,0}],Point[{2,0}],Point[{2,2}],Spline[{{0,0},{2,0},{2,2}},Bezier]},AspectRatioAutomatic]
⁃Graphics⁃
NetworkArrayGraphics::usage="NetworkGraphics[network,nodeorderedq,nodegraphics,nodesize,width,rowgap,nodegap] produces a graphic given the following input: network is a list of ordered pairs of nodes (representing arrows between them); nodeorderedq is a function that takes as input two nodes and returns True if they are in desired order and False otherwise; nodegraphics is a function of the form nodegraphics[node,offset] taking as input the contents of a node and the coordinates of the lower left-hand corner of the node graphic and producing as output a list of graphic objects representing the node; nodesize is a function of the form nodesize[node] which returns {coordinate width of node, coordinate height of node}; width is the maximum width of a graphics row in coordinates; height is the coordinate height of a node; rowgap is the coordinate space between rows; nodegap is the coordinate space between nodes. The nodes are drawn in sorted order from left to right in successive rows, filling up as much of each row as is possible, and arrows are drawn between them.";
BestPath[startx_,startrow_,finishx_,finishrow_,hgaps_]:=Module[{gaprow=startrow+If[startrow<finishrow,0,1],dir=If[startrow<finishrow,1,-1]},{startx,startrow,finishx,finishrow,Sort[{#〚1〛+Abs[#〚2〛-finishx],#〚3〛}&/@Nest[(gaprow+=dir;Flatten[(Function[z,{#〚1〛+Abs[#〚2〛-z],z,Append[#〚3〛,{z,gaprow}]}]/@Flatten[{If[#==={},{},Last[#]]&@Cases[hgaps〚gaprow〛,x_/;x<#〚2〛],If[#==={},{},First[#]]&@Cases[hgaps〚gaprow〛,x_/;x≥#〚2〛]}])&/@#,1])&,{{0,startx,{}}},Abs[finishrow-startrow-1]]]〚1,2〛}]
BestPath7,3,6,2,-,,,,,,,-,,,,,-,,,,,-,,,,-,,,
1
2
3
2
9
2
15
2
23
2
31
2
39
2
1
2
7
2
17
2
27
2
37
2
1
2
9
2
19
2
29
2
39
2
1
2
11
2
23
2
35
2
1
2
11
2
23
2
37
2
7,3,6,2,,3,,2
9
2
7
2
NetworkArrayGraphics[network_,nodes_,nodegraphics_,nodesize_,width_,rowgap_,nodegap_]:=Module[{nodepos,x=0,y=0,rownodes={},r={},s={},hgaps,vgaps={rowgap/2},paths,sortedgap,z,row},Catch[Do[With[{ns=nodesize[nodes〚i〛]},If[ns〚1〛>width,Print["width too small"];Throw[Graphics[]]];If[x+ns〚1〛>width,AppendTo[rownodes,r];m=Max[Last/@s];AppendTo[vgaps,y-m-rowgap/2];Do[nodepos[r〚i〛]={s〚i,1〛,y-m/2},{i,Length[s]}];x=0;y-=m+rowgap;s=r={}];AppendTo[s,{x,ns〚2〛}];AppendTo[r,nodes〚i〛];x+=nodegap+ns〚1〛],{i,Length[nodes]}];AppendTo[rownodes,r];m=Max[Last/@s];AppendTo[vgaps,y-m-rowgap/2];Do[nodepos[r〚i〛]={s〚i,1〛,y-m/2},{i,Length[s]}];hgaps=Append[nodepos[#]〚1〛-nodegap/2&/@#,nodepos[Last[#]]〚1〛+nodesize[Last[#]]〚1〛+nodegap/2]&/@rownodes;paths=Join@@#&/@Transpose[{BestPath[Sequence@@Flatten[#],hgaps]&/@Map[{First[nodepos[#]]+First[nodesize[#]]/2,Position[rownodes,#]〚1,1〛}&,network,{2}],network}];MapIndexed[(sortedgap[#]=Sort[Select[paths,Function[z,MemberQ[z〚5〛,#]]],#1〚1〛+#1〚3〛≤#2〚1〛+#2〚3〛&])&@{#,First[#2]}&,hgaps,{2}];Graphics[{nodegraphics[#,nodepos[#]-{0,nodesize[#]〚2〛/2}]&/@nodes,AbsoluteThickness[.25],GrayLevel[0],{row=#〚2〛;Line[{{x=#〚1〛,(vgaps〚row〛+vgaps〚row+1〛-nodesize[#〚6〛]〚2〛)/2},{x,y=rowgap/2+vgaps〚row+1〛}}],Function[w,z=w〚1〛-nodegap/2+nodegapPosition[sortedgap[w],#]〚1,1〛/(Length[sortedgap[w]]+1);{Spline[{{x,y},{x,y+=If[w〚2〛≥row,-rowgap/2,rowgap/2]},{x=(x+z)/2,y}},Bezier],Spline[{{x,y},{z,y},{z,y+=If[w〚2〛>row,-rowgap/2,rowgap/2]}},Bezier],Line[{{z,y},{x=z,y+=If[w〚2〛>row,-1,1](vgaps〚row=w〚2〛〛-vgaps〚row+1〛-rowgap)}}]}]/@#〚5〛,Spline[{{x,y},{x,y+=If[row≥#〚4〛,rowgap/2,-rowgap/2]},{x=(x+#〚3〛)/2,y}},Bezier],Spline[{{x,y},{x=#〚3〛,y},{x,y-=rowgap/2}},Bezier],Line[{{x,(vgaps〚#〚4〛〛+vgaps〚#〚4〛+1〛+nodesize[#〚7〛]〚2〛)/2},{x,-rowgap/2+vgaps〚#〚4〛〛}}]}&/@paths},AspectRatioAutomatic]]]
,-,-,-,-,-
1
2
3
2
7
2
11
2
15
2
19
2
,-,-,-,-,-
1
2
3
2
7
2
11
2
15
2
19
2
7,3,6,2,,3,,2,"ABAB","AAAB"
9
2
7
2
7,3,6,2,,3,,2,ABAB,AAAB
9
2
7
2
<<"MultiwaySystems/Multiway.m";
<<Graphics`Spline`
MWNodeGraphics[colormap_]:=Table[EdgedRectangle[#2+{i-1,0},#2+{i,1},colormap[StringTake[#,{i}]]],{i,StringLength[#]}]&
MWNetworkArrayGraphics[rule_List,init_List,t_Integer,width_,rowgap_,nodegap_,colormap_:0]:=With[{w=Rest[MWEvolveListT[rule,init,t]],c=Flatten[ToCharacterCode[Flatten[{Apply[List,rule,{1}],init}]]]},NetworkArrayGraphics[Union[Flatten[w,1]],Sort[Union[Flatten[w]],MWStringSortQ],MWNodeGraphics[If[colormap===0,GrayLevel[If[Min[c]Max[c],.85,.85(1-(First[ToCharacterCode[#]]-Min[c])/(Max[c]-Min[c]))]]&,colormap]],{StringLength[#],1}&,width,rowgap,nodegap]]
Show@MWNetworkArrayGraphics[{"A""AB","B""A"},{"A"},5,20,1,1];
So: I made sure nothing overlapped while going through the gaps between strings in a given row, but didn't do anything about other overlaps.
Show@MWNetworkArrayGraphics[{"A""AB","B""A"},{"A"},5,20,2,1];
Show@MWNetworkArrayGraphics[{"A""AA"},{"A"},3,20,1,1];