Distance-Transitive Graph

Author

Eric W. Weisstein
June 10, 2019

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Distance-TransitiveGraph.nb.

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

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

Counts

All DT graphs are known up to <= 13 vertices

Length/@Table[GraphData["DistanceTransitive",n],{n,30}]

TextGrid[Table[{n,Length[dt=GraphData["DistanceTransitive",n]],dt},{n,13}],Dividers->All,Alignment->{{{Decimal},Left}}]

Symmetric but not DT

Length/@Table[GraphData["Symmetric",n],{n,15}]

TextGrid[Table[{n,Length[diff=Complement[GraphData["Symmetric",n],GraphData["DistanceTransitive",n]]],diff},{n,16}],Dividers->All,Alignment->{{{Decimal},Left}}]

GraphData[{"Circulant",{10,{1,4}}},{"DistanceTransitive","DistanceRegular","Symmetric"}]

Through[{DistanceTransitiveGraphQ,DistanceRegularGraphQ,SymmetricGraphQ}[GraphData[{"Circulant",{10,{1,4}}}]]]

DT but not symmetric

Table[Complement[GraphData["DistanceTransitive",n],GraphData["Symmetric",n]],{n,16}]

By Valency

Length[dt=GraphData[{"Connected","DistanceTransitive"}]]

NiceTable[n_]:=TextGrid[SortBy[{GraphData[#,"V"],GraphData[#,"Name"],GraphData[#,"IntersectionArray"]}&/@Select[dt,GraphData[#,"Δ"]===n&],First],Alignment->{{Decimal,{Left}}},Dividers->All]

3

NiceTable[3]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==3&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"},;;130],GraphData[g=#,"Δ"]==3&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->80,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[GraphData[{"DistanceTransitive","Cubic"}],GraphData[#,"V"]&],5,5,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{-40,0}]

4

NiceTable[4]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==4&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"}],GraphData[g=#,"Δ"]==4&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->80,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[GraphData[{"DistanceTransitive","Quartic"}],GraphData[#,"V"]&],5,5,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{-40,0}]

5

NiceTable[5]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==5&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"}],GraphData[g=#,"Δ"]==5&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->80,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData[{"DistanceTransitive","Quintic"}],GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],5,5,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{-40,0}]

6 (missing 1: GD(3,1))

Missing:
GD(3,1) on 1456 nodes

NiceTable[6]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==6&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"}],GraphData[g=#,"Δ"]==6&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Select[GraphData["Regular",#],GraphData[#,"Δ"]==6&]&/@{1456}

IntersectionArray[GraphData[{"BipartiteKneser",{11,5}}]]//Timing

not in http://www.distanceregular.org/indexes/morethan200vertices.html

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->80,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData[{"DistanceTransitive","Sextic"}],GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],5,5,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{-40,0}]

7 (missing 1 doubled Grassmann)

Missing:
"doubled Grassman graph" on 310 nodes,
{"BipartiteKneser", {13, 6}} on 3432 nodes

NiceTable[7]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==7&]

{"Odd", 7} is very slow

(dt2=Monitor[Select[GraphData[{"Connected","Regular"},;;1000],GraphData[g=#,"Δ"]==7&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Select[GraphData["Regular",#],GraphData[#,"Degrees"][[1]]==7&]&/@{310,3432}

IntersectionArray[GraphData[{"Odd",7}]]//Timing

not in http://www.distanceregular.org/indexes/morethan200vertices.html

Reduce[QBinomial[n,k,q]==155&&0<k≤n/2<20&&0<q<10,{n,k,q},Integers]

GraphData[{"Grassmann",{2,{5,2}}},"V"]

Select[GraphData@"Grassman*",GraphData[#,"V"]==310/2&]

Not this one:

VertexCount[g=IndexGraph@BipartiteDoubleGraph[GraphData[{"Grassmann",{2,{5,2}}}]]]

RecognizeGraph[g]

VertexDegree[g]//Union

IntersectionArray[g]//Timing

Or this one:

VertexCount[g=DoubleGraph[GraphData[{"Grassmann",{2,{5,2}}}]]]

RecognizeGraph[g]

VertexDegree[g]//Union

IntersectionArray[g]//Timing

So *which* double?

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->130,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData[{"DistanceTransitive","Septic"}],GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],3,3,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

8

Missing:
{"Odd", 8} on 6435 nodes
{"BipartiteKneser", {15, 7}} on 12870 nodes

NiceTable[8]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==8&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"}],GraphData[g=#,"Δ"]==8&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Entity["Graph",{"Odd",8}]["VertexCount"]{1,2}

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->100,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData[{"DistanceTransitive","Octic"}],GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],4,4,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

9

Missing:
{"Odd", 9} on 24310 nodes
{"BipartiteKneser", {17, 8}} on 48620 nodes

NiceTable[9]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==9&]

{"Cage", {9, 8}} is really slow

(dt2=Monitor[Select[GraphData[{"Connected","Regular"},;;1000],GraphData[g=#,"Δ"]==9&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Entity["Graph",{"Odd",9}]["VertexCount"]{1,2}

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->100,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData["DistanceTransitive"],GraphData[#,"MaximumVertexDegree"]==9&&GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],4,4,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

10 (missing 1: GO(2,4))

Missing:
GO(2,4) on 1755 nodes
O(10) on 92378 nodes
GD(1,9) on 132860 nodes
H(19,9) on 184756 nodes

NiceTable[10]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==10&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"},;;1000],GraphData[g=#,"Δ"]==10&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Entity["Graph",{"Odd",10}]["VertexCount"]{1,2}

Select[GraphData["Regular",#],GraphData[#,"Δ"]==10&]&/@{1755}

From http://www.distanceregular.org/graphs/incidence-16.10.6.html, "The first graph ... is the unique distance-transitive example, namely the distance-3 graph of the folded 6-cube."

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->100,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData["DistanceTransitive"],GraphData[#,"MaximumVertexDegree"]==10&&GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],4,4,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

11 (missing 1: AG)

Missing:
AG(2,11) minus a parallel class on 242 nodes
O(11) on 352716 nodes
H(21,10) on 705432 nodes

NiceTable[11]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==11&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"}],GraphData[g=#,"Δ"]==11&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Entity["Graph",{"Odd",11}]["VertexCount"]{1,2}

AG(2,11) minu parallel class is not in http://www.distanceregular.org/indexes/morethan200vertices.html or http://www.distanceregular.org/indexes/incidencegraphs.html

Should be 5

Select[GraphData["Regular",#],GraphData[#,"MaximumVertexDegree"]==11&]&/@{242}

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->100,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData["DistanceTransitive"],GraphData[#,"MaximumVertexDegree"]==11&&GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],3,3,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

12 (missing 1: GO(4,2))

Missing:
GO(4,2) on 2925 nodes
O(12) on 1352078 nodes
H(23,11) on 2704156 nodes

NiceTable[12]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==12&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"},;;1000],GraphData[g=#,"Δ"]==12&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Entity["Graph",{"Odd",12}]["VertexCount"]{1,2}

Select[GraphData["Regular",#],GraphData[#,"Δ"]==12&]&/@{2925}//Column

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->100,TextAlignment->Center],BaseStyle->{9,Italic}]&/@SortBy[Select[GraphData["DistanceTransitive"],GraphData[#,"MaximumVertexDegree"]==12&&GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],4,4,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

13 (missing 2: AG + doubled Grassman)

Missing:
AG(2,13) minus a parallel class on 338 nodes
doubled Grassmann graph on 2420 nodes
O(13) on 5200300 nodes
H(25,12) on 10400600 nodes

NiceTable[13]

dt1=Select[GraphData["DistanceTransitive"],GraphData[#,"Δ"]==13&]

(dt2=Monitor[Select[GraphData[{"Connected","Regular"}],GraphData[g=#,"Δ"]==13&&DistanceTransitiveGraphQ[GraphData[#]]&],g])//Timing

Complements[dt1,dt2]

Select[GraphData["Regular",#],GraphData[#,"MaximumVertexDegree"]==13&]&/@{338,2420}

Entity["Graph",{"Odd",13}]["VertexCount"]{1,2}

Reduce[QBinomial[n,k,q]==2420/2&&0<k≤n/2<20&&0<q<10,{n,k,q},Integers]

GraphData["Grassmann*"]

Not in http://www.distanceregular.org/indexes/grassmanngraphs.html

GraphicsGrid[Partition[GraphPlot[Graph[#],Method->None,PlotLabel->TextCell[GraphData[#,"Name"],PageWidth->100,TextAlignment->Center],BaseStyle->{10,Italic}]&/@SortBy[Select[GraphData["DistanceTransitive"],GraphData[#,"MaximumVertexDegree"]==13&&GraphData[#,"Embeddings"]=!={}&],GraphData[#,"V"]&],4,4,{1,1},{}]/.AbsolutePointSize[_]:>AbsolutePointSize[4],ImageSize->400,Spacings->{0,0}]

> 13

dt=Select[GraphData[{"Connected","DistanceTransitive"}],GraphData[#,"Δ"]>13&]

TextGrid[SortBy[{GraphData[#,"Δ"],GraphData[#,"V"],GraphData[#,"Name"],GraphData[#,"IntersectionArray"]}&/@dt,First],Alignment->{{Decimal,Decimal,{Left}}},Dividers->All]

Not all in class

Cases[{#,GraphData[#,"DistanceTransitive"]}&/@GraphData["BipartiteKneser"],{g_,False}:>g]

Cases[{#,GraphData[#,"DistanceTransitive"]}&/@GraphData["HalvedCube"],{_,False}]

Cases[{#,GraphData[#,"DistanceTransitive"]}&/@GraphData["Johnson"],{_,False}]

Cases[{#,GraphData[#,"DistanceTransitive"]}&/@GraphData["Kneser"],{g_,False}:>g]

Algorithms

IGraph/M

data=Monitor[{g=#,GraphData[#,"DistanceTransitive"],IGDistanceTransitiveQ[GraphData[#]]}&/@GraphData[All],g];//AbsoluteTiming

Slow:

Print[{#,IGDistanceTransitiveQ[GraphData[#]]//Timing}]&/@{{"Cage",{12,8}},{"Cage",{14,8}},{"Kneser",{14,6}}};

Disconnected:

IGDistanceTransitiveQ[GraphData["2C3"]]

Graphs.m

Slow:

Print[{#,DistanceTransitiveGraphQ[GraphData[#]]//Timing}]&/@{{"Cage",{12,8}},{"Cage",{14,8}},{"Kneser",{14,6}}};

Disconnected:

DistanceTransitiveGraphQ[g=GraphData["2C3"]]

Including 0:

data=Monitor[{g=#,GraphData[#,"DistanceTransitive"],DistanceTransitiveGraphQ[GraphData[#]]}&/@GraphData[All],g];//AbsoluteTiming

DeleteCases[data,{_,x_,x_}]

Excluding 0:

data=Monitor[{g=#,GraphData[#,"DistanceTransitive"],DistanceTransitiveGraphQ[GraphData[#]]}&/@GraphData[All],g];//AbsoluteTiming

DeleteCases[data,{_,x_,x_}]

From large to small excluding 0:

data=Monitor[{g=#,GraphData[#,"DistanceTransitive"],DistanceTransitiveGraphQ[GraphData[#]]}&/@GraphData[All],g];//AbsoluteTiming

DeleteCases[data,{_,x_,x_}]

Comparison

data=Monitor[{
g=#,
GraphData[#,"DistanceTransitive"],
DistanceTransitiveGraphQ[GraphData[#]]//Timing,
IGDistanceTransitiveQ[GraphData[#]]//Timing
}&/@GraphData[All],g];

DeleteCases[data,{_,x_,{_,x_},{_,x_}}]

data[[All,3,1]]//Total

data[[All,4,1]]//Total

list1=Tooltip[#3[[1]],#1]&@@@data;

list2=Tooltip[#4[[1]],#1]&@@@data;

ListPlot[{list1,list2},PlotLegends->{"Graphs.m","IGraph/M"},ImageSize->1000]

ratio=Tooltip[#3[[1]]/#4[[1]],#1]&@@@data;

ListPlot[ratio]

GraphData

CompleteKPartite[k_,n_]:=CompleteGraph@@Table[n,{k}]

GraphDataString

file=OpenWrite["dt.m"]

WriteString[file,GraphDataString[GraphComplement[Graph[{"Lattice",{4,4}}]],
"StandardName"->{"LatticeComplement",{4,4}},
"Name"->"complement of (4,4)-lattice graph",
"Classes"->{"DistanceRegular","DistanceTransitive"},
Debug->True,
TimeConstraint->60,
Vertices->None
]]

WriteString[file,GraphDataString[CompleteKPartite[4,4],
"StandardName"->{"Complete4Partite",{4,4,4,4}},
"Name"->"(4,4,4,4)-complete 4-partite graph",
"Classes"->{"DistanceRegular","DistanceTransitive"},
"Information"->"Completek-PartiteGraph",
Debug->True,
TimeConstraint->60,
Vertices->None
]]

WriteString[file,GraphDataString[CompleteKPartite[3,6],
"StandardName"->{"CompleteTripartite",{6,6,6}},
"Name"->"(6,6,6)-complete tripartite graph",
"Classes"->{"DistanceRegular","DistanceTransitive"},
"Information"->"CompletTripartiteGraph",
Debug->True,
TimeConstraint->60,
Vertices->None
]]

Close[file]

file=OpenAppend["~/graphs.m"]

g=FromUnorderedPairs[ReadGAPEdgeList["~/PGammaU3,4.gap"]]

WriteString[file,
GraphDataString[g,
"StandardName"->"PGammaU34OnNonisotropicPoints",
"Name"->"PΓU(3,4) on nonisotropic points",
"Information"->{"Distance-TransitiveGraph"},
"Skip"->{"ChromaticPolynomial","ClawFree","IndependencePolynomial","MatchingPolynomial"},
"Classes"->{"DistanceTransitive","DistanceRegular"},
"NotationRules"->{"DistanceRegular"->{{12,10,5},{1,1,8}}},
Vertices->None,
Debug->True,
TimeConstraint->60
]]//Timing

Close[file];