Pappus Configuration

Author

Eric W. Weisstein
May 22, 2026

This notebook downloaded from https://mathworld.wolfram.com/notebooks/Configurations/PappusConfiguration.nb.

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

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

Figure

v1={{0,0},{2,0}};
v2={{0,1},{2,5/4}};
l1=Append[v1,v1[[1]]-1/2Subtract@@v1];
l2=Append[v2,{(32/41),(45/41)}];
points=Join[l1,l2];
l3=Flatten[Outer[Line[{#1,#2}]&,l1,l2,1]];

RegionIntersection[Line[points[[{2,4}]]],Line[points[[{1,5}]]]]

RegionIntersection[Line[points[[{4,5}]]],InfiniteLine[{points[[3]],{8/9,5/9}}]]

middlepts=RegionIntersection[Line[points[[#1]]],Line[points[[#2]]]][[1,1]]&@@@{{{1,6},{3,4}},{{1,5},{2,4}},{{3,5},{2,6}}}

points=Join[points,middlepts];

lines=Join[
Line/@{v1,v2},
Delete[l3,List/@{1,5,9}],Line/@{RegionIntersection[Line[points[[#]]],InfiniteLine[points[[{7,9}]]]][[1,1]]&/@{{1,4},{2,5}}}]

Graphics[{lines,
PointSize[.03],Point[points],MapIndexed[Text[#2[[1]],#,2{-2,-1}]&,points]}]

Construction

points={{1,0},{2,0},{3,0},{0,1},{2,2},{4,3},{(6/5),(2/5)},{(3/2),(1/2)},{(18/7),(6/7)}};

lines=ResourceFunction["FindExtraordinaryLines"][points]

ConfigurationGraph[points,lines]

RecognizeGraph@%

LeviGraph[lines]//RecognizeGraph

Embeddings

<<MathWorld`Graphs`

Names

GraphData["PappusConfigurationGraph","StandardName"]

GraphData["PappusConfigurationGraph","StandardNames"]

Primary

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

All

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

Inexact

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

Embedding types

GraphDataEmbeddings[GraphData["PappusConfigurationGraph","EdgeList"]]

Default embedding

GraphPlot[GraphData["PappusConfigurationGraph","Edges"],GraphLayout->"SpringEmbedding"]

v=Tuples[{-1,0,1},2];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,4,7,8,9,6,3,2,1,5,9],e[3,5,7],e[2,4,8,6,2]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

GraphData["GoddardHenningGraph","Graph",4]

v=Tuples[{-1,0,1},2];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,4,7,8,9,6,3,2,1,5,9],e[3,5,7],e[2,4,8,6,2],e[4,5,6]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

RotateGraph[Graph[GraphData["PappusConfigurationGraph","Edges"],GraphLayout->"HighDimensionalEmbedding"],-3Pi/8]

v=Join[UnitCirclePoints[8,-Pi/2],{{0,0}}];
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,5,6,7,8,1,3,5,7,1],e[7,9,3],e[8,9,4],e[6,9,2]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

v=RotationMatrix[Pi/4].(#-{1/2,1/2})&/@{{0,0},{1,0},{1,1},{0,1},{1/2,1/4},{1/4,1/2},{3/4,1/2},{1/2,3/4},{1/2,1/2}};
g=Graph[Range@Length@v,UndirectedEdge@@@{e[1,2,3,4,1,5,2,7,3,8,4,6,1,9,3],e[6,9,7],e[5,9,8]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph@g

Degenerate

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

Configuration

GraphData["PappusConfigurationGraph","Configuration"]

configurations=GraphData["PappusConfigurationGraph","Graph","Configuration"]//StyleGraphs

config=configurations[[1]]

(alledges=AddAllConfigurationEdges[config])//Timing

RecognizeGraph@alledges

ConfigurationDiagram[config,.2]

lines=ConfigurationLines[config]

GraphData["PappusConfigurationGraph","IncidenceLines"]

levi=LeviGraph[lines]

RecognizeGraph[levi]

GraphData["PappusConfigurationGraph","LeviGraph","Name"]

FirstCase[GraphData["PappusConfigurationGraph","StandardNames"],{"Incidence",_}]

Cases[GraphData["PappusConfigurationGraph","StandardNames"],_String?(StringMatchQ[#,"*Configuration*"]&)]

GraphData["PappusConfigurationGraph","OrdinaryLineGraphName"]

(ordinarylinegraph=OrdinaryLineGraph[config])//Timing

RecognizeGraph@ordinarylinegraph

Bilateral

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

Grid[DeleteCases[Monitor[{g=#,BilateralGraphEmbeddingQ[#],GraphSymmetryGroup[#]}&/@GraphData["PappusConfigurationGraph","Graph","All"],g],{_,_,TransformationGroup[{}]}],Dividers->All,Alignment->{{Center,{Left}}}]

Circular

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

Circular construction

Length[hc=FindHamiltonianCycle[GraphData["PappusConfigurationGraph"],All][[All,All,1]]]

CircularEmbeddingFromHamiltonianCycle[GraphData["PappusConfigurationGraph"],#]&/@hc

Length[bilat=DeleteDuplicatesBy[DeleteMissing[BilaterallyRotatedGraph@%],CircularCanonicalGraphEmbedding]]//Timing

gs=bilat

Planar

GraphData["PappusConfigurationGraph","Planar"]

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

Tutte embeddings

faces=ReverseSort@SymmetricallyDistinctFaces[GraphData["PappusConfigurationGraph"]]

Tally[ReverseSort[Length/@faces]]

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

gs=Annotate[#,{VertexLabels->None,ImageSize->Tiny}]&/@{,}

RecognizeGraph/@gs

Tutte embedding construction 4 #1

g=EdgeAdd[GraphData["GoddardHenningGraph","Graph",{"Labeled","Planar"}][[1]],{4\[UndirectedEdge]9,9\[UndirectedEdge]2}]

RecognizeGraph[g]

Tutte embedding construction 4 #2

GraphPlot[RotateGraph[,-3Pi/4]]

v={{0,-1},{1,0},{0,1},{-1,0},{-1/2,0},{0,0},{1/2,0},{1/4,1/4},{-1/4,1/4}};
g=Graph[Range[Length[v]],UndirectedEdge@@@{e[1,2,3,4,1,7,3,5,1],e[4,5,6,7,2],e[5,9,6,8,7],e[9,3,8]},VertexCoordinates->v,VertexLabels->Automatic]

RecognizeGraph[g]

Tutte embedding construction 3 #1

GraphPlot[RotateGraph[,2Pi/3]]

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

RecognizeGraph[g]

Tutte embedding construction 3 #2

GraphPlot[RotateGraph[,2Pi/3]]

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

RecognizeGraph[g]

Circulant

GraphData["PappusConfigurationGraph","Circulant"]

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

Halin

GraphData["PappusConfigurationGraph","Halin"]

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

LCF

GraphData["PappusConfigurationGraph","LCF"]

GraphData["PappusConfigurationGraph","HamiltonianCycleCount"]

GraphData["PappusConfigurationGraph","LCFSignature"]

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

UnitDistance

GraphData["PappusConfigurationGraph","UnitDistance"]

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

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

UnitDistance by refinement

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

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

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

Matchstick

GraphData["PappusConfigurationGraph","Matchstick"]

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

3D default

Graph3D[GraphData["PappusConfigurationGraph","Edges"]]

3D All

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

3D UnitDistance

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

3D Polyhedron

GraphData["PappusConfigurationGraph","Polyhedral"]

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

Graphics3D[{FaceForm[Green,Red],GraphData["PappusConfigurationGraph","Polyhedron"]}]

3D Canonical

GraphData["PappusConfigurationGraph","Graph",{"3D","Canonical"}]

Graphics3D[{Opacity[.5],Red,GraphData["PappusConfigurationGraph","Polyhedron","Canonical"],Yellow,Sphere[]}]

3D Canonical construction

Graphics3D[{FaceForm[Green,Red],poly=GraphPolyhedron[GraphData["PappusConfigurationGraph"],1]}]

(can=FindCanonicalPolyhedron[poly,WorkingPrecision->50,MaxIterations->50000,PrecisionGoal->20,"ProgressInterval"->1000,"TangentFactor"->1/10,"PlanarFactor"->1/10,Debug->True])//Timing

SimplePolyhedronQ[can]

Graphics3D[{Opacity[.5],Red,can,Yellow,Sphere[]}]

(lens=Mean/@Split[Sort[PolyhedronEdgeLengths[can]],Abs[#1-#2]<1.*^-10&])//N

v=PolyhedronCoordinates[can];

colors=With[{n=Length[lens]},Table[Hue[i/n],{i,0,n-1}]]

Graphics3D[{Thick,Sequence@@Nearest[Thread[lens->colors],EuclideanDistance@@v[[#]]],Line[v[[#]]]}&/@PolyhedronEdges[can],Boxed->False]

g=PolyhedronGraph[can]