Harborth Graph

Author

Eric W. Weisstein
May 17, 2022

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

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

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

Embeddings

"HarborthGraph"

GraphData["HarborthGraph","StandardName"]

All

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

Halin

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

LCF

GraphData["HarborthGraph","LCFSignature"]

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

UnitDistance

GraphData["HarborthGraph","UnitDistance"]

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

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

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

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

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

UnitDistance FindSubgraphUnitDistanceEmbedding

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

gs=UniqueEmbeddings[l]

Matchstick

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

MinimalCrossing

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

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

Default embedding

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

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

RecognizeGraph[g]

Exact

Exact embedding derived from Gerbracht (2006)

https://arxiv.org/abs/math/0609360

dist[v1_,v2_]:=Sqrt[#.#&[v1-v2]]

V[HarborthGraph]

ShowLabeledGraph[HarborthGraph]

Norm/@(Subtract@@@(Edges[HarborthGraph]/.Thread[Range[52]->Vertices[HarborthGraph]]))

ml=Mean[%]

m=Mean[Vertices[HarborthGraph]]

v=-Reverse/@((#-m)&/@Vertices[HarborthGraph])/ml;

Length[v]

Show[Graphics[{Line/@(Edges[HarborthGraph]/.Thread[Range[52]->v]),
MapIndexed[Text[#2[[1]],#1+{0,.15},Background->White]&,v],
Red,PointSize[.02],Point/@v}],AspectRatio->Automatic]

AA={xA,0};
BB={xB,yB};
CC={xC,0};
DD={xD,yD};
EE={xE,yE};
FF={xF,yF};
GG={xG,yG};
HH={0,yH};
JJ={0,yJ};

v0={HH,Mean[{HH,DD}],{-1,1}Mean[{HH,DD}],DD,{-1,1}DD,Mean[{HH,GG}],{-1,1}Mean[{HH,GG}],Mean[{GG,DD}],{-1,1}Mean[{GG,DD}]};

Chop[Take[v,9]-v0,.025]

v1={EE,{-1,1}EE,DD+(CC-DD)/3,{-1,1}(DD+(CC-DD)/3),GG,{-1,1}GG,Mean[{EE,BB}],{-1,1}Mean[{EE,BB}],FF,{-1,1}FF};

Chop[Take[v,{10,19}]-v1,.025]

v2={DD+(CC-DD)2/3,{-1,1}(DD+(CC-DD)2/3),JJ,BB,{-1,1}BB,CC,AA,-AA,-CC,{1,-1}BB};

Chop[Take[v,{20,29}]-v2,.025]

p=Join[v0,v1,v2];

v3={-BB,-JJ,{1,-1}p[[20]],{1,-1}p[[21]],{1,-1}FF,-FF,{1,-1}p[[16]],-p[[16]],{1,-1}GG,-GG,{1,-1}p[[12]],-p[[12]],{1,-1}p[[10]],-p[[10]],{1,-1}p[[8]],-p[[8]],{1,-1}p[[6]],-p[[6]],{1,-1}DD,-DD,{1,-1}p[[2]],-p[[2]],-HH};

Chop[Take[v,{30,-1}]-v3,.025]

newv=Join[p,v3];

Max[Abs[Flatten[N[newv-v,20]]]]

-(Reverse/@newv)

Abs[N[#.#&/@(Subtract@@@(Edges[HarborthGraph]/.Thread[Range[52]->newv]))-1,10^5]]//Max

RootReduce[-(Reverse/@newv)]//Timing

Length[vs=Last[%]]

Abs[N[#.#&/@(Subtract@@@(Edges[HarborthGraph]/.Thread[Range[52]->vs]))-1,10^5]]//Max

Union[RootReduce/@((#.#-1)&/@(Subtract@@@(Edges[HarborthGraph]/.Thread[Range[52]->vs])))]//Timing

RootReduce[(1/2) (Root[-12148787578527675-123412000423046805 ((#1)^2)-441020584930952232 ((#1)^4)+273168911377174014 ((#1)^6)-27343071784237320 ((#1)^8)-3667116898760364 ((#1)^10)+823044986987616 ((#1)^12)-32095868573376 ((#1)^14)-4779985142784 ((#1)^16)+615643279360 ((#1)^18)-27098808320 ((#1)^20)+427098112 ((#1)^22)&,6]+Root[-2470693585135788+1679453964496051893 ((#1)^2)-2462573171102886288 ((#1)^4)+1847147913929328048 ((#1)^6)-888334179987132288 ((#1)^8)+302241307009227264 ((#1)^10)-74768143621533696 ((#1)^12)+13516084620361728 ((#1)^14)-1721332250836992 ((#1)^16)+139442448236544 ((#1)^18)-6126808596480 ((#1)^20)+109337116672 ((#1)^22)&,6])]//Timing

(gb=GroebnerBasis[{-12148787578527675-123412000423046805 ((#1)^2)-441020584930952232 ((#1)^4)+273168911377174014 ((#1)^6)-27343071784237320 ((#1)^8)-3667116898760364 ((#1)^10)+823044986987616 ((#1)^12)-32095868573376 ((#1)^14)-4779985142784 ((#1)^16)+615643279360 ((#1)^18)-27098808320 ((#1)^20)+427098112 ((#1)^22)&[x1],-2470693585135788+1679453964496051893 ((#1)^2)-2462573171102886288 ((#1)^4)+1847147913929328048 ((#1)^6)-888334179987132288 ((#1)^8)+302241307009227264 ((#1)^10)-74768143621533696 ((#1)^12)+13516084620361728 ((#1)^14)-1721332250836992 ((#1)^16)+139442448236544 ((#1)^18)-6126808596480 ((#1)^20)+109337116672 ((#1)^22)&[x2],
x1+x2-2x},x,{x1,x2},MonomialOrder->EliminationOrder,Method->"GroebnerWalk"])//Timing

A

N[xA=Last[Reduce[-830376562500+1358127000000#^2-34144387143750#^4+96857243056800#^6-68697978132015#^8-189712941147#^10+6188723588664#^12-704220643376#^14-52577813248#^16+27196394496#^18-2918612992#^20+106774528#^22&[x]==0&&9/10<x<11/10,x,Reals]]]

B

29

xB=Last[Reduce[-17372788157292129+85946816541669534#^2 -172967171143553289#^4+125428630440736260#^6- 35361034276033728#^8+4402034757921792#^10-436015591392256#^12+77220067192832#^14- 11054716223488#^16+874491412480#^18- 34734080000#^20+557842432#^22&[x]==0&&9/10<x-1<11/10,x,Reals]]

yBs=List@@Last/@Reduce[-492075+52356780#^2-1441635408#^4+12222052416#^6-60567699456#^8+189747007488#^10-417660420096#^12+607025037312#^14-655053815808#^16+446118756352#^18-422064422912#^20+437348466688#^22&[x]==0&&-1/10<x-1/10<1/10,x,Reals]

yBs[[1]]

N[dist[{xA,0},{xB,#}]&/@yBs-1,10^3]

N[yB=yBs[[1]]]

C

N[xC=Last[Reduce[-55268097000787592100+83653148035178006805#^2-49933201015710366166#^4+15170804748275250138#^6-2623723693990622868#^8+292733387369474292#^10- 24051159678783648#^12+1563610131071808#^14- 77064294460416#^16+2572257472512#^18-50083921920#^20+427098112#^22&[x]==0&&8/10<x-2<12/10,x,Reals]]]

D

xDs=List@@Last/@Reduce[-15937557042969+69169635141939#^2-133600085051911#^4+150590940104181#^6- 109441808559384#^8+53597367271968#^10-17996039805696#^12+4144963934208#^14- 647005151232#^16+66726690816#^18- 4293132288#^20+139460608#^22&[x]==0&&-2/10<x-17/10<2/10,x,Reals]

yD=Last[Reduce[-2470693585135788+1679453964496051893#^2-2462573171102886288#^4+1847147913929328048#^6-888334179987132288#^8+302241307009227264#^10-74768143621533696#^12+13516084620361728#^14-1721332250836992#^16+139442448236544#^18-6126808596480#^20+109337116672#^22&[x]==0&&-2/10<x-28/10<2/10,x,Reals]]

N[dist[{xC,0},{#,yD}]&/@xDs-3,10^3]

xD=xDs[[1]]

E

xE=Last[Reduce[-30534686672400+184473995962680#^2- 493600710483009#^4+800738068318020#^6- 883225203916608#^8+687262746783744#^10-378024688788480#^12+145061641105408#^14- 37695035736064#^16+6218402758656#^18- 582162055168#^20+27334279168#^22&[x]==0&&-2/10<x-12/10<2/10,x,Reals]]

N[%]

yE=Last[Reduce[-387038865725307+255845547796716#^2-1080696123714384#^4+985178573370432#^6+290816529555456#^8+1229422640467968#^10-399291497201664#^12-226953868935168#^14-145914316455936#^16+84049703993344#^18-9462031056896#^20+437348466688#^22&[x]==0&&-2/10<x-2<2/10,x,Reals]]

F

N[xFs=List@@Last/@Reduce[-622521+20028276#^2- 150285424#^4- 349270464#^6+7694997504#^8-5213620224#^10- 109200064512#^12+709185896448#^14- 1112735219712#^16+387346071552#^18+124822487040#^20+8925478912#^22&[x]==0&&-2/10<x-9/10<2/10,x,Reals]]

N[dist[{xE,yE},{#,yF}]&/@xFs-1,10^3]

N[xF=xFs[[1]]]

N[yF=Last[Reduce[-6156736033068+4132620043369020#^2-28069535202466347#^4+54174190167055116#^6-44321252355544320#^8+16893977313239424#^10-3430375146685440#^12+781964817629184#^14-165954075623424#^16+16400930701312#^18-579898179584#^20+27334279168#^22&[x]==0&&-2/10<x-1<2/10,x,Reals]]]

G

N[xGs=List@@Last/@Reduce[-106929+9380331#^2-257190919#^4+2410771629#^6-11872837680#^8+35430882432#^10-66974055936#^12+79549160448#^14-56180293632#^16+20514865152#^18-2573205504#^20+139460608#^22&[x]==0&&-2/10<x-2/10<2/10,x,Reals]]

N[dist[{xF,yF},{#,yG}]&/@xGs-1,10^3]

N[xG=xGs[[1]]]

N[yG=Last[Reduce[-912811377667500+16117998953248125#^2-36709013218422600#^4+37940201286814800#^6-23463887481854208#^8+10021184125203456#^10-3290335763447808#^12+888521341648896#^14-192809455583232#^16+29839017902080#^18-2742026240000#^20+109337116672#^22&[x]==0&&-2/10<x-165/100<2/10,x,Reals]]]

H

N[yH=Last[Reduce[-12148787578527675-123412000423046805#^2-441020584930952232#^4+273168911377174014#^6-27343071784237320#^8-3667116898760364#^10+823044986987616#^12-32095868573376#^14-4779985142784#^16+615643279360#^18-27098808320#^20+427098112#^22&[x]==0&&-2/10<x-36/10<2/10,x,Reals]]]

J

N[yJ=Last[Reduce[-9964518750000+570277711828125#^2-1780552966387500#^4+849106838377800#^6+644904447905880#^8-102048280254828#^10-56106534718368#^12+9027433758528#^14+605520976896#^16-103349145600#^18-2815229952#^20+427098112#^22&[x]==0&&-2/10<x-7/10<2/10,x,Reals]]]

MinimalCrossing Construction

g=RotateGraph[MinimalCrossingGraph[GraphData["HarborthGraph"]]]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

3D default

Graph3D[GraphData["HarborthGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["HarborthGraph","Polyhedral"]

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

3D Canonical

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

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

3D Polyhedron construction

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

gn="HarborthGraph";
g=Graph3D[Range@GraphData[gn,"V"],GraphData[gn,"Edges"],GraphLayout->"SphericalEmbedding",VertexLabels->None]

v=GraphEmbedding[g];

v0=Mean[v];
f=GraphData[gn,"FaceIndices"];
Graphics3D[{FaceForm[Green,Red],poly=Polyhedron[(#-v0)&/@v,f]}]

(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]

3D Canonical construction from PolyhedralEmbedding

g=GraphData["HarborthGraph","Graph","Planar"][[-1]]

Show[g2=PolyhedralEmbedding[g,"Circular"->True,"Scale"->1],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.03v,faces]}]]

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

Graphics3D[can]

can=Polyhedron[];

(can=FindCanonicalPolyhedron[can,WorkingPrecision->100,MaxIterations->1000,PrecisionGoal->20,"ProgressInterval"->100,"TangentFactor"->1/50,"PlanarFactor"->1/50,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]