Graham's Biggest Little Hexagon

Author

Eric W. Weisstein
April 23, 2025

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputationalGeometry/GrahamsBiggestLittleHexagon.nb.

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

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

As a graph

hex=GraphData[{"BiggestLittlePolygon", 6}]

EdgeLengths[hex]//RootReduce

BLP[6]:=With[{x=,y=,bb=},{{0,0},{(1/2),-y},{x,-bb},{0,-1},{-x,-bb},{-(1/2),-y}}];
BLP[8]:={{0,1},{,},{(1/2),},{,},{0,0},{-,},{-(1/2),},{-,}};
BLP[10]:={{0,0},{,},{,},{(1/2),},{,},{0,1},{-,},{-(1/2),},{-,},{-,}};

BiggestLittlePolygon[n_]:=Graph[Range[n],UndirectedEdge@@@Sort[Sort/@Join[Select[Subsets[Range[n],{2}],(Abs[Norm[Subtract@@(N@BLP[n][[#]])]-1]<.001)&],Partition[Range[n],2,1,1]]],VertexCoordinates->BLP[n]]

MakeBoxes[label[n_],TraditionalForm]:=SubsuperscriptBox["A",MakeBoxes[n,TraditionalForm],"*"]

Graphics[{
ClosedLine[BLP[6]],
{
Red,
Line/@Select[Subsets[BLP[6],{2}],(Abs[Norm[Subtract@@#]-1.]<.001)&]
}
},AspectRatio->Automatic,PlotLabel->Style[TraditionalForm[label[6]≈Abs[Area[Evaluate[Polygon[BLP[6]//N]]]]],Directive[18,FontFamily->"Times"]]]

Figure

({b,d}/.RootReduce[Solve[{b^2+x^2==1,(x+1/2)^2+d^2==1},{b,d}]/.x->maxx])

{bb,dd}=Select[%,#[[1]]>0&&#[[2]]>0&][[1]]

{bb,dd}={Root[-135-720 #1-3160 ((#1)^2)+128 ((#1)^3)+13568 ((#1)^4)+1920 ((#1)^5)-14080 ((#1)^6)+2048 ((#1)^7)-3584 ((#1)^8)-4096 ((#1)^9)+8192 ((#1)^10)&,5],Root[-135+720 #1-360 ((#1)^2)-1536 ((#1)^3)+5952 ((#1)^4)-4224 ((#1)^5)-11008 ((#1)^6)+2048 ((#1)^7)-1536 ((#1)^8)+4096 ((#1)^9)+8192 ((#1)^10)&,5]};

bb[[1]][b]//TraditionalForm

N[{maxx,bb,dd},10]

<<Graphics`Arrow`

RootReduce[bb-dd]

With[{
x=Root[-351+1440 #1+2520 ((#1)^2)-12672 ((#1)^3)-8192 ((#1)^4)+38528 ((#1)^5)+18176 ((#1)^6)-44032 ((#1)^7)-19968 ((#1)^8)+16384 ((#1)^9)+8192 ((#1)^10)&,5],y=Root[105-690 #1+850 ((#1)^2)-352 ((#1)^3)+1664 ((#1)^4)+1600 ((#1)^5)-576 ((#1)^6)+512 ((#1)^7)-1280 ((#1)^8)-512 ((#1)^9)+512 ((#1)^10)&,4],off=.05
},
v={{0,0}, {(1/2),-y},{x,-bb},{0,-1},{-x,-bb},{-(1/2),-y}};
Show[Graphics[
{
Line[Append[v,v[[1]]]],
(* dimensioning *)
Line[{{0,-1.05},{0,-1.15}}],Line[{{x,-bb-.05},{x,-1.15}}],
Arrow[{{0,-1.1},{x,-1.1}}],Arrow[{{x,-1.1},{0,-1.1}}],Text[StyleForm[" 0.343771 ",FontSize->11,FontFamily->"Times"],{x/2,-1.105},{0,0},Background->White],
Line[{{.1,0},{.65,0}}],Line[{{x+off,-bb},{.65,-bb}}],
Arrow[{{.6,0},{.6,-bb}}],Arrow[{{.6,-bb},{.6,0}}],
Text[StyleForm["0.9390533",FontSize->11,FontFamily->"Times"],{.6,-bb/2},{0,0},Background->White],
(* unit lines *)
{Red,Line/@Select[Subsets[v,{2}],(Abs[Norm[Subtract@@#]-1.]<.001)&]}
},
AspectRatio->Automatic],ImageSize->300,PlotRange->All]
]

Numerical Search

pts=Transpose[Array[#,6]&/@{x,y}]

cons=#<=1&/@(Norm/@(Subtract@@@Subsets[pts,{2}]))

area=Abs[Area[Evaluate[Polygon[pts]]]]

Machine Precision

(soln=NMaximize[{area,cons},Flatten[pts]])//Timing

Sqrt[3]/2.

area/.soln[[2]]

cons/.soln[[2]]

First/@cons/.soln[[2]]

Precision = 10

(soln=NMaximize[{area,cons},Flatten[pts],WorkingPrecision->10])//Timing

cons/.soln[[2]]

First/@cons/.soln[[2]]

Plots

<<DiscreteMath`Combinatorica`

pts/.soln[[1]]

ShowGraph[g=ChangeVertices[Cycle[6],pts/.soln[[2]]]]

Diameter[g]

RootReduce[Norm/@(Subtract@@@Subsets[Vertices[g],{2}])]

Max[%]//InputForm

ShowLabeledGraph[ShakeGraph[g,.5],PlotRange->All]

Show[Graphics[{
ClosedLine[pts],
PointSize[.04],Point/@pts
}/.soln[[2]]],AspectRatio->Automatic,Axes->True,PlotRange->All]

Regular hexagon with diameter 1

Show[Graphics[{Red,ClosedLine[v=(1/2) Through[{Cos,Sin}[π #/3]]&/@Range[0,5]]}],AspectRatio->Automatic,Axes->True]

Max[Simplify[Norm/@(Subtract@@@Subsets[v,{2}])]]

(1/2) n (R^2) Sin[((2 π)/n)]/.{n->6,R->1/2}

N[%,10]

With[{a1=Root[11993-78488 #1+144464 ((#1)^2)+1232 ((#1)^3)-221360 ((#1)^4)+146496 ((#1)^5)+21056 ((#1)^6)-30848 ((#1)^7)-3008 ((#1)^8)+8192 ((#1)^9)+4096 ((#1)^10)&,5],a2=((3 (Sqrt[3]))/8)},
(a1-a2)/a2]//N

Hexagon coordinates constructed analytically

Area[Evaluate[Polygon[{{0,0},{(1/2),b-d},{x,b},{0,1},{-x,b},{-(1/2),b-d}}]]]//Simplify

FullSimplify[Solve[{(b/2)+x-b x+d x==area,b^2+x^2==1,(x+1/2)^2+d^2==1},area,{b,d}],0<x<1/2]

soln=GroebnerBasis[{(b/2)+x-b x+d x-area,b^2+x^2-1,(x+1/2)^2+d^2-1},x,{b,d},MonomialOrder->EliminationOrder][[1]]

FullSimplify[Solve[soln==0,area],0<x<1/2]

FullSimplify[Subtract@@{x+(1/2) (Sqrt[1+2 x (-2+3 x-4 (x^3)+(Sqrt[(-1+x) (1+x) (((-1+2 x))^3) (3+2 x)]))]), (1/2) ((Sqrt[1-(x^2)])+x (2-2 (Sqrt[1-(x^2)])+(Sqrt[3-4 x (1+x)])))},0<x<1/2]

Plot[x (Sqrt[1-(x^2)])-(1/2) x (Sqrt[3-4 x (1+x)])+(1/2) (-(Sqrt[1-(x^2)])+(Sqrt[1+2 x (-2+3 x-4 (x^3)+(Sqrt[(-1+x) (1+x) (((-1+2 x))^3) (3+2 x)]))])),{x,0,1/2},PlotStyle->Red]

Plot[x (Sqrt[1-(x^2)])-(1/2) x (Sqrt[3-4 x (1+x)])+(1/2) (-(Sqrt[1-(x^2)])+(Sqrt[1+2 x (-2+3 x-4 (x^3)+(Sqrt[(-1+x) (1+x) (((-1+2 x))^3) (3+2 x)]))])),{x,-1,1},PlotStyle->Red,PlotRange->All]

HexArea[x_] := (1/2) ((Sqrt[1-(x^2)])+x (2-2 (Sqrt[1-(x^2)])+(Sqrt[3-4 x (1+x)])))

With[{maxx=Root[-351+1440 #1+2520 ((#1)^2)-12672 ((#1)^3)-8192 ((#1)^4)+38528 ((#1)^5)+18176 ((#1)^6)-44032 ((#1)^7)-19968 ((#1)^8)+16384 ((#1)^9)+8192 ((#1)^10)&,5]},
Plot[HexArea[x],{x,0,.5},PlotStyle->Red,AxesLabel->TraditionalForm/@{x,A[x]},
Epilog->{Blue,Dashing[{.02}],Line[{{maxx,0},{maxx,1}}]},BaseStyle->Directive[12,FontFamily->"Times"]]
]

Maximum Area Assuming Symmetric Configuration

Area[Polygon[{{0,0},{x2,y2},{x3,y3},{0,1},{-x3,y3},{-x2,y2}}]]//Simplify

Maximize[HexArea[x],x]//FullSimplify

{maxa,maxx}={RootReduce[First[%]],x/.Last[%]}

{maxa,maxx}={Root[11993-78488 #1+144464 ((#1)^2)+1232 ((#1)^3)-221360 ((#1)^4)+146496 ((#1)^5)+21056 ((#1)^6)-30848 ((#1)^7)-3008 ((#1)^8)+8192 ((#1)^9)+4096 ((#1)^10)&,5],Root[-351+1440 #1+2520 ((#1)^2)-12672 ((#1)^3)-8192 ((#1)^4)+38528 ((#1)^5)+18176 ((#1)^6)-44032 ((#1)^7)-19968 ((#1)^8)+16384 ((#1)^9)+8192 ((#1)^10)&,5]};

maxa[[1]][A]==0//TraditionalForm

maxx[[1]][x]==0//TraditionalForm

N[{maxx,maxa},10]