Pappus Graph

Author

Eric W. Weisstein
October 26, 2025

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

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

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

Configuration

GraphData["PappusGraph","Incidence"]

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

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

RecognizeGraph[LeviGraph[#]]&/@lines

GraphData["PappusConfigurationGraph","#"]

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

lines2=Sort@ConfigurationLinesFromGraph[configg]

LeviGraph[lines2]//RecognizeGraph

points=GraphEmbedding[configg]

Pappus configuration plus 3-8-6

lines3=ResourceFunction["FindExtraordinaryLines"][points]

LeviGraph[lines3]

RecognizeGraph@%

ConfigurationGraph[points,lines2,VertexLabels->Automatic]

RecognizeGraph@%

ConfigurationDiagram[points,lines2]

Embeddings

<<MathWorld`Graphs`

Some embeddings by Ed Pegg Jr.
August 30 and October 20, 2002

Names

GraphData["PappusGraph","StandardName"]

GraphData["PappusGraph","StandardNames"]

HouseOfGraphs

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

HouseOfGraphsLookup[hogid]

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

Read and Wilson

distanceregular.org

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

RecognizeGraph[g]

VertexCount[g]

GraphDiameter[g]//Timing

RegularParameters[g]//Timing

DistanceRegularGraphQ[g]//Timing

IntersectionArray[g]//Timing

IntegerSpectrum[g]//SpectrumForm

GroupOrder[GraphAutomorphismGroup[g]]

HamiltonianGraphQ[g]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["PappusGraph","EdgeList"]]

Default embedding

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

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

RecognizeGraph[g]

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

RecognizeGraph[g]

RegionDistance[Line@v[[{7,11}]],v[[18]]]

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

RecognizeGraph[g]

g0=LabelGraph@CenterGraph@

v=GraphEmbedding[g0];
v=Join[v,{v[[1]]-{1,0},v[[16]]+{1,0}}];
ee=Join[EdgeList[g0],UndirectedEdge@@@{{1,17},{16,18},{11,17},{18,8},{7,18},{10,17},{2,15},{14,3}}];
g=Graph[Range@Length@v,ee,VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

g0=;

v0=GraphEmbedding[g0]

v={#/5,#2/6}&@@@v0

g=Annotate[g0,VertexCoordinates->v]

Degenerate

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

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

Incidence

GraphData["PappusGraph","Incidence"]

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

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

levi=LeviGraph[lines]

RecognizeGraph@levi

Bilateral

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

Circular

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

Planar

GraphData["PappusGraph","Planar"]

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

MinimalCrossing

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

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

MinimalCrossing construction

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

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

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

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

IGLayoutTutte[g,"OuterFace"->#]&/@faces

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

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

GraphPlot@

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

LocalCrossingCount@g

gs=UnlabelGraph/@{}

MinimalLocalCrossing

GraphData["PappusGraph","LocalCrossingNumber"]

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

MinimalLocalCrossing construction

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

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

Select[Table[MinimalCrossingGraph[GraphData["PappusGraph"],"CrossingNumber"->cn,RandomSeed->i],{i,500}],!AdjacentCrossingsQ[#,cn]&]//Union//Timing

GraphPlot@

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

RecognizeGraph@g

RectilinearCrossingCount@g

LocalCrossingCount@g

Circulant

GraphData["PappusGraph","Circulant"]

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

Line graph

GraphData["PappusGraph","Line"]

LineGraphQ[GraphData["PappusGraph"]]//Timing

RootGraph

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

RootGraph[GraphData["PappusGraph"]]

Halin

GraphData["PappusGraph","Halin"]

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

Rigid

GraphData["PappusGraph","Rigid"]

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

Flexible

GraphData["PappusGraph","Flexible"]

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

LCF

GraphData["PappusGraph","LCF"]

GraphData["PappusGraph","HamiltonianCycleCount"]

GraphData["PappusGraph","LCFSignature"]

GraphData["PappusGraph","LCFNotations"]

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

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

LCF compute all

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

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

lcf

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

Length[gs]

IntegerCoordinates

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

Integral

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

UnitDistance

GraphData["PappusGraph","UnitDistance"]

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

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

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

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

gs={RotateGraph[,{18,13}],RotateGraph[,{18,15}],RotateGraph[,{2,26}]}

g=RotateGraph[,{2,1}]

UnitDistance construction Gerbracht

From E. Gerbracht

rA=1/2;
A1={rA*Sin[0*2*Pi/6],rA*Cos[0*2*Pi/6]};
A2={rA*Sin[5*2*Pi/6],rA*Cos[5*2*Pi/6]};
A3={rA*Sin[4*2*Pi/6],rA*Cos[4*2*Pi/6]};
A4={rA*Sin[3*2*Pi/6],rA*Cos[3*2*Pi/6]};
A5={rA*Sin[2*2*Pi/6],rA*Cos[2*2*Pi/6]};
A6={rA*Sin[1*2*Pi/6],rA*Cos[1*2*Pi/6]};

alpha=ArcSin[Sin[2*Pi/6]/2];
beta=2*Pi-2*Pi/6-alpha;
rB=-FullSimplify[TrigExpand[Sin[beta]/Sin[2*Pi/6]]];
B1={rB*Sin[0*2*Pi/6],rB*Cos[0*2*Pi/6]};
B2={rB*Sin[5*2*Pi/6],rB*Cos[5*2*Pi/6]};
B3={rB*Sin[4*2*Pi/6],rB*Cos[4*2*Pi/6]};
B4={rB*Sin[3*2*Pi/6],rB*Cos[3*2*Pi/6]};
B5={rB*Sin[2*2*Pi/6],rB*Cos[2*2*Pi/6]};
B6={rB*Sin[1*2*Pi/6],rB*Cos[1*2*Pi/6]};

rC=Sin[1/2*(Pi-2*k/n*Pi)]/Sin[k*2*Pi/n]/.{n->6,k->1};gamma=FullSimplify[TrigExpand[ArcCos[(1-rC^2-rB^2)/(2*rB*rC)]]];
C1={-FullSimplify[rC*Sin[gamma]],-rC*Cos[gamma]};
C2={-FullSimplify[TrigExpand[rC*Sin[gamma-2*Pi/6]]],-FullSimplify[TrigExpand[rC*Cos[gamma-2*Pi/6]]]};
C3={-FullSimplify[TrigExpand[rC*Sin[gamma-2*2*Pi/6]]],-FullSimplify[TrigExpand[rC*Cos[gamma-2*2*Pi/6]]]};
C4={-FullSimplify[TrigExpand[rC*Sin[gamma-3*2*Pi/6]]],-FullSimplify[TrigExpand[rC*Cos[gamma-3*2*Pi/6]]]};
C5={-FullSimplify[TrigExpand[rC*Sin[gamma-4*2*Pi/6]]],-FullSimplify[TrigExpand[rC*Cos[gamma-4*2*Pi/6]]]};
C6={-FullSimplify[TrigExpand[rC*Sin[gamma-5*2*Pi/6]]],-FullSimplify[TrigExpand[rC*Cos[gamma-5*2*Pi/6]]]};

v=FullSimplify[ToExpression/@Flatten[Outer[StringJoin,{"A","B","C"},ToString/@Range[6]]]]//ToRadicals

Count[Norm/@(Subtract@@@Subsets[v,{2}]),_?(#==1.&)]//Quiet

g=Graph[Range[Length[v]],UnitEdges[v],VertexCoordinates->v]

RecognizeGraph[g]

Matchstick

GraphData["PappusGraph","Matchstick"]

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

xyz

GraphData["PappusGraph","Graph","XYZ"]//StyleGraphs

xyz construction

Projection2D[v0_,o_:{0,0,0},r_:1]:=Module[{v=v0-o},{v[[1]],v[[2]]}r/(r-v[[3]])]

g=With[{g=XYZGraph[3]},Annotate[g,VertexCoordinates->(Projection2D[#,20{1,1,2},20]&/@GraphEmbedding[g])]]

GraphEmbedding[g]

3D default

Graph3D[GraphData["PappusGraph","Edges"]]

3D All

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

3D xyz

GraphData["PappusGraph","Graph",{"3D","XYZ"}]

3D xyz construction

XYZGraph[3]

3D UnitDistance

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

3D Polyhedron

GraphData["PappusGraph","Polyhedral"]

GraphData

GraphMatrixPlot

GraphicsRow[GraphMatrixPlot[GraphData["PappusGraph"]],Alignment->Top]

GraphDataClassString

GraphDataClassString["PappusGraph"]

GraphDataTable

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