17
$\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

Improve this question
$\endgroup$
7
  • $\begingroup$ @Kuba fixed the question $\endgroup$
    – M.R.
    Sep 16, 2016 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, 2016 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, 2016 at 17:09
  • 1
    $\begingroup$ related: Generating visually pleasing circle packs $\endgroup$
    – Kuba ♦
    Sep 16, 2016 at 17:22
  • 2
    $\begingroup$ Related: mathematica.stackexchange.com/a/69703/94 $\endgroup$
    – Mark Adler
    Sep 16, 2016 at 17:32

3 Answers 3

Reset to default
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

Improve this answer
$\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

Improve this answer
$\endgroup$
2
  • $\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$
    – Letshin
    Jul 11, 2018 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.'s eventual burnout ♦
    Sep 24, 2018 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.

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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