Happy End Problem

Author

Eric W. Weisstein
January 24, 2004

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

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

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

Computational

<<DiscreteMath`ComputationalGeometry`
<<DiscreteMath`Combinatorica`

ConvexNGon[l_List,n_]:=Module[{s=Select[#[[ConvexHull[#]]]&/@KSubsets[l,n],Length[#]==n&,1]},
If[s=={},{},s[[1]]]
]

ClosedLine[l_]:=Line[Append[l,First[l]]]

NGon[l_,n_]:=Module[{c=ConvexNGon[l,n]},
If[c=={},{},ClosedLine[c]]
]

Triangle

p=Table[Random[Real],{5},{3},{2}]

Union[Length/@(ConvexNGon[#,3]&/@p)]

Show[GraphicsArray[
Graphics[
{
PointSize[.08],
Point/@#,
NGon[#,3]
},
AspectRatio->Automatic,PlotRange->{{0,1},{0,1}},Frame->True,FrameTicks->None]&/@p]]

Square

4 Points

p4=Table[Random[Real],{10},{4},{2}]

Union[Length/@(ConvexNGon[#,4]&/@p4)]

Show[GraphicsArray[
Partition[Graphics[
{
PointSize[.08],
Point/@#,
NGon[#,4]
},
AspectRatio->Automatic,PlotRange->{{0,1},{0,1}},Frame->True,FrameTicks->None]&/@p4,5]]]

5 Points

p5=Table[Random[Real],{10},{5},{2}]

Union[Length/@(ConvexNGon[#,4]&/@p5)]

Show[GraphicsArray[
Partition[Graphics[
{
PointSize[.08],
Point/@#,
NGon[#,4]
},
AspectRatio->Automatic,PlotRange->{{0,1},{0,1}},Frame->True,FrameTicks->None]&/@p5,5]]]

Pentagon

8 Points

p8=Table[Random[Real],{10},{8},{2}]

Union[Length/@(ConvexNGon[#,5]&/@p8)]

Show[GraphicsArray[
Partition[Graphics[
{
PointSize[.08],
Point/@#,
NGon[#,5]
},
AspectRatio->Automatic,PlotRange->{{0,1},{0,1}},Frame->True,FrameTicks->None]&/@p8,5]]]

9 Points

p9=Table[Random[Real],{100},{9},{2}];

Union[Length/@(ConvexNGon[#,5]&/@p9)]//Timing

Hexagons

p=Table[Random[Real],{100},{30},{2}];

i=0;
While[l=Length[ConvexNGon[r=Table[Random[Real],{9},{2}],6]]>0,i++;
If[Mod[i,10]==0,Print[i,"..."]
]];
{i,r,ConvexNGon[r,6]}

i=0;
While[l=Length[ConvexNGon[r=Table[Random[Real],{10},{2}],6]]>0,i++;
If[Mod[i,10]==0,Print[i,"..."]
]];
{i,r,ConvexNGon[r,6]}

i=0;
While[l=Length[ConvexNGon[r=Table[Random[Real],{11},{2}],6]]>0,i++;
If[Mod[i,10]==0,Print[i,"..."]
]];
{i,r,ConvexNGon[r,6]}

p={{0.7848594046731805`,0.5882600968568017`},{0.7870669047148386`,0.49312823419061813`},{0.3468871016811131`,0.324669627515676`},{0.4326068692173522`,0.670365965383893`},{0.8350430353588773`,0.3495840886962882`},{0.28652693461562134`,0.08904993071347599`},{0.4966514482762856`,0.561640009755739`},{0.8502911421386248`,0.7919564903954044`},{0.5428853133116156`,0.5046432847692016`},{0.034557335898123966`,0.8655929252371125`},{0.3016578387177457`,0.6964659969105412`}};

Or@@CollinearQ/@KSubsets[Point/@p,3]

Or@@CollinearQ/@KSubsets[Point/@Rationalize[p,0],3]

ConvexNGon[Rationalize[p,0],6]

Show[Graphics[
{
PointSize[.08],
Point/@p,
NGon[p,6]
},
AspectRatio->Automatic,PlotRange->{{0,1},{0,1}},Frame->True,FrameTicks->None]]

i=0;
While[l=Length[ConvexNGon[r=Table[Random[Real],{12},{2}],6]]>0,i++;
If[Mod[i,10]==0,Print[i,"..."]
]];
{i,r,ConvexNGon[r,6]}

t=AbsoluteTime[];
i=0;
While[l=Length[ConvexNGon[r=Table[Random[Real],{13},{2}],6]]>0,i++;
If[Mod[i,10]==0,Print[i,"..."]
]];
{AbsoluteTime[]-t,i,r,ConvexNGon[r,6]}

t=AbsoluteTime[];
i=0;
While[l=Length[ConvexNGon[r=Table[Random[Real],{14},{2}],6]]>0,i++;
If[Mod[i,10]==0,Print[i,"..."]
]];
{AbsoluteTime[]-t,i,r,ConvexNGon[r,6]}

30838 Seconds...

Values

3, 5, 9, ≥13 (experimental) / ≥ 17 (theoretical)

Bounds

Lower Bounds

Table[(2^(n-2))+1,{n,6}]

Upper Bounds

f[1,n_]:=f[2,n]+1
f[2,n_]:=Binomial[2n-4,n-2]
f[3,n_]:=Binomial[2n-4,n-2]+7-2n
f[4,n_]:=Binomial[2n-5,n-2]+2

Table[f[k,n],{k,4},{n,10}]//ColumnForm