How to generate approximately equally spaced points efficiently
Many solutions similar to how to get $n$ equidistributed points on the unit sphere are possible, especially if one can accept that points are not on the edges of a region. For instance, one can use analytical Lloyd's method:
With[{reg = RegularPolygon[5]},
Nest[RegionNearest[reg][
RegionCentroid@RegionIntersection[reg, #] & /@
MeshPrimitives[VoronoiMesh@#, 2]] &, RandomPoint[reg, 20], 20] //
Graphics[{LightBlue, reg, Black, Point@#}] &]
This is awfully slow, though.
A much faster variant is to use a Monte Carlo method to estimate Voronoi cell centroids:
With[{reg = RegularPolygon[5]},
With[{points = 500, samples = 40000, iterations = 20},
Nest[With[{randoms = Join[#, RandomPoint[reg, samples]]},
RegionNearest[reg][
Mean@randoms[[#]] & /@
Values@PositionIndex@Nearest[#, randoms]]] &,
RandomPoint[reg, points], iterations]] //
Graphics[{LightBlue, reg, Black, Point@#}] &]
A more complex concave example (which benefits from higher iteration count) as suggested by @J.M.:
With[{reg =
Cases[Graphics`PolygonUtils`PolygonData[
"HexaSpiral"], _Polygon, \[Infinity]][[1]]},
With[{points = 500, samples = 40000, iterations = 200},
Nest[With[{randoms = Join[#, RandomPoint[reg, samples]]},
RegionNearest[reg][
Mean@randoms[[#]] & /@
Values@PositionIndex@Nearest[#, randoms]]] &,
RandomPoint[reg, points], iterations]] //
Graphics[{LightBlue, reg, Black, Point@#}] &]
Annealing
Found this to be an interesting question and immediately I thought it to be a good application for simulated annealing.
Here's a little unoptimized annealing function I wrote. The idea is that your points move around like atoms in random directions but they "cool down" over time and move less and settle into a minimum energy configuration state.
My rules are:
- plan a move in a random direction and random distance of maximum length
step
- move only if the distance to the nearest point increases
- move only if the new location is inside the region
Assumes rm is a globally defined RegionMember function.
anneal[pts_, step_] :=
Module[{np, nn, test1, test2, pl, potentialMoves},
pl = Length@pts;
np = Nearest@pts;
nn = np[#, 2][[2]] & /@ pts;
potentialMoves = RandomReal[step, pl]*RandomPoint[Circle[], pl];
test1 =
Boole@Thread[
MapThread[EuclideanDistance[#1, #2] &, {pts, nn}] <
MapThread[
EuclideanDistance[#1, #2] &, {pts + potentialMoves, nn}]];
test2 = Boole[rm /@ (pts + potentialMoves)];
pts + potentialMoves*test1*test2]
Here is an example with 200 pts, 1000 steps and an anneal rate of .995. Initial step should be on the order of the region size:
Clear[x,y];reg=ImplicitRegion[x^2-y^2<=1,{{x,-3,3},{y,-3,3}}];
rm=RegionMember[reg];
pts=RandomPoint[reg,200];
step=1;
Do[pts=anneal[pts,step=.995*step],1000];
Show[RegionPlot[reg],Graphics[{Black,Point/@pts}]]
Here is an animation of the process:
This does not give you real control over the number of points, but its one way to get somewhat equally spaced distribution of points:
region = ConvexHullMesh[RandomReal[1, {100, 2}]];
<< NDSolve`FEM`
elementMesh = ToElementMesh[region, MeshQualityGoal -> 0];
coordinates = elementMesh[[1]];
triangles = elementMesh[[2, 1, 1]];
centers =
Table[
Sum[{coordinates[[triangles[[i, j]], 1]],coordinates[[triangles[[i, j]], 2]]}, {j, 1, 3}]/3
, {i, 1, Length[triangles]}];
Show[region, Graphics[Point[centers]]]
Update
Trivial solution, but seems to be relatively quick:
numberOfPoints = 500;
region = BoundaryDiscretizeGraphics[Text["K"], _Text];
<< NDSolve`FEM`
elementMesh = ToElementMesh[region, MeshQualityGoal -> 0];
coordinates = Transpose[elementMesh[[1]]];
Xmin = Min[coordinates[[1]]];
Xmax = Max[coordinates[[1]]];
Ymin = Min[coordinates[[2]]];
Ymax = Max[coordinates[[2]]];
scale = (Xmax - Xmin + Ymax - Ymin)/2;
spacing = scale/40;
test[x_] := RegionMember[region, x];
points := DeleteCases[
Flatten[Table[ If[test[{i, j}], {i, j}, -1], {i, Xmin, Xmax, spacing}, {j, Ymin, Ymax, spacing}], 1]
, -1];
(
data = Table[{1/(spacing = ii scale/300), points // Length} // Reverse, {ii, 10, 20}];
fun[x_] = NonlinearModelFit[data, a + b x^(1/2), {a, b}, x] // Normal;
spacing = 1/fun[numberOfPoints];
(pts = points) // Length
) // AbsoluteTiming
Show[region, Graphics[Point[pts]]]
{0.187837, 505}
We can see that within 0.188
seconds we have generated a distribution of 505
points where we tried to generate a 500
points distribution. The error in number of points is always just a few percent at the most.