44
$\begingroup$

edit: Excellent answers have been provided and I made an animation which is suitable for my use, however, all the examples rely on bitmap/rasterized data; is there a vector based approach?

I would like to animate the formation of a voronoi network from a set of semi-random points. 

points = Table[{i, j} + RandomReal[0.4, 2], {i, 10}, {j, 10}]; points = Flatten[points, 1];

The final VoronoiDiagram can be easily plotted with DiagramPlot in the ComputationalGeometry package.

Needs["ComputationalGeometry`"] voronoi = DiagramPlot[points, TrimPoints -> 50, LabelPoints -> False];

I want to animate a series of circles growing outwards uniformly from each of the points until they intersect to form the voronoi network.

ExpandingCircles[r_, points_] := Graphics@{Point /@ points, Circle[#, r] & /@ points} plots = ExpandingCircles[#, points] & /@ {0.1, 0.2, 0.3, 0.4, 0.5}; GraphicsGrid@Partition[Join[plots, {voronoi}], 3]

Mathematica graphics

Similar to that progression but in mine the circles overlap. I want them to stop growing as they hit the adjacent circle to form the voronoi network but I can't figure out how to do this.

Based on @R.M.s pointing out @belisarius answer I've tried this:

GraphicsGrid@ Partition[ ColorNegate@ EdgeDetect@ Dilation[ColorNegate@Binarize@Rasterize@Graphics@Point@points, DiskMatrix[#]] & /@ Range[1, 24, 3], 4]

Mathematica graphics

However, I can't get them to merge into the voronoi structure.

Somewhat like this video (http://www.youtube.com/watch?v=FlkrBSh4514) except all of mine start growing at the same point in time.

Improve this question
$\endgroup$
3
  • 5
    $\begingroup$ There is this very nice answer by belisarius that answers your question. Since he's also active here, I'll wait for him to post that answer here, but do utilize that in the mean time for your work. $\endgroup$ Commented Apr 5, 2012 at 19:52
  • $\begingroup$ @R.M That answer of mine was for a more difficult requirement, because the OP there wanted a final result looking like a "natural" tissue. I think the current answers are ok for this question $\endgroup$ Commented Apr 6, 2012 at 1:06
  • 1
    $\begingroup$ Re the edit: There is a natural vector-based approach. It relies on the fact that each Voronoi cell "belongs" to a specific point. (This is not the case for higher-order Voronoi diagrams.) Therefore, intersecting the disk of radius $r$ around each point $i$ with that point's Voronoi cell produces the desired collection of (non-overlapping) polygons at stage $r$ in the animation. Mathematica is not well suited to computing and displaying intersections of disks and polygons. $\endgroup$ Commented Apr 6, 2012 at 16:05

2 Answers 2

Reset to default
44
$\begingroup$

The first step is to rasterize the points, so let's just start there as an example:

n = 512; g = Image[Map[Boole[# > 0.001] &, RandomReal[{0, 1}, {n, n}], {2}]]

The trick is to exploit the distance image. Almost all the work is done here (and it's fast):

i = DistanceTransform[g] // ImageAdjust // ImageData;

We need a little more precomputation of the final boundaries. Rasterizing a vector-based Voronoi tessellation would be faster, but here's a quick and dirty solution:

mask = Image[WatershedComponents[Image[i]]]

Now the animation is instantaneous: it's done simply by thresholding the distances. (Colorize it if you like.) Have fun!

Manipulate[ ImageMultiply[ Image[MorphologicalComponents[Image[Map[1 - Min[c, #] &, i, {2}]], 1 - c]], mask], {c, 0, 1} ]

enter image description here

Improve this answer
$\endgroup$
4
  • $\begingroup$ Wonderful approach! And how would you add colors to that? I was thinking of using your result as a mask on a colorized Voronoi diagram, would that work? $\endgroup$ Commented Apr 5, 2012 at 21:56
  • $\begingroup$ I haven't tested it--and am out of time today--but I imagine another application of MorphologicalComponents followed by Colorize would do it. $\endgroup$ Commented Apr 5, 2012 at 21:58
  • $\begingroup$ Ah--it's not quite that simple, because the colors determined by Colorize change from frame to frame. Instead, consider colorizing the components of the "mask" itself, and then masking that with the thresholded distances. This will keep the colors constant. Not only that, it will be even faster because each frame requires only a threshold and multiply, nothing more. $\endgroup$ Commented Apr 5, 2012 at 22:05
  • $\begingroup$ This solution is incredible! Thank you so much for it. However, I have been struggling to colorize it using the suggestions in the comments above. Are you able to show how the code needs to be modified for a colored animation? $\endgroup$ Commented Feb 12, 2019 at 0:10
25
$\begingroup$

enter image description here

I know think of at least one way of doing it slowly and in a bitmap approach:

img[p_, r_] := Module[{f, closest, color, colors, n, t}, n = 250; colors = List @@@ {Red, Green, Blue, Yellow, Orange, Pink, RGBColor[0, 0, 0], Cyan, Magenta, Brown, Purple}; color[i_] := Module[{c}, c = colors[[1 + Mod[i, Length@colors]]]; If[i == 0, {1, 1, 1}, c] ]; closest[pt_] := First@Ordering[Norm[pt - #] & /@ p, 1]; Image[Table[Module[{res, pt}, pt = {(i + 0.5)/n, (j + 0.5)/n}; res = closest[pt]; color[If[Norm[pt - p[[res]]] < r, res, 0]] ], {i, 1, n}, {j, 1, n}]] ]

which is then used as:

points = RandomReal[1, {25, 2}]; t = Table[img[points, r], {r, 0.03, 0.4, 0.03}]; Export["growth.gif", t];

What it does is for each point of the graph, determine both what's the closest point in the points set, and whether it's close enough to actually be inside it growth radius. Animate that on a fixed set of points with an increasing radius, and I believe you're there.

Improve this answer
$\endgroup$
0

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.