Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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

enter image description here

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

enter image description here

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

enter image description here

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

share|improve this question
3  
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. –  Yves Klett Mar 23 '12 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. –  rcollyer Mar 23 '12 at 13:27
    
"progressively color themselves" one at a time or all together increasing color intensity? –  Vitaliy Kaurov Mar 23 '12 at 13:46
    
@Vitality, all together I think. –  500 Mar 23 '12 at 13:50
2  
@500, Vitaliy, besides, if you want to do something with physics take a look at: Firework blog –  Yu-Sung Chang Mar 23 '12 at 16:43

5 Answers 5

up vote 22 down vote accepted

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).

Animation

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!

share|improve this answer
    
@Y-Sung, Thank You very Much !!! Do you know how I could export that in a little movie or .gif ? –  500 Mar 23 '12 at 13:58
    
Very nice! I took the liberty to paste some images into place. Please feel free to do this properly. –  Yves Klett Mar 23 '12 at 14:05
    
@Yevs, Nope. Don't mind at all. Thanks –  Yu-Sung Chang Mar 23 '12 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 Mar 23 '12 at 14:13
    
@500, Also, you can try swf (Flash) or mov (QuickTime, in M8) export... –  Yu-Sung Chang Mar 23 '12 at 14:13

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]

enter image description here

share|improve this answer
2  
Uh, Partition plus infix notation makes my head ache, otherwise +1 ;-) –  Yves Klett Mar 23 '12 at 14:36
3  
@YvesKlett That's there solely to get Mr.Wizard's vote ;) –  rm -rf Mar 23 '12 at 14:37
1  
+1 for infix notation. :^) –  Mr.Wizard Mar 24 '12 at 21:02

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

drifting points

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

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.

Animation

share|improve this answer
    
As always, a pleasure to read your answer! :) –  rm -rf Mar 25 '12 at 2:37
    
Same as above ! THank You very much ! –  500 Mar 25 '12 at 16:23

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

img = Import["http://i.stack.imgur.com/7VDkO.gif"];
Image3D[img]

enter image description here

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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