Morphing Graphics, color and location

Question

I would like to make a small animation :

1-We start with a random distribution of gray points :

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.

Answer 1

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!

Answer 2

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.

Answer 3

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]]

Answer 4

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]

Answer 5

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

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