Möbius-Kantor Graph

Author

Eric W. Weisstein
June 21, 2023

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/Moebius-KantorGraph.nb.

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

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

Configuration

GraphData["MoebiusKantorGraph","Incidence"]

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

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

RecognizeGraph[LeviGraph[#]]&/@lines

GraphData["MoebiusKantorConfigurationGraph","#"]

https://en.wikipedia.org/wiki/Möbius–Kantor_configuration

there is no solution in the Euclidean plane

Embeddings

<<MathWorld`Graphs`

Names

GraphData["MoebiusKantorGraph","StandardName"]

GraphData["MoebiusKantorGraph","StandardNames"]

Primary

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

Read and Wilson

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["MoebiusKantorGraph","EdgeList"]]

Default embedding

GraphPlot[GraphData["MoebiusKantorGraph","Edges"],GraphLayout->"SpringElectricalEmbedding"]

((v[[6,2]])/(v[[13,2]]))

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

RecognizeGraph@g

GraphPlot[GraphData["MoebiusKantorGraph","Edges"],GraphLayout->"HighDimensionalEmbedding"]

GraphPlot@RotateGraph[GraphicsToGraph@,Pi/12]

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

RecognizeGraph[g]

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

RecognizeGraph[g]

Degenerate

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

CVT construction

g=CubicVertexTransitiveGraph[16]

RecognizeGraph@g

HoneycombToroidal construction

GraphData["MoebiusKantorGraph","NotationRules","HoneycombToroidal"]

HoneycombToroidalGraph[1,16,5]

RecognizeGraph[%]

GeneralizedHoneycombGraph construction

With[{n=16},Cases[Table[{k,g=GeneralizedHoneycombGraph[n,k],RecognizeGraph@g},{k,n-1}],{__,"MoebiusKantorGraph"}]]//Timing

g=GeneralizedHoneycombGraph[16,5]

RecognizeGraph@g

Bilateral

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

Circular

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

IGraph

GraphData["MoebiusKantorGraph","NotationRules","IGraph"]

Cases[GraphData["MoebiusKantorGraph","StandardNames"],{"IGraph",_}]

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

IGraph construction

IGraph@@@Cases[GraphData["MoebiusKantorGraph","StandardNames"],{"IGraph",ind_}:>ind]//StyleGraphs

GeneralizedPetersen

GraphData["MoebiusKantorGraph","NotationRules","GeneralizedPetersen"]

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

Planar

GraphData["MoebiusKantorGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

GraphPlot@RotateGraph[,.52]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

GraphPlot@RotateGraph[,{14,9}]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

IntegerCoordinates

GraphData["MoebiusKantorGraph","Graph","IntegerCoordinates"]//StyleGraphs

IntegerCoordinates construction

GraphData["MoebiusKantorGraph","Embeddings"][[6]]

ShowLabeledGraph[g=GraphData["MoebiusKantorGraph","Graphs"][[6]]]

v=Vertices[GraphData["MoebiusKantorGraph","Graphs"][[6]]]

s=Last[v[[2]]-v[[1]]]

ShowGraph[g2=ChangeVertices[g,Round[(#-v[[1]])&/@v/s]]]

ToCommonEdges[g2,"MoebiusKantorGraph"]

GetGraphData["MoebiusKantorGraph","File"]

Integral

GraphData["MoebiusKantorGraph","Graph","Integral"]//StyleGraphs

Circulant

GraphData["MoebiusKantorGraph","Circulant"]

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

Halin

GraphData["MoebiusKantorGraph","Halin"]

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

LCF

GraphData["MoebiusKantorGraph","LCF"]

GraphData["MoebiusKantorGraph","HamiltonianCycleCount"]

GraphData["MoebiusKantorGraph","LCFSignature"]

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

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

LCF compute

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

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

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,{_,1}]]}]

UnitDistance

GraphData["MoebiusKantorGraph","UnitDistance"]

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

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

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

UnitDistance construction GP

e=Sort[Sort/@Join[
Partition[Range[8],2,1,1],
Partition[Range[9,16],2,1,1],
{{1,11},{4,12},{7,13},{2,14},{5,15},{8,16},{3,9},{6,10}}
]]

r=Sin[1/2(Pi-2k/n Pi)]/Sin[k 2 Pi/n]/.{n->8,k->3};
R=Sin[1/2(Pi-2k/n Pi)]/Sin[k 2 Pi/n]/.{n->8,k->1};
v=Join[
r Table[Through[{Cos,Sin}[π/8+2Pi 3k/8]],{k,8}],
R Table[Through[{Cos,Sin}[π/8+2Pi(k+1)/8]],{k,8}]
];

g=Graph[Range[15],
UndirectedEdge@@@e,
VertexCoordinates->v]

RecognizeGraph[g]

UnitDistance construction from {"CubicTransitive", 73}

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

g=IndexGraph@ContractCoincidentVertices[,Tolerance->.2]

g2=UnitDistanceEmbeddingRefine@g

RecognizeGraph@g

UnitDistanceGraphEmbeddingQ@g2

v={{-x-1,-1/2},{-x-1,1/2},{-1/2,x},{-1/2,-x},{x,-1/2},{x,1/2},{-1/2,-x-1},{-1/2,x+1},{1/2,-x-1},{1/2,x+1},{-x,-1/2},{-x,1/2},
{1/2,x},{1/2,-x},{x+1,-1/2},{x+1,1/2}};
eqn=UnitEdgeEquations[v,EdgeList@g]//FullSimplify//Union

Solve[eqn,x,PositiveReals]//FullSimplify

g=Graph[Range[16],EdgeList[g2],VertexCoordinates->(v/.x->-(1/2)+(1/(Sqrt[2])))]

RecognizeGraph@g

UnitDistanceGraphEmbeddingQ@g

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

FindUnitDistanceEmbedding[GraphData["MoebiusKantorGraph"],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

gs={,,,,,,,,,,,,,,,,};

Matchstick

GraphData["MoebiusKantorGraph","Matchstick"]

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

3D default

Graph3D[GraphData["MoebiusKantorGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["MoebiusKantorGraph","Polyhedral"]

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

Properties

Matrices

GraphicsRow[GraphMatrixPlot[GraphData["MoebiusKantorGraph"]]]

Misc.

ChromaticPolynomial[MoebiusKantorGraph,z]//Timing

Factor[Last[%17]]//TraditionalForm

TraditionalForm[Last[%17]]

GraphData

GraphClassString

GraphClassString["MoebiusKantorGraph"]

GraphDataTable

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