Wiener-Araya Graph

Author

Eric W. Weisstein
May 16, 2022

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Wiener-ArayaGraph.nb.

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

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

Embeddings

"WienerArayaGraph"

GraphData["WienerArayaGraph","StandardName"]

All

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

Halin

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

LCF

GraphData["WienerArayaGraph","LCFSignature"]

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

UnitDistance

GraphData["WienerArayaGraph","UnitDistance"]

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

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

Select[%,!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&]

Select[UnitDistanceEmbeddingRefine/@Complement@@(GraphData["WienerArayaGraph","Graph",#]&/@{"All","UnitDistance"}),UnitDistanceGraphEmbeddingQ]

FindUnitDistanceEmbedding[GraphData["WienerArayaGraph"],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

UnitDistance FindSubgraphUnitDistanceEmbedding

{"WienerArayaGraph",l=FindSubgraphUnitDistanceEmbedding[GraphData["WienerArayaGraph"],TimeConstraint->300,"Results"->All]//Timing}

gs=UniqueEmbeddings[l]

Matchstick

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

MinimalCrossing

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

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

Default embedding

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

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

RecognizeGraph[g]

MinimalCrossing Construction

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["WienerArayaGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

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

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

3D Canonical

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

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

3D Polyhedron construction

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

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->1000,MaxIterations->10000,PrecisionGoal->20])//Timing

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]

Properties

Missing

Select[GraphData["UltimateQuestionGraph","Properties"],Head[h=GraphData["UltimateQuestionGraph",#]]===Missing&&h=!=Missing["TooLarge"]&]

Faces

ShowLabeledGraph[g2]

Faces[g2]

Length[%]

Hamiltonian Paths

g=Graph[{{{1, 3}}, {{1, 7}}, {{2, 5}}, {{2, 8}}, {{3, 9}}, {{4, 6}}, {{5, 10}}, {{6, 11}}, {{6, 12}}, {{7, 13}}, {{8, 14}}, 
  {{9, 12}}, {{9, 13}}, {{10, 11}}, {{10, 14}}, {{11, 15}}, {{12, 16}}, {{13, 17}}, {{14, 18}}, {{15, 16}}, {{15, 18}}, 
  {{15, 22}}, {{16, 17}}, {{17, 20}}, {{17, 21}}, {{18, 23}}, {{19, 20}}, {{20, 25}}, {{21, 22}}, {{21, 28}}, {{22, 26}}, 
  {{23, 24}}, {{23, 26}}, {{25, 28}}, {{25, 29}}, {{26, 27}}, {{26, 30}}, {{27, 28}}, {{27, 32}}, {{28, 31}}, {{29, 33}}, 
  {{29, 35}}, {{30, 34}}, {{30, 36}}, {{31, 33}}, {{31, 37}}, {{32, 34}}, {{32, 37}}, {{33, 38}}, {{34, 40}}, {{35, 41}}, 
  {{36, 42}}, {{37, 39}}, {{38, 41}}, {{40, 42}}, {{39, 40}}, {{38, 39}}, {{2, 42}}, {{41, 42}}, {{1, 41}}, {{1, 2}}, 
  {{3, 4}}, {{4, 5}}, {{8, 24}}, {{24, 36}}, {{7, 19}}, {{19, 35}}}, {{{0.0128629, 0.026698899999999998}}, 
  {{0.0128629, 0.0408036}}, {{0.014038199999999999, 0.028461999999999998}}, 
  {{0.014038199999999999, 0.033604300000000004}}, {{0.014038199999999999, 0.038452799999999995}}, 
  {{0.0150667, 0.033751199999999995}}, {{0.015213599999999997, 0.0278743}}, {{0.015213599999999997, 0.0396282}}, 
  {{0.0159482, 0.03125350000000001}}, {{0.0159482, 0.036102}}, {{0.016389, 0.034779700000000004}}, 
  {{0.0165359, 0.0328696}}, {{0.0171236, 0.030224999999999995}}, {{0.0174175, 0.037865100000000006}}, 
  {{0.018445999999999997, 0.035514300000000006}}, {{0.0185929, 0.032428900000000004}}, 
  {{0.018739800000000004, 0.0309596}}, {{0.018886699999999996, 0.0375712}}, {{0.0199152, 0.0278743}}, 
  {{0.0199152, 0.0293435}}, {{0.0199152, 0.0328696}}, {{0.0199152, 0.0358081}}, {{0.0199152, 0.0385997}}, 
  {{0.0199152, 0.0396282}}, {{0.020796799999999997, 0.0309596}}, {{0.021090599999999998, 0.0375712}}, 
  {{0.0213845, 0.0353674}}, {{0.0216783, 0.0325758}}, {{0.022412900000000003, 0.030224999999999995}}, 
  {{0.022706799999999996, 0.037865100000000006}}, {{0.023441399999999998, 0.0327227}}, 
  {{0.023441399999999998, 0.0350735}}, {{0.023882100000000003, 0.0308127}}, {{0.023882100000000003, 0.0368366}}, 
  {{0.0246168, 0.0278743}}, {{0.0246168, 0.0396282}}, {{0.024910599999999998, 0.0338981}}, 
  {{0.025792100000000002, 0.029049600000000005}}, {{0.025792100000000002, 0.0338981}}, 
  {{0.025792100000000002, 0.038452799999999995}}, {{0.0269675, 0.026698899999999998}}, {{0.0269675, 0.0408036}}}];

Length[h=HamiltonianPaths[g,All]]//Timing

Put[h,"UltimateQuestionGraph-HC.m"]

Construction

Explicit

g=Graph[{{{1,2}},{{1,4}},{{1,5}},{{1,6}},{{2,3}},{{2,7}},{{2,8}},{{3,4}},{{3,9}},{{3,10}},{{4,11}},{{4,12}},{{5,16}},{{5,17}},{{6,13}},{{6,18}},{{7,13}},{{7,19}},{{8,14}},{{8,20}},{{9,14}},{{9,21}},{{10,15}},{{10,22}},{{11,15}},{{11,23}},{{12,16}},{{12,24}},{{13,25}},{{14,26}},{{15,27}},{{16,28}},{{17,18}},{{17,29}},{{18,30}},{{19,20}},{{19,31}},{{20,32}},{{21,22}},{{21,33}},{{22,34}},{{23,24}},{{23,35}},{{24,36}},{{25,30}},{{25,31}},{{26,32}},{{26,33}},{{27,34}},{{27,35}},{{28,29}},{{28,36}},{{29,37}},{{30,37}},{{31,38}},{{31,41}},{{32,38}},{{33,39}},{{34,39}},{{35,40}},{{35,42}},{{36,40}},{{37,40}},{{37,41}},{{38,39}},{{39,42}},{{41,42}}},{{{-1,1}},{{1,1}},{{1,-1}},{{-1,-1}},{{-25/30.0,20/30.0}},{{-20/30.0,25/30}},{{20/30.0,25/30.0}},{{25/30.0,20/30}},{{25/30.0,-20/30.0}},{{20/30.0,-25/30}},{{-20/30.0,-25/30.0}},{{-25/30.0,-20/30}},{{0,25/30.0}},{{25/30.0,0}},{{0,-25/30.0}},{{-25/30.0,0}},{{-19/30.0,10.0/30.0}},{{-10/30.0,19/30.0}},{{10/30.0,19.0/30.0}},{{19/30.0,10/30.0}},{{19/30.0,-10.0/30.0}},{{10/30.0,-19/30.0}},{{-10/30.0,-19.0/30.0}},{{-19/30.0,-10/30.0}},{{0,19/30.0}},{{19/30.0,0}},{{0,-19/30.0}},{{-19/30.0,0}},{{-15/30.0,5/30.0}},{{-5/30.0,14/30.0}},{{5/30.0,14/30.0}},{{15/30.0,5/30.0}},{{15/30.0,-5/30.0}},{{5/30.0,-14/30.0}},{{-5/30.0,-14/30.0}},{{-15/30.0,-5/30.0}},{{-8/30.0,8/30.0}},{{8/30.0,8/30.0}},{{8/30.0,-8/30.0}},{{-8/30.0,-8/30.0}},{{3/30.0,10/30.0}},{{-3/30.0,-10/30.0}}}];

ShowGraph[g]

From Paper

http://arxiv.org/abs/0904.3012

l=;

(g=LinesToGraph[l,5])//ShowLabeledGraph

GraphPlot[g2=DeleteEdges[AddEdges[g,{{39,40},{38,39},{2,42},{41,42},{1,41},{1,2},{3,4},{4,5},{8,24},{24,36},{7,19},{19,35}}],{{38,40},{3,5},{8,36},{7,35}}],Method->None]

g2

RecognizeGraph[g2]

PlanarQ[g2]

HamiltonianQ[g2]//Timing

FastHamiltonianQ[g2]//Timing

HypohamiltonianQ[g2]//Timing

GraphData

GraphClassString

GraphData["UltimateQuestionGraph","Classes"]

GraphClassString[{"UltimateQuestionGraph"}]

GraphDataString

GraphDataString[g2,
"Name"->"ultimate question graph",
"StandardName"->"UltimateQuestionGraph",
Debug->True,
TimeConstraint->60
]

GetGraphData["ZamfirescuGraph48","File"]