Maximally Graceful Graph

Author

Eric W. Weisstein
December 30, 2024

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

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

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

Source

Knuth, D.E.  Problem 97 in The Art of Computer Programing, Vol. 4, Pre-Fascicle 7A, §7.2.2.3, pp. 121 and , 2024.

A002494: simple graphs with no isolated vertices

1, 2, 7, 23, 122, 888, 11302

A379575: Total numbers of fundamentally distinct graceful labelings among all simple graphs on n vertices having no isolated points.

1, 2, 13, 157, 3292

Figures

All graphs

TextGrid[data=MapIndexed[Prepend[#,#2[[1]]]&,{#[[1,1]],Rest/@#}&/@Table[SplitBy[SortBy[
DeleteCases[
GraphData[#,{"GracefulLabelingCount","#","Graph"}]&/@GraphData[n],
{_Missing,__}
],
First],First][[-1]],{n,8}]]/.g_Graph:>Annotate[g,ImageSize->Tiny],Dividers->All]

expanded=Flatten[Table[{data[[i,1]],data[[i,2]],#[[2]]}&/@data[[i,3]],{i,Length[data]}],1]

Length[expanded]

$Version

Row[{1,"label"}," "]

"1 label"

GraphicsGrid[Partition[Annotate[StyleGraphs@#3,PlotLabel->Column[{Row[{Style["n",Italic],"==",#}," "],Row[{#2,If[#2==1,"labeling","labelings"]},"  "]},Alignment->Center,BaseStyle->Directive[Black,FontFamily->"Times"]]]&@@@expanded,UpTo[5]],Dividers->All,Alignment->Top,ImageSize->700]

Connected

TextGrid[data=MapIndexed[Prepend[#,#2[[1]]]&,{#[[1,1]],Rest/@#}&/@Table[SplitBy[SortBy[
DeleteCases[
GraphData[#,{"GracefulLabelingCount","#","Graph"}]&/@GraphData["Connected",n],
{_Missing,__}
],
First],First][[-1]],{n,8}]]/.g_Graph:>Annotate[g,ImageSize->Tiny],Dividers->All]

expanded=Flatten[Table[{data[[i,1]],data[[i,2]],#[[2]]}&/@data[[i,3]],{i,Length[data]}],1]

Length[expanded]

GraphicsGrid[Partition[Annotate[StyleGraphs@#3,PlotLabel->Column[{Row[{Style["n",Italic],"==",#}," "],Row[{#2,If[#2==1,"labeling","labelings"]}," "]},Alignment->Center,BaseStyle->Directive[Black,FontFamily->"Times"]]]&@@@expanded,UpTo[5]],Dividers->All,Alignment->Top,ImageSize->700]

StyleGraphs[GraphData[{"MaximumPlanarEmbedding",{8,1}}],ImageSize->Small,PlotLabel->"3778 labelings",LabelStyle->Directive[14,Black,FontFamily->"Times"]]

GraphData[{"MaximumPlanarEmbedding",{8,1}},"GracefulLabelingCount"]

GraphData[{"MaximumPlanarEmbedding",{8,1}},"StandardNames"]

GraphData[{"MaximumPlanarEmbedding",{8,1}},"PlanarEmbeddingCount"]

Embeddings

<<MathWorld`Graphs`

{"MaximallyGraceful", {8, 1}}

Names

GraphData[{"MaximallyGraceful",{8,1}},"StandardName"]

GraphData[{"MaximallyGraceful",{8,1}},"StandardNames"]

Primary

GraphData[{"MaximallyGraceful",{8,1}}]//StyleGraphs[#,ImageSize->Small]&

All

GraphData[{"MaximallyGraceful",{8,1}},"Graph","All"]//StyleGraphs

Construction from connected component

cc=GraphData[{"MaximallyGraceful",{8,1}},"ConnectedComponents","Name"]

GraphData[cc[[1]],"Graph","All"]

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

gs=MyGraphUnion[#,"K1"]&/@GraphData[cc[[1]],"Graph","All"]

RecognizeGraph/@gs

Inexact

Select[GraphData[{"MaximallyGraceful",{8,1}},"Graph","All"],(!FreeQ[GraphEmbedding[#],_?InexactNumberQ]&)]//StyleGraphs

Embedding types

GraphDataEmbeddings[GraphData[{"MaximallyGraceful",{8,1}}]]

Default embedding

GraphPlot[Graph[GraphData[{"MaximallyGraceful",{8,1}},"VertexList"],GraphData[{"MaximallyGraceful",{8,1}},"Edges"]]]

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

RecognizeGraph@g

Degenerate

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Degenerate"]//StyleGraphs

DegenerateGraphEmbeddingTypes/@GraphData[{"MaximallyGraceful",{8,1}},"Graph","Degenerate"]

GeneralizedPetersen

GraphData[{"MaximallyGraceful",{8,1}},"Graph","GeneralizedPetersen"]//StyleGraphs

IGraph

GraphData[{"MaximallyGraceful",{8,1}},"Graph","IGraph"]//StyleGraphs

Bilateral

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Bilateral"]//StyleGraphs

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

Circular

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Circular"]//StyleGraphs

Circular construction

GraphData[{"MaximallyGraceful",{8,1}},"Hamiltonian"]

GraphData[{"MaximallyGraceful",{8,1}},"LCF"]

GraphData[{"MaximallyGraceful",{8,1}},"HamiltonianCycleCount"]

Planar

GraphData[{"MaximallyGraceful",{8,1}},"Planar"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Planar"]//StyleGraphs

Planar construction

PlanarGraphEmbedding[GraphData[{"MaximallyGraceful",{8,1}}],GraphLayout->#]&/@{"TutteLayout","DavidsonHarelLayout"}

Table[PlanarGraphEmbedding[GraphData[{"MaximallyGraceful",{8,1}}]],10]

PlanarGraphEmbeddings

GraphData[{"MaximallyGraceful",{8,1}},"PlanarEmbeddingCount"]

(plemb=PlanarGraphEmbeddings[GraphData[{"MaximallyGraceful",{8,1}}],Debug->True])//Timing

Length[plemb]

Tutte embeddings

faces=ReverseSort@SymmetricallyDistinctFaces[GraphData[{"MaximallyGraceful",{8,1}}]]

Tally[ReverseSort[Length/@faces]]

gs=IGLayoutTutte[GraphData[{"MaximallyGraceful",{8,1}}],"OuterFace"->#]&/@faces

TextGrid[DeleteCases[{#,GraphSymmetryGroup[#]}&/@gs,{_,TransformationGroup[{}]}],Dividers->All]

Grid[DeleteCases[{#,Cases[GraphSymmetryGroup[#],r_Rotation:>r,∞]}&/@gs,{_,{}}],Dividers->All]

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

RecognizeGraph/@gs

Tutte embedding construction

GraphPlot[RotateGraph[]]

TutteLayoutManipulate[g_Graph]:=Manipulate[
With[{face=OuterFace[g]},
IGLayoutTutte[IGEdgeMap[(EuclideanDistance@@#)^pow&,EdgeWeight->IGEdgeVertexProp[VertexCoordinates],IGLayoutTutte[g,"OuterFace"->face]],"OuterFace"->face,ImageSize->Automatic]],{{pow,1},.1,2}]

TutteLayoutManipulate[]

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

RecognizeGraph[g]

MinimalCrossing

GraphData[{"MaximallyGraceful",{8,1}},{"RCN","CN"}]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","MinimalCrossing"]//StyleGraphs

MinimalCrossingNumber

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->1])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->10])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->60])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->5 3600])//AbsoluteTiming

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->86400])//AbsoluteTiming

MinimalCrossing construction

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->1])//AbsoluteTiming

(g=MinimalCrossingGraph[GraphData[{"MaximallyGraceful",{8,1}}],"CrossingNumber"->cn])//PolyhedralGraphQ

faces=ReverseSort@SymmetricallyDistinctFaces[g]

Tally[ReverseSort[Length/@faces]]

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

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"MaximallyGraceful",{8,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

Select[gs,Max[OuterFace[#]]<=GraphData[{"MaximallyGraceful",{8,1}},"V"]&]

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

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"MaximallyGraceful",{8,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

(gs=Table[MinimalCrossingGraph[GraphData[{"MaximallyGraceful",{8,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,50}]//Union)//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"MaximallyGraceful",{8,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

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

RecognizeGraph[g]

RectilinearCrossingCount[g]

RectilinearLocalCrossingCount[g]

MinimalLocalCrossing

GraphData[{"MaximallyGraceful",{8,1}},{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","MinimalLocalCrossing"]//StyleGraphs

MinimalRectilinearLocalCrossing

GraphData[{"MaximallyGraceful",{8,1}},{"LocalCrossingNumber","RectilinearLocalCrossingNumber"}]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","MinimalRectilinearLocalCrossing"]//StyleGraphs

MinimaRectilinearlLocalCrossing construction

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

(cn=CrossingNumber[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->10])//AbsoluteTiming

(gs=Select[Table[MinimalCrossingGraph[GraphData[{"MaximallyGraceful",{8,1}}],"CrossingNumber"->cn,RandomSeed->i],{i,20000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"MaximallyGraceful",{8,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

(gs=Select[Table[MinimalCrossingGraph[GraphData[{"MaximallyGraceful",{8,1}}],"CrossingNumber"->(cn=XXX),RandomSeed->i],{i,20000}],!AdjacentCrossingsQ[#,cn]&]//Union)//Timing

Select[gs,GraphSymmetryGroup[#,AdditionalData->Join[Table[True,GraphData[{"MaximallyGraceful",{8,1}},"V"]],Table[False,cn]],SameTest->Equal]=!=TransformationGroup[{}]&]

Circulant

GraphData[{"MaximallyGraceful",{8,1}},"Circulant"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Circulant"]//StyleGraphs

Circulant construction

GraphData[{"MaximallyGraceful",{8,1}},"NotationRules","Circulant"]

(ci=CirculantIndices[GraphData[{"MaximallyGraceful",{8,1}}]])//Timing

CirculantGraph1@@@ci

Cases[GraphData[{"MaximallyGraceful",{8,1}},"StandardNames"],{"Circulant",i_}:>i]

CirculantGraph1@@@%

Complement graph

compl=GraphData[{"MaximallyGraceful",{8,1}},"ComplementGraph","Name"]

GraphData[compl,"Graph","All"]

gs=GraphComplement/@%

Select[%,!DegenerateGraphEmbeddingQ[#]&]

Line graph

GraphData[{"MaximallyGraceful",{8,1}},"Line"]

LineGraphQ[GraphData[{"MaximallyGraceful",{8,1}}]]//Timing

RootGraph

roots=Select[GraphData[All],GraphData[#,"LineGraph","Name"]==={"MaximallyGraceful",{8,1}}&]

RootGraph[GraphData[{"MaximallyGraceful",{8,1}}]]

RecognizeGraph[%]

GraphData[roots[[1]],"Graph","All"]

gs=LineGraph/@%

Halin

GraphData[{"MaximallyGraceful",{8,1}},"Halin"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Halin"]//StyleGraphs

Rigid

GraphData[{"MaximallyGraceful",{8,1}},"Rigid"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Rigid"]//StyleGraphs

Flexible

GraphData[{"MaximallyGraceful",{8,1}},"Flexible"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Flexible"]//StyleGraphs

LCF

GraphData[{"MaximallyGraceful",{8,1}},"LCF"]

GraphData[{"MaximallyGraceful",{8,1}},"HamiltonianCycleCount"]

GraphData[{"MaximallyGraceful",{8,1}},"LCFSignature"]

GraphData[{"MaximallyGraceful",{8,1}},"LCFNotations"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","LCF"]//StyleGraphs

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

LCF compute random

FindRandomLCFNotation[GraphData[{"MaximallyGraceful",{8,1}}],TimeConstraint->120]

LCF compute 10^5

Tally[(lcf=LCF[GraphData[{"MaximallyGraceful",{8,1}}],10^5])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

(nice=SelectFirst[lcf,GraphSymmetryGroup[LCFGraph@@#]=!=TransformationGroup[{}]&])//Timing

l={
{{"MaximallyGraceful",{8,1}},{0,Missing["NotAvailable",LCFNotation/@gs]}}
}

PropertyReplace[l,"LCFNotations","14.1"]

RenameGraphFiles[]

LCF compute all

Divisors[GraphData[{"MaximallyGraceful",{8,1}},"V"]]

Length[FindHamiltonianCycle[GraphData[{"MaximallyGraceful",{8,1}}],All][[All,All,1]]]//Timing

Tally[(lcf=LCF[GraphData[{"MaximallyGraceful",{8,1}}],All])[[All,2]]]//Timing

MaxMemoryUsed[]/10.^9 "GB"

Tally[(lcf=ReadProperty["LCFNotations",GraphNameToFileName[{"MaximallyGraceful",{8,1}},".m.gz"]])[[All,2]]]//Timing

DeleteCases[lcf,{_,1}]

LCFGraph@@@DeleteCases[lcf,{_,1}]//StyleGraphs

Tally[LCFNotation[#][[-1]]&/@(gs=NiceLCFGraphs[lcf,2,1])]//Timing

Length[gs]

gs

BilateralGraphEmbeddingQ/@gs

(nice=SelectFirst[lcf,GraphSymmetryGroup[LCFGraph@@#]=!=TransformationGroup[{}]&])//Timing

i=0;
gs={};
t0=AbsoluteTime[];
count=Length[order2];
Monitor[
Do[
If[!MissingQ[g=BilateralLCFGraph[LCFGraph@@order2[[i]]]],AppendTo[gs,g]],
{i,count}
],
Column[{
ProgressIndicator[i,{1,count}],
Row[{i,"/",count}],
Row[{"estimated time remaining: ",Round[(AbsoluteTime[]-t0) (count/i-1)]," s"}],
Row[{Length[gs]," bilateral graphs"}]
}]
];//Timing

UnitDistance

GraphData[{"MaximallyGraceful",{8,1}},"UnitDistance"]

UnitDistanceGraphQ[GraphData[{"MaximallyGraceful",{8,1}}],Debug->True]//Timing

GraphData[{"MaximallyGraceful",{8,1}},"Graph","UnitDistance"]//StyleGraphs

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

UnitDistance by refinement

UnitDistanceEmbeddingRefine[Graph[GraphData[{"MaximallyGraceful",{8,1}},"VertexList"],GraphData[{"MaximallyGraceful",{8,1}},"EdgeList"]],MaxIterations->500]

UnitDistanceGraphEmbeddingQ[%]

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

Select[%,UnitDistanceGraphEmbeddingQ]

UnitDistance by FindUnitDistanceEmbedding

FindUnitDistanceEmbedding[GraphData[{"MaximallyGraceful",{8,1}}],MaxIterations->5000,"ReturnWithMessage"->True]//Timing

FindUnitDistanceEmbedding[GraphData[{"MaximallyGraceful",{8,1}}],MaxIterations->5000,"ReturnWithMessage"->False]//Quiet//Timing

UnitDistance by FindSubgraphUnitDistanceEmbedding

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

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

Select[IndexGraph/@gs,!DegenerateGraphEmbeddingQ[#]&&GraphSymmetryGroup[#]=!=TransformationGroup[{}]&]//Timing

Matchstick

GraphData[{"MaximallyGraceful",{8,1}},"Matchstick"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph","Matchstick"]//StyleGraphs

3D default

Graph3D[GraphData[{"MaximallyGraceful",{8,1}},"Edges"]]

3D construction

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

RecognizeGraph[g]

3D All

GraphData[{"MaximallyGraceful",{8,1}},"Graph",{"3D","All"}]

3D UnitDistance

GraphData[{"MaximallyGraceful",{8,1}},"Graph",{"3D","UnitDistance"}]

3D Polyhedron

GraphData[{"MaximallyGraceful",{8,1}},"Polyhedral"]

GraphData[{"MaximallyGraceful",{8,1}},"Graph",{"3D","Polyhedron"}]

Graphics3D[{FaceForm[Green,Red],GraphData[{"MaximallyGraceful",{8,1}},"Polyhedron"]}]

3D Canonical

GraphData[{"MaximallyGraceful",{8,1}},"Graph",{"3D","Canonical"}]

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

Counts

<<MathWorld`Graphs`

fundcounts=Table[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","GracefulLabelingCount","GracefulLabelingCount_0"<>ToString[n]<>".m"}]],{n,8}];

Maximally graceful (not necessarily connected)

A379395

Max/@fundcounts

data=Table[
{
n,
pos=Flatten[Position[fundcounts[[n]],Max[fundcounts[[n]]]]],
gs=Graphs[n][[pos]],
RecognizeGraph[#,"Cache"->"InternalOnly"]&/@gs
},{n,8}]

Maximally graceful connected

Table[Max[fundcounts[[n]][[ConnectedGraphIndices[n]]]],{n,8}]

data2=Table[
{
n,
pos=Flatten[Position[cnts=fundcounts[[n]][[ConnectedGraphIndices[n]]],Max[cnts]]],
gs=Graphs[n][[ConnectedGraphIndices[n]]][[pos]],
RecognizeGraph[#,"Cache"->"InternalOnly"]&/@gs
},{n,8}]

data[[All,-1]]

GetGraphData[{"MaximumPlanarEmbedding",{8,1}},"File"]

Maximally graceful not allowing isolated vertices

A339892

mindegrees=Table[Get[FileNameJoin[{$GraphDataDirectory,"Nodes","MinimumVertexDegree","MinimumVertexDegree_0"<>ToString[n]<>".m"}]],{n,8}];

NoIsolatedPointPositions=Table[Flatten@Position[mindegrees[[n]],_Integer?Positive],{n,8}];

Table[Max[fundcounts[[n]][[NoIsolatedPointPositions[[n]]]]],{n,8}]

data=Table[
MaximalBy[
DeleteCases[
MapIndexed[{#,#2[[1]],Min[VertexDegree[Graphs[n][[#2[[1]]]]]]>0}&,Import[FileNameJoin[{$GraphDataDirectory,"Nodes","GracefulLabelingCount","GracefulLabelingCount_0"<>ToString[n]<>".m"}]]],
{_,_,False}
],
First
],{n,8}]

data[[2;;,1,1]]

GraphData

AddIndexedClass

Most@data[[All,-1]]

rules=Flatten[MapIndexed[Rule[#,#2]&,Most@data[[All,-1]],{2}],1]

AddIndexedClass["MaximallyGraceful",rules,14.3,"AddClass"->False]

RenameGraphFiles[]

GraphDataString

file=OpenWrite["~/maximally-graceful.m"]

WriteString[file,GraphDataString[,
"StandardName"->{"MaximallyGraceful",{8,1}},
"Name"->"8\[Hyphen]maximally graceful graph 1",
"Information"->"MaximallyGracefulGraph",
"NotationRules"->{"MaximallyGracefulGraph"}
]]

Close[file]