Kiteck-Payne Graph

Author

Eric W. Weisstein
July 26, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/GraphTheory/Kiteck-PayneGraph.nb.

For more information, see Eric's MathWorld entry https://mathworld.wolfram.com/Kiteck-PayneGraph.html.

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

Source

https://digitalresearch.bsu.edu/mathexchange/wp-content/uploads/2021/12/Kitech-and-Payne.pdf

Kiteck, D. and Payne, K.  "A 21-Vertex 4-Chromatic Unit-Distance Graph of Girth 4."  Ball State Undergraduate Mathematics Exchange 15, No. 1, 2–9, 2021.

Figure

GraphicsRow[
StyleGraphs[
GraphData["KiteckPayneGraph","Graph","All"]
],
Dividers->All
]

Embeddings

<<MathWorld`Graphs`

Names

GraphData["KiteckPayneGraph","StandardName"]

GraphData["KiteckPayneGraph","StandardNames"]

HouseOfGraphs

hogid=GraphData["KiteckPayneGraph","NotationRules","HouseOfGraphs"]

HouseOfGraphsLookup[hogid]

HouseOfGraphsGraph[hogid]//StyleGraphs[#,ImageSize->Small]&

Wikidata

GraphData["KiteckPayneGraph","WikidataID"]

GraphData["KiteckPayneGraph","WikidataID","URL"]

Primary

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

All

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

CurvedEdge

GraphData["KiteckPayneGraph","Graph","CurvedEdge"]//StyleGraphs

Inexact

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

Degenerate

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

DegenerateGraphEmbeddingTypes/@GraphData["KiteckPayneGraph","Graph","Degenerate"]//Column

Embeddings

GraphDataEmbeddings[GraphData["KiteckPayneGraph"]]

Default embedding

g0=GraphPlot[Graph[GraphData["KiteckPayneGraph","VertexList"],GraphData["KiteckPayneGraph","Edges"]]]

Configuration

GraphData["KiteckPayneGraph","Configuration"]

configurations=GraphData["KiteckPayneGraph","Graph","Configuration"]//StyleGraphs

GeneralizedPetersen

GraphData["KiteckPayneGraph","Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData["KiteckPayneGraph","Graph","IGraph"]//StyleGraphs

CompleteKPartite

GraphData["KiteckPayneGraph","Graph","CompleteKPartite"]//StyleGraphs

Bipartite

GraphData["KiteckPayneGraph","Bipartite"]

GraphData["KiteckPayneGraph","Graph","Bipartite"]//StyleGraphs

Bilateral

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

Grid[DeleteCases[Monitor[{g=#,BilateralGraphEmbeddingTypes[#],GraphSymmetryGroup[#]}&/@GraphData["KiteckPayneGraph","Graph","All"],g],{_,_,TransformationGroup[{}]}],Dividers->All,Alignment->{{Center,{Left}}}]//Quiet

Circular

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

Circular construction All

GraphData["KiteckPayneGraph","Hamiltonian"]

GraphData["KiteckPayneGraph","HamiltonianCycles"]

GraphData["KiteckPayneGraph","HamiltonianCycleCount"]

GraphData["KiteckPayneGraph","LCF"]

GraphData["KiteckPayneGraph","LCFSignature"]

BilateralHamiltonianCycleQ[GraphData["KiteckPayneGraph"]]

FindBilateralHamiltonianCycle[GraphData["KiteckPayneGraph"]]

Length[hc=FindHamiltonianCycle[GraphData["KiteckPayneGraph"],10][[All,All,1]]]//Timing

gs=CircularEmbeddingFromHamiltonianCycle[GraphData["KiteckPayneGraph"],#]&/@Take[hc,10]

g=gs[[1]]

Planar

GraphData["KiteckPayneGraph","Planar"]

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

MinimalCrossingNumber crossings.uos.de [verified 5]

CrossingNumber[GraphData["KiteckPayneGraph"],Method->"WebCompute"]//AbsoluteTiming

DateString[]

MinimalCrossingNumber: "EmbeddingScheme" -> 1

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->1,TimeConstraint->1])//AbsoluteTiming

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

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

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->1,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->1,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->1,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 2

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->2,TimeConstraint->1])//AbsoluteTiming

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

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

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->2,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->2,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->2,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossingNumber: "EmbeddingScheme" -> 3

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->3,TimeConstraint->1])//AbsoluteTiming

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

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

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->3,TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->3,TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],"EmbeddingScheme"->3,TimeConstraint->86400])//AbsoluteTiming

MinimalCrossing

GraphData["KiteckPayneGraph","CN"]

(gs=GraphData["KiteckPayneGraph","Graph","MinimalCrossing"])//StyleGraphs

GraphCrossingCount/@gs

GraphCrossingDiagram/@gs

MinimalRectilinearCrossing

GraphData["KiteckPayneGraph","RCN"]

GraphData["KiteckPayneGraph","Graph","MinimalRectilinearCrossing"]//StyleGraphs

MinimalCrossing construction Tutte

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],TimeConstraint->1])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData["KiteckPayneGraph"],"CrossingNumber"->cn])//PolyhedralGraphQ//AbsoluteTiming

MinimalCrossing construction Random 1k [115 s]

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],TimeConstraint->1])//AbsoluteTiming

Length[diagrams=DistinctMinimalCrossingDiagramData[
GraphData["KiteckPayneGraph"],
1000,
"CrossingNumber"->cn,
EdgeShapeFunction->"BezierEdge"
]]//AbsoluteTiming

No crossing points on the boundary:

Length[diagrams0=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==0&],"Graph",{}]]//Timing

Take[diagrams0,UpTo[10]]

One crossing point on the boundary:

Length[diagrams1=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==1&],"Graph",{}]]//Timing

Take[diagrams1,UpTo[10]]

g=RotateGraph[,2Pi/5]

GraphCrossingCount@g

GraphCrossingDiagram@g

graphs=#["Graph"]&/@diagrams;

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[#]
}&/@graphs;//AbsoluteTiming

MaxMemoryUsed[]/10^9.GB

Symmetric embeddings:

Length[SymmetricMinimalEmbeddingData=DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]
]//AbsoluteTiming

SymmetricMinimalEmbeddingData

SymmetricMinimalEmbeddingGraphs=SymmetricMinimalEmbeddingData[[All,1]]

GraphCrossingCount/@SymmetricMinimalEmbeddingGraphs

GraphCrossingDiagram/@SymmetricMinimalEmbeddingGraphs

MinimalCrossing construction Random 5k [601 s]

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],TimeConstraint->1])//AbsoluteTiming

Length[diagrams=DistinctMinimalCrossingDiagramData[
GraphData["KiteckPayneGraph"],
5000,
"CrossingNumber"->cn,
EdgeShapeFunction->"BezierEdge"
]]//AbsoluteTiming

No crossing points on the boundary:

Length[diagrams0=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==0&],"Graph",{}]]//Timing

Take[diagrams0,UpTo[10]]

One crossing point on the boundary:

Length[diagrams1=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==1&],"Graph",{}]]//Timing

Take[diagrams1,UpTo[10]]

graphs=#["Graph"]&/@diagrams;

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[#]
}&/@graphs;//AbsoluteTiming

MaxMemoryUsed[]/10^9.GB

Symmetric embeddings:

Length[SymmetricMinimalEmbeddingData=DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]
]//AbsoluteTiming

SymmetricMinimalEmbeddingData

SymmetricMinimalEmbeddingGraphs=SymmetricMinimalEmbeddingData[[All,1]]

GraphCrossingCount/@SymmetricMinimalEmbeddingGraphs

GraphCrossingDiagram/@SymmetricMinimalEmbeddingGraphs

MinimalCrossing construction Random 20k [2462 s]

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],TimeConstraint->1])//AbsoluteTiming

Length[diagrams=DistinctMinimalCrossingDiagramData[
GraphData["KiteckPayneGraph"],
20*^3,
"CrossingNumber"->cn,
EdgeShapeFunction->"BezierEdge"
]]//AbsoluteTiming

No crossing points on the boundary:

Length[diagrams0=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==0&],"Graph",{}]]//Timing

Take[diagrams0,UpTo[10]]

One crossing point on the boundary:

Length[diagrams1=Lookup[Select[diagrams,MinimalCrossingOuterCrossingCount[#]==1&],"Graph",{}]]//Timing

Take[diagrams1,UpTo[10]]

graphs=#["Graph"]&/@diagrams;

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[#]
}&/@graphs;//AbsoluteTiming

MaxMemoryUsed[]/10^9.GB

Symmetric embeddings:

Length[SymmetricMinimalEmbeddingData=DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]
]//AbsoluteTiming

SymmetricMinimalEmbeddingData

SymmetricMinimalEmbeddingGraphs=SymmetricMinimalEmbeddingData[[All,1]]

GraphCrossingCount/@SymmetricMinimalEmbeddingGraphs

GraphCrossingDiagram/@SymmetricMinimalEmbeddingGraphs

MinimalCrossing construction Random 1k [old]

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],TimeConstraint->1])//AbsoluteTiming

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["KiteckPayneGraph"],"CrossingNumber"->cn,RandomSeed->n],{n,1000}]//Union);//Timing

RandomGraphsWithOuterCrossingPointCounts={
#,
Count[OuterFace[#],_?(GreaterThan[GraphData["KiteckPayneGraph","V"]])]
}&/@RandomGraphs;

Small numbers of crossing points on the boundary:

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,0}:>g]

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,1}:>g]

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[
#,
AdditionalData->Join[Table[True,GraphData["KiteckPayneGraph","V"]],Table[False,cn]],
SameTest->Equal
]
}&/@RandomGraphs;

MaxMemoryUsed[]/10^9.GB

DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]/.g_Graph:>BilateralGraph[CenterGraph@g,"ReturnNonbilateralGraph"->True]

MinimalCrossing construction Random 20k [old]

(cn=CrossingNumber[GraphData["KiteckPayneGraph"],TimeConstraint->1])//AbsoluteTiming

(RandomGraphs=Table[MinimalCrossingGraph[GraphData["KiteckPayneGraph"],"CrossingNumber"->cn,RandomSeed->n],{n,20000}]//Union);//Timing

RandomGraphsWithOuterCrossingPointCounts={
#,
Count[OuterFace[#],_?(GreaterThan[GraphData["KiteckPayneGraph","V"]])]
}&/@RandomGraphs;

Small numbers of crossing points on the boundary:

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,0}:>g]

Cases[RandomGraphsWithOuterCrossingPointCounts,{g_,1}:>g]

Symmetric embeddings:

RandomGraphsWithSymmetryGroups={
#,
GraphSymmetryGroup[
#,
AdditionalData->Join[Table[True,GraphData["KiteckPayneGraph","V"]],Table[False,cn]],
SameTest->Equal
]
}&/@RandomGraphs;

MaxMemoryUsed[]/10^9.GB

DeleteCases[
RandomGraphsWithSymmetryGroups,
{_,TransformationGroup[{}]}
]/.g_Graph:>BilateralGraph[CenterGraph@g,"ReturnNonbilateralGraph"->True]

MinimalLocalCrossing

GraphData["KiteckPayneGraph",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["KiteckPayneGraph","Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalRectilinearLocalCrossing

GraphData["KiteckPayneGraph",{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData["KiteckPayneGraph","Graph","MinimalRectilinearLocalCrossing"]//StyleGraphs

MinimaRectilinearlLocalCrossing construction 1000

AdjacentCrossingsQ[g_Graph,cn_Integer]:=Module[{a=AdjacencyList[g],n=VertexCount[g]-cn},Max[Take[a,-cn]]>n]

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

(gs=Select[Table[MinimalCrossingGraph[GraphData["KiteckPayneGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,1000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

MinimaRectilinearlLocalCrossing construction 20000

AdjacentCrossingsQ[g_Graph,cn_Integer]:=Module[{a=AdjacencyList[g],n=VertexCount[g]-cn},Max[Take[a,-cn]]>n]

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

(gs=Select[Table[MinimalCrossingGraph[GraphData["KiteckPayneGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,20000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

Circulant

GraphData["KiteckPayneGraph","Circulant"]

GraphData["KiteckPayneGraph","Graph","Circulant"]//StyleGraphs

Circulant construction

GraphData["KiteckPayneGraph","NotationRules","Circulant"]

(ci=CirculantIndices[GraphData["KiteckPayneGraph"]])//AbsoluteTiming

CirculantGraph1@@@ci

Cases[GraphData["KiteckPayneGraph","StandardNames"],{"Circulant",i_}:>i]

CirculantGraph1@@@%

Complement graph

compl=GraphData["KiteckPayneGraph","ComplementGraph","Name"]

Line graph

GraphData["KiteckPayneGraph","Line"]

LineGraphQ[GraphData["KiteckPayneGraph"]]//Timing

RootGraph

roots=Select[GraphData[All],GraphData[#,"LineGraph","Name"]==="KiteckPayneGraph"&]

RootGraph[GraphData["KiteckPayneGraph"]]

Halin

GraphData["KiteckPayneGraph","Halin"]

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

Rigid

GraphData["KiteckPayneGraph","Rigid"]

GraphData["KiteckPayneGraph","Graph","Rigid"]//StyleGraphs

Flexible

GraphData["KiteckPayneGraph","Flexible"]

GraphData["KiteckPayneGraph","Graph","Flexible"]//StyleGraphs

Voltage

gs=GraphData["KiteckPayneGraph","Graph","Voltage"]//StyleGraphs

VoltageGraphNotation/@gs//Column

Voltage construction

VoltageGraph[GraphData["KiteckPayneGraph"],"MaxResults"->20,Debug->True]

LCF

GraphData["KiteckPayneGraph","LCF"]

GraphData["KiteckPayneGraph","HamiltonianCycleCount"]

GraphData["KiteckPayneGraph","LCFSignature"]

GraphData["KiteckPayneGraph","LCFNotations"]

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

Tally[LCFNotation[#][[2]]&/@%]

UnitDistance

GraphData["KiteckPayneGraph","UnitDistance"]

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

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

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

UnitDistance by refinement of default embeddings

Graph[edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["KiteckPayneGraph","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

Graph[vertex list, edge list]

(g=UnitDistanceEmbeddingRefine[Graph[GraphData["KiteckPayneGraph","VertexList"],GraphData["KiteckPayneGraph","EdgeList"]],MaxIterations->500])//Timing

UnitDistanceGraphEmbeddingQ[g]

UnitDistance by refinement of existing embeddings

gs=UnitDistanceEmbeddingRefine[Graph[VertexList[#],EdgeList[#],VertexCoordinates->GraphEmbedding[#]],MaxIterations->500]&/@Complement@@(GraphData["KiteckPayneGraph","Graph",#]&/@{"All","UnitDistance"})

TextGrid[
gdata=SortBy[
{#,DegenerateGraphEmbeddingQ[#],GraphSymmetryGroup[#],Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
],
Dividers->All
]

Cases[gdata,{__,0.}]

Symmetric:

gs=Cases[
gdata,
{g_,_,sym:Except[TransformationGroup[{}]],diff_}:>{
HighlightGraph[g1=BilateralGraph[CenterGraph[g],"ReturnNonbilateralGraph"->True],Flatten[FindCoincidentVertices[g1]]],
sym,
diff
}]

UnitDistance by refinement of stored LCF embeddings

FileByteCount[file=FileNameJoin[{$PropertiesDir,"LCFNotations-Nice",GraphNameToFileName["KiteckPayneGraph",".m.gz"]}]]

Tally[(lcf=Import[file])[[All,-1]]]//Timing//AbsoluteTiming

lcf=LCFNotation/@nicelcfgs;

gs=UnitDistanceEmbeddingRefine[LCFGraph@@#,MaxIterations->500]&/@lcf;//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

NondegenerateSymmetricGraphs=Select[
gdata,
And[
DegenerateGraphEmbeddingQ[#[[1]]]===False,
GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]
]&
]/.g_Graph:>CenterGraph[g]

UnitDistance by FindUnitDistanceEmbedding  (random embeddings returning on messages)

gs=FindUnitDistanceEmbedding[GraphData["KiteckPayneGraph"],50,"ReturnWithMessage"->True];//Quiet//Timing

gdata=SortBy[
{#,Max[Abs[EdgeLengths[#]-1]]}&/@gs,
Last
]

Cases[gdata,{g_?UnitDistanceGraphEmbeddingQ,_}:>g]

SymmetricEmebddings=Select[gdata,GraphSymmetryGroup[#[[1]]]=!=TransformationGroup[{}]&]

UnitDistance by FindUnitDistanceEmbedding  (random embedding waiting until UD is found)

FindUnitDistanceEmbedding[GraphData["KiteckPayneGraph"],"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

{$Version,DateString[]}

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

gs=SortBy[UniqueEmbeddings[l],Replace[RectilinearCrossingCount[#],Infinity->0]&]

Select[IndexGraph/@gs,!DegenerateGraphEmbeddingQ[#]&&GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]//Timing

Matchstick

GraphData["KiteckPayneGraph","Matchstick"]

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

3D default

Graph3D[GraphData["KiteckPayneGraph","Edges"]]

3D construction

3D All

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

3D UnitDistance construction Random

GraphData["KiteckPayneGraph","Dimension"]

(g=UnitDistanceEmbeddingRefine[
Graph3D[
GraphData["KiteckPayneGraph","VertexList"],
GraphData["KiteckPayneGraph","EdgeList"]
],
WorkingPrecision->25])//Timing

EdgeLengths[g]

UnitDistanceGraphEmbeddingQ[g]

3D UnitDistance

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

3D Polyhedron

GraphData["KiteckPayneGraph","Polyhedral"]

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

Construction

https://digitalresearch.bsu.edu/mathexchange/wp-content/uploads/2021/12/Kitech-and-Payne.pdf

Numeric

v={{60,25},{76,29},{132,50},{155,54},{73,49},{118,71},{110,94},{98,71},{92,64},{85,89},{117,11},{177,11},{177,71},{131,109},{72,109},{129,130},{87,149},{53,109},{48,104},{30,67},{14,64}}/60.;

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

g1=Graph[Range@Length@v,UnitEdges[v,Tolerance->.025],VertexCoordinates->v,VertexLabels->Automatic]

g2=Graph[Range@Length@v,Sort[Sort/@(UndirectedEdge@@@{e[11,12,13,14,17,19],e[21,1,11,6,13],e[17,7,4,14],e[3,5,15,14,3,12],e[4,8,19],{8,18},e[21,5,11,9,18],e[6,16,15,20,2,3],e[1,8],{2,6},e[20,10,16],{3,10},{5,7},{18,21},{9,14}})],VertexCoordinates->v,VertexLabels->Automatic]

EdgeList[g2][[{-7}]]

EdgeLengths[g2]

MinMax[%]

Through[{GraphGirth,ChromaticNumber}[g2]]

g3=UnitDistanceEmbeddingRefine[g2]

UnitDistanceGraphEmbeddingQ[g3]

Other unit edges:

extra=Complement[UnitEdges[GraphEmbedding[g3]],EdgeList[g3]]

g4=Graph[VertexList@g3,UnitEdges[GraphEmbedding[g3]],VertexCoordinates->GraphEmbedding[g3]]

gs1=Graph[VertexList@g3,Union[EdgeList[g3],#],VertexCoordinates->GraphEmbedding[g3]]&/@{extra[[{1}]],extra[[{2}]],extra}

Through[{GraphGirth,ChromaticNumber}[#]]&/@gs1

Try removing an edge:

gs=EdgeDelete[g3,#]&/@EdgeList[g3];

ChromaticNumber/@gs

Exact

q=-45Degree;
cs[q_]:=Through[{Cos,Sin}[q]]
v={{0,0},{0,1},{1,1},{1,0},cs[q],{1,0}+cs[q],{1,1}+cs[q]};
lab={"W","X","Y","Z","V1","S","T"};
g=Graph[Range@Length@v,UnitEdges[v],VertexCoordinates->v,VertexLabels->MapIndexed[#2[[1]]->#&,Take[lab,Length@v]]]

Certified construction (2026-07-26)

This section supersedes the exploratory numerical reconstruction above. It follows Kiteck and Payne's labeled construction from the unit square WXYZ. For two centers A and B, every circle-intersection branch is fixed by choosing the unit-circle intersection C for which A-B-C is counterclockwise. The resulting chain is Q2=ccw(X,Q1), Q3=ccw(Z,Q2), Q4=ccw(Q3,X), Q5=ccw(Z,Q4), followed by U3=ccw(U2,W), U4=ccw(Y,U3), U1=ccw(W,U2), U5=ccw(U4,U1), V5=ccw(V1,Y), V4=ccw(V5,U5), V3=ccw(W,V4), and V2=ccw(U5,V3).

The first intermediate-value interval is theta in [-39.8,-39.7] degrees, with closure-function signs (-,+) and derivative interval [2.28892291527634,3.38436136585122]. Equivalently, t=tan(theta/2) is the unique root in (-0.4,-0.3) of 23 t^4+48 t^3+22 t^2-1. The certified theta bracket has width below 5.935*10^-68 degrees. The second starting interval is phi in [137.825,137.828] degrees, with signs (+,-) and derivative interval [-21.1617574406339,-0.731702090568673]. Its certified bracket has width below 2.053*10^-51 degrees. The companion Sage/Arb certificate uses 512-bit real balls and records the full endpoint intervals.

The intended graph has the 38 drawn edges, not all distance-1 pairs of the point set. Exactly two additional unit pairs occur: X-Q1 and Q3-Q5. Adding them creates three triangles, so the full distance graph has girth 3; omitting them gives the paper's triangle-free graph with girth 4. All 21 vertices are interval-certified distinct, all 38 intended edges are unit, and every other pair except those two is certified nonunit.

An explicit 4-coloring has classes {W,Y,U5,Q2,Q4,S}, {V1,X,V3,Z,U1,U3,T}, {U2,U4,V2,V4,Q1,Q3}, and {V5,Q5}. Exhaustive Boolean SAT finds no 3-coloring. The graph is asymmetric, with automorphism-group order 1. Its nauty canonical graph6 string is T?G?_P?GC_?_?@@??CW?I?u@CAEC@?o_m`_S and its canonical sparse6 string is :TcAeBc`a_BdjdgKLjLeFHI`DK_@EMbCHNPQ_AFGNP. An exact check against all 12,823 GraphData entries in Wolfram 15.1 Devel found no isomorphic graph, and an exact House of Graphs graph6 search returned zero results.

Get["/Users/eww/Data/Development/Codex/GraphData/kiteck-payne-graph/KiteckPayneGraphConstruction.wl"]

g=;

UnitDistanceGraphEmbeddingQ[g]

GraphData

GraphDataClassString

GraphDataClassString["KiteckPayneGraph"]

GraphDataString

stream=OpenWrite["~/k-p.m"]

WriteString[
stream,
GraphDataString[
,
"StandardName"->"KiteckPayneGraph",
"Name"->"Kiteck\[Hyphen]Payne graph",
"Information"->"Kiteck-PayneGraph"
]
]

Close[stream]