Kummer Graph

Author

Eric W. Weisstein
December 15, 2023

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

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

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

Configuration

GraphData["KummerGraph","Incidence"]

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

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

RecognizeGraph[LeviGraph[#]]&/@lines

GraphData["KummerConfigurationGraph","#"]

configg=GraphData["KummerConfigurationGraph","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`

Names

GraphData["KummerGraph","StandardName"]

GraphData["KummerGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["KummerGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

DegenerateGraphEmbeddingTypes/@GraphData["KummerGraph","Graph","Degenerate"]

Incidence

GraphData["KummerGraph","Incidence"]

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

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

ConfigurationNotation[lines]

levi=LeviGraph[lines]

RecognizeGraph@levi

Bilateral

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

Circular

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

Planar

GraphData["KummerGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

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

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

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["KummerGraph","Circulant"]

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

Halin

GraphData["KummerGraph","Halin"]

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

Rigid

GraphData["KummerGraph","Rigid"]

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

Flexible

GraphData["KummerGraph","Flexible"]

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

LCF

GraphData["KummerGraph","LCF"]

GraphData["KummerGraph","HamiltonianCycleCount"]

GraphData["KummerGraph","LCFSignature"]

GraphData["KummerGraph","LCFNotations"]

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

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

LCF compute random

ComputeRandomLCFNotation["KummerGraph",2,TimeConstraint->120]

LCF compute 10^7

GraphData["KummerGraph","HamiltonianCycleCount"]

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

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1|2}]

lcf={{{{-15,-11,-9,13},{-7,3,11,15},{-11,-7,5,7},{-13,-7,3,7},{-15,-11,-3,7},{-13,-7,11,15},{-7,-3,7,13},{-5,7,9,11}},4},{{{-15,-11,-9,13},{-5,3,9,15},{-11,-9,5,9},{-13,-9,3,9},{-15,-9,-3,5},{-13,-7,11,15},{-7,-3,7,13},{-5,7,9,11}},4},{{{-15,-11,-3,7},{-13,-7,-5,15},{-11,5,7,9},{-13,-9,3,9},{-15,-9,5,13},{-7,3,11,15},{-7,-3,7,13},{-7,-5,7,11}},4},{{{-15,-11,-3,7},{-13,-5,9,15},{-9,-3,9,13},{-9,-7,-5,11},{-15,5,7,13},{-7,3,11,15},{-11,-7,5,7},{-13,-7,3,7}},4},{{{-15,-11,-3,7},{-13,9,11,15},{-11,-9,-7,5},{-13,-7,3,7},{-15,-11,7,13},{-7,3,11,15},{-7,-3,7,13},{-7,-5,7,11}},4},{{{-15,-11,7,13},{-13,-7,-5,15},{-3,7,9,13},{-9,-5,9,11},{-15,-9,5,13},{-13,-7,11,15},{-11,5,7,9},{-13,-9,-7,3}},4},{{{-15,-11,7,13},{-13,-7,11,15},{-11,5,7,9},{-13,-9,-7,3},{-15,-11,7,13},{-13,9,11,15},{-9,-7,-3,13},{-7,-5,7,11}},4},{{{-15,-11,7,13},{-13,-5,9,15},{-11,-9,-7,5},{-13,3,7,9},{-15,-9,5,13},{-13,9,11,15},{-9,-7,-3,13},{-7,-5,7,11}},4},{{{-15,-11,7,13},{-5,3,9,15},{-9,-3,9,13},{-9,-5,9,11},{-15,-9,-3,5},{-13,9,11,15},{-11,-9,-7,5},{-13,-7,3,7}},4},{{{-15,-9,-3,5},{-13,-7,-5,15},{-11,5,7,9},{-13,-9,3,9},{-15,-9,5,13},{-5,3,9,15},{-9,-3,9,13},{-9,-5,9,11}},4},{{{-15,-9,-3,5},{-13,-5,9,15},{-9,-3,9,13},{-9,-7,-5,11},{-15,5,7,13},{-5,3,9,15},{-11,-9,5,9},{-13,-9,3,9}},4},{{{-15,-9,5,13},{-13,-7,-5,15},{-3,7,9,13},{-9,-5,9,11},{-15,-9,5,13},{-13,-5,9,15},{-11,-9,-7,5},{-13,3,7,9}},4},{{{-15,-7,-5,13},{-13,5,7,15},{-11,-7,3,9},{-13,-9,5,7},{-5,3,11,13},{-13,-7,-3,9},{-9,-5,7,13},{-11,-3,5,11}},4},{{{-15,-7,-5,13},{-13,5,7,15},{-11,-5,3,11},{-13,-7,5,9},{-9,3,7,13},{-13,-11,-3,5},{-7,-5,9,13},{-9,-3,7,11}},4},{{{-15,-7,-5,13},{-13,5,7,15},{-11,-3,3,13},{-13,-5,5,11},{-7,3,9,13},{-13,-9,-3,7},{-11,-5,5,13},{-13,-3,3,11}},4},{{{-15,-7,-3,11},{-11,3,7,15},{-13,-5,5,11},{-11,-5,3,11},{-13,-5,-3,11},{-11,3,5,13},{-11,-3,5,11},{-11,-5,5,13}},4},{{{-15,-7,-3,11},{-11,3,7,15},{-13,-3,5,13},{-11,-5,3,11},{-13,-7,-3,9},{-9,3,7,13},{-11,-3,5,11},{-13,-5,3,13}},4},{{{-15,-5,-3,9},{-9,3,5,15},{-13,-7,5,9},{-13,-9,5,7},{-13,-5,-3,11},{-7,3,9,13},{-9,-5,7,13},{-11,-5,5,13}},4},{{{-15,-5,-3,9},{-9,3,5,15},{-13,-5,5,11},{-13,-7,5,9},{-13,-9,-3,7},{-11,3,5,13},{-7,-5,9,13},{-9,-5,7,13}},4},{{{-15,-5,-3,9},{-9,3,5,15},{-13,-5,5,11},{-13,-5,5,11},{-13,-5,-3,11},{-11,3,5,13},{-11,-5,5,13},{-11,-5,5,13}},4},{{{-15,-5,-3,9},{-9,3,5,15},{-13,-3,5,13},{-13,-5,5,11},{-13,-7,-3,9},{-9,3,7,13},{-11,-5,5,13},{-13,-5,3,13}},4},{{{-15,-5,9,13},{-13,-11,-9,15},{-5,3,5,11},{-13,-7,5,9},{-13,-9,7,13},{-13,-11,-3,5},{-7,9,11,13},{-9,-5,7,13}},4},{{{-15,-5,9,13},{-13,-9,5,15},{-13,-11,-5,11},{-7,3,5,9},{-13,-9,7,13},{-13,-11,5,13},{-7,-5,-3,9},{-9,7,11,13}},4},{{{-15,-5,9,13},{-13,-9,5,15},{-13,-11,-3,13},{-5,3,5,11},{-13,-7,9,13},{-13,-9,7,13},{-11,-5,-3,5},{-13,3,11,13}},4},{{{-15,9,11,13},{-13,-9,5,15},{-13,-7,5,9},{-13,-11,-9,7},{-5,3,11,13},{-13,-7,9,13},{-9,-5,7,13},{-11,-5,-3,5}},4},{{{-15,9,11,13},{-13,-9,5,15},{-13,-5,5,11},{-13,-11,-5,11},{-5,3,11,13},{-13,-11,5,13},{-11,-5,5,13},{-11,-5,-3,5}},4}};

l={{"KummerGraph",{0,Missing["NotAvailable",lcf]}}}

PropertyReplace[l,"LCFNotations","13.3"]

RenameGraphFiles[]

LCFGraph@@@DeleteCases[lcf,{_,1|2}]//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[{BilateralLCFGraph@#,#}&,Map[LCFGraph@@#&,SplitBy[DeleteCases[lcf,{_,1|2}],Last],{2}],{2}],
(* order-1 bilateral only *)
DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,XXX}]]}])//Timing

Length[%6[[2]]]

DeleteMissing[BilateralLCFGraph@@@Cases[lcf,{_,2}]]

Length[%]

UnitDistance

GraphData["KummerGraph","UnitDistance"]

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

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData["KummerGraph","VertexList"],GraphData["KummerGraph","EdgeList"]],MaxIterations->500]

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

UnitDistance by FindUnitDistanceEmbedding

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

Matchstick

GraphData["KummerGraph","Matchstick"]

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

3D default

Graph3D[GraphData["KummerGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["KummerGraph","Polyhedral"]

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

Construction

Merge antipodes; called Folded 6-cube by Brouwer

e=Union[Sort/@Edges[Graph["H6"]]/.Rule@@@Union[Sort/@Position[GraphDistanceMatrix[Graph["H6"]],6]]]

v=Union[Flatten[e]]

newe=Union[Sort/@(e/.Thread[v->Range[Length[v]]])]

g=FromUnorderedPairs[newe]

V[g]

FastAutomorphismCount[g]

Girth[g]

ShowGraph[g]

HamiltonianQ[g]

Degrees[g]//Union

GraphData

GraphClassString

GraphClassString["KummerGraph"]

GraphDataString

h=HamiltonianCycles[g,All];//Timing

Put[h,"Kummer.m"]

GraphDataString[g,
"Name"->"Kummer graph",
"StandardName"->"KummerGraph",
"Vertices"->None,
"Classes"->{"Unitransitive","Incidence"},
"Unitransitivity"->2,
"Information"->"KummerGraph",
TimeConstraint->60,
Debug->True
]