How can I get edges to bend to avoid crossing?

Question

I want to generate a layered drawing of the Hoffman–Singlelton graph. As an example of what I want, here is a layered drawing of the Petersen graph:

Now if I right click on the output of PetersenGraph[] and do Graph Layout -> Layered, drawing, I get this:

Clearly a lot of the important visual information at the end layer is lost because the edges all overlap. Is there a way to recreate something similar to the the top image, where the edges at the last layer are visible?

My actual goal is not to do this with the Petersen, but with the Hoffman–Singleton (in Mathematica, FromEntity[Entity["Graph", "HoffmanSingletonGraph"]]). Needless to say, I got a similar output for this graph:

I appreciate any assistance with this.

Answer 1

Here's the one way by using the custom edge function:

arcRight[{a:{x1_,y1_},___,b:{x2_,y2_}}]/;y1>y2:=arcRight[{b, a}];
arcRight[{a:{x1_,y1_},___,b:{x2_,y2_}}]/;y1<=y2:=BSplineCurve[{a, {x1 + (y2-y1).7, (y1+y2)/2},b}]

iLayeredDrawing[g_, spos_Integer:1, opt___?OptionQ] :=
    Module[{s, vlist, leaves},
        vlist = VertexList[g];
        s = vlist[[spos]];
        leaves = MaximalBy[Reap[BreadthFirstScan[g, s, "DiscoverVertex"->(Sow[{#1,#3}]&)]][[2,1]], Last][[All,1]];
        Graph[vlist, EdgeList[g],
         opt, GraphLayout->{"LayeredEmbedding", "Orientation"->Left, "LeafDistance"->1/(Length[leaves]/2), "RootVertex" -> s}, EdgeShapeFunction->{a_\[UndirectedEdge]b_/;SubsetQ[leaves,{a,b}]:>(arcRight[#1]&)}]
    ]

For example,

iLayeredDrawing[PetersenGraph[], EdgeStyle -> Black, 
 VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .3]

iLayeredDrawing[FromEntity[Entity["Graph", "HoffmanSingletonGraph"]], 
 EdgeStyle -> Black, 
 VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .6, 
 ImageSize -> 600]

Answer 2

1. Rescale the vertex coordinates given by "LayeredEmbedding" to run form 0 to 1 in each dimension,
2. Pick the edges with vertices in the right-most layer by checking if both vertices have first coordinate equal to 1.,
3. Use a slightly modified version of the built-in edge shape function "CurvedArc" as the EdgeShapeFunction for the right-most edges.

ClearAll[eSF, toLayered, layeredG]
eSF[curv_: 1] := GraphElementData[{"CurvedArc", "Curvature" -> curv}][
    SortBy[-Last @ # &] @ #[[{1, -1}]], ##2] &;

toLayered = Module[{el = EdgeList[#], g, re, 
     vcoords = Round[#, .001] & @ Transpose[Rescale /@ 
        Transpose[GraphEmbedding[#, {"LayeredEmbedding", "Orientation" -> Left}]]]},
    g = SetProperty[#, VertexCoordinates -> vcoords];
    re = Pick[el, First[PropertyValue[{g, #}, VertexCoordinates]]& /@ Apply[List][#] == 
        {1., 1.}& /@ el];
    SetProperty[g, { EdgeShapeFunction -> {Alternatives @@ re -> eSF[]}}]] &;

We compose toLayered with Graph to get a function that takes the same arguments and options as Graph:

layeredG = toLayered @* Graph;

Examples:

layeredG[PetersenGraph[], EdgeStyle -> Black, 
 VertexStyle -> Directive[White, EdgeForm[Black]], VertexSize -> .3]

hsg = FromEntity[Entity["Graph", "HoffmanSingletonGraph"]];
layeredG[hsg, ImageSize -> 600, VertexSize -> .8, 
  VertexStyle -> White, EdgeStyle -> Gray]