18-Point Problem

Author

Eric W. Weisstein
April 16, 2004

This notebook downloaded from http://mathworld.wolfram.com/notebooks/ComputationalGeometry/18-PointProblem.nb.

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

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

Code

DiffQuadsQ[l_List]:=Module[
		{segs,i,j=1,n=Length[l]},
		segs=Table[{i,i+1}/n,{i,0,n-1}];
		While[j<=n,
			  i=1;
			  While[ i<=Length[segs] && !(segs[[i,1]]<=l[[j]]<segs[[i,2]]) ,i++ ];
   	 	j++;
      	If[i<=Length[segs],segs=Drop[segs,{i}]];
		];
		segs=={}
]

SubsetsDiffQuadsQ[l_List]:=Module[{i},
		And@@Table[DiffQuadsQ[Take[l,i]],{i,Length[l]}]
]

Notes

Code should be rewritten

10

SubsetsDiffQuadsQ[{.95,.05,.34,.74,.58,.17,.45,.87,.26,.66}]

SubsetsDiffQuadsQ[{.06,.55,.77,.39,.96,.28,.64,.13,.88,.48}]

14

SubsetsDiffQuadsQ[{.06,.55,.77,.39,.96,.28,.64,.13,.88,.48,.19,.71,.35,.82}]

17

pt17={4/7,2/7,16/17,1/14,8/11,5/11,1/7,14/17,
		3/8,11/17,3/14,15/17,1/2,0,13/17,5/16,10/17}

SubsetsDiffQuadsQ[pt17]

pt17up={7/12,5/17,1,1/13,11/15,6/13,2/13,5/6,5/13,2/3,3/13,
		11/12,9/17,1/17,4/5,6/17,11/17}

SubsetsDiffQuadsQ[pt17up]

SubsetsDiffQuadsQ[pt17up-.001]