s-Route

Author

Eric W. Weisstein
November 16, 2010

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/s-Route.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/s-Route.html.

©2010 Wolfram Research, Inc. except for portions noted otherwise

Algorithm

SRoutes[edges_,1]:=Join[#,Reverse/@#]&[edges]
SRoutes[edges_,n_Integer]:=SRoutes[SRoutes[edges,n-1],SRoutes[edges,1]]
(*
SRoutes[edges_,n_Integer]:=Module[{routes=SRoutes[edges,n-1],arcs=SRoutes[edges,1]},
Flatten[Function[v,Append[v[[1]],#]&/@v[[2]]]/@({#,Cases[arcs,{#[[-1]],Except[#[[-2]]]}][[All,-1]]}&/@routes),1]
]
*)

SRoutes[routes_,arcs_]:=
Flatten[Function[v,Append[v[[1]],#]&/@v[[2]]]/@({#,Cases[arcs,{#[[-1]],Except[#[[-2]]]}][[All,-1]]}&/@routes),1]

ArcTransitiveQ[g_System`Graph,s_]:=Module[{
auto=AutomorphismGroup[g],
edges=List@@@EdgeList[g],
sroutes,
orbs
},
sroutes=SRoutes[edges,s];
orbs=GroupOrbits[auto,sroutes,Function[v,PermutationReplace[v,#2]]/@#1&];
Sort[orbs]=={Sort[sroutes]}
]

ArcTransitivity[g_System`Graph]:=Module[{
auto=AutomorphismGroup[g],
arcs,
sroutes,
orbs,
s=1,
dom=Range[VertexCount[g]],
done=False
},
If[GroupOrbits[auto,dom[[{1}]]]=!={dom},
$Failed,
(* Else *)
arcs=sroutes=SRoutes[List@@@EdgeList[g],s];
While[!done&&s<8,
orbs=GroupOrbits[auto,sroutes[[{1}]],Function[v,PermutationReplace[v,#2]]/@#1&];
If[Sort[orbs]=!={Sort[sroutes]},
done=True,
(* Else *)
s++;
sroutes=SRoutes[sroutes,arcs]
]
];
If[s<8,s-1,$Failed]
]
]

Cube

GraphData["CubicalGraph","LabeledImage"]

arc=Select[GraphData[All],GraphData[#,"ArcTransitive"]&];

edges=GraphData["CubicalGraph","EdgeIndices"]

arcs=Join[#,Reverse/@#]&[edges]

Cases[arcs[1],{#[[2]],Except[#[[1]]]}]&/@arcs[1]

l=Sort[Flatten[Function[v,Append[v[[1]],#]&/@v[[2]]]/@({#,Cases[arcs[1],{#[[-1]],Except[#[[-2]]]}][[All,-1]]}&/@arcs[1]),1]]

s1=SRoutes[edges,1]

Union[s1]===Sort[s1]

s2=Sort[SRoutes[edges,2]]

s2=SRoutes[s1,arcs]

Union[s2]===Sort[s2]

s3=SRoutes[edges,3]

s3=SRoutes[s2,arcs]

Union[s3]==Sort[s3]

ArcTransitivity[GraphData["CubicalGraph"]]

Table[ArcTransitiveQ[GraphData["CubicalGraph"],n],{n,4}]

Levi Graph

ArcTransitivity[GraphData["LeviGraph"]]

Table[ArcTransitiveQ[GraphData["LeviGraph"],n],{n,6}]

Cycle

Table[ArcTransitiveQ[GraphData["TriangleGraph"],n],{n,4}]

OptionValue[Debug->False,{Debug->True},Debug]

ArcTransitivity[GraphData[{"Path",2}],Debug->True]

Through[{PathGraphQ,AcyclicGraphQ}[GraphData["TriangleGraph"]]]

ArcTransitivity[GraphData["TriangleGraph"]]

SRoutes[GraphData["C5","EdgeIndices"]]

SRoutes[GraphData["C5","EdgeIndices"],3]