16
$\begingroup$

I need to generate an image of $n$ randomly sized but non-overlapping blobs in a fixed rectangular region; for example, a square of 300 pixels.

The blobs could be disks to keep things simple. The non-overlapping part is tricky; this is what I have so far:

Clear @ pair;
pair[n_] := Module[{pts=RandomReal[1,{n,2}]},
    Image @ Rasterize[Graphics[{{PointSize@RandomReal[{0,.5}],Point[#]}&/@pts},
        PlotRange->{{0,1},{0,1}},PlotRangePadding->Scaled[.1]],
        ImageSize->300]->n
]

As you can see the ten disks are overlapping:

my attempt

$\endgroup$
  • $\begingroup$ @Kuba fixed the question $\endgroup$ – M.R. Sep 16 '16 at 17:01
  • 1
    $\begingroup$ What is the question? It seems fairly clear that the code shown will generate blobs, and that there is nothing to force them to not overlap.Are you looking for advice on how to separate them? How to generate and accept/reject based on overlap? Something else? $\endgroup$ – Daniel Lichtblau Sep 16 '16 at 17:05
  • $\begingroup$ The question is, how to create an mxm image with n non-overlapping disks of varying size. $\endgroup$ – M.R. Sep 16 '16 at 17:09
  • 1
    $\begingroup$ related: Generating visually pleasing circle packs $\endgroup$ – Kuba Sep 16 '16 at 17:22
  • 2
    $\begingroup$ Related: mathematica.stackexchange.com/a/69703/94 $\endgroup$ – Mark Adler Sep 16 '16 at 17:32
20
$\begingroup$

Just a quick modification of the code here,

distinctDisks[n_, range_:{0, 1}, radiusRange_:{0.03, 0.15}] := Module[
     {d, f, p, r},
      d = {Disk[RandomReal[range, 2], RandomReal[radiusRange]]};
      Do[f = RegionDistance[RegionUnion @@ d];
       While[
        r = RandomReal[radiusRange];
        p = RandomReal[range, 2];
        f[p] < r];
       d = Append[d, Disk[p, r]], {n - 1}];
      d]

distinctDisks[25, {0, 5}, {0, 2}] // Graphics

Mathematica graphics

$\endgroup$
9
$\begingroup$

Here's my take. It should work in earlier versions that do not yet have region-related functionality:

distinctDisks[n_Integer?Positive, {xmin_, xmax_}, {ymin_, ymax_}, {rmin_, rmax_}] := 
    Module[{df = Max[0, EuclideanDistance[#1[[1]], #2[[1]]] - (#1[[2]] + #2[[2]])] &,
            dlist = {}, k = 0, c, d, r},
           While[c = RandomReal /@ {{xmin, xmax}, {ymin, ymax}};
                 r = RandomReal[{rmin, rmax}]; 
                 If[k == 0 || (Min[c[[1]] - xmin, xmax - c[[1]],
                                   c[[2]] - ymin, ymax - c[[2]]] > r && 
                               df[First[Nearest[dlist, d = Disk[c, r],
                                                DistanceFunction -> df]], d] > 0),
                    k++; AppendTo[dlist, d]]; k < n]; dlist]

An example:

BlockRandom[SeedRandom["many disks"]; (* for reproducibility *)
            Graphics[Riffle[distinctDisks[150, {0, 5}, {0, 3}, {1/20, 3/2}], 
                            Unevaluated[ColorData[61, RandomInteger[{1, 9}]]],
                            {1, -2, 2}], PlotRange -> {{0, 5}, {0, 3}}]]

randomly placed disks

$\endgroup$
  • $\begingroup$ Hi, sorry for necroing this but I came across this post and after checking the timing found your solution to be fastest. I'm going through the code trying to understand it and was wondering if you could explain the If function in the code. In particular, I'm not sure what "df[First[Nearest[dlist, d = Disk[c, r], DistanceFunction -> df]], d] > 0)" does. Thanks. $\endgroup$ – Zhao Jul 11 '18 at 19:14
  • $\begingroup$ @Zhao, you can break it up into steps: d = Disk[c, r] is the candidate disk being tested for inclusion into dlist. From there, Nearest[dlist, d, DistanceFunction -> df] uses the metric function df to pick out which of the disks already in dlist are nearest to d. You then compute the "distance" of that (after applying First[]) from d with df. The positivity condition implies that d should not intersect the nearest disk, before it can be included into dlist (AppendTo[dlist, d]). $\endgroup$ – J. M. is away Sep 24 '18 at 11:13
5
$\begingroup$

I have to say, I have seen this question many times in SE, but it's difficult for me to find the duplicate post. Thus, I post my answer again:

disk = Reap[
   region = 
    RegionUnion[
     BoundaryDiscretizeGraphics[
        CountryData[#, "Polygon"]] & /@ {"China", "Taiwan"}]; 
   Do[p = RandomPoint[region]; 
    rad = If[(tem = Abs[SignedRegionDistance[region, p]]) < .2, tem, 
      RandomReal[{.2, 
        Min[{tem, Min@(Subtract @@ RegionBounds@region)/40}]}]]; 
    region = 
     RegionDifference[region, DiscretizeRegion@Sow[Disk[p, rad]]], 
    2500]][[-1, -1]]; Graphics[
 Transpose[{RandomColor[
    Hue[1/3, NormalDistribution[.6, .2], NormalDistribution[.6, .07]],
     disk // Length], disk}]]

enter image description here

It is composed of 2500 disks. This low-efficiency code's main time is taken up by RegionDifference. But you can produce any shape by changing region.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.