Graceful Pi-Way

Author

Eric W. Weisstein
December 12, 2024

This notebook downloaded from http://mathworld.wolfram.com/notebooks/GraphTheory/GracefulPi-Way.nb.

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

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

Graceful labeling

Source

ImageCrop@Import["/Users/eww/Documents/Books/KunthFasc7a.pdf",{"PDF","PageImages"}][[32]]

Construction and check

GraphData["ContiguousUSAGraph","Graph","Labeled"]

GraphData["ContiguousUSAGraph","Graceful"]

gracefullabels=GraphData["ContiguousUSAGraph","GracefulLabelings"]/.Missing[_,l_List]:>l

gracefullylabeledgraph=Annotate[GraphData["ContiguousUSAGraph"],VertexLabels->Thread[Range[49]->gracefullabels]]

GracefullyLabeledGraphQ[gracefullylabeledgraph]

diffdata={#,#2,Abs[Subtract@@#2]}&@@@(Transpose/@(GraphData["ContiguousUSAGraph","Edges","List"]/.i_Integer:>{i,gracefullabels[[i]]}))

diffs=diffdata[[All,-1]]

Max[diffs]

Union[diffs]==Range[107]

VertexShapeFunction (ugly)

vf[{xc_,yc_},name_,{w_,h_}]:=Block[{xmin=xc-w,xmax=xc+w,ymin=yc-.7h,ymax=yc+.7h},
{FaceForm[None],Rectangle[{xmin,ymin},{xmax,ymax},RoundingRadius->(xmax-xmin)/3],Text[Style[gracefullabels[[name]],Directive[FontFamily->"Courier",16,Black]],{xc,yc},Background->None]}]

Annotate[GraphData["ContiguousUSAGraph"],{VertexShapeFunction->vf,VertexSize->.8,EdgeStyle->Black,ImageSize->700}]

Graphics by hand

With[{v=GraphData["ContiguousUSAGraph","VertexCoordinates"],e=GraphData["ContiguousUSAGraph","Edges","List"],a=.2,r=.2,dy=-.03},
Graphics[{
Line[v[[#]]&/@e],
FaceForm[White],EdgeForm[Black],MapIndexed[
With[{lab=gracefullabels[[#2[[1]]]]},
With[{w=(Max[IntegerLength[lab],1]-1)/4},
{Rectangle[#-a-{a w ,0},#+a+{a w,0},RoundingRadius->r],Text[lab,#+{0,dy}]}
]
]&,v]
},
BaseStyle->Directive[FontFamily->"Courier",16],
ImageSize->700
]
]

Miraculously, a graceful labeling can be found in which the 15 states on the western and northern borders from California to Maine are labeled with the numbers 31, 41,
59, 26, 53, 58, 97, 93, 23, 84, 62, 64, 33, 83, and 27, which are precisely the first 30 decimal digits of π!

pidigits=FromDigits/@Partition[RealDigits[Pi,10,30][[1]],2]

piway=Flatten[Position[gracefullabels,#]&/@pidigits]

With[{v=GraphData["ContiguousUSAGraph","VertexCoordinates"],e=GraphData["ContiguousUSAGraph","Edges","List"],a=.2,r=.2,dy=-.03},
Graphics[{
Line[v[[#]]&/@e],
{Red,Thickness[.01],Line[v[[piway]]]},
FaceForm[White],EdgeForm[Black],MapIndexed[
With[{lab=gracefullabels[[#2[[1]]]]},
With[{w=(Max[IntegerLength[lab],1]-1)/4},
{Rectangle[#-a-{a w ,0},#+a+{a w,0},RoundingRadius->r],Text[lab,#+{0,dy}]}
]
]&,v]
},
BaseStyle->Directive[FontFamily->"Courier",16],
ImageSize->700,PlotLabel->"graceful pi\[Hyphen]way",
LabelStyle->Directive[Black,Italic,FontFamily->"Times"]
]
]