Klein Graphs

Author

Eric W. Weisstein
December 16, 2022

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

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

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

Graphs

GraphData["KleinGraph*"]

Configuration

GraphData["KleinGraph120","Incidence"]

lines=GraphData["KleinGraph120","Configurations"]

Subscript@@Reverse@Flatten@Tally[Length/@lines[[1]]]

RecognizeGraph[LeviGraph[#]]&/@lines

GraphData["KleinConfigurationGraph120","#"]

configg=GraphData["KleinConfigurationGraph120","Graph",{"Configuration","Labeled"}][[1]]

lines2=Sort@ConfigurationLinesFromGraph[configg]

LeviGraph[lines2]//RecognizeGraph

points=GraphEmbedding[configg]

ResourceFunction["FindExtraordinaryLines"][points]==lines2

ConfigurationGraph[points,lines2,VertexLabels->Automatic]

RecognizeGraph@%

ConfigurationDiagram[points,lines2,.3]

Embeddings

<<MathWorld`Graphs`

KleinGraph24

GraphData["KleinGraph24","StandardName"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["KleinGraph24","EdgeList"]]

Default embedding

GraphPlot@GraphData["KleinGraph24","Edges"]

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

RecognizeGraph[g]

Degenerate

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

distanceregular.org

g=DistanceRegularGraph["klein"]

RecognizeGraph[g]

Bilateral

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

Circular

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

Planar

GraphData["KleinGraph24","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

g=RotateGraph[MinimalCrossingGraph[GraphData["KleinGraph24"],"CrossingNumber"->cn]]

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["KleinGraph24","Circulant"]

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

Halin

GraphData["KleinGraph24","Halin"]

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

LCF

GraphData["KleinGraph24","LCF"]

GraphData["KleinGraph24","HamiltonianCycleCount"]

GraphData["KleinGraph24","LCFSignature"]

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

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

LCF compute

Length[FindHamiltonianCycle[GraphData["KleinGraph24"],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["KleinGraph24"],10^4])[[All,2]]]//Timing

Tally[(lcf=LCF[GraphData["KleinGraph24"],10^5])[[All,2]]]//Timing

gs=Join[With[{g=BilateralLCFEmbedding[#]},If[MissingQ[g],#,g]]&/@LCFGraph@@@DeleteCases[lcf,{_,1|2}],DeleteMissing[BilateralLCFEmbedding/@LCFGraph@@@Cases[lcf,{_,2}]]]

Tally[(lcf=LCF[GraphData["KleinGraph24"],10^6])[[All,2]]]//Timing

gs=Join[With[{g=BilateralLCFEmbedding[#]},If[MissingQ[g],#,g]]&/@LCFGraph@@@DeleteCases[lcf,{_,1|2}],DeleteMissing[BilateralLCFEmbedding/@LCFGraph@@@Cases[lcf,{_,2}]]]

UnitDistance

GraphData["KleinGraph24","UnitDistance"]

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

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

Matchstick

GraphData["KleinGraph24","Matchstick"]

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

3D default

Graph3D[GraphData["KleinGraph24","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["KleinGraph24","Polyhedral"]

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

KleinGraph120

Names

GraphData["KleinGraph120","StandardName"]

GraphData["KleinGraph120","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["KleinGraph120","EdgeList"]]

Default embedding

GraphPlot@GraphData["KleinGraph120","Edges"]

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

RecognizeGraph[g]

Degenerate

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

Incidence

GetGraphData["KleinGraph120","File"]

GraphData["KleinGraph120","Incidence"]

Select[GraphData[All],GraphData[#,"LeviGraph","Name"]==="KleinGraph120"&]

lines=GraphData["KleinGraph120","IncidenceLines"]

ConfigurationNotation[lines]

levi=LeviGraph[lines]

RecognizeGraph@levi

Bilateral

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

Circular

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

Planar

GraphData["KleinGraph120","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

(cn=CrossingNumber[GraphData["KleinGraph120"],TimeConstraint->300])//AbsoluteTiming

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

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

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

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["KleinGraph120","Circulant"]

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

Halin

GraphData["KleinGraph120","Halin"]

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

LCF

GraphData["KleinGraph120","LCF"]

GraphData["KleinGraph120","HamiltonianCycleCount"]

GraphData["KleinGraph120","LCFSignature"]

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

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

LCF compute (10^4)

Length[FindHamiltonianCycle[GraphData["KleinGraph120"],1*^4][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["KleinGraph120"],1*^4])[[All,2]]]//Timing

(nice=SelectFirst[lcf,GraphSymmetryGroup[LCFGraph@@#]=!=TransformationGroup[{}]&])//Timing

MaxMemoryUsed[]/10^9.

LCF compute (10^5)

Length[FindHamiltonianCycle[GraphData["KleinGraph120"],(10^5)][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["KleinGraph120"],(10^5)])[[All,2]]]//Timing

MaxMemoryUsed[]/10^9.

(nicelcf=SelectFirst[lcf,GraphSymmetryGroup[LCFGraph@@#]=!=TransformationGroup[{}]&])//Timing

MaxMemoryUsed[]/10^9.

LCFGraph@@@lcf//StyleGraphs

gs=Flatten[{
(* all LCF's with order >1, sorted by order and with bilateral graphs first *)
Join[DeleteCases[#,{_Missing,_}][[All,1]],Cases[#,{_Missing,_}][[All,2]]]&/@Map[{BilateralLCFEmbedding[#],#}&,Map[LCFGraph@@#&,SplitBy[DeleteCases[lcf,{_,1}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFEmbedding/@LCFGraph@@@Cases[lcf,{_,XXX}]]}]

Length[gs]

LCF compute (10^6)

Length[FindHamiltonianCycle[GraphData["KleinGraph120"],(10^6)][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData["KleinGraph120"],(10^6)])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

LCF compute 5*^6

Tally[(lcf=LCF[GraphData["KleinGraph120"],5*^6])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

l={
{"KleinGraph120",{0,Missing["NotAvailable",LCFNotation/@gs]}}
}

PropertyReplace[l,"LCFNotations","14.1"]

RenameGraphFiles[]

UnitDistance

GraphData["KleinGraph120","UnitDistance"]

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

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["KleinGraph120","VertexList"],GraphData["KleinGraph120","EdgeList"]]]

UnitDistanceEmbeddingRefine[Annotate[#,VertexCoordinates->N[GraphEmbedding[#]]]]&/@Complement@@(GraphData["KleinGraph120","Graph",#]&/@{"All","UnitDistance"})

UnitDistance by FindUnitDistanceEmbedding

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

Matchstick

GraphData["KleinGraph120","Matchstick"]

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

3D default

Graph3D[GraphData["KleinGraph120","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["KleinGraph120","Polyhedral"]

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

Construction

Klein24 Hyperbolic

Graphics[HyperbolicTiling[7,3]]

p=Select[First/@HyperbolicTilingVertices[7,3],Norm[#]<.82&];
Graphics[MapIndexed[{{Red,PointSize[.015],Point[#]},Text[First[#2],#+.035]}&,p]]

Flatten[Join[
{Partition[{9,10,16,18,24,23,17,15},2,1,1]},
Partition[#,2,1]&/@{{20,22,18},{30,28,24}}],1]

ShowLabeledGraph[g=Graph[List/@Flatten[Join[
{
Partition[{9,10,16,18,24,23,17,15},2,1,1]},
{{{12,14},{22,26},{28,32},{27,29},{19,21},{7,11},{1,5},{4,6}}},
{{{}}}
Partition[#,2,1]&/@{{20,22,18},{30,28,24},{31,27,23},{25,21,17},{13,11,15},{3,5,9},{2,6,10},{8,12,16}}],1],List/@p]]

M[g]

Klein120

https://arxiv.org/abs/2010.08863

In an abstract projective space, there are 60 points and 60 planes such that 15 points are on each plane and 15 planes go through each point. The configuration is built from what Klein called the 15 fundamental tetrahedra, which define 60 distinct planes. An abstract presentation is here.

The following can be considered the points OR planes:

points={{0,0,1,1},{0,0,1,I},{0,0,1,-1},{0,0,1,-I},{0,1,0,1},{0,1,0,I},{0,1,0,-1},{0,1,0,-I},{0,1,1,0},{0,1,I,0},{0,1,-1,0},{0,1,-I,0},{1,0,0,1},{1,0,0,I},{1,0,0,-1},{1,0,0,-I},{1,0,1,0},{1,0,I,0},{1,0,-1,0},{1,0,-I,0},{1,1,0,0},{1,I,0,0},{1,-1,0,0},{1,-I,0,0},{1,0,0,0},{0,1,0,0},{0,0,1,0},{0,0,0,1},{1,1,1,1},{1,1,1,-1},{1,1,-1,1},{1,1,-1,-1},{1,-1,1,1},{1,-1,1,-1},{1,-1,-1,1},{1,-1,-1,-1},{1,1,I,I},{1,1,-I,I},{1,1,I,-I},{1,1,-I,-I},{1,-1,I,I},{1,-1,I,-I},{1,-1,-I,I},{1,-1,-I,-I},{1,I,1,I},{1,I,1,-I},{1,-I,1,I},{1,-I,1,-I},{1,I,-1,I},{1,I,-1,-I},{1,-I,-1,I},{1,-I,-1,-I},{1,I,I,1},{1,I,-I,1},{1,-I,I,1},{1,-I,-I,1},{1,I,I,-1},{1,I,-I,-1},{1,-I,I,-1},{1,-I,-I,-1}};

Length[points]

Each point is on 15 planes, and vice-versa:

planes=Table[Select[points, points[[k]].# ==0&],{k,60}]

Tally[Length/@planes]

LeviGraph[planes]//RecognizeGraph

Original construction

Ed Pegg, Jr.
Dec 15, 2022

In an abstract projective space, there are 60 points and 60 planes such that 15 points are on each plane and 15 planes go through each point. The configuration is built from what Klein called the 15 fundamental tetrahedra, which define 60 distinct planes. An abstract presentation is here.

More recently, Piotr Pokora, Tomasz Szemberg, Justyna Szpond, “Unexpected properties of the Klein configuration of 60 points in (ℙ^3)” found a less abstract set of points. arxiv.

The following can be considered the points OR planes:

points={{0,0,1,1},{0,0,1,I},{0,0,1,-1},{0,0,1,-I},{0,1,0,1},{0,1,0,I},{0,1,0,-1},{0,1,0,-I},{0,1,1,0},{0,1,I,0},{0,1,-1,0},{0,1,-I,0},{1,0,0,1},{1,0,0,I},{1,0,0,-1},{1,0,0,-I},{1,0,1,0},{1,0,I,0},{1,0,-1,0},{1,0,-I,0},{1,1,0,0},{1,I,0,0},{1,-1,0,0},{1,-I,0,0},{1,0,0,0},{0,1,0,0},{0,0,1,0},{0,0,0,1},{1,1,1,1},{1,1,1,-1},{1,1,-1,1},{1,1,-1,-1},{1,-1,1,1},{1,-1,1,-1},{1,-1,-1,1},{1,-1,-1,-1},{1,1,I,I},{1,1,-I,I},{1,1,I,-I},{1,1,-I,-I},{1,-1,I,I},{1,-1,I,-I},{1,-1,-I,I},{1,-1,-I,-I},{1,I,1,I},{1,I,1,-I},{1,-I,1,I},{1,-I,1,-I},{1,I,-1,I},{1,I,-1,-I},{1,-I,-1,I},{1,-I,-1,-I},{1,I,I,1},{1,I,-I,1},{1,-I,I,1},{1,-I,-I,1},{1,I,I,-1},{1,I,-I,-1},{1,-I,I,-1},{1,-I,-I,-1}};

From https://en.wikipedia.org/wiki/Levi_graph:
From a collection of points and lines in an incidence geometry or a projective configuration, we form a graph with one vertex per point, one vertex per line, and an edge for every incidence between a point and a line.
...
Levi graphs may also be defined for other types of incidence structure, such as the incidences between points and planes in Euclidean space.

Denote point vertices as above, place vertices as 2*point vertices,  and create edges when points lie on a plane:

edges=Flatten[Table[UndirectedEdge[2points[[k]],#]&/@Select[points,points[[k]].#==0&],{k,60}],1]

vertices=Union[Flatten[List@@@edges,1]]

Length[vertices]

Union[points,2points]===vertices

kc=IndexGraph@Graph[vertices,edges]

kc2=Graph[VertexList[kc],Sort[Sort/@EdgeList[kc]]]

kc2=;

VertexCount[kc]

RecognizeGraph@kc

Factor[CharacteristicPolynomial[AdjacencyMatrix[kc],x]]

DistanceRegularGraphQ@kc

DistanceTransitiveGraphQ@kc

GraphData

GraphClassString

GraphClassString["KleinGraph24"]

GraphDataTable

TableForm[GraphDataTable["KleinGraph24",x],TableDepth->2]//TraditionalForm

GraphDataString

GraphDataString[KleinGraph,
"Name"->"Klein graph",
"StandardName"->"KleinGraph24",
"Classes"->{"DistanceRegular"},
"Vertices"->None,
"Skip"->{"Perfect"},
Debug->True,
TimeConstraint->60
]

file=OpenWrite["klein.m"]