Parts Graphs

Author

Eric W. Weisstein
December 13, 2022

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

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

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

Graphic

DateString[]

parts=SortBy[GraphData["Parts*"],GraphData[#,"V"]&]

Unit-distance 5-chromatic

ColorGraph[g_Graph,opts___?OptionQ]:=Module[{col=FindVertexColoring[g],cols={Red,Green,Yellow,Green,Blue,Orange}},
Annotate[g,{EdgeStyle->LightGray,opts,VertexStyle->MapIndexed[#2[[1]]->cols[[#]]&,col]}]
]

partsud=Select[GraphData["Parts*"],GraphData[#,"UnitDistance"]&]

GraphicsGrid[Partition[Show[ColorGraph[GraphData[#]],PlotLabel->Style[GraphData[#,"Name"],Directive[Black,FontSlant->Italic,FontFamily->"Times"]]]&/@Reverse[partsud],UpTo[3]],ImageSize->700,Dividers->All]

Small 6-chromatic 2-distance graphs

parts=Select[GraphData["Parts*"],GraphData[#,"V"]<200&]

GraphicsGrid[Partition[Show[ColorGraph[GraphData[#],EdgeStyle->Gray],PlotLabel->Style[GraphData[#,"Name"],Directive[Black,FontSlant->Italic,FontFamily->"Times"]]]&/@parts,UpTo[4]],ImageSize->700,Dividers->All]

Print[{#,DegenerateGraphEmbeddingTypes[GraphData[#]]//Timing}]&/@parts;

Table

UD

partsud=Select[GraphData["Parts*"],GraphData[#,"UnitDistance"]&]

Print[{#,VertexChromaticNumber[GraphData[#]]//Timing,UnitDistanceGraphEmbeddingQ[GraphData[#],WorkingPrecision->∞]//Quiet//Timing}]&/@partsud;

TextGrid[GraphData[#,{"V","M","ChromaticNumber","Name"}]&/@partsud,Dividers->All]

"PartsGraph16"

Embeddings

Primary

GraphData["PartsGraph16"]//StyleGraphs[#,ImageSize->Small]&

All

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

Inexact

Select[GraphData["PartsGraph16","Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData["PartsGraph16","EdgeList"]]

Default embedding

GraphPlot[GraphData["PartsGraph16","Edges"],GraphLayout->"SpringEmbedding"]

g0=GraphicsToGraph@;

GraphPlot[Annotate[g0,VertexCoordinates->({# .6,#2}&@@@GraphEmbedding[g0])]]

v=Join[UnitCirclePoints[14],{{-1/4,0},{1/4,0}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[{1,14},1,7,16,1,15,8,14,15,7,10,15,12,14,2,4,6,8,12,10,1,3,16,5,8,16,14,5,3,6,2,15,6],e[11,13,16,9,13,1],e[3,7,9,11],{9,12},{2,5},{10,13}},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Degenerate

GraphData["PartsGraph16","Graph","Degenerate"]//StyleGraphs

GraphData["PartsGraph16","EmbeddingClasses"]

Bilateral

GraphData["PartsGraph16","Graph","Bilateral"]//StyleGraphs

Circular

GraphData["PartsGraph16","Graph","Circular"]//StyleGraphs

LCF

GraphData["PartsGraph16","LCF"]

MinimalCrossing

GraphData["PartsGraph16","CrossingNumber"]

(cn=CrossingNumber[GraphData["PartsGraph16"],TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData["PartsGraph16"],TimeConstraint->60])//AbsoluteTiming

Union[Select[Table[RotateGraph[MinimalCrossingGraph[GraphData["PartsGraph16"],"CrossingNumber"->cn,RandomSeed->n]],{n,500}],Max[OuterFace[#]]<=GraphData["PartsGraph16","V"]&]]//Timing

Table[MinimalCrossingGraph[GraphData["PartsGraph16"],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union

UnitDistance

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

Construction

Import["https://arxiv.org/pdf/2010.12656.pdf","EmbeddedImages"]

https://dustingmixon.wordpress.com/2019/08/05/polymath16-fourteenth-thread-automated-graph-minimization/#comment-24448

https://arxiv.org/pdf/2010.12656.pdf

e1={{1,2},{1,3},{2,4},{2,5},{3,4},{3,6},{4,7},{4,8},{5,6},{5,8},{5,9},{6,7},{6,10},{7,9},{7,12},{7,13},{8,10},{8,11},{8,13},{9,11},{10,12},{11,12},{11,14},{12,15},{13,14},{13,15},{14,16},{15,16}};
ephi={{1,5},{1,6},{2,3},{2,6},{2,7},{2,9},{3,5},{3,8},{3,10},{4,9},{4,10},{4,11},{4,12},{5,13},{6,13},{7,10},{7,14},{8,9},{8,15},{9,13},{9,14},{10,13},{10,15},{11,15},{11,16},{12,14},{12,16},{14,15}};
e=Union[e1,ephi];

c=CirclePoints[{0,-(NumericalApproximation[Root, (RowDefault["-0.425", FEExpressionsNumericalApproximationElider]), Root[1-20 ((#1)^2)+80 ((#1)^4)&,1], ])},(Sqrt[(1/10)(5-(Sqrt[5]))]),5]//FullSimplify

Graph[Range[5],UndirectedEdge@@@Partition[{1,3,5,2,4},2,1,1],VertexCoordinates->c,VertexLabels->Automatic]

EuclideanDistance@@c[[{1,3}]]//FullSimplify

c[[1,2]]//FullSimplify

c2=CirclePoints[{0,(3/2) (Sqrt[(1/10) (5+(Sqrt[5]))])},Csc[Pi/5]/2,5]//FullSimplify

Graph[Range[5],UndirectedEdge@@@Partition[{1,3,5,2,4},2,1,1],VertexCoordinates->c2,VertexLabels->Automatic]

EuclideanDistance@@c2[[{5,1}]]//FullSimplify

c2[[1]]-c[[2]]//FullSimplify

EuclideanDistance@@v[[{11,12}]]//FullSimplify

G16Vertices={
(*1*){1,-1}c2[[3]],
(*2*){1,-1}c2[[2]],
(*3*)-c2[[2]],
(*4*){1,-1}c[[3]],
(*5*){1,-1}c[[2]],
(*6*)-c[[2]],
(*7*)c[[1]],
(*8*){-1,1}c[[1]],
(*9*){GoldenRatio,0}-c[[1]],
(*10*)c[[1]]-{GoldenRatio,0},
(*11*)c[[2]],
(*12*){-1,1}c[[2]],
(*13*)c[[3]],
(*14*)c2[[2]],
(*15*){-1,1}c2[[2]],
(*16*)c2[[3]]
};
G16=Graph[Range[16],UndirectedEdge@@@e,VertexCoordinates->G16Vertices,VertexLabels->Automatic]

GraphAutomorphismGroup[G16]//GroupOrder

EdgeCount[G16]

EdgeList[G16]

EuclideanDistance@@G16Vertices[[#]]&/@e1//FullSimplify//Union

EuclideanDistance@@G16Vertices[[#]]&/@ephi//FullSimplify//Union

VertexChromaticNumber[G16]

GraphData

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

WriteString[file,GraphDataString[G16,
"StandardName"->"PartsGraph16",
"Name"->"Parts graph 16",
"Information"->"PartsGraphs"
]]

"PartsGraph31"

Embeddings

All

GraphData["PartsGraph31","Graph","All"]

Circular

GraphData["PartsGraph31","Graph","Circular"]

LCF

GraphData["PartsGraph31","LCF"]

MinimalCrossing

GraphData["PartsGraph31","CrossingNumber"]

CrossingNumber[GraphData["PartsGraph31"],TimeConstraint->60]//AbsoluteTiming

UnitDistance

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

Cycles

cyc={{1,20,21},{1,20,28,21},{1,20,28,25,21},{1,20,28,30,25,21},{1,20,28,30,29,22,21},{1,20,28,30,29,27,25,21},{1,20,28,30,29,27,25,22,21},{1,20,28,30,29,27,25,23,18,21},{1,20,28,30,29,27,25,23,24,22,21},{1,20,28,30,29,27,25,23,24,22,17,21},{1,20,28,30,29,27,25,23,24,22,17,18,21},{1,20,28,30,29,27,25,23,24,22,17,19,18,21},{1,20,28,30,29,27,25,23,24,26,19,22,17,18,21},{1,20,28,30,29,27,31,26,23,25,22,24,17,19,18,21},{1,5,13,15,16,31,30,28,29,27,25,23,24,22,17,20,21},{1,5,13,15,16,31,30,28,29,27,25,23,24,22,17,20,18,21},{1,5,13,15,16,31,30,28,29,27,25,23,24,22,17,19,18,20,21}};

HighlightGraph[GraphData["PartsGraph31"],Style[UndirectedEdge@@@Partition[#,2,1,1],Directive[Thick,Red]]]&/@cyc

Construction

https://dustingmixon.wordpress.com/2019/08/05/polymath16-fourteenth-thread-automated-graph-minimization/#comment-24448

https://arxiv.org/pdf/2010.12656.pdf

Consider the 31-vertex graph G31, shown on the left in Fig. 2 and formed from two copies of G16 rotated around a common vertex 1 by the angle arccos((95+(Sqrt[5]))/100) , which gives an additional edge of unit length between copies of vertex 16 (alternatively, you can take the angle arccos((95-(Sqrt[5]))/100), giving an additional edge length d).

G16Vertices0=(#-G16Vertices[[1]])&/@G16Vertices

G31Vertices=Join[G16Vertices0,RotationMatrix[ArcCos[((95+(Sqrt[5]))/100)]].#&/@Rest[G16Vertices0]]//FullSimplify

Length[G31Vertices]

...which gives an additional edge of unit length between copies of vertex 16

G31Edges=Union[Join[e,e/.n_/;n>1:>n+15],{{16,31}}]

EuclideanDistance@@G31Vertices[[{16,31}]]//FullSimplify

G31=Graph[Range[31],UndirectedEdge@@@G31Edges,VertexCoordinates->G31Vertices,VertexLabels->Automatic]

Select[G31Edges,Abs[EuclideanDistance@@G31Vertices[[#]]-1]<10^-3&]//Quiet

Select[G31Edges,Abs[EuclideanDistance@@G31Vertices[[#]]-GoldenRatio]<10^-3&]//Quiet

EdgeLengths[G31]//RootReduce//Tally//Timing

VertexChromaticNumber[G31]//Timing

<<IGraphM`

IGChromaticNumber[G31]//Timing

GraphData

WriteString[file,GraphDataString[G31,
"StandardName"->"PartsGraph31",
"Name"->"Parts graph 31",
"Information"->"PartsGraphs",
"Skip"->{"ConnectedDominatingSet"},
TimeConstraint->10
]]

Close[file]

"PartsGraph199"

GraphData["PartsGraph199"]

Preprint

https://arxiv.org/pdf/2010.12656.pdf

5/. Import["https://arxiv.org/pdf/2010.12656.pdf","EmbeddedImages"]

Vertex coordinates original

In graph G199, a mono-pair is formed between vertices 170 and 175.

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/199"];

Length[v=ToExpression/@Import["g199.vtx","Lines"]]

Length[e=Select[Subsets[Range[Length[v]],{2}],Abs[(d=EuclideanDistance@@v[[#]])-1]<.001||Abs[d-2]<.001&]]//Quiet//Timing

(PartsGraph199=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

EdgeLengths[PartsGraph199]//RootReduce//Tally//Timing//Quiet

GraphData

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

WriteString[file,GraphDataString[PartsGraph199,
"StandardName"->"PartsGraph199",
"Name"->"Parts graph 199",
"Information"->"PartsGraphs",
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

"PartsGraph509"

GraphData["PartsGraph509"]

Dropbox

https://www.dropbox.com/sh/ufknm1v9gtbhad3/AAC6uRgySFEQfFJdqiN7DME4a/JP/Large?dl=0&subfolder_nav_tracking=1

Vertex coordinates 1

v509e2442.vtx was sent by email by request January 12, 2022

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/509"];

Length[v1=ToExpression/@Import["v509e2442.vtx","Lines"]]

Length[e=UnitEdges[v1]]//Timing

(PartsGraph509=Graph[Range[Length[v1]],UndirectedEdge@@@e,VertexCoordinates->v1])

RecognizeGraph[PartsGraph509]

UnitDistanceGraphEmbeddingQ[PartsGraph509,WorkingPrecision->∞]//Timing

VertexChromaticNumber[PartsGraph509]//Timing

Vertex coordinates 2

g509.txt was sent Jan 16, 2022. It's the same as the original except replaces nested radials with their simpler denested form for vertices 379, 382, 449, 452.

From Jan Paarts, Jan 16, 2022

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/509"];

Length[v2=ToExpression/@Import["g509.vtx","Lines"]]

v1-v2//FullSimplify//Union

data=Transpose[{Range[509],v1,v2}];

TextGrid[DeleteCases[data,{_,x_,x_}],Dividers->All]

FullSimplify[(1/8) (Sqrt[(5/2) (7-(Sqrt[33]))])]

y1=v1[[{379,382,449,452},2]]

Simplify`SimplifyCount/@y1

y2=v2[[{379,382,449,452},2]]

Simplify`SimplifyCount/@y2

y1-y2//FullSimplify

Length[e=UnitEdges[v2]]//Timing

g=Graph[Range[Length[v2]],UndirectedEdge@@@e,VertexCoordinates->v2]

RecognizeGraph[g]

Arxiv

Import["2010.12665.pdf","EmbeddedImages"]

{Import["2010.12665.pdf",{"PageGraphics",21}], Import["2010.12665.pdf",{"PageImages",21}]}

GraphData

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

WriteString[file,GraphDataString[PartsGraph509,
"StandardName"->"PartsGraph509",
"Name"->"Parts graph 509",
"Information"->"PartsGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

"PartsGraph510" (2502 edges)

Dropbox

https://www.dropbox.com/sh/ufknm1v9gtbhad3/AAC6uRgySFEQfFJdqiN7DME4a/JP/Large?dl=0&subfolder_nav_tracking=1

Vertex coordinates

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/510"];

Length[v=ToExpression/@Import["v510e2502.vtx","Lines"]]

Length[e=UnitEdges[v]]//Timing

(PartsGraph510=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

RecognizeGraph[PartsGraph510]

UnitDistanceGraphEmbeddingQ[PartsGraph510,WorkingPrecision->∞]//Timing

VertexChromaticNumber[PartsGraph510]//Timing

GraphData

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

WriteString[file,GraphDataString[PartsGraph510,
"StandardName"->"PartsGraph510",
"Name"->"Parts graph 510",
"Information"->"PartsGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

"PartsGraph510" (2508 edges)

Mixon blog

https://dustingmixon.wordpress.com/2019/07/08/polymath16-thirteenth-thread-bumping-the-deadline/#comment-23999

Deleted DropBox link: https://www.dropbox.com/s/v5lbv5adropt2l0/v510e2508.vtx?dl=0

Large part of it, (Subscript[L, 375]):

Vertex coordinates

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/510"];

Length[v=ToExpression/@Import["v510eXXXX.vtx","Lines"]]

Length[e=UnitEdges[v]]//Timing

(PartsGraph510=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

RecognizeGraph[PartsGraph510]

UnitDistanceGraphEmbeddingQ[PartsGraph510,WorkingPrecision->∞]//Timing

VertexChromaticNumber[PartsGraph510]//Timing

GraphData

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

WriteString[file,GraphDataString[PartsGraph510,
"StandardName"->"PartsGraph510",
"Name"->"Parts graph 510",
"Information"->"PartsGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

"PartsGraph525"

Mixon blog

https://dustingmixon.wordpress.com/2019/07/08/polymath16-thirteenth-thread-bumping-the-deadline/#comment-23814

Dropbox

https://www.dropbox.com/s/2mcb5o7r0uewoua/v525e2605.vtx?dl=0

Vertex coordinates

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/525"];

Length[v=ToExpression/@Import["v525e2605.vtx","Lines"]]

Length[e=UnitEdges[v]]//Timing

(PartsGraph525=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

RecognizeGraph[PartsGraph525]

UnitDistanceGraphEmbeddingQ[PartsGraph525,WorkingPrecision->∞]//Timing

VertexChromaticNumber[PartsGraph525]//Timing

GraphData

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

WriteString[file,GraphDataString[PartsGraph525,
"StandardName"->"PartsGraph525",
"Name"->"Parts graph 525",
"Information"->"PartsGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

"PartsGraph529"

Mixon blog

https://dustingmixon.wordpress.com/2019/03/23/polymath16-twelfth-thread-year-in-review-and-future-plans/#comment-23713

Jaan Parts says:
July 4, 2019 at 11:19 am

At the request of Aubrey, I publish also my version of the graph with 529 vertices and 2630 edges. This can hardly be considered as an improvement of Marijn’s graph. The graphs are almost the same. See:
https://www.dropbox.com/s/zbwjv3pj6d93fb7/g529_2630.vtx?dl=0

Vertex coordinates

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/529"];

Length[v=ToExpression/@Import["g529_2630.vtx","Lines"]]

Length[e=UnitEdges[v]]//Timing

(PartsGraph529=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

RecognizeGraph[PartsGraph529]

UnitDistanceGraphEmbeddingQ[PartsGraph529,WorkingPrecision->∞]//Timing

VertexChromaticNumber[PartsGraph529]//Timing

GraphData

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

WriteString[file,GraphDataString[PartsGraph529,
"StandardName"->"PartsGraph529",
"Name"->"Parts graph 529",
"Information"->"PartsGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]

"PartsGraph553"

Mixon blog

https://dustingmixon.wordpress.com/2019/03/23/polymath16-twelfth-thread-year-in-review-and-future-plans/#comment-23713

Jaan Parts says:
July 4, 2019 at 11:19 am

Reducing graphs based on the second-order Minkowski sums only, I was able to get 553-vertex graph. Further reduction requires the involvement of new orbits of vertices. Here it is:
https://www.dropbox.com/s/zknw7c8ckl79qgu/g553_2840.vtx?dl=0

Vertex coordinates

SetDirectory["/Users/eww/Documents/Mathematica/Paclets/GraphData/Collections/UnitDistance/Parts/553"];

Length[v=ToExpression/@Import["g553_2840.vtx","Lines"]]

Length[e=UnitEdges[v]]//Timing

(PartsGraph553=Graph[Range[Length[v]],UndirectedEdge@@@e,VertexCoordinates->v])

RecognizeGraph[PartsGraph553]

UnitDistanceGraphEmbeddingQ[PartsGraph553,WorkingPrecision->∞]//Timing//Quiet

VertexChromaticNumber[PartsGraph553]//Timing

GraphDataString

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

WriteString[file,GraphDataString[PartsGraph553,
"StandardName"->"PartsGraph553",
"Name"->"Parts graph 553",
"Information"->"PartsGraphs",
"ChromaticNumber"->5,
"Skip"->{"CliqueCoveringNumber","ConnectedInducedSubgraphPolynomial","CrossingNumber","DominatingSet","GracefulLabeling","GracefulLabelings","IndependencePolynomial","MatchingGeneratingPolynomial","MatchingPolynomial","RadioNumber","TotalDominatingSet","VertexCover"},
TimeConstraint->5,
Debug->True]]

Close[file]