Clebsch Graph

Author

Eric W. Weisstein
February 25, 2023

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

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

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

Embeddings

GraphData["ClebschGraph","StandardName"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["ClebschGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

Degenerate

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

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

Bilateral

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

Circular

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

Planar

GraphData["ClebschGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

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

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

Circulant

GraphData["ClebschGraph","Circulant"]

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

Halin

GraphData["ClebschGraph","Halin"]

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

Rigid

GraphData["ClebschGraph","Rigid"]

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

Flexible

GraphData["ClebschGraph","Flexible"]

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

LCF

GraphData["ClebschGraph","LCF"]

GraphData["ClebschGraph","HamiltonianCycleCount"]

GraphData["ClebschGraph","LCFSignature"]

GraphData["ClebschGraph","LCFNotations"]

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

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

LCF compute random

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

LCF compute all

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

Tally[(lcf=LCF[GraphData["ClebschGraph"],All])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

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

Length[gs]

UnitDistance

GraphData["ClebschGraph","UnitDistance"]

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

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

UnitDistance by refinement

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

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

UnitDistance by FindUnitDistanceEmbedding

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

Matchstick

GraphData["ClebschGraph","Matchstick"]

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

3D default

Graph3D[GraphData["ClebschGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["ClebschGraph","Polyhedral"]

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

Properties

CrossingNumber

GraphData["ClebschGraph","CrossingNumber"]

Dear Eric Weisstein,

we are sorry to report that the requested computation (Clebsch graph) failed.
Please contact Markus Chimani (http://www-lehre.informatik.uni-osnabrueck.de/theoinf/index/staff/chimani)
if you really need to compute the crossing number of this graph.

Please visit this link for detailed results: http://crossings.uos.de/job/gadTvBkFZK7uFQ3KclBy2Q

RectilinearCrossingNumber

GraphData["ClebschGraph","RectilinearCrossingNumber"]

GraphData["ClebschGraph","Graph","MinimalRectilinearCrossing"]

RectilinearCrossingCount/@%

Construction

MinimalRectilinearCrossing (Exoo)

Show[img=ImageCrop[Import["http://isu.indstate.edu/ge/COMBIN/RECTILINEAR/clebsch.png"]],ImageSize->Small]

Length[pts=ImageValuePositions[img,Red,.1]]

Graphics[Point[pts],ImageSize->Small]

Length[v=Mean/@FindClusters[pts,16,Method->"Agglomerate"]]

Graphics[Point[v],ImageSize->Small]

v=v/Max[Abs[v]];

GraphData["ClebschGraph","VertexDegrees"]

g=System`Graph[Range[Length[v]],Union[Sort/@UndirectedEdge@@@Join@@(Partition[#,2,1]&/@{
{1,16,2},Sequence@@({15,#}&/@{16,3,6,12,11}),{16,8},{16,7},{3,1,3,4},{3,15},{3,13},{1,5},{14,1},{14,11},{14,13},{14,12},{14,2},{4,11},{4,8},{5,6},{5,7},{5,12},{5,4},{2,4},{10,12},{10,7},{10,3},{10,9},{9,11},{9,6},{13,7},{13,8},{13,14},{13,6},{2,6},{8,9},{8,12},{7,11},{10,2},{1,9}
})],VertexCoordinates->v,VertexLabels->"Name"]

VertexDegree[g]

Position[System`AdjacencyMatrix[g][[1]]//Normal,1]//Flatten

RecognizeGraph[g]

RectilinearCrossingCount[g]

l={{gn="ClebschGraph",{0,Append[GraphData[gn,"Embeddings"],ToCommonEdges[g,GraphData[gn]]]}}}

PropertyReplace[l,"Embeddings","11.3"]

RenameGraphFiles[]

l={{gn,{0,Append[GraphData[gn,"EmbeddingClasses"],{}]}}}

PropertyReplace[l,"EmbeddingClasses","11.3"]

RenameGraphFiles[]

3D UD (Pegg)

Ed Pegg, Jr.
Mar 20, 2018

cleb=RootReduce[Join[Flatten[Append[#,0]&/@CirclePoints[5]#&/@{Root[1-10 #1^2+5 #1^4&,2],Root[1-5 #1^2+5 #1^4&,4]},1],Append[#,Root[-4+5 #1^4&,2]]&/@Append[CirclePoints[5]Root[1-5 #1^2+5 #1^4&,3],{0,0}]]];
unitlines=Select[Subsets[cleb,{2}],Chop[Quiet@N[1-Quiet@EuclideanDistance@@#]]==0&];
Graphics3D[{Table[Text[n,cleb[[n]]],{n,1,16}],Line/@unitlines},ViewPoint->{0,0,20},Boxed->False]

e=unitlines/.Thread[cleb->Range[Length[cleb]]]

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

gn=RecognizeGraph[g]

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

ToCommonEdges[g,GraphData[gn]]

v=ToCommonEdges[g,GraphData[gn]]/.Thread[N[cleb]->cleb]

l={{gn,{0,{v}}}}

PropertyReplace[l,"Embeddings3D","11.4"]

RenameGraphFiles[]

l={{gn,{0,{{"Primary", "UnitDistance"}}}}}

PropertyReplace[l,"EmbeddingClasses3D","11.4"]

RenameGraphFiles[]

From the 2-Keller graph

KellerCond[v_]:=Module[{diff=Select[Transpose[v],UnsameQ@@#&]},
Length[diff]>1&&!FreeQ[Mod[Subtract@@@diff,4],2]
]

KellerGraph[n_]:=MakeGraph[Tuples[Range[0,3],{n}],KellerCond[{#1,#2}]&,Combinatorica`Type->Undirected,VertexLabel->True]

KellerGraph[2]//ShowGraph

(cg=ChangeVertices[KellerGraph[2],Flatten[Table[{x,y},{x,0,3},{y,0,3}],1]])//ShowGraph

RecognizeGraph/@KellerGraph/@Range[4]

4^Range[6]

v=ToCommonEdges[cg,Graph["ClebschGraph"]]

i=GraphData["ClebschGraph","AllImages"]

Length[i]

l={{"ClebschGraph",{0,ReplacePart[GraphData["ClebschGraph","Embeddings"],4->v]}}}

GraphData["ClebschGraph","EmbeddingClasses"]

l={{"ClebschGraph",{0,ReplacePart[GraphData["ClebschGraph","EmbeddingClasses"],4->{"IntegerCoordinates"}]}}}

As a folded 5-cube

FoldedCube[n_]:=Module[{join,h=Hypercube[n]},
join=Rule@@@(Reverse/@Union[Sort/@Position[GraphDistanceMatrix[h],n]]);
Graph[List/@Union[Sort/@(Edges[h]/.join)],
List/@Vertices[DeleteVertices[h,First/@join]]]
]

FoldedCube[5]//RecognizeGraph

From TesseractGraph by adding diagonals

GraphData["TesseractGraph","Diameter"]

diags=Union[Sort/@Position[GetGraphData["TesseractGraph","DistanceMatrix"]//Normal,4]]

AddEdges[Graph["TesseractGraph"],diags]//RecognizeGraph

ShowLabeledGraph/@(AddEdges[ChangeVertices[Graph["TesseractGraph"],#],diags]&/@GraphData["TesseractGraph","Embeddings"])

Symmertic

ShowLabeledGraph[g=AddEdges[
AddVertices[Graph[{},{{{0,0}}}],
Join[(2Through[{Sin,Cos}[2Pi #/5]]&/@Range[0,4]),(1.2Through[{Sin,Cos}[2Pi #/10]]&/@Range[0,9])]],
{
Sequence@@Partition[Range[2,6],2,1,1],
Sequence@@Partition[Range[7,16],2,1,1],
{2,7},{6,15},{3,9},{5,13},{4,11},{2,14},{2,10},{6,12},{5,16},{5,10},{4,14},{4,8},{3,16},{3,12},
Sequence@@({1,#}&/@Range[8,16,2]),
{7,13},{7,11},{6,8},{9,13},{15,11},{15,9}
}
]]

Degrees[g]

distanceregular.org

g=DistanceRegularGraph["http://www.distanceregular.org/graphdata/clebsch.am"]

VertexCount[g]

GraphDiameter[g]//Timing

RegularParameters[g]//Timing

DistanceRegularGraphQ[g]//Timing

IntersectionArray[g]//Timing

IntegerSpectrum[g]//SpectrumForm

GroupOrder[GraphAutomorphismGroup[g]]

HamiltonianGraphQ[g]

GraphData

GraphClassString

GraphClassString["ClebschGraph"]