How to generate random dots with given distances?

Question

I am interested in the following problem, and am curious if Mathematica could be used to solve it.

I start with a radius function $\rho:D\to \mathbf{R}_{\ge 0}$ on a region $D\subseteq \mathbf{R}^n$. Fix $r_2>r_1$ and a finite subset $S_0\subset D$ of points.

Problem: I am interested randomly in generating a fairly large set $S\supset S_0$ of dots $x_i$ in $D$ such that $$|x_i-x_j|\ \not\in\ [\rho(x_i)r_1,\rho(x_i)r_2]$$ for all $i\ne j$.

There are lots of example uses of Mathematica generating a random set of points, but I am not sure how to alter these solutions to include this condition on the distances between the points.

To be extremely precise for the sake of argument, take for instance $D=[0,1]^2\subseteq \mathbf{R}^2$ with $r_1=1$, $r_2=2$ and radius function $\rho(x,y)=x^2+xy+y^2.$

Answer 1

This (I hope after discussion with OP), is closer to what is desired. This does not scale well (not >100 points). I just use euclidean norm but this could be changed.

I only post it in case it motivates others.

rand[n_, a_, b_] := Module[{r = RandomReal[{0, 1}, {n, 2}], rg, cl},
  rg = RelationGraph[
    Not[a < EuclideanDistance[#1, #2] < b && 
       EuclideanDistance[#1, #2] != 0] &, r];
  cl = First@FindClique[rg];
  Graphics[{Red, Point[r], Black, PointSize[0.03], Point[#]} & /@ cl, 
   Axes -> True, PlotRange -> {{0, 1}, {0, 1}}, Frame -> True]]

The red points are the original points and the black over red points are those that comply with constraint.

Illustrating this:

Manipulate[
 With[{plot = rand[100, a, a + b]}, 
  Manipulate[
   Show[plot, 
    Graphics[{Circle[p, a], Circle[p, a + b]}]], {p, {0.5, 0.5}, 
    Locator, Appearance -> "+"}]], {a, {0.05, 0.1, 0.2}, 
  PopupMenu}, {b, {0.1, 0.2, 0.3}, PopupMenu}]

Answer 2

Here is a brute-force approach (which is essentially a poor copy of @ubpdqn 's answer):

SeedRandom[12345];
(* Set parameters *)
f[r_, {x_, y_}] := r (x^2 + x y + y^2)
r1 = 0.1;
r2 = 0.3;
(* Number of points to select *)
n = 50;
(* Array to store sequential plots *)
plt = ConstantArray[0, n];
(* Initial point )
pts = {RandomVariate[UniformDistribution[{0, 1}], 2]};
noPts = {};
m = 100;  ( Fineness of grid showing area where no points can be selected )
( Create a list of points on a fine grid that can no longer be selected *)
Do[Do[status = True;
  If[f[r1, {i/m, j/m}] <= Norm[{i/m, j/m} - pts[[1]]] <= f[r2, {i/m, j/m}], status = False];
  If[status == False, noPts = Join[noPts, {{i/m, j/m}}]], {i, m}], {j, m}];
plt[[1]] = 
  ListPlot[{pts, noPts, pts}, PlotRange -> {{0, 1}, {0, 1}}, AspectRatio -> 1, 
   PlotStyle -> {{Blue, PointSize[0.01]}, {Gray, PointSize[0.005]}, {Red, PointSize[0.02]}}, Frame -> True];
(* Selete points 2 through n )
Do[good = False; ( Initial status of potential sample point )
 While[! good,
  {x0, y0} = RandomVariate[UniformDistribution[{0, 1}], 2];
  status = True;  ( 
  Assume status of potential sample point is true until proven otherwise )
  ( Check on relationship with all other points *)
  Do[If[f[r1, {x0, y0}] <= Norm[{x0, y0} - pts[[j]]] <= 
     f[r2, {x0, y0}], status = False], {j, 1, h - 1}];
  If[status, good = True; pts = Join[pts, {{x0, y0}}]]];
(* Highlight locations where the next point cannot occur *)
 noPts = {};
 m = 100;
 Do[Do[status = True;
   Do[If[f[r1, {i/m, j/m}] <= Norm[{i/m, j/m} - pts[[k]]] <= f[r2, {i/m, j/m}], status = False], 
   {k, h}];
   If[status == False, noPts = Join[noPts, {{i/m, j/m}}]], {i, m}], {j, m}];
(* Create plot of currently sampled points and the area that can no longer be sampled *)
 plt[[h]] = ListPlot[{pts, noPts, {pts[[h]]}}, PlotRange -> {{0, 1}, {0, 1}}, 
   AspectRatio -> 1, 
   PlotStyle -> {{Blue, PointSize[0.01]}, {Gray, PointSize[0.005]}, {Red, PointSize[0.02]}}, Frame -> True],
{h, 2, n}]

The red dot represents the currently sampled point and the blue dots are all of the previously sampled points. The smaller gray dots represent the area than can no longer be sampled due to the restrictions imposed.