Random particle motion

Question

I have a foundational function that allows me to simulate particles moving in a box according to some movement function. The code is here:

obj[{xfunc_, yfunc_}, rad_, lag_, npts_][x_] := 
 MapThread[{Opacity[#1, ColorData["SunsetColors", #1]], 
    Disk[{xfunc@#2, yfunc@#2}, rad Exp[#1 - 1]]} &, 
  Through[{Rescale, Identity}[Range[x - lag, x, lag/npts]]]]

frames = Most@
   Table[Overlay[
     Table[Graphics[
        obj[{Sin[2 #] + RandomReal[] &, Sin[3 #] &}, 0.1, 1, 500][u], 
        PlotRange -> {{-2, 2}, {-2, 2}}, Axes -> False, 
        ImageSize -> 300, Background -> Black]~Blur~3, {particlenumber, 1, 
       2}]], {u, 0, 2 Pi, 0.1}];

Currently, I have Sin[2 #]+RandomReal[] and Sin[3#] as movement functions, and this works fine.

However, I would like to have a random particle motion.

Question: How can I replace my current movement functions with ones that will generate random, continuous motion for my particles?

Answer 1

There are endless possibilities to model random movement. Let me show an easy one that fits into your current code. You have two functions xfunc and yfunc that define the movement of your particle. Currently, you are using a combination of two sine's which gives something similar to a Lissajous curve.

What you could do instead, is to use random points. So instead of a smooth sine-curve for the x- and y-movement, you use a set of random points and interpolate between them. The curve for the e.g. x-movement could then look like this

ListLinePlot[RandomReal[{-2, 2}, {20}]]

There are some things to consider: For a nice loop, you probably want your interpolation to be periodic so that you end where you start. A linear interpolation like the above gives you hard turns in your particles. For a smoother version you can e.g. use one of the two monotonic, periodic interpolations that @J.M. described here.

Let me use the FritschCarlson method here

FritschCarlsonPeriodicInterpolation[data_?MatrixQ] := 
 Module[{dTrans = Transpose[data], del, h, m}, 
  h = Differences[First[dTrans]]; del = Differences[Last[dTrans]]/h;
  m = If[Equal @@ Sign[Last[#]] && And @@ Thread[Last[#] != 0], 
      3 Total[First[#]]/Total[({{1, 2}, {2, 1}}.First[#])/Last[#]], 
      0] & /@ Transpose[{Partition[h, 2, 1, {-1, 1}], 
      Partition[del, 2, 1, {-1, 1}]}];
  Interpolation[
   MapThread[Append[MapAt[List, #1, 1], #2] &, {data, m}], 
   PeriodicInterpolation -> True]]

To create a random periodic function with the above function, we create a table of n points (we pay attention, that the first point is also the last point).

makeRandomFunc[{t0_, t1_}, {ymin_, ymax_}, n_] := 
 With[{dt = (t1 - t0)/(n - 1)},
  FritschCarlsonPeriodicInterpolation[
   Append[#, {t1, #[[1, 2]]}] &@
    Table[{t, RandomReal[{ymin, ymax}]}, {t, N@t0, t1 - dt, dt}]]
  ]

Now, we can create new movement functions, that don't leave your box of {-2,2}. I'm using t from -1 to 0 to fit in what you already have

{xfunc, yfunc} = Table[makeRandomFunc[{-1, 0}, {-2, 2}, 20], 2]

The rest is basically your code. I just removed some parts and rasterized the graphics which usually gives better performance when you view the animation

obj[{xfunc_, yfunc_}, rad_, lag_, npts_][x_] := 
 MapThread[{Opacity[#1, ColorData["SunsetColors", #1]], 
    Disk[{xfunc@#2, yfunc@#2}, rad Exp[#1 - 1]]} &, 
  Through[{Rescale, Identity}[Range[x - lag, x, lag/npts]]]]

frames = Most@
   Table[Rasterize@
      Graphics[obj[{xfunc, yfunc}, 0.1, .1, 500][u], 
       PlotRange -> {{-2, 2}, {-2, 2}}, Axes -> False, 
       ImageSize -> 300, Background -> Black]~Blur~3, {u, 0, 1, 
     0.01}];