Morphing Graphics, color and location

I would like to make a small animation :

Graphics[{
Black, Rectangle[{-2, -2}, {2, 2}],
Gray,Point /@ RandomReal[{-2, 2}, {4000, 2}]},
PlotRange -> {{-2, 2}, {-2, 2}}]


2-Then I would like that those points progressively color themselves to obtain the following :

Graphics[{
Black, Rectangle[{-2, -2}, {2, 2}],
Pink,Point /@ RandomReal[{-2, 2}, {1000, 2}],
RGBColor[.4, .4, 1],Point /@ RandomReal[{-2, 2}, {1000, 2}],
Green,Point /@ RandomReal[{-2, 2}, {1000, 2}],
Yellow,Point /@ RandomReal[{-2, 2}, {1000, 2}]},
PlotRange -> {{-2, 2}, {-2, 2}}]


Ideally : -the points progressively adopt the color. All at the same time, at the same rate (2 seconds ?) -OR each points suddenly change color but just 100 at a time.

3-Finally, once the point are colored i would like to see them move, to join their piers like such :

 normalRDN[μ_, σ_, No_] :=
RandomVariate[NormalDistribution[μ, σ], No]

Graphics[{
Black, Rectangle[{-2, -2}, {2, 2}],
Pink,Point /@ ((normalRDN[#, .5, 1000] & /@ {-1, -1})\[Transpose]),
RGBColor[.4, .4, 1],Point /@ ((normalRDN[#, .5, 1000] & /@ {-1, 1})\[Transpose]),
Green,Point /@ ((normalRDN[#, .5, 1000] & /@ {1, -1})\[Transpose]),
Yellow,Point /@ ((normalRDN[#, .5, 1000] & /@ {1, 1})\[Transpose])},
PlotRange -> {{-2, 2}, {-2, 2}}]


I am not sure of the means available for doing such animations, thus my illustrative codes might not be relevant.

• Which law should define the movement? Probably the easiest way would to start with your "ordered" version (last image) and define random displacements for each colored dot. Interpolation in between should be not too complicated. Commented Mar 23, 2012 at 13:18
• @YvesKlett starting with the end product would work, but I think starting at the random distribution would work, also. That said, I'd probably use simple kinematics with a color dependent gravity and a heavy damping force (to overdamp out the oscillations), and have each colored dot attracted to a "dark mass" near each corner. To give some additional spatial distribution, I'd also add a repulsive force between dots of the same color. Commented Mar 23, 2012 at 13:27
• "progressively color themselves" one at a time or all together increasing color intensity? Commented Mar 23, 2012 at 13:46
• @Vitality, all together I think.
– 500
Commented Mar 23, 2012 at 13:50
• @500, Vitaliy, besides, if you want to do something with physics take a look at: Firework blog Commented Mar 23, 2012 at 16:43

Try a simple way. Typical key frame animation is done by nothing more than n-degree interpolation (and n is usually 1), and they look quite reasonable.

Here is how I would tackle (it is generic version, so individual points have its own colors).

1. Define "start" and "final" positions:

startPos = RandomReal[{-2, 2}, {4000, 2}];

normalRDN[μ_, σ_, No_] := RandomVariate[
NormalDistribution[μ, σ], No];

(* Tuples does the neat trick to create corner points *)
finalPos = Join @@ Table[((normalRDN[#, .5, 1000] & /@ c)\[Transpose]),
{c, Tuples[{-1, 1}, 2]}];

2. Define "start" and "final" colors as a list of triples:

startCol = Table[0.5, {4000}, {3}];

finalCol = Join[Table[{1., .5, .5}, {1000}], Table[{.4, .4, 1.}, {1000}],
Table[{0., 1., 0.}, {1000}], Table[{1., 1., 0.}, {1000}]];
(* Numericize them to make sure that the end results are all nicely packed. *)

3. Define "duration" functions: a function from time to [0, 1]

locationDuration[t_] := Piecewise[{{0, t < 2},
{0.5 t - 1, 2 <= t < 4}, {1, True}}]

colorDuration[t_] := Piecewise[{{0, t < 0}, {0.5 t, 0 <= t < 2}, {1, True}}]


They are just piecewise linear functions, but you can find your own (such as CDF--much smooth) or try random perturbation.

4. Define "easing" function: Interpolating from start to end values with duration

easing[t_, f_, sPos_, fPos_] := (1 - f[t]) sPos + f[t] fPos;


Again, it can be more sophisticated, but usually linear is OK.

5. Put them together: The key here is usage of VextexColors; very effective way to change colors.

Manipulate[
Graphics[Point[easing[t, locationDuration, startPos, finalPos],
VertexColors -> easing[t, colorDuration, startCol, finalCol]],
PlotRange -> 2, Background -> Black], {t, -0.5, 4.5, Animator,
AnimationRepetitions -> 1}]


Here is the result (tiny).

Forget to mention that when you are using VertexColors, it doesn't get antialiased by default unlike other 2D graphics (true for Polygon too). It may result in square points, not circular points. You may want to turn on the hardware AA in Preference->Appearance->Graphics. One way to avoid (if your graphics hardware does not support AA) is to use color directive separately for each color group.

Thanks!

• @Y-Sung, Thank You very Much !!! Do you know how I could export that in a little movie or .gif ?
– 500
Commented Mar 23, 2012 at 13:58
• Very nice! I took the liberty to paste some images into place. Please feel free to do this properly. Commented Mar 23, 2012 at 14:05
• @Yevs, Nope. Don't mind at all. Thanks Commented Mar 23, 2012 at 14:12
• Make a Table of the frames then use ListAnimate and finally Export["animation.gif",p] where p is the output of ListAnimate.
– VLC
Commented Mar 23, 2012 at 14:13
• @500, Also, you can try swf (Flash) or mov (QuickTime, in M8) export... Commented Mar 23, 2012 at 14:13

The contribution of this reply is to suggest that an interesting sequence can be created by running the animation in reverse: begin with the final (relatively ordered, highly colored, low-entropy) state and let it evolve physically so it "blows up." Then let the points gradually lose their colors. This needs no interpolation to perform.

The basic functions are few: step to create the next stage of the forward motion, desaturate to turn all colors a little grayer, and display to plot one frame. In the following implementation, step utilizes a more basic function, move, which displaces a single point. It is responsible for keeping the points within bounds. (For convenience, the bounds turn out to be the rectangle $[1,3] \times [1,3]$.)

As an example, let's let the points diffuse (a Brownian motion).

ClearAll[move, step, desaturate, display];
move[Point[{x_, y_}], {dx_, dy_}] :=
Point[{If[1 <= x + dx <= 3, x + dx, x - dx], If[1 <= y + dy <= 3, y + dy, y - dy]}]


(move displaces {x,y} by {dx,dy}, optionally reversing either of both of dx and dy in an effort to stay within the box.)

step[p_List, e_] := With[
{dp = Table[RandomReal[{-e, e}, {Length[p[[i]]], 2}], {i, 1, 4}]},
ParallelTable[MapThread[move, {p[[i]], dp[[i]]}], {i, 1, 4}]
];


(step generates random small displacements of up to e in any direction and then applies them to a set of points via move.)

desaturate[RGBColor[r_, g_, b_], e_] := With[{m = 0.6},
RGBColor @@ ({r, g, b} (1 - e) + e {m, m, m})];
desaturate[c_List, e_] := desaturate[#, e] & /@ c;


(desaturate mixes a color with a little bit of gray.)

display[p_, colors_] :=
Graphics[{Black, Rectangle[{1, 1}, {3, 3}],  Riffle[colors, p]}, ImageSize -> 200]


That's all we need. Here's how the pieces can be used.

Create the initial (ultimately final) state.

n = 200;
colors = {Blue, Yellow, Red, Green};
points = Flatten[
MapIndexed[Function[{xy}, Point[xy + #2]] /@ #1 & ,
RandomReal[BetaDistribution[2, 2], {2, 2, n, 2}], {2}], 1];


Diffuse the points.

frames1 =
ParallelMap[display[#, colors] &, stage1 = NestList[step[#, 0.075] &, points, 192]];


Turn them gray.

frames2 =
ParallelMap[display[Last[stage1], #] &, NestList[desaturate[#, 0.1] &, colors, 64]];


Assemble the animation and reverse it.

ca inserts some pauses at the beginning, middle, and end.

ca = Function[{s, i}, ConstantArray[s[[i]], 16]];
ListAnimate[
Join[ca[frames1, 1], frames1, ca[frames1, -1], frames2, ca[frames2, -1]] // Reverse]


The reverse diffusion is so random and undirected that it looks pretty amazing when all the points coalesce at the end.

– rm -rf
Commented Mar 25, 2012 at 2:37
• Same as above ! THank You very much !
– 500
Commented Mar 25, 2012 at 16:23

How about using a random walk? Starting from an initial list of random points pts0 we're creating a random walk by moving each point over a distance dr in an arbitrary direction at each time step. Since the points should drift towards a centre we also apply a force to each point depending on the distance of the point to the centre given by force. The parameter df indicates the strength of the force. Then pts[[i, All, j]] is the random walk for point j of colour i.

dim = {{-1, 1}, {-1, 1}};
dr = .1;
df = .08;
nn = 1000;
tsteps = 40;
force[pt_, p0_] := (p0 - pt)/Sqrt[2]
p0 = Tuples[{-0.5, .5}, 2];
pts0 = RandomReal[{-1, 1}, {4, nn, 2}];
cols = {Yellow, Green, Blue, Red};
angs = RandomReal[2 Pi, {4, tsteps, nn}];
pts = Table[FoldList[# + (dr {Cos[#], Sin[#]} & /@ #2) + (df force[#,
p0[[i]]] & /@ #) &, pts0[[i]], angs[[i]]], {i, 4}];


We could use pts directly to create an animation, but for a smoother effect we're moving the points along bspline curves spanned by the random paths

curves = Table[BSplineFunction[#] & /@ Transpose[pts[[i]]], {i, 4}];
pts1 = Table[curves[[i, j]][x], {i, 4}, {x, 0, 1, .005}, {j, nn}];


Then plotting the points for each time step gives:

grlist = Table[Graphics[{PointSize[.001],
Table[{cols[[i]], Point[pts1[[i, t]]]}, {i, 4}]},
PlotRange -> dim, Background -> Black, ImageSize -> 150],
{t, 1, Length[pts1[[1]]], 1}];


Edit

For the transition from grey to coloured points we're using a blend of GrayLevel[.5] with the appropriate colours:

col[t_, i_] := Blend[{GrayLevel[.5], cols[[i]]}, t]
dt = .005;
grlist0 = Table[Graphics[{PointSize[.001],
Table[{col[t, i], Point[pts0[[i]]]}, {i, 4}]},
Background -> Black, ImageSize -> 150, PlotRange -> dim],
{t, 0, 1, dt}];


Here, dt is the rate at which the colours change from gray to colour. By joining grlist0 and grlist, and exporting everything to a .gif we get

Export["drift_small.gif", Join[grlist0, grlist]]


• this is so smooth ! Any way to start with Gray points ?
– 500
Commented Mar 24, 2012 at 16:40
• sorry, i have tried unsuccessfully to adapt other solutions strategy for color :-(
– 500
Commented Mar 24, 2012 at 18:11
• @500 I've added blending to my answer. Commented Mar 24, 2012 at 18:44
• As usual you make something extra pretty. Commented Mar 24, 2012 at 21:04

Yu-Sung has answered your question well. Here is my approach which is slightly different in some aspects, but the basic idea is nevertheless the same.

First generate the list of points and graphics for the first part:

pts1 = RandomReal[{-2, 2}, {4000, 2}] ~Partition~ 4 // Transpose;
g1 = Graphics[{Black, Rectangle[{-2, -2}, {2, 2}], Gray,
Point[pts1 ~Flatten~ 1]}, PlotRange -> {{-2, 2}, {-2, 2}}];
g2 = Graphics[{
{Black, Rectangle[{-2, -2}, {2, 2}]},
{Red, Point[#1]}, {Blue, Point[#2]},
{Green, Point[#3]}, {Yellow, Point[#4]}},
PlotRange -> {{-2, 2}, {-2, 2}}] & @@ pts1;


For the transition from grayscale to colour, I use ImageCompose with varying alpha levels to simulate the transition.

frames1 = Table[ImageCompose[Image@g1, {Image@g2, α}], {α, 0, 1, 0.05}];


For the second part, we generate points from a multivariate distribution as:

pts2 = RandomVariate[MultinormalDistribution[#, 0.25 IdentityMatrix[2]],
{1000}] & /@ Tuples[{-1, 1}, 2];


Note that I constructed pts1 and pts2 to have the same shape, so now I can simply pair them up and transition with a linear path and generate frames:

path[pt1_, pt2_, t_] := (1 - t) pt1 + t pt2
frames2 = Table[Graphics[{
{Black, Rectangle[{-2, -2}, {2, 2}]},
{Red, Point[#1]}, {Blue, Point[#2]},
{Green, Point[#3]}, {Yellow, Point[#4]}},
PlotRange -> {{-2, 2}, {-2, 2}}] & @@ path[pts1, pts2, t], {t, 0, 1, 0.05}];


Combining the two and exporting, you get:

Export["morph.gif", frames1 ~Join~ frames2]


• Uh, Partition plus infix notation makes my head ache, otherwise +1 ;-) Commented Mar 23, 2012 at 14:36
• @YvesKlett That's there solely to get Mr.Wizard's vote ;)
– rm -rf
Commented Mar 23, 2012 at 14:37

I nice 3D effect of the particles evolution using Image3D on @Heike's gif.

img = Import["https://i.sstatic.net/7VDkO.gif"];
Image3D[img]