Graceful Graph

Author

Eric W. Weisstein
August 16, 2019

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

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

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

Graceful graph counts by vertex count

SetDirectory[FileNameJoin[{$GraphDataDirectory,"Nodes","Graceful"}]];

data=Table[ToExpression@Import["GracefulLabeling_0"<>ToString[n]<>".m","Lines"],{n,8}];

All on n vertices

A308548

Length[DeleteCases[#,{}]]&/@data

FirstCase[Sort[GraphData[#,{"V","#","Graceful"}]&/@GraphData[All]],{n_,_,_Missing}]

SortBy[Select[GraphData[7],GraphData[#,"Graceful"]===Missing["NotAvailable"]&],GraphData[#,"M"]&]

SortBy[Select[GraphData[8],GraphData[#,"Graceful"]===Missing["NotAvailable"]&],GraphData[#,"M"]&]

Length/@Table[GraphData["Graceful",n],{n,7}]

TextGrid[Table[{n,GraphData["Graceful",n]},{n,6}],Dividers->All]

TextGrid[Table[{n,GraphData[#,"Notation"]&/@GraphData["Graceful",n]},{n,6}],Dividers->All]//TraditionalForm

No isolated points on m edges

A308544

1, 1, 3, 5, 12, 37, 112, 340, 1078, 3620, 12737

TextGrid[Table[{n,Select[GraphData["Graceful"],GraphData[#,"M"]==n&&GraphData[#,"MinimumVertexDegree"]=!=0&]},{n,5}],Dividers->All]

TextGrid[Table[{n,GraphData[#,"Notation"]&/@Select[GraphData["Graceful"],GraphData[#,"M"]==n&&GraphData[#,"MinimumVertexDegree"]=!=0&]},{n,5}],Dividers->All]//TraditionalForm

Connected on n vertices

A308549

Table[Length[DeleteCases[data[[n,ConnectedGraphIndices[n]]],{}]],{n,8}]

FirstCase[Sort[GraphData[#,{"V","#","Graceful"}]&/@GraphData["Connected"]],{_,_,_Missing}]

Length/@Table[GraphData[{"Connected","Graceful"},n],{n,7}]

TextGrid[Table[{n,GraphData[{"Connected","Graceful"},n]},{n,6}],Dividers->All]

TextGrid[Table[{n,GraphData[#,"Notation"]&/@GraphData[{"Connected","Graceful"},n]},{n,6}],Dividers->All]//TraditionalForm

Connected on m edges

A308545

1, 1, 3, 5, 11, 28, 79, 227, 701, 2302, 8071

Not all of these are in GraphData:

Cases[Sort[GraphData[#,{"M","#","Graceful"}]&/@GraphData["Connected"]],{_,_,_Missing}]

Tally[Sort[GraphData[#,"M"]&/@Select[GraphData[{"Connected","Graceful"}],GraphData[#,"M"]<12&]]]

%[[2;;,2]]

{1,1,3,5,11,28,79,227,701,2302,8071}-%

Disconnected

Column[Table[GraphData[{"Disconnected","Graceful"},n],{n,6}],Dividers->All]

Ungraceful that do/do not satisfy vertex/edge count criterion

A333865

https://oeis.org/A333865

"trivially" ungraceful

ungracefulfromuncoverablecounts=Table[Total[Boole[VertexCount[#]>EdgeCount[#]+1]&/@Graphs[n]],{n,8}]

Do[Print[{n,Total[Boole[VertexCount[#]>EdgeCount[#]+1]&/@Graphs[n]]//Timing}],{n,8}];

Get["Combinatorica`"]//Quiet

Table[Total[Take[CoefficientList[GraphPolynomial[n,x],x],n-1]],{n,20}]//Timing

Total/@Table[NumberOfGraphs[v,e],{v,20},{e,0,v-2}]//Timing

Sum_{k=10..n-12} A008406(n,k).

ungracefulfromuncoverablecounts={0,1,2,4,8,18,40,100,256,705,2057,6370,20803,71725,259678,985244,3905022,16124936,69188809,307765510,1416146859,6727549181,32938379216,165942445714,859020421012,4563322971706,24847598243116,138533012486423,790075521708603,4605183081182354};

FindSequenceFunction[ungracefulfromuncoverablecounts,n]//Head//Timing

FindGeneratingFunction[ungracefulfromuncoverablecounts,x]//Head//Timing

Head/@Table[FindLinearRecurrence[Drop[ungracefulfromuncoverablecounts,k]],{k,0,3}]//Union//Timing

ungracefulcounts=Table[Length[GraphData["Ungraceful",n]],{n,7}]

ungracefulcounts={0,1,2,4,12,30,85,300};

Length/@{ungracefulcounts,ungracefulfromuncoverablecounts}

equallength=(Take[#,8]&/@{ungracefulcounts,ungracefulfromuncoverablecounts})

Subtract@@equallength

Divide@@equallength//N//Quiet

Ungraceful graph counts by vertex count

All on n vertices

A308556

FirstCase[Sort[GraphData[#,{"V","#","Ungraceful"}]&/@GraphData[All]],{_,_,_Missing}]

Length/@Table[GraphData["Ungraceful",n],{n,7}]

TextGrid[Table[{n,GraphData["Ungraceful",n]},{n,6}],Dividers->All]

TextGrid[Table[{n,GraphData[#,"Notation"]&/@GraphData["Ungraceful",n]},{n,6}],Dividers->All]//TraditionalForm

Connected on n vertices

A308557

FirstCase[Sort[GraphData[#,{"V","#","Ungraceful"}]&/@GraphData["Connected"]],{_,_,_Missing}]

Length/@Table[GraphData[{"Connected","Ungraceful"},n],{n,7}]

Length/@con

TextGrid[Table[{n,GraphData[{"Connected","Ungraceful"},n]},{n,6}],Dividers->All]

TextGrid[Table[{n,GraphData[#,"Notation"]&/@GraphData[{"Connected","Ungraceful"},n]},{n,6}],Dividers->All]//TraditionalForm

GraphicsGrid[Map[Show[GraphData[#]//StyleGraphs,PlotLabel->TextCell[Style[GraphData[#,"Name"],Directive[Black,Italic,FontFamily->"Times"]]]]&,
Flatten[Table[Partition[GraphData[{"Connected","Ungraceful"},n],UpTo[4]],{n,6}],1],{2}],Dividers->All,Alignment->{Center,Top},ImageSize->500]

Eulerian graphs

Ungraceful if Eulerian and mod(m, 4) ≡ 1, 2

Select[GraphData[All],MatchQ[GraphData[#,"M"],1|2]&&GraphData[#,"Graceful"]=!=False&]

Select[GraphData["Eulerian"],MatchQ[GraphData[#,"M"],1|2]&&GraphData[#,"Graceful"]=!=False&]

Column[Table[Select[GraphData["Eulerian",n],MatchQ[Mod[GraphData[#,"M"],4],1|2]&],{n,7}],Dividers->All]

Maximal number of edges for n-node gracefulness

A004137

Length[max={0,1,3,6,9,13,17,23,29,36,43,50,58,68,79,90,101,112,123,138,153,168,183,198,213}]

Wrong:

Table[Select[GraphData[n],GraphData[#,"M"]>max[[n]]&&GraphData[#,"Graceful"]===True&],{n,Length[max]}]

Missing (can fill in as Ungraceful):

Flatten[Table[Select[GraphData[n],GraphData[#,"M"]>max[[n]]&&MissingQ[GraphData[#,"Graceful"]]&],{n,Length[max]}],1]

Sorted by VertexCount/EdgeCount

Sort[Flatten[Table[GraphData[#,{"V","M","#"}]&/@GraphData["Graceful",n],{n,4}],1]]

Graceful labelings form sparse rulers

Use a ruler to search for graceful graphs

qtry=Select[$SparseRulers,Last[#]==22&]

sub=Subsets[{0,1,2,3,8,13,18,22},{2}]

GatherBy[sub,#[[2]]-#[[1]]&]

subs=Subsets[qq=RandomChoice[qtry],{2}]

(diffs=GatherBy[subs,#[[2]]-#[[1]]&])//Column

e=RandomChoice/@diffs

RecognizeGraph[Graph[UndirectedEdge@@@e]]

All

Sort[GraphData[#,{"M","V","#"}]&/@Select[GraphData[All],MemberQ[$SparseRulerSignatures,GraphData[#,{"M","V"}]]&]]

Union[%[[All,1]]]

Rulers are defined and at least one Graph in GraphData with corresponding (E, V) is missing GracefulLabeling

Sort[GraphData[#,{"M","V","#"}]&/@Select[GraphData[All],GraphData[#,"GracefulLabeling"]==Missing["NotAvailable"]&&MemberQ[$SparseRulerSignatures,GraphData[#,{"M","V"}]]&]]

Union[%[[All,1]]]

*Complete* Rulers are defined and at least one Graph in GraphData with corresponding (E, V) is missing GracefulLabeling

Sort[GraphData[#,{"M","V","#"}]&/@Select[GraphData[All],GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&&MemberQ[$CompleteRulerSignatures,GraphData[#,{"M","V"}]]&]]

Union[%[[All,1]]]

{#,SparseRulerCount[#]}&/@%98

*Complete* Rulers are *not* defined and at least one Graph in GraphData with corresponding (E, V) is missing GracefulLabeling

Sort[GraphData[#,{"M","V","#"}]&/@Select[GraphData[All],GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&&
MemberQ[$SparseRulerSignatures,GraphData[#,{"M","V"}]]&&!MemberQ[$CompleteRulerSignatures,GraphData[#,{"M","V"}]]&]]

Union[%[[All,1]]]

Compute

SparseRulerDifferenceSets[sparseruler_List?VectorQ,opts___?OptionQ]:=Module[
{
diffs,lens,
debug=Debug/.{opts}/.Debug->False
},
diffs=GatherBy[Subsets[sparseruler,{2}],#[[2]]-#[[1]]&];
If[debug,Print["diffs: ",diffs]];
If[debug,Print["generating outer product with signature ",lens=Tally[Sort[Length/@diffs]]," containing ",Times@@Power@@@lens," elements"]];
Distribute[diffs,List]
]

SparseRulerDifferenceSets[sparserulers:{_List..},opts___?OptionQ]:=Module[
{
all={},
t,graphs,labels,new,
i,
meth=Method/.{opts}/.Method->"Map",
init="InitialIndex"/.{opts}/."InitialIndex"->1,
maxcount="MaxCount"/.{opts}/."MaxCount"->Infinity,
debug=Debug/.{opts}/.Debug->False,
len=Length[sparserulers]
},
Switch[meth,
"Map",
	Union@@(SparseRulerDifferenceSets/@sparserulers),
"Incremental",
i=init;
While[i≤len&&Length[all]<maxcount,
t=AbsoluteTime[];
labels=Union[SparseRulerDifferenceSets[sparserulers[[i]]]];
graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels;
new=
SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]];
Print[{Row[{i,"/",len}],Length[labels],AbsoluteTime[]-t,Select[new,!MemberQ[all[[All,1]],#[[1]]]&]}];
all=SplitBy[Union[new,all],First][[All,1]];
i++
];
all,
_,
	$Failed
]
]

Test Memory Use/timing

boundedListIndices[bound_]:= Developer`ToPackedArray@Flatten[Outer[List,Sequence@@(Range/@bound)],Length[bound]-1];

SparseRulerDifferenceSets0[sparseruler_]:=Module[{diffs,lengths ,indices},
diffs=GatherBy[Subsets[sparseruler,{2}],#[[2]]-#[[1]]&];
lengths=Length/@diffs;
indices=boundedListIndices[lengths];
MapIndexed[diffs[[#2[[1]],#1]]&,#]&/@indices
]

SparseRulerDifferenceSets1[sparseruler_List?VectorQ,opts___?OptionQ]:=Module[
{
diffs,lens,
debug=Debug/.{opts}/.Debug->False
},
diffs=Developer`ToPackedArray@GatherBy[Subsets[sparseruler,{2}],#[[2]]-#[[1]]&];
If[debug,Print["diffs: ",diffs]];
If[debug,Print["generating outer product with signature ",lens=Tally[Sort[Length/@diffs]]," containing ",Times@@Power@@@lens," elements"]];
Developer`ToPackedArray@Flatten[Outer[List,Sequence@@diffs,1],Length[diffs]-1]
]

SparseRulerDifferenceSets2[sparseruler_List?VectorQ,opts___?OptionQ]:=Module[
{
diffs,lens,
debug=Debug/.{opts}/.Debug->False
},
diffs=GatherBy[Subsets[sparseruler,{2}],#[[2]]-#[[1]]&];
If[debug,Print["diffs: ",diffs]];
If[debug,Print["generating outer product with signature ",lens=Tally[Sort[Length/@diffs]]," containing ",Times@@Power@@@lens," elements"]];
Developer`ToPackedArray@Flatten[Outer[Developer`ToPackedArray[List[##]]&,Sequence@@diffs,1],Length[diffs]-1]
]

SparseRulerDifferenceSets3[sparseruler_List?VectorQ,opts___?OptionQ]:=Module[
{
diffs,lens,
debug=Debug/.{opts}/.Debug->False
},
diffs=GatherBy[Subsets[sparseruler,{2}],#[[2]]-#[[1]]&];
If[debug,Print["diffs: ",diffs]];
If[debug,Print["generating outer product with signature ",lens=Tally[Sort[Length/@diffs]]," containing ",Times@@Power@@@lens," elements"]];
Distribute[diffs,List]
]

SparseRulerDifferenceSets4[sparseruler_List?VectorQ,opts___?OptionQ]:=Module[
{
diffs,lens,
debug=Debug/.{opts}/.Debug->False
},
diffs=GatherBy[Subsets[sparseruler,{2}],#[[2]]-#[[1]]&];
If[debug,Print["diffs: ",diffs]];
If[debug,Print["generating outer product with signature ",lens=Tally[Sort[Length/@diffs]]," containing ",Times@@Power@@@lens," elements"]];
Developer`ToPackedArray@Distribute[diffs,List]
]

30

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==30&])]

MaxMemoryUsed[diffs0=SparseRulerDifferenceSets0[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs1=SparseRulerDifferenceSets1[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs2=SparseRulerDifferenceSets2[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs3=SparseRulerDifferenceSets3[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs4=SparseRulerDifferenceSets4[rulers[[1]]]]//Timing

diffs0==diffs1==diffs2==diffs3==diffs4

44

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==44&])]

MaxMemoryUsed[diffs0=SparseRulerDifferenceSets0[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs1=SparseRulerDifferenceSets1[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs2=SparseRulerDifferenceSets1[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs3=SparseRulerDifferenceSets3[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs4=SparseRulerDifferenceSets4[rulers[[1]]]]//Timing

Developer`PackedArrayQ/@{diffs0,diffs1,diffs2,diffs3,diffs4}

ByteCount/@{diffs0,diffs1,diffs2,diffs3,diffs4}

diffs0==diffs1==diffs2==diffs3==diffs4

50

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==50&])]

MaxMemoryUsed[diffs0=SparseRulerDifferenceSets0[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs1=SparseRulerDifferenceSets1[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs2=SparseRulerDifferenceSets1[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs3=SparseRulerDifferenceSets3[rulers[[1]]]]//Timing

MaxMemoryUsed[diffs4=SparseRulerDifferenceSets4[rulers[[1]]]]//Timing

Developer`PackedArrayQ/@{diffs0,diffs1,diffs2,diffs3,diffs4}

ByteCount/@{diffs0,diffs1,diffs2,diffs3,diffs4}

diffs0==diffs1==diffs2==diffs3==diffs4

Test Method->"Incremental"

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==18&])]

SparseRulerDifferenceSets[rulers,Method->"Incremental","InitialIndex"->240,"MaxCount"->2]

all=SparseRulerDifferenceSets[rulers,Method->"Incremental"]

TextGrid[all,Dividers->All]

8 edges

MemberQ[$CompleteRulerLengths,8]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==8&])]

Select[GraphData[8],GraphData[#,"M"]==5&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Length[allgraphs=Union[CanonicalGraph[UndirectedEdge@@@#]&/@labels]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

18 edges

MemberQ[$CompleteRulerLengths,18]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==18&])]

Select[GraphData[8],GraphData[#,"M"]==18&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Length[allgraphs=Union[CanonicalGraph[UndirectedEdge@@@#]&/@labels]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

19 edges

MemberQ[$CompleteRulerLengths,19]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==19&])]

Select[GraphData[8],GraphData[#,"M"]==19&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

20 edges

MemberQ[$CompleteRulerLengths,20]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==20&])]

Select[GraphData[8],GraphData[#,"M"]==20&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

21 edges

MemberQ[$CompleteRulerLengths,21]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==21&])]

Select[GraphData[8],GraphData[#,"M"]==21&]

GraphData["K7+K1","GracefulLabeling"]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

22 edges

MemberQ[$CompleteRulerLengths,22]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==22&])]

Select[GraphData[8],GraphData[#,"M"]==22&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

23 edges

MemberQ[$CompleteRulerLengths,23]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==23&])]

Select[GraphData[8],GraphData[#,"M"]==23&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

24 edges

MemberQ[$CompleteRulerLengths,24]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==24&])]

Select[GraphData[9],GraphData[#,"M"]==24&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

25 edges

MemberQ[$CompleteRulerLengths,25]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==25&])]

Select[GraphData[9],GraphData[#,"M"]==25&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

26 edges

MemberQ[$CompleteRulerLengths,26]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==26&])]

Select[GraphData[9],GraphData[#,"M"]==26&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

27 edges

MemberQ[$CompleteRulerLengths,27]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==27&])]

Select[GraphData[9],GraphData[#,"M"]==27&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

28 edges

MemberQ[$CompleteRulerLengths,28]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==28&])]

Select[GraphData[9],GraphData[#,"M"]==28&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

30 edges

MemberQ[$CompleteRulerLengths,30]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==30&])]

Select[GraphData[10],GraphData[#,"M"]==30&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

31 edges

MemberQ[$CompleteRulerLengths,31]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==31&])]

Select[GraphData[10],GraphData[#,"M"]==31&]

Select[%,MissingQ[GraphData[#,"Graceful"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

32 edges

MemberQ[$CompleteRulerLengths,32]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==32&])]

Select[GraphData[10],GraphData[#,"M"]==32&]

Select[%,MissingQ[GraphData[#,"GracefulLabeling"]]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

33 edges

MemberQ[$CompleteRulerLengths,33]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==33&])]

Select[GraphData[10],GraphData[#,"M"]==33&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

35 edges

MemberQ[$CompleteRulerLengths,35]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==35&])]

Select[GraphData[10],GraphData[#,"M"]==35&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

36 edges

MemberQ[$CompleteRulerLengths,36]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==36&])]

Select[GraphData[10],GraphData[#,"M"]==36&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all=SplitBy[Sort@Select[Transpose[{graphs,labels}],DataPaclets`GraphDataDump`MyGraphQ[#[[1]]]&],First][[All,1]],Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

38 edges

MemberQ[$CompleteRulerLengths,38]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==38&])]

Select[GraphData[11],GraphData[#,"M"]==38&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

Length[all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->1]]//Timing

Union[graphs=RecognizeGraph[Graph[UndirectedEdge@@@#]]&/@labels]//Length//Timing

TextGrid[all,Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

44 edges

MemberQ[$CompleteRulerLengths,44]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==44&])]

Select[GraphData[12],GraphData[#,"M"]==44&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[{"CompleteTripartite",{2,4,6}},"Graceful"]

GraphData[{"CompleteTripartite",{2,4,6}},"GracefulLabeling"]

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->1])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

45 edges

MemberQ[$CompleteRulerLengths,45]

SparseRulerCount[45]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==45&])]

Select[GraphData[12],GraphData[#,"M"]==45&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->1])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

46 edges

MemberQ[$CompleteRulerLengths,46]

SparseRulerCount[46]

Length[rulers=Select[$SparseRulers,Last[#]==46&]]

Select[GraphData[12],GraphData[#,"M"]==46&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->2])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

48 edges

Length[rulers=Select[$SparseRulers,Last[#]==48&]]

MemberQ[$CompleteRulerLengths,48]

SparseRulerCount[48]

Length[rulers[[1]]]

gs=Select[GraphData[12],GraphData[#,"M"]==48&]

Select[gs,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@gs

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->7])//Timing

TextGrid[all,Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

52 edges

MemberQ[$CompleteRulerLengths,52]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==52&])]

Select[GraphData[13],GraphData[#,"M"]==52&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental"])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

59 edges

MemberQ[$CompleteRulerLengths,59]

SparseRulerCount[59]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==59&])]

gs=Select[GraphData[14],GraphData[#,"M"]==59&]

Select[gs,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@gs

DeleteCases[%,False]//Length

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->1])//Timing

TextGrid[all,Dividers->All,BaseStyle->ShowStringCharacters->True]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

60 edges

MemberQ[$CompleteRulerLengths,60]

SparseRulerCount[60]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==60&])]

Select[GraphData[14],GraphData[#,"M"]==60&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->1])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

61 edges

MemberQ[$CompleteRulerLengths,61]

SparseRulerCount[61]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==61&])]

Select[GraphData[14],GraphData[#,"M"]==61&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

63 edges

MemberQ[$CompleteRulerLengths,63]

SparseRulerCount[63]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==63&])]

Select[GraphData[14],GraphData[#,"M"]==63&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

75 edges

MemberQ[$CompleteRulerLengths,75]

Length[rulers=Select[$SparseRulers,Last[#]==75&]]

Select[GraphData[15],GraphData[#,"M"]==75&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

54+ GB

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->7])//Timing

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental","MaxCount"->7,"InitialIndex"->14])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

80 edges

MemberQ[$CompleteRulerLengths,80]

SparseRulerCount[80]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==80&])]

Select[GraphData[16],GraphData[#,"M"]==80&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

88 edges

MemberQ[$CompleteRulerLengths,88]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==88&])]

Select[GraphData[16],GraphData[#,"M"]==88&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

Needs 42+ GB

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental"])//Timing

TextGrid[all,Dividers->All]

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

108 edges

MemberQ[$CompleteRulerLengths,108]

SparseRulerCount[108]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==108&])]

Select[GraphData[18],GraphData[#,"M"]==108&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

130 edges

MemberQ[$CompleteRulerLengths,130]

SparseRulerCount[130]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==130&])]

Select[GraphData[20],GraphData[#,"M"]==130&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

180 edges

MemberQ[$CompleteRulerLengths,180]

SparseRulerCount[180]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==180&])]

Select[GraphData[24],GraphData[#,"M"]==180&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental"])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

185 edges

MemberQ[$CompleteRulerLengths,185]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==185&])]

SparseRulerCount[185]

Select[GraphData[24],GraphData[#,"M"]==185&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental"])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

189 edges

MemberQ[$CompleteRulerLengths,189]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==189&])]

SparseRulerCount[189]

Select[GraphData[24],GraphData[#,"M"]==189&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=SparseRulerDifferenceSets[rulers,Method->"Incremental"])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

191 edges

MemberQ[$CompleteRulerLengths,191]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==191&])]

SparseRulerCount[191]

Select[GraphData[24],GraphData[#,"M"]==191&]

Select[%,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

200 edges

MemberQ[$CompleteRulerLengths,200]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==200&])]

SparseRulerCount[200]

gs=Select[GraphData[25],GraphData[#,"M"]==200&]

Select[gs,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

204 edges

MemberQ[$CompleteRulerLengths,204]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==204&])]

SparseRulerCount[204]

gs=Select[GraphData[25],GraphData[#,"M"]==204&]

Select[gs,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

206 edges

MemberQ[$CompleteRulerLengths,206]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==206&])]

SparseRulerCount[206]

gs=Select[GraphData[25],GraphData[#,"M"]==206&]

Select[gs,GraphData[#,"GracefulLabeling"] === Missing["NotAvailable"]&]

GraphData[#,"Graceful"]&/@%

(all=MemoryConstrained[SparseRulerDifferenceSets[rulers,Method->"Incremental",Debug->True],50*^9])//Timing

new=Select[all,MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

Convert to ordered vertex labeling

l={#,{0,Normal[FindGraphIsomorphism[GraphData[#],Graph[UndirectedEdge@@@#2]][[1]]][[All,2]]}}&@@@new

Generated by sparse rulers but no example in GraphData

Inventory in GraphData

Function[sig,{sig,Select[GraphData[{"Graceful","Connected"},sig[[2]]],GraphData[#,"M"]==sig[[1]]&]}]/@$SparseRulerSignatures

Cases[%,{sig_,{}}:>sig]

29 edges

MemberQ[$CompleteRulerLengths,29]

Tally[Length/@(rulers=Select[$SparseRulers,Last[#]==29&])]

Select[GraphData[9],GraphData[#,"M"]==29&]

Select[%,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

Length[labels=SparseRulerDifferenceSets[rulers]]//Timing

Length[allgraphs={#[[1,1]],Length[#],#[[All,2]]}&/@SplitBy[Sort[{CanonicalGraph[UndirectedEdge@@@#],#}&/@labels],First]]//Timing

allgraphs[[1]]

Tally[Sort[allgraphs[[All,2]]]]

Excessively graceful

Distinct vertex labels used that generate consecutive edge labelings via difference, but require vertex labels > m

Called "semi-graceful" by Ed Pegg, apparently without much justification, literature citation, mention that the is a new term being coined, etc.  Semi-graceful doesn't seem the best terminology choice...

https://demonstrations.wolfram.com/SemigracefulEulerianGraphs/

P3+K1,3

GraphData["P3+K1,3","Graceful"]

FindGracefulLabeling[GraphData["P3+K1,3"]]//Timing

g=SetProperty[GraphData["P3+K1,3"],VertexLabels->Thread[Range[7]->{0,2,1,3,5,4,6}]]//StyleGraphs

EdgeCount[g]

Abs[Subtract@@@(List@@@EdgeList[g]/.Thread[Range[7]->{0,2,1,3,5,4,6}])]//Sort

Enumeration by EdgeCount

Code to generate graceful graphs.

https://en.wikipedia.org/wiki/Permutation#Numbering _permutations

https://en.wikipedia.org/wiki/Lehmer_code

LehmerEncode=Compile[{{l0,_Integer,1}},Module[{l=l0,i,j,n=Length[l0]},
Do[
If[l[[j]]>l[[i]],l[[j]]--],
{i,n-1},
{j,i+1,n}
];
l
]];

LehmerEncoding[m_,index_Integer]:=NumberDecompose[index,Range[m-1,0,-1]!]

GracefulGraphEdges[m_,index_Integer]:=MapIndexed[#+{0,#2[[1]]}&,LehmerEncoding[m,index]]
GracefulGraphEdges[p_List]:=MapIndexed[#+{0,#2[[1]]}&,LehmerEncode[p]]

GracefulGraph[m_,index_]:=Graph[UndirectedEdge@@@GracefulGraphEdges[m,index]]
GracefulGraph[p_]:=Graph[UndirectedEdge@@@GracefulGraphEdges[p]]

LabeledGracefulGraph[m_,index_]:=Module[
{
edges=GracefulGraphEdges[m,index],
verts
},
verts=Union[Flatten[edges]];
Graph[UndirectedEdge@@@edges,VertexLabels->(Rule[#,#]&/@verts)]
]

StyledLabeledGracefulGraph[m_,index_]:=
With[
{
edges=GracefulGraphEdges[m,index],
verts=Union[Flatten[GracefulGraphEdges[m,index]]]
},
Graph[
UndirectedEdge@@@edges,
EdgeLabels->(Rule[UndirectedEdge@@#,Style[ToString[-Subtract@@#],20]]&/@edges),
VertexSize->.4,
VertexStyle->Lighter[LightCyan],
VertexLabels->(#->Placed[Style[#,18,Red],Center]&/@verts),ImagePadding->10]
]

GracefulGraph[10,3587883]

LabeledGracefulGraph[10,3587883]

StyledLabeledGracefulGraph[10,3587883]

GracefulGraphs[n_Integer]:=GracefulGraph[n,#]&/@Range[n!]
DistinctGracefulGraphsByIntegerIndices[n_]:=Union[CanonicalGraph/@GracefulGraphs[n]]

DistinctGracefulGraphs[n_]:=Module[{p=Range[0,n-1],gs={}},
Do[
gs=Union[gs,{CanonicalGraph[GracefulGraph[p]]}];
p=NextPermutation[p],
{i,n!}];
gs
]

RecognizeGraph[%]

StyledLabeledGracefulGraph[1,#]&/@Range[1!]

StyledLabeledGracefulGraph[1,#]&/@Range[1!]

RecognizeGraph/@GracefulGraphs[1]

StyledLabeledGracefulGraph[2,#]&/@Range[2!]

RecognizeGraph/@%

StyledLabeledGracefulGraph[3,#]&/@Range[3!]

GracefulGraphs[3]

TextGrid[Table[{n,SortBy[Tally[RecognizeGraph/@GracefulGraphs[n]],Last]},{n,7}],Dividers->All,BaseStyle->ShowStringCharacters->True]

Enumerate

0

DistinctGracefulGraphs[0]

Sort[RecognizeGraph/@DistinctGracefulGraphs[0]]

Select[GraphData[All],GraphData[#,"M"]==0&&GraphData[#,"Graceful"]===True&]

1

Sort[RecognizeGraph/@DistinctGracefulGraphs[1]]

Select[GraphData[All],GraphData[#,"M"]==1&&GraphData[#,"Graceful"]===True&]

2

Sort[RecognizeGraph/@DistinctGracefulGraphs[2]]

Select[GraphData[All],GraphData[#,"M"]==2&&GraphData[#,"Graceful"]===True&]

3

Sort[RecognizeGraph/@DistinctGracefulGraphs[3]]

Select[GraphData[All],GraphData[#,"M"]==3&&GraphData[#,"Graceful"]===True&]

4

g1=Sort[RecognizeGraph/@DistinctGracefulGraphs[4]]

g2=Select[GraphData[All],GraphData[#,"M"]==4&&GraphData[#,"Graceful"]===True&]

Complement[g2,g1]

GraphData/@%

5

g1=Sort[RecognizeGraph/@DistinctGracefulGraphs[5]]

g2=Select[GraphData[All],GraphData[#,"M"]==5&&GraphData[#,"Graceful"]===True&]

Complement[g2,g1]

GraphData/@%

6

g1=Sort[RecognizeGraph/@DistinctGracefulGraphs[6]]

g2=Select[GraphData[All],GraphData[#,"M"]==6&&GraphData[#,"Graceful"]===True&]

Complement[g2,g1]

GraphData/@%

1-8

Length/@Table[GracefulGraphs[n],{n,8}]//Timing

Length/@(gracefulgraphs=Table[DistinctGracefulGraphs[n],{n,8}])//Timing

Select[#,!FreeQ[VertexDegree[#],0]&]&/@gracefulgraphs

Count[#,_?ConnectedGraphQ]&/@gracefulgraphs

gracefulnames=RecognizeGraph/@(Union@@gracefulgraphs);

Select[Intersection[GraphData[All],gracefulnames],GraphData[#,"Graceful"]=!=True&]

Select[GraphData[All],GraphData[#,"M"]≤8&&!MemberQ[gracefulnames,#]&&GraphData[#,"Graceful"]=!=False &]

Select[%,FreeQ[GraphData[#,"ConnectedComponents","Name"],"SingletonGraph"]&]

1-9

Length/@Table[GracefulGraphs[n],{n,9}]//Timing

Length/@(gracefulgraphs=Table[DistinctGracefulGraphs[n],{n,9}])//Timing

gracefulnames=RecognizeGraph/@(Union@@gracefulgraphs);

Select[Intersection[GraphData[All],gracefulnames],GraphData[#,"Graceful"]=!=True&]

Select[GraphData[All],GraphData[#,"M"]≤9&&!MemberQ[gracefulnames,#]&&GraphData[#,"Graceful"]=!=False &]

Select[%,FreeQ[GraphData[#,"ConnectedComponents","Name"],"SingletonGraph"]&]

1-10

Length/@(gracefulgraphs=Table[DistinctGracefulGraphs[n],{n,10}])//Timing

MaxMemoryUsed[]/10^9.

Total/@Boole[Map[ConnectedGraphQ,gracefulgraphs,{2}]]

11

No isolated points (A308544):

seq={1,1,3,5,12,37,112,340,1078,3620,12737,46376};

FindSequenceFunction[seq,n]

FindLinearRecurrence[Drop[seq,2]]

FindGeneratingFunction[seq,x]

Connected (A308545):

seq={1,1,3,5,11,28,79,227,701,2302,8071,29502};

FindSequenceFunction[seq,n]

FindLinearRecurrence[Drop[seq,2]]

FindGeneratingFunction[seq,x]

Length/@(byedgecount=Table[Select[GraphData[{"Connected","Graceful"}],GraphData[#,"M"]==m&],{m,8}])

TextGrid[Tally/@Sort/@Map[GraphData[#,"V"]&,byedgecount,{2}],Dividers->All]

Position[Table[SelectFirst[GraphData[{"Connected","Graceful"}],GraphData[#,"M"]==m&,None],{m,1,200}],None]//Flatten

Special cases

Union of (Subscript[nK, 4]) having an edge in common (crossed book graph)

Delorme 1980

CrossedBookGraph[n_,opts___?OptionQ]:=Module[{e=List@@@EdgeList[GraphComputation`GraphProduct[StarGraph[n+1],PathGraph[Range[2]],"Cartesian",opts]]},
Graph[
Range[2n+2],
UndirectedEdge@@@Join[e,Table[{1,i+n+2},{i,n}],Table[{n+2,i+1},{i,n}]],
opts]
]

Table[CrossedBookGraph[n,VertexLabels->"Name"],{n,4}]

RecognizeGraph/@%

GraphData[#,"GracefulLabeling"]&/@%

2C3+Pn

Disgraceful in n=2, 3, 4, 5, or 6 (Seoud and Wilson 1993, Seoud)

TwoC3PlusPn[n_]:=Graph[Range[n+6],UndirectedEdge@@@(Sort/@Union[Partition[Range[3],2,1,1],Partition[Range[4,6],2,1,1],Partition[Range[7,n+6],2,1]]),VertexCoordinates->Join[{{0,0},{1,0},{1/2,Sqrt[3]/2}},{1/5+1+#1,#2}&@@@{{0,0},{1,0},{1/2,Sqrt[3]/2}},Table[{x,-1/5},{x,0,2+1/5,If[n==1,3,(2+1/5)/(n-1)]}]]]

TwoC3PlusPn[n_,GraphLayout->"UnitDistance"]:=Graph[Range[n+6],UndirectedEdge@@@(Sort/@Union[Partition[Range[3],2,1,1],Partition[Range[4,6],2,1,1],Partition[Range[7,n+6],2,1]]),VertexCoordinates->Join[{{0,0},{1,0},{1/2,Sqrt[3]/2}},{1/5+1+#1,#2}&@@@{{0,0},{1,0},{1/2,Sqrt[3]/2}},Table[{x,-1/5},{x,0,n-1}]]]

Table[TwoC3PlusPn[n],{n,9}]

l=Table[{gn="2C3+P"<>ToString[n],{0,Join[GraphData[gn,"Embeddings"],{ToCommonEdges[TwoC3PlusPn[n,GraphLayout->"UnitDistance"],GraphData[gn]]}]}},{n,3,9}]

PropertyReplace[l,"Embeddings","12.1"]

RenameGraphFiles[]

l2=Table[e=ToCommonEdges[g=TwoC3PlusPn[n,GraphLayout->"UnitDistance"],GraphData[r=RecognizeGraph[g]]];{r,{0,Join[GraphData[r,"EmbeddingClasses"],{{"Integral","Matchstick", "MinimalCrossing","MinimalIntegral", "MinimalRectilinearCrossing","Planar","UnitDistance"}}]}},{n,3,9}]

PropertyReplace[l2,"EmbeddingClasses","12.1"]

RenameGraphFiles[]

gs=RecognizeGraph/@Table[GraphData["2C3+P"<>ToString[n]],{n,2,9}]

GraphData[#,"Graceful"]&/@gs

GraphData[#,"GracefulLabeling"]&/@gs

file=OpenAppend["~/2c3+pn.m"]

Do[WriteString[file,GraphDataString[TwoC3PlusPn[n],
"StandardName"->"2C3+P"<>(nn=ToString[n]),
"AlternateStandardNames"->Sort[{"2C3P"<>nn,"P"<>nn<>"+2C3"}],
"Name"->"two triangles and "<>nn<>"\[Hyphen]path",
"Classes"->{"Matchstick",If[n<7,"Ungraceful",Nothing],"UnitDistance"},
"Skip"->{"ComplementOddChordlessCycle","ComplementOddChordlessCycles","MinimumWeightFractionalColoring","MinimumWeightFractionalEdgeColoring"},
TimeConstraint->10,
Debug->True
]],{n,3,9}]

Close[file]

C3+Pn

Graceful if n=1,4,5,6,7,8,9 but ungraceful if n=2 or 3 (Seoud and Wilson 1993)

C3PlusPn[n_]:=Graph[Range[n+3],UndirectedEdge@@@(Sort/@Union[Partition[Range[3],2,1,1],Partition[Range[4,n+3],2,1]]),VertexCoordinates->Join[{{0,0},{1,0},{1/2,Sqrt[3]/2}},Table[{x,-1/5},{x,0,1,If[n==1,2,1/(n-1)]}]]]

C3PlusPn[n_,GraphLayout->"UnitDistance"]:=Graph[Range[n+3],UndirectedEdge@@@(Sort/@Union[Partition[Range[3],2,1,1],Partition[Range[4,n+3],2,1]]),VertexCoordinates->Join[{{0,0},{1,0},{1/2,Sqrt[3]/2}},Table[{x,-1/5},{x,0,n-1}]]]

Table[C3PlusPn[n],{n,9}]

l=Table[g1=C3PlusPn[n];g2=C3PlusPn[n,GraphLayout->"UnitDistance"];r=RecognizeGraph[g1];
{r,{0,ToCommonEdges[#,GraphData[r]]&/@{g1,g2}}},{n,3,9}]

PropertyReplace[l,"Embeddings","12.1"]

RenameGraphFiles[]

l2=Table[e=ToCommonEdges[g=C4PlusPn[n,GraphLayout->"UnitDistance"],GraphData[r=RecognizeGraph[g]]];{r,{0,{{"Matchstick", "MinimalCrossing", "MinimalRectilinearCrossing","Planar","Primary"},{"Integral","Matchstick", "MinimalCrossing","MinimalIntegral", "MinimalRectilinearCrossing","Planar","UnitDistance"}}}},{n,3,9}]

PropertyReplace[l2,"EmbeddingClasses","12.1"]

RenameGraphFiles[]

gs=RecognizeGraph/@%

GraphData[#,"Graceful"]&/@gs

GraphData[#,"GracefulLabeling"]&/@gs

rules={
"C3+P8"->{3,4,7,5,0,10,1,9,2,8,6},
"C3+P9"->{1,4,9,5,6,8,2,11,0,10,3,7}
};

file=OpenAppend["~/c3+pn.m"]

Do[WriteString[file,GraphDataString[C3PlusPn[n],
"StandardName"->"C3+P"<>(nn=ToString[n]),
"AlternateStandardNames"->Sort[{"C3P"<>nn,"P"<>nn<>"+C3","P"<>nn<>"C3"}],
"Name"->"triangle and "<>nn<>"\[Hyphen]path",
"Classes"->{"Matchstick","Graceful","UnitDistance"},
"Skip"->{"ComplementOddChordlessCycle","ComplementOddChordlessCycles","MinimumWeightFractionalColoring","MinimumWeightFractionalEdgeColoring"},
TimeConstraint->10,
Debug->True
]],{n,8,9}]

Close[file]

C4+Pn

Graceful if n>=3 by Frucht and Salinas (see Seoud and Wilson 1993)

C4PlusPn[n_]:=Graph[Range[n+4],UndirectedEdge@@@(Sort/@Union[Partition[Range[4],2,1,1],Partition[Range[5,n+4],2,1]]),VertexCoordinates->Join[{{0,0},{1,0},{1,1},{0,1}},Table[{x,-1/5},{x,0,1,If[n==1,2,1/(n-1)]}]]]

C4PlusPn[n_,GraphLayout->"UnitDistance"]:=Graph[Range[n+4],UndirectedEdge@@@(Sort/@Union[Partition[Range[4],2,1,1],Partition[Range[5,n+4],2,1]]),VertexCoordinates->Join[{{0,0},{1,0},{1,1},{0,1}},Table[{x,-n/10},{x,0,n-1}]]]

Table[C4PlusPn[n],{n,2,9}]

l=Table[e=ToCommonEdges[g=C4PlusPn[n,GraphLayout->"UnitDistance"],GraphData[r=RecognizeGraph[g]]];{r,{0,Join[GraphData[r,"Embeddings"],{e}]}},{n,3,9}]

PropertyReplace[l,"Embeddings","12.1"]

RenameGraphFiles[]

l2=Table[e=ToCommonEdges[g=C4PlusPn[n,GraphLayout->"UnitDistance"],GraphData[r=RecognizeGraph[g]]];{r,{0,Join[GraphData[r,"EmbeddingClasses"],{{"Integral","Matchstick", "MinimalCrossing","MinimalIntegral", "MinimalRectilinearCrossing","Planar","UnitDistance"}}]}},{n,3,9}]

PropertyReplace[l2,"EmbeddingClasses","12.1"]

RenameGraphFiles[]

gs=RecognizeGraph/@%

GraphData[#,"Graceful"]&/@gs

GraphData[#,"GracefulLabeling"]&/@gs

file=OpenAppend["~/c4+pn.m"]

Do[WriteString[file,GraphDataString[C4PlusPn[n],
"StandardName"->"C4+P"<>(nn=ToString[n]),
"AlternateStandardNames"->Sort[{"C4P"<>nn,"P"<>nn<>"+C4","P"<>nn<>"C4"}],
"Name"->"square and "<>nn<>"\[Hyphen]path",
"Classes"->{"Matchstick","Graceful","UnitDistance"},
"Skip"->{"MinimumWeightFractionalColoring","MinimumWeightFractionalEdgeColoring"},
TimeConstraint->10,
Debug->True
]],{n,9,9}]

Close[file]

{8, 12339}

e={{0,1},{0,2},{0,11},{0,15},{0,18},{0,23},{1,11},{1,15},{1,18},{1,21},{1,23},{2,11},{2,15},{2,18},{2,21},{2,23},{11,15},{11,18},{11,23},{15,21},{15,23},{18,21},{18,23}};

RecognizeGraph[Graph[UndirectedEdge@@@e]]

lab=DeleteDuplicates[Flatten[e]]

With[{gn={8,12339}},SelectFirst[Sort[Permutations[lab]],GracefullyLabeledGraphQ[gnew=SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->#]]]&]]

gnew

GracefullyLabeledGraphQ[gnew]

{"Circulant", {8, {1, 2, 4}}}

lab=SelectFirst[Permutations[{0,9,16,6,18,14,1,20}],GracefullyLabeledGraphQ[SetProperty[GraphData[gn={"Circulant",{8,{1,2,4}}}],VertexLabels->Thread[Range[GraphData[gn,"V"]]->#]]]&]

g=SetProperty[GraphData[gn],VertexLabels->Sort[Thread[Range[GraphData[gn,"V"]]->lab]]]

GracefullyLabeledGraphQ[g]

FindGracefulLabeling[GraphData[{"Circulant",{8,{1,2,4}}}]]//Timing

{"Circulant", {9, {1, 2, 3}}}

lab=SelectFirst[Permutations[{0,2,21,24,17,1,18,27,13}],GracefullyLabeledGraphQ[SetProperty[GraphData[gn={"Circulant",{9,{1,2,3}}}],VertexLabels->Thread[Range[GraphData[gn,"V"]]->#]]]&]

g=SetProperty[GraphData[gn],VertexLabels->Sort[Thread[Range[GraphData[gn,"V"]]->lab]]]

GracefullyLabeledGraphQ[g]

https://math.stackexchange.com/questions/3250051/is-paley-13-a-graceful-graph

GraphData[{"Circulant",{9,{1,2,3}}},"Toroidal"]

{"Complete", 3}

g=CompleteGraph[3,VertexLabels->{1->0,2->1,3->3}]

GracefullyLabeledGraphQ[g]

{"Complete", 4}

g=CompleteGraph[4,VertexLabels->Thread[Range[4]->{0,1,4,6}]]

GracefullyLabeledGraphQ[g]

{"Cone", {5, 3}}

SelectFirst[Permutations[{0,7,12,18,20,1,17,3}],GracefullyLabeledGraphQ[SetProperty[GraphData[{"Cone",{5,3}}],VertexLabels->Thread[Range[8]->#]]]&]

g=SetProperty[GraphData[{"Cone",{5,3}}],VertexLabels->Sort[Thread[Range[8]->{0,18,3,17,20,7,12,1}]]]

GracefullyLabeledGraphQ[g]

FindGracefulLabeling[GraphData[{"Cone",{5,3}}]]//Timing

{"Cycle", 4}

SelectFirst[Permutations[{0,2,3,4}],GracefullyLabeledGraphQ[SetProperty[GraphData[gn={"Cycle",4}],VertexLabels->Thread[Range[4]->#]]]&]

g=SetProperty[GraphData[gn],VertexLabels->Sort[Thread[Range[GraphData[gn,"V"]]->{0,3,2,4}]]]

GracefullyLabeledGraphQ[g]

{"Graceful", {12, 48, 1}}

From Ed
Jun 22, 2019

elist={{0,29},{0,33},{0,37},{0,41},{0,48},{1,29},{1,33},{1,37},{1,41},{1,45},{1,48},{2,29},{2,33},{2,37},{2,41},{2,45},{2,48},{3,23},{3,29},{3,33},{3,37},{3,41},{3,45},{23,29},{23,33},{23,37},{23,41},{23,48},{24,29},{24,33},{24,37},{24,41},{29,45},{29,48},{33,48},{37,48},{41,48},{1,3},{0,3},{1,24},{0,24},{0,45},{33,45},{2,24},{2,23},{37,45},{23,24},{41,45}};

vlist=Union[Flatten[e]]

vrules=Thread[{1,45,3,0,48,23,2,24,29,37,33,41}->{{2,-5},{5,-2},{5,2},{2,5},{-2,5},{-5,2},{-5,-2},{-2,-5},{-2,0},{0,-4},{0,4},{2,0}}]

g0=Graph[vlist,UndirectedEdge@@@elist,VertexLabels->"Name",VertexCoordinates->(vlist/.vrules)]

RecognizeGraph[g0]

newvlist=Range[Length[vlist]]

vmap=Thread[vlist->newvlist]

(vrules[[All,1]]/.vmap)

vmap[[All,1]]

g=Graph[newvlist,UndirectedEdge@@@(elist/.vmap),VertexLabels->Thread[newvlist->vmap[[All,1]]],VertexCoordinates->Sort[Thread[(vrules[[All,1]]/.vmap)->vrules[[All,2]]]][[All,2]]]

GracefullyLabeledGraphQ[g]

RecognizeGraph[g]

VertexCount[g]

EdgeCount[g]

HamiltonianGraphQ[g]

"OctahedralGraph"

lab=SelectFirst[Permutations[{0,1,2,6,9,12}],GracefullyLabeledGraphQ[SetProperty[GraphData[gn="OctahedralGraph"],VertexLabels->Thread[Range[GraphData[gn,"V"]]->#]]]&]

g=SetProperty[GraphData[gn],VertexLabels->Sort[Thread[Range[GraphData[gn,"V"]]->lab]]]

GracefullyLabeledGraphQ[g]

FindGracefulLabeling[GraphData["OctahedralGraph"]]//Timing

{"Paley", 13}

https://math.stackexchange.com/questions/3250051/is-paley-13-a-graceful-graph

GraphData[{"Paley",13},"Toroidal"]

GraphData[{"Paley",13},"Graceful"]

FindGracefulLabeling[GraphData[{"Paley",13}],Debug->True]

lab={0,1,5,39,23,34,13,3,21,7,38,33,24};

"A depth first search of the possible vertex values. I can limit the search space a little because 0 and 39 must be connected. Backtrack as soon as a known edge value is not unique. Fortunately it didn't need to search far. The search started at 0−1−3… and the first solution was at 0−1−5…  I'm checking the Shrikhande Graph now, but that's much harder."

GracefullyLabeledGraphQ[SetProperty[GraphData[gn={"Paley",13}],VertexLabels->Thread[Range[GraphData[gn,"V"]]->lab]]]

g=SetProperty[GraphData[gn],VertexLabels->Sort[Thread[Range[GraphData[gn,"V"]]->lab]]]

{"Path", 2}

g=PathGraph[{1,2},VertexLabels->{1->0,2->1}]

GracefullyLabeledGraphQ[g]

{"PathComplement", 9}

e={{0,1},{0,6},{0,9},{0,16},{0,23},{0,28},{1,3},{1,9},{1,16},{1,27},{1,28},{3,6},{3,16},{3,23},{3,27},{3,28},{6,16},{6,23},{6,27},{6,28},{9,16},{9,23},{9,27},{9,28},{16,27},{16,28},{23,27},{23,28}};

r=RecognizeGraph[g=Graph[UndirectedEdge@@@e]]

lab=DeleteDuplicates[Flatten[e]]

With[{gn={"PathComplement",9}},GracefullyLabeledGraphQ[gnew=SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]]]

With[{gn=r},SelectFirst[Sort[Permutations[lab]],GracefullyLabeledGraphQ[gnew=SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->#]]]&]]

gnew

GracefullyLabeledGraphQ[gnew]

"PetersenGraph"

GraphData["P","Graph","Labeled"]

g=SetProperty[GraphData["P"],VertexLabels->Thread[Range[10]->{14,1,4,8,12,2,15,0,5,3}]]

GracefullyLabeledGraphQ[g]

With[{gn="PetersenGraph"},SelectFirst[Sort[Permutations[{14,1,4,8,12,2,15,0,5,3}]],GracefullyLabeledGraphQ[gnew=SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->#]]]&]]

gnew

GracefullyLabeledGraphQ[gnew]

GraphData["PetersenGraph","GracefulLabeling"]

FindGracefulLabeling[GraphData["PetersenGraph"],Debug->True]//Timing

{"Queen", {2, 4}}

GraphData[{"Queen",{2,4}},"Graceful"]

Text@Style[Grid[{{0,22,6,17},{1,13,3,21}},Frame->All],30]

With[{gn={"Queen",{2,4}}},SelectFirst[Sort[Permutations[Join[{0,22,6,17},{1,13,3,21}]]],GracefullyLabeledGraphQ[gnew=SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->#]]]&]]

gnew

GracefullyLabeledGraphQ[gnew]

{"Rook", {2, 5}}

GraphData[gn={"Rook",{2,5}},"Graph",{"Grid","Labeled"}]

https://math.stackexchange.com/questions/3262295/minimal-rook-difference-grids

lab={0,6,7,21,25,24,22,19,11,2}[[Ordering@{1,3,5,7,9,6,8,10,2,4}]]

g=SetProperty[GraphData[gn,"Graph","Grid"][[1]],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]

GracefullyLabeledGraphQ[g]

{"Rook", {2, 6}} [ungraceful]

https://math.stackexchange.com/questions/3262295/minimal-rook-difference-grids

GraphData[gn={"Rook",{2,6}},"Graph",{"Grid","Labeled"}]

From Ed Pegg, Jun 24, 2019.  {"Rook", {2, 6}} is not graceful with 36 edges. Smallest grid with distinct values needs 38.

Grid[{{0,1,10,16,34,38},{35,32,24,37,5,12}},Frame->All]

lab=Flatten[{{0,1,10,16,34,38},{35,32,24,37,5,12}}][[Ordering@{1,3,5,7,9,11,2,4,6,8,10,12}]]

g=SetProperty[GraphData[gn,"Graph","Grid"][[1]],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]

GracefullyLabeledGraphQ[g]

Abs[Subtract@@@(List@@@EdgeList[g]/.Thread[VertexList[g]->lab])]//Sort

Complement[Range[38],%]

{"Rook", {2, 7}} [ungraceful]

https://math.stackexchange.com/questions/3262295/minimal-rook-difference-grids

GraphData[gn={"Rook",{2,7}},"Graph",{"Grid","Labeled"}]

From Ed Pegg, Jun 24, 2019.  {"Rook", {2, 7}} is not graceful with 49 edges. Smallest grid with distinct values needs 53.

Grid[{{0,6,16,24,38,41,53},{31,52,3,51,12,8,1}},Frame->All]

lab=Flatten[{{0,6,16,24,38,41,53},{31,52,3,51,12,8,1}}][[Ordering@{1,9,11,13,3,5,7,8,2,4,6,10,12,14}]]

g=SetProperty[GraphData[gn,"Graph","Grid"][[1]],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]

GracefullyLabeledGraphQ[g]

Abs[Subtract@@@(List@@@EdgeList[g]/.Thread[VertexList[g]->lab])]//Sort

Complement[Range[53],%]

{"Rook", {3, 4}}

https://math.stackexchange.com/questions/3262295/minimal-rook-difference-grids

GraphData[gn={"Rook",{3,4}},"Graph",{"Grid","Labeled"}]

Grid[{{0, 1, 9, 30}, {16, 29, 2, 19}, {22, 3, 27, 7}}, Frame -> All]

lab=Flatten[{{0, 1, 9, 30}, {16, 29, 2, 19}, {22, 3, 27, 7}}][[Ordering@{1,10,4,7,6,2,8,11,9,6,12,3}]]

g=SetProperty[GraphData[gn,"Graph","Grid"][[1]],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]

GracefullyLabeledGraphQ[g]

{"Rook", {4, 4}}

https://math.stackexchange.com/questions/3262295/minimal-rook-difference-grids

GraphData[gn={"Rook",{4,4}},"Graph",{"Grid","Labeled"}]

Grid[{{0,1,23,47},{19,44,9,2},{37,42,3,11},{48,4,36,32}},Frame->All]

lab=Flatten[{{0,1,23,47},{19,44,9,2},{37,42,3,11},{48,4,36,32}}][[Ordering@{1,2,3,4,5,8,11,14,6,9,12,15,7,10,13,16}]]

g=SetProperty[GraphData[gn,"Graph","Grid"][[1]],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]

GracefullyLabeledGraphQ[g]

"ShrinkhandeGraph"

https://math.stackexchange.com/questions/3250051/is-paley-13-a-graceful-graph

g=Graph[UndirectedEdge@@@{{1,2},{2,4},{45,48},{40,44},{43,48},{39,45},{36,43},{36,44},{30,39},{30,40},{6,17},{24,36},{1,14},{0,14},{24,39},{14,30},{0,17},{6,24},{24,43},{4,24},{24,45},{14,36},{17,40},{6,30},{14,39},{17,43},{17,44},{2,30},{1,30},{14,44},{17,48},{4,36},{6,39},{6,40},{1,36},{4,40},{6,43},{2,40},{0,39},{4,44},{4,45},{1,43},{2,45},{0,44},{0,45},{2,48},{1,48},{0,48}},VertexCoordinates->Thread[{14,0,48,1,44,17,43,36,40,6,24,4,30,39,45,2}->Tuples[{0,1,2,3},{2}]],VertexLabels->"Name"]

r=RecognizeGraph[g]

ToCommonEdges[g,GraphData[r]]

GetGraphData[r,"File"]

GraphData["ShrikhandeGraph","Graph","All"]

GraphPlot[Rule@@@{{1,2},{2,4},{45,48},{40,44},{43,48},{39,45},{36,43},{36,44},{30,39},{30,40},{6,17},{24,36},{1,14},{0,14},{24,39},{14,30},{0,17},{6,24},{24,43},{4,24},{24,45},{14,36},{17,40},{6,30},{14,39},{17,43},{17,44},{2,30},{1,30},{14,44},{17,48},{4,36},{6,39},{6,40},{1,36},{4,40},{6,43},{2,40},{0,39},{4,44},{4,45},{1,43},{2,45},{0,44},{0,45},{2,48},{1,48},{0,48}},Method->"Legacy",VertexLabeling->True,"VertexCoordinateRules"->Thread[{14,0,48,1,44,17,43,36,40,6,24,4,30,39,45,2}->Tuples[{0,1,2,3},{2}]]]

lab=Normal[FindGraphIsomorphism[GraphData[r],g][[1]]][[All,2]]

GracefullyLabeledGraphQ[SetProperty[GraphData[r],VertexLabels->Thread[GraphData[r,"VertexList"]->lab]]]

{"Septic", {10, 4}}

lab=SelectFirst[Permutations[{1,34,19,30,0,23,35,6,3,9}],GracefullyLabeledGraphQ[SetProperty[GraphData[gn={"Septic",{10,4}}],VertexLabels->Thread[Range[GraphData[gn,"V"]]->#]]]&]

g=SetProperty[GraphData[gn],VertexLabels->Sort[Thread[Range[GraphData[gn,"V"]]->lab]]]

GracefullyLabeledGraphQ[g]

FindGracefulLabeling[GraphData[{"Septic",{10,4}}]]//Timing

Theorems

Disjoint union of trees (??)

Gallian claims, "The  disjoint  union  of  trees  is  a  case  where there are too many vertices for the number of edges"

But clearly disjoint unions of singletons and paths are graceful.  And in fact two claws are also graceful:

TextGrid[Select[{#,GraphData[#,"Graceful"],GraphData[#,"ConnectedComponents","Name"]}&/@GraphData["Disconnected"],With[{nontrivial=DeleteCases[#[[3]],"SingletonGraph"|{"Empty"|"Path",_}]},
Length[nontrivial]>1&&AllTrue[nontrivial,DataPaclets`GraphDataDump`MyGraphQ[#]&&GraphData[#,"Tree"]===True&]]&],Dividers->All]

GraphData["2K1,3","GracefulLabeling"]

SetProperty[GraphData["2K1,3"],VertexLabels->Thread[Range[8]->%]]

So some additional qualification must be needed...

The Ringel-Kotzig conjecture (all trees are graceful )

The Ringel-Kotzig conjecture (GTC) that all trees are graceful has been the focus of many papers.  Kotzig [953] has called the effort to prove it a “disease.

Trees with at most 4 end-vertices are graceful

Select[GraphData["Tree"],GraphData[#,"LeafCount"]<5&&GraphData[#,"Graceful"]=!=True&]

Trees with diameter at most 5 are graceful

Select[GraphData["Tree"],GraphData[#,"Diameter"]<6&&GraphData[#,"Graceful"]=!=True&]

All trees with 30, 35, or 40 vertices are graceful

Select[GraphData["Tree",#],GraphData[#1,"Graceful"]=!=True&]&/@{30,35,40}

Tree graphs are known to be Graceful up to (at least) n == 35

Select[GraphData["Tree",;;35],GraphData[#1,"Graceful"]=!=True&]

Lobsters are conjectured to be Graceful

In 1979 Bermond [405] conjectured that lobsters are graceful (a lobster is a tree with the property that the removal of the endpoints leaves a caterpillar).

Select[GraphData["Lobster"],GraphData[#,"Graceful"]=!=True&]

All lobsters with perfect matchings are graceful

Morgan [1641] has shown that all lobsters with perfect matchings are graceful.

Select[GraphData[{"Lobster","PerfectMatching"}],GraphData[#,"Graceful"]=!=True&]

A lobster that has a perfect matching that covers all but one vertex (i.e., that has an almost perfect matching) is graceful

Krop [1318] proved that a lobster that has a perfect matching that covers all but one vertex (i.e., that has an almost perfect matching) is graceful.

Firecrackers are graceful

Select[GraphData["Firecracker"],GraphData[#,"Graceful"]=!=True&]

Banana trees are graceful

Select[GraphData["BananaTree"],GraphData[#,"Graceful"]=!=True&]

Cone graph (Subscript[C, m])+ (Subscript[(OverBar[K]), n])

graceful when when m ≡ 0 or 3 (mod 12)

Select[GraphData["Cone"],MatchQ[Mod[First["Cone"/.GraphData[#,"NotationRules"]],12],0|3]&&GraphData[#,"Graceful"]=!=True&]

ungraceful when n is even and m is 2, 6 or 10 (mod 12) [parity condition violated]

Select[GraphData["Cone"],({m,n}="Cone"/.GraphData[#,"NotationRules"];Mod[n,2]==0&&MatchQ[Mod[m,12],2|6|10])&&GraphData[#,"Graceful"]=!=False&]

graceful: {4, n}, {5, 2}, {7, n}, {9, 2}, {11, n}, {19, n}

Select[GraphData["Cone"],MatchQ["Cone"/.GraphData[#,"NotationRules"],{4,n_}|{5,2}|{7,_}|{9,2}|{11,_}|{19,_}]&&GraphData[#,"Graceful"]=!=True&]

Dutch windmill

(Subscript[C, 3]^((t))) (that  is,  the friendship  graph or Dutch t-windmill) is graceful if and only if t ≡ 0 or 1 (mod 4)

DeleteCases[{#,GraphData[#,"Graceful"],MatchQ[Mod[#2,4],0|1]}&@@@Cases[{#,"DutchWindmill"/.GraphData[#,"NotationRules"]}&/@GraphData["DutchWindmill"],{g_,{3,t_}}:>{g,t}],{_,x_,x_}]

Rogers,  Lee,  and Toh [1275] conjecture that (Subscript[C, n]^((t))) is graceful if and only if nt ≡ 0 or 3 (mod 4).  Yang and Lin [2576] have proved the conjecture for the case n = 5 and Yang, Xu,  Xi,  Li,  and Haque [2582] did the case n = 7.  Xu,  Yang,  Li and Xi [2564] did the case n = 11.  Xu, Yang, Han and Li [2565] did the case n = 13.  Qian [1855] verifies this conjecture for the case that t = 2 and n is even and Yang, Xu, Xi, and Li [2583] did the case n = 9.

DeleteCases[{#,GraphData[#,"Graceful"],MatchQ[Mod[#1 #2,4],0|3]}&@@@Select[{#,"DutchWindmill"/.GraphData[#,"NotationRules"]}&/@GraphData["DutchWindmill"],MatchQ[#[[2]],{5|7|9|11|13,_}]&],{_,x_,x_}]

Grid 2×m×n is graceful

Select[Cases[{#,"Grid"/.GraphData[#,"NotationRules"]}&/@GraphData["Grid"],{g_,{2,_,_}}:>g],GraphData[#,"Graceful"]=!=True&]

StackedPrism

In 1992 Jungreis and Reid [1161] proved that all Cm × Pn are graceful when m and n are even or when m ≡ 0 (mod 4).

Select[{#,"StackedPrism"/.GraphData[#,"NotationRules"]}&/@GraphData["StackedPrism"],GraphData[#[[1]],"Graceful"]=!=True&&(Mod[#[[2,1]],2]==0&&Mod[#[[2,2]],2]==0||Mod[#[[1]],4]==0)&]

ang and Wang have shown that the prisms
C
4
n
+2
×
P
4
m
+3
[2581],
C
n
×
P
2
[2579], and
C
6
×
P
m
(
m
≥
2) (see [2581]) are graceful.  Singh [2166] proved that
C
3
×
P
n
is graceful for
all
n

Select[Cases[{#,"StackedPrism"/.GraphData[#,"NotationRules"]}&/@GraphData["StackedPrism"],{_,{_?(Mod[#,4]==2&),_?Mod[#,4]==3&}|{3|6,_?(GreaterThan[1])}}][[All,1]],GraphData[#,"Graceful"]=!=True&]

TorusGrid

In 1992 Jungreis and Reid [1161] showed that Cm×Cn is graceful when m ≡ 0 (mod 4) and n is even

Select[{#,"TorusGrid"/.GraphData[#,"NotationRules"]}&/@GraphData["TorusGrid"],GraphData[#[[1]],"Graceful"]=!=True&&Mod[#[[2,1]],4]==0&&Mod[#[[2,2]],2]==0&]

CompleteTripartite

Aravamudhan and Murugan [160] have shown that the complete tripartite graph K1,m,n is  both  graceful  and  harmonious  while  Gnanajothi  [827,  pp.   25–31]  has  shown that K1,1,m,n is both graceful and harmonious and K2,m,n is graceful.

Select[Cases[{#,"CompleteTripartite"/.GraphData[#,"NotationRules"]}&/@GraphData["CompleteTripartite"],{_,{1|2,_,_}}][[All,1]],GraphData[#,"Graceful"]=!=True&]

GraphData[#,"Graceful"]&/@%

Beutner  and  Harborth  [411]  give  graceful  labelings  for K1,m,n, K2,m,n, K1,1,m,n and conjecture that these and Km,n are the only complete multipartite graphs that are graceful. They have verified this conjecture for graphs with up to 23 vertices via computer.

DeleteCases[{#,GraphData[#,"Graceful"],MatchQ[#2,{1|2,_,_}]}&@@@({#,"CompleteTripartite"/.GraphData[#,"NotationRules"]}&/@GraphData["CompleteTripartite",;;23]),{_,x_,x_}]

{_,{1|2,_,_}}][[All,1]],

CompleteKPartite

Aravamudhan and Murugan [160] have shown that the complete tripartite graph K1,m,n is  both  graceful  and  harmonious  while  Gnanajothi  [827,  pp.   25–31]  has  shown that K1,1,m,n is both graceful and harmonious and K2,m,n is graceful.

Select[Cases[{#,"CompleteKPartite"/.GraphData[#,"NotationRules"]}&/@GraphData["CompleteKPartite"],{_,{1,1,_,_}}][[All,1]],GraphData[#,"Graceful"]=!=True&]

Beutner  and  Harborth  [411]  give  graceful  labelings  for K1,m,n, K2,m,n, K1,1,m,n and conjecture that these and Km,n are the only complete multipartite graphs that are graceful. They have verified this conjecture for graphs with up to 23 vertices via computer.

DeleteCases[{#,GraphData[#,"Graceful"],MatchQ[#2,{1,1,_,_}]}&@@@Select[({#,"CompleteKPartite"/.GraphData[#,"NotationRules"]}&/@GraphData["CompleteKPartite",;;23]),Length[#[[2]]]>3&],{_,x_,x_}]

Kn-e

Beutner and Harborth [411] also show that Kn−e (Kn with an edge deleted) is graceful only if n≤5

DeleteCases[Table[{r=RecognizeGraph@EdgeDelete[CompleteGraph[n],1\[UndirectedEdge]2],GraphData[r,"Graceful"],n≤5},{n,2,20}],{{},__}]//Quiet

Kn-2e

any Kn−2e (Kn with two edges deleted) is graceful only if n≤6

Table[Union[RecognizeGraph/@With[{g=CompleteGraph[n]},EdgeDelete[g,#]&/@Subsets[EdgeList[g],{2}]]],{n,3,6}]

DeleteCases[Table[{r=RecognizeGraph@EdgeDelete[CompleteGraph[n],{1\[UndirectedEdge]2,2\[UndirectedEdge]3}],GraphData[r,"Graceful"],n≤6},{n,3,20}],{{},__}|{_,_GraphData,_}]//Quiet

Kn-3e

and any Kn−3 e is graceful only if n≤6

Select[Flatten[Table[Union[RecognizeGraph/@With[{g=CompleteGraph[n]},EdgeDelete[g,#]&/@Subsets[EdgeList[g],{3}]]],{n,3,6}],1],GraphData[#,"Graceful"]=!=True&]

new=Select[Flatten[Table[Union[RecognizeGraph/@With[{g=CompleteGraph[n]},EdgeDelete[g,#]&/@Subsets[EdgeList[g],{3}]]],{n,7,11}],1],GraphData[#,"Graceful"]=!=False&]//Quiet

Windmill

The windmill graph (Subscript[K, n]^((m))) (n >3) consists of m copies of Kn with a vertex in common. A necessary condition for (Subscript[K, n]^((m))) to be graceful is that n≤5

GraphData[{"Windmill",{2,4}}]

Select[{#,"Windmill"/.GraphData[#,"NotationRules"]}&/@GraphData["Windmill"],#[[2,2]]>5&&GraphData[#[[1]],"Graceful"]=!=False&][[All,1]]

(Subscript[K, 4]^((m))) is graceful for 4<=m<=1000

Select[Cases[{#,"Windmill"/.GraphData[#,"NotationRules"]}&/@GraphData["Windmill"],{_,{_?(4≤#≤1000&),4}}][[All,1]],GraphData[#[[1]],"Graceful"]=!=True&]

Bermond, Kotzig, and Turgeon [408] proved that (Subscript[K, n]^((m))) is  not  graceful  when n =  4  and m =  2  or  3,  and  when m =  2  and n =  5

Select[GraphData[{"Windmill",#},"#"]&/@{{2,4},{3,4},{2,5}},GraphData[#,"Graceful"]=!=False&]

r (Subscript[C, n])

3 (Subscript[C, 4k]) are graceful

{#,GraphData[#,"Graceful"]}&/@Table["3C"<>ToString[4k],{k,3}]

GraphData["Disconnected"]

r≥2 and s = 3 or 5, rCs is not graceful.

l={#1,{0,False}}&/@Select[#1<>"C"<>#2&@@@Map[ToString,Flatten[Outer[List,Range[2,5],{3,5}],1],{2}],DataPaclets`GraphDataDump`MyGraphQ[#]&&GraphData[#,"Graceful"]=!=False&]

m (Subscript[K, n])

GraphData["Complete"]

In 1978 Kotzig and Turgeon [1305] proved that m (Subscript[K, n]) is graceful if and only if m= 1 and n≤4.

But what about m (Subscript[K, 1]) and m (Subscript[K, 2]) which seem to satify teh condition just fine?

DeleteCases[{#,#2,GraphData[#,"Graceful"],MatchQ[#2,{1,_?(#<5&)}]}&@@@With[{ks=GraphData["Complete"],ns=GraphData["Complete","V"]},{#1,{Length[#2],#2[[1]]/.Thread[ks->ns]}}&@@@Select[{#,GraphData[#,"ConnectedComponents","Name"]}&/@GraphData["Disconnected"],Complement[#[[2]],ks]==={}&&SameQ@@#[[2]]&]],{_,_,x_,x_}]

GraphData[{"LadderRung",2},"GracefulLabeling"]

(Subscript[C, s])⋃(Subscript[P, n])

(Subscript[C, s])⋃(Subscript[P, n]) is graceful if and only s+n≥6

l1={#,GraphData[#,"Graceful"],{#2[[1]]/.Thread[GraphData["Cycle"]->GraphData["Cycle","V"]],#2[[2]]/.Thread[GraphData["Path"]->GraphData["Path","V"]]}}&@@@Select[{#,GraphData[#,"ConnectedComponents","Name"]}&/@GraphData["Disconnected"],Length[#[[2]]]==2&&MatchQ[#[[2]],{Alternatives@@GraphData["Cycle"],Alternatives@@GraphData["Path"]}]&]

l2={#,GraphData[#,"Graceful"],{#2[[2]]/.Thread[GraphData["Cycle"]->GraphData["Cycle","V"]],#2[[1]]/.Thread[GraphData["Path"]->GraphData["Path","V"]]}}&@@@Select[{#,GraphData[#,"ConnectedComponents","Name"]}&/@GraphData["Disconnected"],Length[#[[2]]]==2&&MatchQ[#[[2]],{Alternatives@@GraphData["Path"],Alternatives@@GraphData["Cycle"]}]&]

{#,#2,#3.{1,1}≥6}&@@@Join[l1,l2]

Parametrized families

Andrasfai

seq=Table[GraphData[{"Andrasfai",n},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Andrasfai",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Antiprism

Entity["Graph",{"Antiprism",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Antiprism",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Antiprism",n},"Graceful"],{n,3,25}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Antiprism",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,25}],{_,_,_Missing,_}],Dividers->All]

Apollonian

seq=Table[GraphData[{"Apollonian",n},"Graceful"],{n,6}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Apollonian",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,6}],{_,_,_Missing,_}],Dividers->All]

Barbell

seq=Table[GraphData[{"Barbell",n},"Graceful"],{n,3,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Barbell",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Bishop n×n

Table[GraphData[{"Bishop",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Bishop",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

BlackBishop n×n

Table[GraphData[{"BlackBishop",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"BlackBishop",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Book

seq=Table[GraphData[{"Book",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Book",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

Maheo

Table[GracefullyLabeledGraphQ[labg=SetProperty[GraphData[gn={"Book",n},"Graph"],VertexLabels->Thread[GraphData[gn,"VertexList"]->(lab=GracefulLabeling[gn])]]],{n,4,20,2}]

TextGrid[Table[{n,GracefulLabeling[{"Book",n}]},{n,4,20,2}],Dividers->All]

l=Table[{gn={"Book",n},{0,GracefulLabeling[gn]}},{n,6,20,2}]

Delorme

Table[GracefullyLabeledGraphQ[labg=SetProperty[GraphData[gn={"Book",n},"Graph"],VertexLabels->Thread[GraphData[gn,"VertexList"]->(lab=GracefulLabeling[gn])]]],{n,Select[Range[4,20],Mod[#,4]=!=3&]}]

TextGrid[Table[{n,GracefulLabeling[{"Book",n}]},{n,2,20}],Dividers->All]

l=Table[{gn={"Book",n},{0,GracefulLabeling[gn]}},{n,Select[Range[6,20],Mod[#,4]≠3&]}]

Bruhat

seq=Table[GraphData[{"Bruhat",n},"Graceful"],{n,6}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Bruhat",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,6}],{_,_,_Missing,_}],Dividers->All]

Caterpillar

https://www.cos.ufrj.br/uploadfile/publicacao/2668.pdf, p. 11

Centipede

seq=Table[GraphData[{"Centipede",n},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Centipede",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

CocktailParty

Would be known if (Subscript[K, n×2]) were known

seq=Table[GraphData[{"CocktailParty",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"CocktailParty",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Complete

Entity["Graph",{"Complete",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Complete",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Complete",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Complete",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

CompleteBipartite m×n

Entity["Graph",{"CompleteBipartite",{m,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"CompleteBipartite",{m,n}}]["Classes"]],"Graceful"]

https://www.cos.ufrj.br/uploadfile/publicacao/2668.pdf, pp. 11-12

FindIndependentVertexSet[GraphData[{"CompleteBipartite",{3,4}}],Infinity,All]//Sort

GracefulLabeling[{"CompleteBipartite",{3,4}}]

l={#,{0,GracefulLabeling[#]}}&/@Select[GraphData["CompleteBipartite"],MissingQ[GraphData[#,"GracefulLabeling"]]&]

DeleteCases[
Sort@Flatten[Table[{
{m,n},
GraphData[{"CompleteBipartite",{m,n}},"Graceful"],
True
},{n,20},{m,n}],1],
{_,x_,x_}
]

CompleteBipartite n×n

Entity["Graph",{"CompleteBipartite",{n,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"CompleteBipartite",{n,n}}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"CompleteBipartite",{n,n}},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"CompleteBipartite",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

CompleteTripartite k×m×n

Beutner  and  Harborth  [411]  give  graceful  labelings  for K1,m,n, K2,m,n, K1,1,m,n and conjecture that these and Km,n are the only complete multipartite graphs that are graceful. They have verified this conjecture for graphs with up to 23 vertices via computer.

Entity["Graph",{"CompleteTripartite",{k,m,n}}]["VertexCount"]

Entity["Graph",{"CompleteTripartite",{k,m,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"CompleteTripartite",{k,m,n}}]["Classes"]],"Graceful"]

DeleteCases[
Sort@Flatten[Table[{
{k,m,n},
GraphData[{"CompleteTripartite",{k,m,n}},"Graceful"],
({{\[Piecewise], ({{True, Min[k,m,n]≤2}, {False, True}})}})
},
{n,10},{m,n},{k,m}],2],
{_,x_,x_}
]

DeleteCases[%,{_,x_,x_}]

https://www.cos.ufrj.br/uploadfile/publicacao/2668.pdf, p. 12

GracefulLabeling[{"CompleteTripartite",{1,m_,n_}}]:=Module[{z,a,b},
{z,a,b}=Sort[FindIndependentVertexSet[GraphData[{"CompleteTripartite",{1,m,n}}],Infinity,3]];
Sort[Join[Thread[z->{0}],Thread[a->Range[m]],Thread[b->Table[(k+1) m+k,{k,n}]]]][[All,2]]
]

GracefulLabeling[{"CompleteTripartite",{2,p_,q_}}]:=Module[{z,a,b},
{z,a,b}=Sort[FindIndependentVertexSet[GraphData[{"CompleteTripartite",{2,p,q}}],Infinity,3]];
Sort[Join[Thread[z->{p q+p+2q-1,p q+2p+2q}],Thread[a->Range[p]],Thread[b->Prepend[Table[k p+2(k-1),{k,2,q}],0]]]][[All,2]]
]

l={#,{0,GracefulLabeling[#]}}&/@Select[Cases[GraphData["CompleteTripartite"],{_,{1,_,_}}],GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

l={#,{0,GracefulLabeling[#]}}&/@Select[Cases[GraphData["CompleteTripartite"],{_,{2,_,_}}],GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

CompleteTripartite n×n×n

Beutner  and  Harborth  [411]  give  graceful  labelings  for K1,m,n, K2,m,n, K1,1,m,n and conjecture that these and Km,n are the only complete multipartite graphs that are graceful. They have verified this conjecture for graphs with up to 23 vertices via computer.

Entity["Graph",{"CompleteTripartite",{n,n,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"CompleteTripartite",{n,n,n}}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"CompleteTripartite",{n,n,n}},"Graceful"],{n,10}]

Table[GraphData[{"CompleteTripartite",{n,n,n}},"V"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"CompleteTripartite",{n,n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Complete KPartitite 1×1×p×q

https://www.cos.ufrj.br/uploadfile/publicacao/2668.pdf, p. 12

GracefulLabeling[{"CompleteKPartite",{1,1,p_,q_}}]:=Module[{x,y,a,b},
{x,y,a,b}=Sort[FindIndependentVertexSet[GraphData[{"CompleteKPartite",{1,1,p,q}}],Infinity,4]];
Sort[Join[Thread[x->{0}],Thread[y->{p q+2p+2q+1}],Thread[a->Range[p]],Thread[b->Table[k p+2(k-1),{k,2,q+1}]]]][[All,2]]
]

kpartite={"CompleteKPartite",#}&/@Select[("CompleteKPartite"/.GraphData[#,"NotationRules"])&/@GraphData["CompleteKPartite"],MatchQ[{1,1,_,_}]]

l={GraphData[#,"#"],{0,GracefulLabeling[#]}}&/@Select[kpartite,GraphData[#,"GracefulLabeling"]===Missing["NotAvailable"]&]

CrossedPrism

seq=Table[GraphData[{"CrossedPrism",2n},"Graceful"],{n,2,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"CrossedPrism",2n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,2,10}],{_,_,_Missing,_}],Dividers->All]

Crown

seq=Table[GraphData[{"Crown",n},"Graceful"],{n,3,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Crown",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Cycle

Entity["Graph",{"Cycle",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Cycle",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Cycle",n},"Graceful"],{n,3,20}]

https://www.cos.ufrj.br/uploadfile/publicacao/2668.pdf, p. 10

TextGrid[Table[{n,GracefulLabeling[{"Cycle",n}]},{n,3,20}],Dividers->All]

l=Table[{{"Cycle",n},{0,GracefulLabeling[{"Cycle",n}]}},{n,13,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Cycle",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

DiagonalIntersection

seq=Table[GraphData[{"DiagonalIntersection",n},"Graceful"],{n,3,14}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"DiagonalIntersection",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,14}],{_,_,_Missing,_}],Dividers->All]

Dipyramid

seq=Table[GraphData[{"Dipyramid",n},"Graceful"],{n,3,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Dipyramid",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Empty

Entity["Graph",{"Empty",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Empty",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Empty",n},"Graceful"],{n,30}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Empty",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,30}],{_,_,_Missing,_}],Dividers->All]

FibonacciCube

seq=Table[GraphData[{"FibonacciCube",n},"Graceful"],{n,15}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"FibonacciCube",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,15}],{_,_,_Missing,_}],Dividers->All]

FoldedCube

seq=Table[GraphData[{"FoldedCube",n},"Graceful"],{n,2,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"FoldedCube",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,2,10}],{_,_,_Missing,_}],Dividers->All]

Fiveleaper n×n

seq=Table[GraphData[{"Fiveleaper",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Fiveleaper",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Gear

seq=Table[GraphData[{"Gear",n},"Graceful"],{n,3,20}]

K. J. Ma and C. J. Feng.  On the gracefulness of gear graphs.  Mathematics in Practice and Theory 4, 72-73 1984.

Table[GraphData[{"Gear",n},"M"],{n,3,10}]

FindSequenceFunction[%,n-2]//Factor

GraphData[{"Gear",5},"Graph",{"All","Labeled"}][[2]]

GracefulLabeling[{"Gear",6}]

Table[GracefullyLabeledGraphQ[labg=SetProperty[GraphData[gn={"Gear",n},"Graph","All"][[2]],VertexLabels->Thread[GraphData[gn,"VertexList"]->(lab=GracefulLabeling[gn])]]],{n,5,20}]

TextGrid[Table[{n,GracefulLabeling[{"Gear",n}]},{n,3,20}],Dividers->All]

l=Table[{{"Gear",n},{0,GracefulLabeling[{"Gear",n}]}},{n,6,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Gear",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Grid m×n

Entity["Graph",{"Grid",{m,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Grid",{m,n}}]["Classes"]],"Graceful"]

Table[GraphData[{"Grid",{m,n}},"Graceful"],{n,10},{m,n}]//Column//TraditionalForm

labeled=Select[{#,"Grid"/.GraphData[#,"NotationRules"]}&/@GraphData["Grid"],Length[#[[2]]]==2&&!MissingQ[GraphData[#[[1]],"GracefulLabeling"]]&]

TextGrid[DeleteCases[{gn=#[[1]],#[[2]],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]}&/@labeled,{_,_,_Missing,_}],Dividers->All]

GraphData[{"Grid",{3,4}},"Graph","Labeled"]

(odd, odd)

lab=GracefulLabeling[{"Grid",{5,7}}]

With[{gn={"Grid",{5,7}}},SetProperty[GraphData[gn],VertexLabels->Thread[Range[35]->lab]]]

GracefullyLabeledGraphQ[%]

(odd, even)

lab=GracefulLabeling[{"Grid",{3,6}}]

With[{gn={"Grid",{3,6}}},SetProperty[GraphData[gn],VertexLabels->Thread[Range[18]->lab]]]

GracefullyLabeledGraphQ[%]

(even, odd)

lab=GracefulLabeling[{"Grid",{4,7}}]

With[{gn={"Grid",{4,7}}},SetProperty[GraphData[gn],VertexLabels->Thread[Range[28]->lab]]]

GracefullyLabeledGraphQ[%]

(even, even)

lab=GracefulLabeling[{"Grid",{4,8}}]

With[{gn={"Grid",{4,8}}},SetProperty[GraphData[gn],VertexLabels->Thread[Range[32]->lab]]]

GracefullyLabeledGraphQ[%]

All

Sort@Cases[Flatten[Table[{{m,n},GracefullyLabeledGraphQ[labg=SetProperty[GraphData[gn={"Grid",{m,n}},"Graph"],VertexLabels->Thread[GraphData[gn,"VertexList"]->(lab=GracefulLabeling[gn])]]]},{n,10},{m,n}],1],{x_,False}:>x]

TextGrid[Sort@Flatten[Table[{{m,n},GracefulLabeling[{"Grid",{m,n}}]},{n,5},{m,n}],1],Dividers->All]

new=Select[GraphData["Grid"],Length["Grid"/.GraphData[#,"NotationRules"]]==2&&MissingQ[GraphData[#,"GracefulLabeling"]]&]

l={#,{0,GracefulLabeling[#]}}&/@new

Grid n×n

Entity["Graph",{"Grid",{n,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Grid",{n,n}}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Grid",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Grid",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Grid k×m×n

Entity["Graph",{"Grid",{k,m,n}}]["Graceful"]

Grid n×n×n

Entity["Graph",{"Grid",{n,n,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Grid",{n,n,n}}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Grid",{n,n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Grid",{n,n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

HalvedCube

seq=Table[GraphData[{"HalvedCube",n},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"HalvedCube",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Hanoi

seq=Table[GraphData[{"Hanoi",n},"Graceful"],{n,5}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Hanoi",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,5}],{_,_,_Missing,_}],Dividers->All]

Helm

seq=Table[GraphData[{"Helm",n},"Graceful"],{n,3,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Helm",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

GraphData[{"Helm",4},"Graph","Labeled"]

lab=GracefulLabeling[{"Helm",12}]

SetProperty[g=GraphData[{"Helm",12}],VertexLabels->Thread[VertexList[g]->lab]]

lab=GracefulLabeling[{"Helm",14}]

SetProperty[g=GraphData[{"Helm",14}],VertexLabels->Thread[VertexList[g]->lab]]

Table[GracefullyLabeledGraphQ[labg=SetProperty[GraphData[gn={"Helm",n},"Graph"],VertexLabels->Thread[GraphData[gn,"VertexList"]->(lab=GracefulLabeling[gn])]]],{n,3,20}]

TextGrid[Table[{n,GracefulLabeling[{"Helm",n}]},{n,3,20}],Dividers->All]

l=Table[{gn={"Helm",n},{0,GracefulLabeling[gn]}},{n,7,20,2}]

Hypercube

Entity["Graph",{"Hypercube",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Hypercube",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Hypercube",n},"Graceful"],{n,0,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Hypercube",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,0,10}],{_,_,_Missing,_}],Dividers->All]

KayakPaddle

data=GraphData[#,{"#","Graceful"}]&/@GraphData["KayakPaddle"];

Cases[data,{g_,False}:>g]

Cases[data,{g_,True}:>g]

Cases[data,{g_,_Missing}:>g]

kayak=Select[GraphData["KayakPaddle"],GraphData[#,"GracefulLabelings"]===Missing["NotAvailable"]&]

Graceful by Litarsky:

Select[kayak,({k,m,n}=#[[2]];Or[
Mod[k,4]==0&&MatchQ[Mod[m,4],0|3],
Mod[k,4]==Mod[m,4]==2&&k≥3,
Mod[k,4]==1&&Mod[m,4]==3
])&]

Not covered by Litarsky:

Complement[kayak,%]

Keller

Entity["Graph",{"Keller",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Keller",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Keller",n},"Graceful"],{n,5}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Keller",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,5}],{_,_,_Missing,_}],Dividers->All]

King m×n

King n×n

Table[GraphData[{"King",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"King",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Knight m×n

Entity["Graph",{"Knight",{m,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Knight",{m,n}}]["Classes"]],"Graceful"]

Knight n×n

Entity["Graph",{"Knight",{n,n}}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Knight",{n,n}}]["Classes"]],"Graceful"]

Table[GraphData[{"Knight",{n,n}},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Knight",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

Ladder

Entity["Graph",{"Ladder",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Ladder",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Ladder",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Ladder",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

Maheo (1980)

GracefulLabeling[{"Ladder",3}]

GracefulLabeling[{"Ladder",4}]

GracefulLabeling[{"Ladder",6}]

GracefulLabeling[{"Ladder",8}]

GracefulLabeling[{"Ladder",9}]

Table[GracefullyLabeledGraphQ[labg=SetProperty[GraphData[gn={"Ladder",n},"Graph"],VertexLabels->Thread[GraphData[gn,"VertexList"]->(lab=GracefulLabeling[gn])]]],{n,3,20}]

TextGrid[Table[{n,GracefulLabeling[{"Ladder",n}]},{n,3,20}],Dividers->All]

l=Table[{{"Ladder",n},{0,GracefulLabeling[{"Ladder",n}]}},{n,7,20}]

L5

With[{fixed={13,4,0,8,12,5}},Select[Join[fixed,#]&/@Flatten[Permutations/@Subsets[Complement[Range[0,13],fixed],{4}],1],GracefullyLabeledGraphQ[SetProperty[GraphData[{"Ladder",5}],VertexLabels->Thread[Range[10]->#]]]&]]

L6

With[{fixed={16,5,0,10,15,6,1,9}},Select[Join[fixed,#]&/@Flatten[Permutations/@Subsets[Complement[Range[0,16],fixed],{4}],1],GracefullyLabeledGraphQ[SetProperty[GraphData[{"Ladder",6}],VertexLabels->Thread[Range[12]->#]]]&]]

L7

With[{fixed1={19,6,0,12,18,7,1,11}},SelectFirst[Join[fixed1,#]&/@Flatten[Permutations/@Subsets[Complement[Range[0,19],fixed1],{6}],1],GracefullyLabeledGraphQ[SetProperty[GraphData[{"Ladder",7}],VertexLabels->Thread[Range[14]->#]]]&]]

L8

GracefullyLabeledGraphQ[SetProperty[GraphData[{"Ladder",8}],VertexLabels->Thread[Range[16]->{22,7,0,14,21,8,1,13,20,9,2,12,19,10,3,11}]]]

L9

GracefullyLabeledGraphQ[SetProperty[GraphData[{"Ladder",9}],VertexLabels->Thread[Range[18]->{25,8,0,16,24,9,1,15,23,10,2,14,22,11,3,13,21,12}]]]

LadderRung

seq=Table[GraphData[{"LadderRung",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"LadderRung",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

MengerSponge

seq=Table[GraphData[{"MengerSponge",n},"Graceful"],{n,3}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"MengerSponge",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3}],{_,_,_Missing,_}],Dividers->All]

MoebiusLadder

Entity["Graph",{"MoebiusLadder",n}]["Graceful"]

seq=Table[GraphData[{"MoebiusLadder",n},"Graceful"],{n,3,25}]

MemberQ[CanonicalName[Entity["Graph",{"MoebiusLadder",n}]["Classes"]],"Graceful"]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"MoebiusLadder",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,25}],{_,_,_Missing,_}],Dividers->All]

TBNotation[tb_,bt_]:=Module[{t,b,a,n},
t=Flatten[{0,Replace[tb,{k_,c_}:>Table[c,k],{1}]}];
n=Length[t];
b=Flatten[{3n,Replace[bt,{k_,c_}:>Table[c,k],{1}]}];
a=Transpose[Accumulate/@{t,b}];
Do[a[[i]]=Reverse[a[[i]]],{i,2,n,2}];
Flatten[Transpose[a]]
]

res=TBNotation[{{3,1},3,1},{{3,-2},-4,2}]

GraphData[{"MoebiusLadder",6},"Graph","Labeled"]

MoebiusLadder[6,VertexLabels->"Name"]

g=SetProperty[GraphData["M6"],VertexLabels->Thread[Range[12]->res]]

GracefullyLabeledGraphQ[g]

GraphData[{"MoebiusLadder",5},"GracefulLabeling"]

GraphData[{"MoebiusLadder",3},"Graph",{"Labeled","All"}][[-1]]

GracefulLabeling[{"MoebiusLadder",15}]

With[{n=13},SetProperty[MoebiusLadder[n],VertexLabels->Thread[Range[2n]->GracefulLabeling[{"MoebiusLadder",n}]]]]

GracefullyLabeledGraphQ/@Table[SetProperty[MoebiusLadder[n],VertexLabels->Thread[Range[2n]->GracefulLabeling[{"MoebiusLadder",n}]]],{n,3,30}]

l=Table[{gn={"MoebiusLadder",n},{0,GracefulLabeling[gn]}},{n,7,25}]

MongolianTent

g=GraphData[{"MongolianTent",{3,7}},"Graph","Labeled"]

xeqns=Flatten@With[{m=3,n=7},Table[x[i,j]-x[i+1,j]==(((-1))^(i+j))(i+(2n-1)(j-1)),{j,m},{i,n-1}]]

yeqns=Flatten@With[{m=3,n=7},Table[x[i,j]-x[i,j+1]==(((-1))^(i+j))(-n+(2n-1)j+i),{j,m-1},{i,n}]]

roofeqns=With[{m=3,n=7},Table[x[2k-1,m]==(k+n-1+(2n-1)(m-1)),{k,(n+1)/2}]]

vars=Flatten[Array[x,{7,3}]]

eqns=Join[xeqns,yeqns,roofeqns]

Sort[Solve[eqns,vars][[1]]/.x[i_,j_]:>x[j,i]]

v=GraphData[{"MongolianTent",{3,7}},"Embeddings"][[1]]

edgelabels=Join[xeqns,yeqns]/.x[i__]-x[j__]==w_:>(UndirectedEdge@@Flatten[{Position[v,{i}],Position[v,{j}]}]->w)

SetProperty[g,{EdgeLabels->edgelabels,EdgeLabelStyle->Blue}]

GracefulLabeling[{"MongolianTent",{3,7}}]

GracefulLabeling[{"MongolianTent",{3,5}}]

GracefulLabeling[{"MongolianTent",{2,7}}]

l={#,{0,GracefulLabeling[#]}}&/@Select[GraphData["MongolianTent"],MissingQ[GraphData[#,"GracefulLabeling"]]&]

Mycielski

Entity["Graph",{"Mycielski",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Mycielski",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Mycielski",n},"Graceful"],{n,8}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Mycielski",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,8}],{_,_,_Missing,_}],Dividers->All]

Odd

Entity["Graph",{"Odd",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Odd",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Odd",n},"Graceful"],{n,7}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Odd",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,7}],{_,_,_Missing,_}],Dividers->All]

Pan

seq=Table[GraphData[{"Pan",n},"Graceful"],{n,3,20}]

Table[FindGracefulLabeling[GraphData[{"Pan",n}],10],{n,3,8}]//Column

Select[GraphData["Pan"],MissingQ[GraphData[#,"GracefulLabeling"]]&]

<<MathWorld`Graphs`

TextGrid[DeleteCases[Table[
{
n,
GraphData[gn={"Pan",n},"#"],
lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]
},
{n,3,20}
],{_,_,_Missing,_}],Dividers->All]

GraphData[{"Cycle",12},"GracefulLabeling"]

Complement[Range[0,12],%]

Complement[Range[13],Abs[Subtract@@@Partition[%147,2,1,1]]]

PanGraph[12,VertexLabels->"Name"]

GraphData[{"Pan",12},"Graph","Labeled"]

SetProperty[GraphData[{"Pan",12}],VertexLabels->Thread[Range[13]->Append[RotateLeft[GraphData[{"Cycle",12},"GracefulLabeling"]],13]]]

l=DeleteCases[Table[{{"Pan",n},{0,GracefulLabeling[{"Pan",n}]}},{n,13,20}],{_,{_,$Failed}}]

Quotient[9,4]

Clear[GracefulLabeling]

GracefulLabeling[{"Pan",n_}]:=Module[{mod4=Mod[n,4],p=Quotient[n,4]},
Print[4,"×",p,"+",mod4];
Switch[mod4,
1,{Transpose[{Range[0,p-1],Range[4p,3p+1,-1]}],Transpose[{Range[p,2p-1],Range[3p,2p+1,-1]}],2p,4p+2,4p+1}
]
]

Subtract[4p,3p+2]

lab=GracefulLabeling[{"Pan",13}]

Flatten[lab]

lab={0,8,1,6,2,3,5,4,10,9}

SetProperty[PanGraph[9],VertexLabels->Thread[Range[10]->lab]]

GracefullyLabeledGraphQ[%]

Path

Entity["Graph",{"Path",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Path",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Path",n},"Graceful"],{n,20}]

Table[FindGracefulLabeling[GraphData[{"Path",n}],10],{n,10}]//Timing

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Path",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

Table[GracefulLabeling[{"Path",n}],{n,7}]//Column

Can use consecutive triangular numbers: 0, 1, 3, 6, 10, 15, ... (but that's extended graceful)

PathComplement

seq=Table[GraphData[{"PathComplement",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"PathComplement",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

Prism

Entity["Graph",{"Prism",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Prism",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Prism",n},"Graceful"],{n,3,25}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Prism",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,25}],{_,_,_Missing,_}],Dividers->All]

Frucht and Gallian 1988

{res1,res2}=Table[{i,j},{i,2},{j,4}]

res1

lab=GracefulLabeling[{"Prism",4}]

PrismGraph[4,VertexLabels->"Name"]

lab=GracefulLabeling[{"Prism",6}]

<<MathWorld`Graphs`

lab=GracefulLabeling[{"Prism",13}]

g=With[{n=13},SetProperty[PrismGraph[n],VertexLabels->Thread[Range[2n]->GracefulLabeling[{"Prism",n}]]]]

Abs[Subtract@@@(EdgeList[g]/.n_Integer:>GracefulLabeling[{"Prism",13}][[n]])]//Sort

Table[SetProperty[PrismGraph[n],VertexLabels->Thread[Range[2n]->GracefulLabeling[{"Prism",n}]]],{n,3,20}]

GracefullyLabeledGraphQ/@%

And@@%

TextGrid[Table[{n,GracefulLabeling[{"Prism",n}]},{n,3,20}],Dividers->All]

l=Table[{gn={"Prism",n},{0,GracefulLabeling[gn]}},{n,21,25}]

Queen n×n

Table[GraphData[{"Queen",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Queen",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Rook m×n

Table[GraphData[{"Rook",{m,n}},"Graceful"],{n,10},{m,n}]//Column

Rook 2×n

Table[GraphData[{"Rook",Sort[{2,n}]},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Rook",Sort[{2,n}]},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

Rook n×n

Table[GraphData[{"Rook",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Rook",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

RookComplement n×n

Table[GraphData[{"RookComplement",{n,n}},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"RookComplement",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

SierpinskiCarpet

seq=Table[GraphData[{"SierpinskiCarpet",n},"Graceful"],{n,4}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"SierpinskiCarpet",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,4}],{_,_,_Missing,_}],Dividers->All]

SierpinskiSieve

seq=Table[GraphData[{"SierpinskiSieve",n},"Graceful"],{n,5}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"SierpinskiSieve",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,5}],{_,_,_Missing,_}],Dividers->All]

SierpinskiTetrahedron

seq=Table[GraphData[{"SierpinskiTetrahedron",n},"Graceful"],{n,6}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Andrasfai",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,6}],{_,_,_Missing,_}],Dividers->All]

Star

Entity["Graph",{"Star",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Star",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Star",n},"Graceful"],{n,25}]

Table[FindGracefulLabeling[GraphData[{"Star",n}],10],{n,8}]//Column

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Star",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,25}],{_,_,_Missing,_}],Dividers->All]

Sun

seq=Table[GraphData[{"Sun",n},"Graceful"],{n,3,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Sun",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Sunlet

seq=Table[GraphData[{"Sunlet",n},"Graceful"],{n,3,20}]

Table[GraphData[{"Sunlet",n},"Graph","Labeled"],{n,5,7}]

GracefulLabeling[{"Sunlet",7}]

TextGrid[Table[{n,GracefulLabeling[{"Sunlet",n}]},{n,3,20}],Dividers->All]

l=Table[{{"Sunlet",n},{0,GracefulLabeling[{"Sunlet",n}]}},{n,7,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Sunlet",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Tadpole

tads=GraphData[#,{"#","GracefulLabeling"}]&/@GraphData["Tadpole"]

Cases[tads,{_,_Missing}]

GraphData[{"Tadpole",{4,3}},"Graph","Labeled"]

TadpoleGraph[8,3,VertexLabels->"Name"]

Massively corrected version of Koh 1980

GracefulLabeling[{"Tadpole",{r_,l_}}]:=Module[{k=r/4,n=r+l,res},
res=Table[Piecewise[{{(i-1)/2,Mod[i,2]==1&&i≤2k},{(i+1)/2,Mod[i,2]==1},{n+1-i/2,Mod[i,2]==0}}],{i,n}];
(* shift to GraphData's preference to place tail at vertex 1 *)
Join[RotateRight[Take[res,r]],Drop[res,r]]
]/;Mod[r,4]==0

lab=GracefulLabeling[{"Tadpole",{8,3}}]

SetProperty[TadpoleGraph[8,3],VertexLabels->Thread[Range[11]->lab]]

GracefullyLabeledGraphQ[%]

lab=GracefulLabeling[{"Tadpole",{4,3}}]

SetProperty[TadpoleGraph[4,3],VertexLabels->Thread[Range[7]->lab]]

GracefullyLabeledGraphQ[%]

Tetrahedral

seq=Table[GraphData[{"Tetrahedral",n},"Graceful"],{n,6,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Tetrahedral",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,6,10}],{_,_,_Missing,_}],Dividers->All]

Transposition

Entity["Graph",{"Transposition",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Transposition",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Transposition",n},"Graceful"],{n,6}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Transposition",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,6}],{_,_,_Missing,_}],Dividers->All]

Triangular

seq=Table[GraphData[{"Triangular",n},"Graceful"],{n,2,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Triangular",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,2,10}],{_,_,_Missing,_}],Dividers->All]

TriangularGrid

seq=Table[GraphData[{"TriangularGrid",n},"Graceful"],{n,0,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularGrid",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,0,10}],{_,_,_Missing,_}],Dividers->All]

TriangularHoneycombAcuteKnight

seq=Table[GraphData[{"TriangularHoneycombAcuteKnight",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularHoneycombAcuteKnight",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

TriangularHoneycombBishop

seq=Table[GraphData[{"TriangularHoneycombBishop",n},"Graceful"],{n,9}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularHoneycombBishop",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,9}],{_,_,_Missing,_}],Dividers->All]

TriangularHoneycombObtuseKnight

seq=Table[GraphData[{"TriangularHoneycombObtuseKnight",n},"Graceful"],{n,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularHoneycombObtuseKnight",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,20}],{_,_,_Missing,_}],Dividers->All]

TriangularHoneycombQueen

seq=Table[GraphData[{"TriangularHoneycombQueen",n},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularHoneycombQueen",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

TriangularHoneycombRook

seq=Table[GraphData[{"TriangularHoneycombRook",n},"Graceful"],{n,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularHoneycombRook",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,10}],{_,_,_Missing,_}],Dividers->All]

TriangularSnake

seq=Table[GraphData[{"TriangularSnake",n},"Graceful"],{n,1,19,2}]

Table[MatchQ[Mod[(n-1)/2,4],0|1],{n,1,19,2}]

Table[MatchQ[Mod[n,8],1|3],{n,1,19,2}]

GraphData[{"TriangularSnake",17},"Graph","Labeled"]

rules={
{"TriangularSnake",17}->{0,19,24,17,1,15,23,6,2,4,22,13,7,10,20,9,8},
{"TriangularSnake",19}->{14,13,0,22,27,20,1,17,26,6,2,4,25,15,7,18,24,12,9}
};

TextGrid[DeleteCases[Table[{n,GraphData[gn={"TriangularSnake",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,1,19,2}],{_,_,_Missing,_}],Dividers->All]

Web

seq=Table[GraphData[{"Web",n},"Graceful"],{n,3,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Web",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,3,20}],{_,_,_Missing,_}],Dividers->All]

Wheel

Entity["Graph",{"Wheel",n}]["Graceful"]

MemberQ[CanonicalName[Entity["Graph",{"Wheel",n}]["Classes"]],"Graceful"]

seq=Table[GraphData[{"Wheel",n},"Graceful"],{n,4,20}]

https://www.cos.ufrj.br/uploadfile/publicacao/2668.pdf, pp. 10-11

Frucht (1979)

TextGrid[Table[{n,GracefulLabeling[{"Wheel",n}]},{n,4,20}],Dividers->All]

l=Table[{{"Wheel",n},{0,GracefulLabeling[{"Wheel",n}]}},{n,12,20}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"Wheel",n},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,4,20}],{_,_,_Missing,_}],Dividers->All]

WhiteBishop n×n

Table[GraphData[{"WhiteBishop",{n,n}},"Graceful"],{n,2,10}]

TextGrid[DeleteCases[Table[{n,GraphData[gn={"WhiteBishop",{n,n}},"#"],lab=GraphData[gn,"GracefulLabeling"],SetProperty[GraphData[gn],VertexLabels->Thread[GraphData[gn,"VertexList"]->lab]]},{n,2,10}],{_,_,_Missing,_}],Dividers->All]

Check against computation by node count

SetDirectory[FileNameJoin[{$GraphDataDirectory,"Nodes","Graceful"}]];

Ungraceful

data=Table[
{
n,
Row[{Length[data=ToExpression@Import["GracefulLabeling_0"<>ToString[n]<>".m","Lines"]],"/",SimpleGraphCount[n]}],
Count[data,{}],
Count[data[[Select[ConnectedGraphIndices[n],#≤Length[data]&]]],{}],
DeleteCases[
Select[MapIndexed[{GraphData[gn={n,#2[[1]]},"#"],GraphData[gn,"Graceful"],#=!={}}&,data]//Quiet,FreeQ[GraphData]],
{_,x_,x_}]
},
{n,8}];

TextGrid[Prepend[data,{"V","graphs/total","ungraceful","connected ungraceful","disagreement"}],Dividers->All,Alignment->{Automatic,{Decimal}}]

all: A308556
connected: A308557

Algorithm

Weisstein (various methods)

1-6 nodes

Method 1:

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#]]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

Method 2:

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#]]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

Method 3:

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#],Method->"NextPermutation"]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

Method 4:

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#],Method->"NextPermutation"]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

Method 4 with Compiled NextPermutation:

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#],Method->"NextPermutation"]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

Method 4 with Compiled NextPermutation and using known maximum number of edges to mark as ungraceful:

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#],Method->"NextPermutation"]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#],Method->"NextPermutation"]=!=$Failed}&/@GraphData[;;6],g],{_,x_,x_}]//Timing

Up to 7 nodes

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#]]=!=$Failed}&/@GraphData[;;7],g],{_,x_,x_}]//Timing

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#]]=!=$Failed}&/@GraphData["Graceful",;;7],g],{_,x_,x_}]//Timing

Trees up to 10 nodes

DeleteCases[
Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabeling[GraphData[#],Method->"NextPermutation"]=!=$Failed}&/@GraphData["Tree",;;10],g],
{_,x_,x_}]//Timing

FindGracefulLabeling[GraphData["Propane"],Method->"NextPermutationTreePreprocess"]//Timing

FindGracefulLabeling[GraphData["Propane"],Method->"NextPermutation"]//Timing

Szabolcs Horvát

2019-09-19

I was hoping that I could cook up something rudimentary before I respond, but I didn't really manage.

Naive formulations with FindInstance don't seem to work very well.

The problem with implementing backtracking directly in Mathematica is that such brute-force approaches rely on raw speed. It really should be written in a language like C (or at least Compile[]d in Mathematica) to be usable.

The notebook I attached has a program that just blindly tries all labellings. Of course, this is not going to work very well ...

I was trying to think of a workable formulation in terms of Boolean satisfiability, but I did not manage to come up with one.

It's an interesting problem. If you find good solutions, do let me know.

This is the small graph from Wikipedia.

g=Graph[{1<->2,2<->3,3<->1,1<->4,4<->5}];
g=IndexGraph[g];

Brute force: try all possibilities

telist=Transpose@Developer`ToPackedArray[List@@@EdgeList[ig]]

i=1;
max=Binomial[EdgeCount[g]+1,VertexCount[g]];
PrintTemporary@Dynamic[i];
result=Catch@While[i<max,
lab0=First@Subsets[Range[0,EdgeCount[g]],{VertexCount[g]},{i++}];
Do[
If[DuplicateFreeQ@Abs[Subtract@@(lab[[#]]&/@telist)],
Throw[lab]
],
{lab,Permutations[lab0] (* this is dangerous! it may fill up the memory *)}
]
]

Graph[
g,
EdgeLabels->Thread[
EdgeList[g]->Abs[Subtract@@(result[[#]]&/@telist)]
],
VertexLabels->Thread[
VertexList[g]->result
]
]

Clear[FindGracefulLabelingHorvat]

FindGracefulLabelingHorvat[g_System`Graph]:=Module[{
i=1,
max=Binomial[EdgeCount[g]+1,VertexCount[g]],
telist=Transpose@Developer`ToPackedArray[List@@@EdgeList[g]],
lab0,
lab,
result
},
result=Catch@While[i<max,
lab0=First@Subsets[Range[0,EdgeCount[g]],{VertexCount[g]},{i++}];
Do[
If[DuplicateFreeQ@Abs[Subtract@@(lab[[#]]&/@telist)],
Throw[lab]
],
{lab,Permutations[lab0] (* this is dangerous! it may fill up the memory *)}
]
];
result
]

GraphData[{"Tadpole",{3,2}}]

FindGracefulLabelingHorvat[GraphData[{"Tadpole",{3,2}}]]

FindGracefulLabelingHorvat[GraphData["P2+K1"]]

FindGracefulLabelingHorvat[GraphData["C3"]]

DeleteCases[Monitor[{g=#,GraphData[#,"Graceful"],FindGracefulLabelingHorvat[GraphData[#]]=!=$Failed}&/@GraphData[;;3],g],{_,x_,x_}]//Timing