How to get a specified number of points that are nearly equally spaced in a closed rectangle

Question

TriangulateMesh is almost the right tool for this problem. For example,

numb = 113;
region = BoundaryMeshRegion[{{0, 0}, {3, 0}, {3, 1}, {0, 1}}, Line[{1, 2, 3, 4, 1}]];
mesh = TriangulateMesh[region, MaxCellMeasure :> RegionMeasure[region]/numb]

Then I can do the following:

points = MeshCoordinates @ mesh;
Graphics @ Point @ points

Length @ points
 102

However, 113 points were desired, and this approach will always (or almost always) find slightly fewer points than what were desired. Is there an efficient way to get exactly the desired number of points? Perhaps we can spelunk the TriangulateMesh algorithm and use undocumented-internal functions to subdivide the largest cells to get the desired number of points.

This wolfram blog post by @silvia is definitely worth a look — gpap, Jan 30 '17 at 10:20
Do you desire points to be "stuck" on the boundary? (That is: "is the convex hull of the solution points EQUAL to the rectangle you are trying to fill?") Or may points be off-boundary? In the latter case, does the "distance from a point near the edge to its nearest edge" matter? — Dan H, Jun 01 '18 at 19:54

score 20 · Accepted Answer · edited Jan 29 '17 at 17:07

20

There is a neat (and widely known) trick to produce n approximately evenly distributed points in a disk, or on any surface of revolution. Points are placed on a spiral, each time turning by the "golden angle". The reference is:

Vogel, H (1979). "A better way to construct the sunflower head". Mathematical Biosciences. 44 (44): 179–189.4.

We can adapt the same thing to a rectangle by "wrapping the $x$ coordinate around".

Let r be the aspect ratio of the rectangle (height/width) and n the number of points. Then use

r = 1.5;
n = 150;

Graphics[
 Point@Table[{Mod[k/GoldenRatio, 1], r k/n}, {k, 1., n}]
]

The nice thing about this arrangement is that the points will look approximately equally spaced regardless of the aspect ratio. You can compress or stretch the rectangle along either axis and they will still look equally spaced.

edited Jan 29 '17 at 17:07

J. M.'s missing motivation

124,525
11
401
574

answered Jan 28 '17 at 23:11

Szabolcs

234,956
30
623
1,263

2

The "phyllotactic" arrangement of points was also featured on the Wolfram Blog. Here's a slightly simplified version: With[{n = 150, w = 2, h = 3}, Graphics[Point[N @ Table[{Mod[w k (GoldenRatio - 1), w], h k/n}, {k, n}]]]] – J. M.'s missing motivation Jan 29 '17 at 11:55
Extra points for the "squishing" animation... and it's true that this operation preserves the equality of the edges connecting the nodes... HOWEVER it does fly in the face of "preserving the equidistance" because the "diagonal distance" ("across" a cell) soon becomes noticeably smaller than the original "edge" length. – Dan H Jun 01 '18 at 19:27

score 9 · Answer 2 · edited Apr 13 '17 at 12:55

Lloyd relaxation (previously featured here) gives a "nice" point distribution:

pts = With[{n = 150, w = 2, h = 3,
            maxit = 50, (* maximum iterations *)
            tol = 0.001 (* distance tolerance *)},
           FixedPoint[Function[pts, 
                               Block[{cells, ci, vm},
                                     vm = VoronoiMesh[pts, {{0, w}, {0, h}}];
                                     cells = MeshPrimitives[vm, "Faces"];
                                     ci = Region`Mesh`MeshMemberCellIndex[vm];
                                     RegionCentroid /@ cells[[ci[pts][[All, -1]]]]]], 
                      RescalingTransform[{{0, 1}, {0, 1}}, {{0, w}, {0, h}}] @
                      RandomReal[1, {n, 2}], maxit, 
                      SameTest -> (Max[MapThread[EuclideanDistance, {#1, #2}]] < tol &)]];

Graphics[Point[pts]]

Lloyd-relaxed points

score 6 · Answer 3 · edited Apr 13 '17 at 12:55

My implementation of the Poisson-disc distribution from this answer perhaps fits the bill:

findBestCandidate[samplePoints_, nrOfCandidates_, {w_, h_}] :=
Module[{nearestFunction, candidates},
  nearestFunction = Nearest[samplePoints];
  candidates = Transpose[{RandomInteger[{1, w}, nrOfCandidates],
                          RandomInteger[{1, h}, nrOfCandidates]}];
  Last @ SortBy[candidates, Norm[# - First @ nearestFunction @ #] &]
  ]

sample[nrOfSamplePoints_, nrOfCandidates_, {w_, h_}] := Nest[
  # ~Append~ findBestCandidate[#, nrOfCandidates, {w, h}] &,
  {{RandomInteger[w], RandomInteger[h]}},
  nrOfSamplePoints - 1
  ]

We can use it like this:

sample[113, 100, {3000, 1000}] // Point // Graphics

Mathematica graphics

113 is the number of points, and 100 is the number of iterations allowed to find the best position (so the higher number, the better), and {3000, 1000} is the size of the grid. The size of the grid controls the resolution (also in this case, the higher the better).

How to get a specified number of points that are nearly equally spaced in a closed rectangle

3 Answers3

Linked