Owens Graphs

Author

Eric W. Weisstein
May 4, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/OwensGraphs.nb.

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

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

Description

"OwensGraph76"

The 76-node Owens graph (Owens 1980) provides the smallest known example of a polyhedral quintic nonhamiltonian graph. It was constructed by inserting copies of the skeleton of the gyroelongated pentagonal pyramid (Subscript[J, 11]) at the 10 of the 11 vertices of the Herschel graph.

"OwensGraph78"

The 78-node Owens graph (Owens 1983) is a bicubic nonhamiltonian graph which at the time was the smallest such graph known. It was constructed by various operations on the generalized Petersen graph GP(8, 2).

Figure

Owens=SortBy[GraphData["Owens*"],(ToExpression[StringCases[#,DigitCharacter..][[1]]]&)]

bug(342624): TextCell[..., PageWidth -> 50, Hyphenation -> True] fails to hyphenate
bug(422923): GraphicsRow/GraphicsGrid cut off plot label text

GraphicsRow[Show[StyleGraphs[GraphData[#],VertexSize->{"Scaled",.01}],PlotLabel->TextCell[Style[GraphData[#,"Name"],Directive[16,Black,Italic,FontFamily->"Times New Roman",Hyphenation->True]],PageWidth->160,TextAlignment->Center]]&/@Owens,Dividers->All,ImageSize->500]

GraphicsRow[Show[StyleGraphs[GraphData[#],VertexSize->{"Scaled",.02}],PlotLabel->TextCell[Style[GraphData[#,"V"],Directive[14,Black,FontFamily->"Times New Roman"]],TextAlignment->Center]]&/@Owens,Dividers->All,ImageSize->800]

Properties: "OwensGraph76"

Embeddings

Default

StyleGraphs[GraphData["OwensGraph76"],VertexSize->.5]

All

GraphData["OwensGraph76","Graph","All"]//StyleGraphs

Planar

GraphData["OwensGraph76","Planar"]

GraphData["OwensGraph76","Graph","Planar"]//StyleGraphs

Tutte embeddings

<<IGraphM`

faces=ReverseSort@SymmetricallyDistinctFaces[GraphData["OwensGraph76"]]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[GraphData["OwensGraph76"],"OuterFace"->#]&/@Select[faces,Length[#]>3&]

gs=Annotate[#,{VertexLabels->None,ImageSize->Tiny}]&/@{}

Tutte embedding construction

GraphPlot[RotateGraph[,Pi]]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Halin

GraphData["OwensGraph76","Graph","Halin"]//StyleGraphs

LCF

GraphData["OwensGraph76","HamiltonianCycleCount"]

GraphData["OwensGraph76","LCFSignature"]

GraphData["OwensGraph76","Graph","LCF"]//StyleGraphs

UnitDistance

GraphData["OwensGraph76","UnitDistance"]

UnitDistanceGraphQ[GraphData["OwensGraph76"],Debug->True]//Timing

GraphData["OwensGraph76","Graph","UnitDistance"]//StyleGraphs

Matchstick

GraphData["OwensGraph76","Matchstick"]

GraphData["OwensGraph76","Graph","Matchstick"]//StyleGraphs

MinimalCrossing

GraphData["OwensGraph76",{"RCN","CN"}]

GraphData["OwensGraph76","Graph","MinimalCrossing"]//StyleGraphs

Default embedding

g=Graph@GraphData["OwensGraph76","Edges"]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

MinimalCrossing Construction

GraphPlot@RotateGraph[MinimalCrossingGraph[GraphData["OwensGraph76"]]]

v={};
g=Graph[Range[Length[v]],UndirectedEdge@@@{},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["OwensGraph76","Edges"]]

3D All

GraphData["OwensGraph76","Graph",{"3D","All"}]

3D UnitDistance

GraphData["OwensGraph76","Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData["OwensGraph76","Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData["OwensGraph76","Polyhedron"]}]

3D Canonical

GraphData["OwensGraph76","Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData["OwensGraph76","Polyhedron"],Yellow,Sphere[]}]

3D Polyhedron construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["OwensGraph76"],-1]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->5000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/5,"PlanarFactor"->1/5,Debug->True])//Timing

Graphics3D[can]

SimplePolyhedronQ[can]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

3D Canonical construction from PolyhedralEmbedding

g=GraphData["OwensGraph76","Graph","Planar"][[1]]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->3],Boxed->True]//Quiet

With[
{faces=PlanarFaceList[Graph[EdgeList[g2]]],v=GraphEmbedding@g2},
Graphics3D[{Point[{0,0,0}],Opacity[.5],Sphere[],FaceForm[Green,Red],
poly=Polyhedron[1.2v,faces]}]]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->2000,PrecisionGoal->20,"ProgressInterval"->500,"TangentFactor"->1/20,"PlanarFactor"->1/20,Debug->True])//Timing

Graphics3D[can]

SimplePolyhedronQ[can]

If[%===False,Quit[]]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]

Properties

Hamiltonian

GraphData["OwensGraph76","Hamiltonian"]

TimeConstrained[HamiltonianGraphQ[GraphData["OwensGraph76"]],5]//Timing

HamiltonianCycleCount

GraphData["OwensGraph76","HamiltonianCycleCount"]

HamiltonianPathCount

GraphData["OwensGraph76","HamiltonianPathCount"]

HamiltonianPaths

GraphData["OwensGraph76","HamiltonianPaths"]

Traceable

GraphData["OwensGraph76","Traceable"]

TimeConstrained[TraceableGraphQ[GraphData["OwensGraph76"]],5]//Timing

UnitDistance

GraphData["OwensGraph76","UnitDistance"]

UnitDistanceGraphQ[GraphData["OwensGraph76"],Debug->True]//Timing

Construction

"OwensGraph76"

Owens, P.J.  "On Regular Graphs and Hamiltonian Circuits, Including Answers to Some Questions of Joseph Zaks."  J. Combin Theory, Ser. B 28, 262–277, 1980.

https://doi.org/10.1016/0095-8956(80)90072-6

v={{156.765625`,161.6875`},{156.28125`,100.66015625`},{214.13671875`,145.1171875`},{193.328125`,212.6640625`},{120.8984375`,212.9921875`},{98.30078125`,142.07421875`},{58.89453125`,194.85546875`},{156.14453125`,263.140625`},{255.49609375`,195.671875`},{218.7421875`,78.33984375`},{96.140625`,79.30859375`}};

e[l__]:=Sequence@@Partition[{l},2,1]

alpha=ScaleGraph@CenterGraph@Graph[Range[Length[v]],UndirectedEdge@@@{e[11,10,9,8,7,11,2,10,3,9,4,8,5,7,6,11],e[2,3,4,5,6,2,1,5],e[6,1,4],{1,3}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@alpha

GraphData[{"JohnsonSkeleton",11},"Graph","All"]

GraphData[{"JohnsonSkeleton",11},"StandardNames"]

PolyhedronData[{"Johnson",11},"StandardNames"]

GraphData[{"JohnsonSkeleton",11},"V"]

delta0=RotateGraph[GraphData[{"JohnsonSkeleton",11},"Graph","Labeled"],-Pi/2];

delta=Graph[Range[12],Union[EdgeList[delta0],UndirectedEdge[#,12]&/@{8,10,11}],VertexCoordinates->Append[GraphEmbedding[delta0],{3,0}],VertexLabels->Automatic]

e[l__]:=Sequence@@Partition[{l},2,1]

g0=Graph[Range[11],UndirectedEdge@@@{e[5,10,6,1,5,7,9,8,6,3,2,4,5],{1,2},{9,10},e[4,11,8],e[7,11,3]},VertexCoordinates->{{-3,0},{-2,0},{-1,1},{-1,-1},{0,-2},{0,2},{1,-1},{1,1},{2,0},{3,0},{0,0}},VertexLabels->Automatic]

RecognizeGraph[g0]

The Herschel graph is the smallest nonhamiltonian polyhedral graph

GraphData["HerschelGraph","Graph","All"]

<<MathWorld`Graphs`

greplaced=Fold[VertexReplaceGraph[#1,delta,Sequence@@#2]&,g0,{{1,.2,Pi/2},{10,.2,Pi},{3,.2,-Pi/4},{4,.2,3Pi/4},{8,.2,5Pi/4},{7,.2,3Pi/4}}]

g76=IndexGraph@VertexDelete[EdgeAdd[greplaced,UndirectedEdge@@@{{23,6},{23,2},{20,2},{18,5},{32,6},{5,30},{35,66},{35,80},{2,44},{42,6},{47,2},{47,11},{56,11},{5,54},{59,2},{59,11},{78,5},{5,83},{83,11},{6,68},{71,6},{71,11}}],9]

VertexCount[g76]

VertexDegree[g76]//Union

RectilinearCrossingCount[g76]//Timing

FindHamiltonianCycle[g76]//Timing

g76new=Graph[VertexList[g76],Sort[Sort/@EdgeList[g76]],VertexCoordinates->GraphEmbedding[g76]]

g76new=;

"OwensGraph78"

Owens, P.J.  "Bipartite Cubic Graphs and a Shortness Exponent."  Disc. Math. 44, 327–330, 1983.

<<MathWorld`Graphs`

graphH=EdgeDelete[RotateGraph[GraphData[{"GeneralizedPetersen",{8,3}},"Graph",{"Labeled","GeneralizedPetersen"}][[1]],Pi/8+Pi/2],UndirectedEdge@@@{{1,16},{8,9}}]

graphI0=MyGraphUnion[graphH,2,VertexLabels->Automatic]

Position[VertexDegree[graphI0],2]//Flatten

I orientation 1

graphI=EdgeAdd[graphI0,UndirectedEdge@@@{{16,17},{1,32},{9,24},{8,25}}]

VertexDegree[graphI]//Union

BipartiteGraphQ[graphI]

graphL=HighlightGraph[VertexDelete[graphI,{16,17}],{{11,15},{22,18}}]

Tally[VertexDegree[graphL]]//Sort

VertexCount[graphL]

RecognizeGraph[graphL]

baseJ=Graph[Range[5],UndirectedEdge@@@{{4,5}},VertexCoordinates->{{0,0},{-2,2},{2,2},{0,2},{0,3}},VertexLabels->Automatic]

g78=EdgeAdd[VertexReplaceGraph[VertexReplaceGraph[VertexReplaceGraph[baseJ,graphL,2,.3,0],graphL,3,.3,0],graphH,1,.3,0,VertexSize->.5,VertexLabels->Automatic],UndirectedEdge@@@{
(* L1x *){16,4},{20,85},
(* L1y *){23,5},{27,78},
(* L2x *){48,4},{52,77},
(* L2y *){59,5},{55,70}
}
]

g78=;

VertexCount[g78]

BipartiteGraphQ[g78]

VertexDegree[g78]//Union

VertexConnectivity[g78]

VertexList[g78][[Position[VertexDegree[g78],2|4]//Flatten]]

TimeConstrained[FindHamiltonianCycle[g78],1]

I orientation 2

graphI2=EdgeAdd[graphI0,UndirectedEdge@@@{{16,25},{1,32},{9,24},{8,17}}]

IsomorphicGraphQ[graphI,graphI2]

VertexDegree[graphI2]//Union

BipartiteGraphQ[graphI2]

graphL2=HighlightGraph[VertexDelete[graphI2,{16,17}],{{11,15},{22,18}}]

VertexCount[graphL2]

RecognizeGraph[graphL2]

baseJ2=Graph[Range[5],UndirectedEdge@@@{{4,5}},VertexCoordinates->{{0,0},{-2,2},{2,2},{0,2},{0,3}},VertexLabels->Automatic]

g78=EdgeAdd[VertexReplaceGraph[VertexReplaceGraph[VertexReplaceGraph[baseJ2,graphL,2,.3,0],graphL,3,.3,0],graphH,1,.3,0,VertexSize->.5,VertexLabels->Automatic],UndirectedEdge@@@{
(* L1x *){16,4},{20,85},
(* L1y *){23,5},{27,78},
(* L2x *){48,4},{52,77},
(* L2y *){59,5},{55,70}
}
]

VertexCount[g78]

BipartiteGraphQ[g78]

VertexDegree[g78]//Union

VertexConnectivity[g78]

VertexList[g78][[Position[VertexDegree[g78],2|4]//Flatten]]

TimeConstrained[FindHamiltonianCycle[g78],1]

Table[Binomial[2n,2],{n,2,16,2}]

Random

gbase=IndexGraph@VertexReplaceGraph[VertexReplaceGraph[VertexReplaceGraph[baseJ2,graphL,2,.3,0],graphL,3,.3,0],graphH,1,.3,0,VertexSize->.5,VertexLabels->Automatic]

d=VertexDegree[gbase]

one=Position[d,1]//Flatten

two=Position[d,2]//Flatten

sub1=Subsets[Flatten[Outer[List,{1,2},{13,17,18,22}],1],{2}]

ss1=Select[sub1,Length[Union[Flatten[#]]]==4&]

sub2=Subsets[Flatten[Outer[List,{1,2},{43,47,48,52}],1],{2}]

ss2=Select[sub2,Length[Union[Flatten[#]]]==4&]

top=Flatten[Outer[Join,ss1,ss2,1],1]

Length[top]

left={13,17,18,22};
right={43,47,48,52};
bot={63,70,71,78};

top[[1]]

edges=Flatten[Function[p,Join[p,#]&/@Select[Subsets[Tuples[{Complement[{13,17,18,22,43,47,48,52},Flatten@p],bot}],{4}],Length[Union[Flatten[#]]]==8&]]/@Take[top,All],1];

Length[edges]

Take[edges,1]

Length[gs=Union[CanonicalGraph[EdgeAdd[gbase,UndirectedEdge@@@#]]&/@edges]]//Timing

gs

CubicGraphQ/@gs

BipartiteGraphQ/@gs

bip=Select[gs,BipartiteGraphQ]

TextGrid[{#,FindHamiltonianCycle[#][[All,All,1]]//Timing}&/@bip,Dividers->All]

GraphData

GraphDataString

"OwensGraph76"

<<MathWorld`Graphs`

file=OpenWrite["~/owens.m"]

WriteString[file,GraphDataString[
g76new,
"StandardName"->"OwensGraph76",
"Name"->"Owens graph 76",
"Information"->"OwensGraphs",
"Classes"->{"Nonhamiltonian"},
"Skip"->{"ConnectedInducedSubgraphPolynomial"}
]]