28
$\begingroup$

It has been 12 years since @simon-woods created this fascinating animation an invented a boids model which is more efficient than typical ones. Code is extremely short an elegant:

enter image description here

n = 1000;
r := RandomInteger[{1, n}];
f := (#/(.01 + Sqrt[#.#])) & /@ (x[[#]] - x) &;
s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r];
x = RandomReal[{-1, 1}, {n, 2}];
{p, q} = RandomInteger[{1, n}, {2, n}];
Graphics[{PointSize[0.007], Dynamic[If[r < 100, s];
Point[x = 0.995 x + 0.02 f[p] - 0.01 f[q]]]}, PlotRange -> 2]

QUESTION: post modifications of this code that produce NEW interesting behavior. Modifications can range from simple parameter change to completely different code of boids. The only requirement is the boids behavior should be somehow different. The most interesting behavior / animation wins.

Simon's explanation:

The latest way I have found to use my expensive math software for frivolous entertainment is this. Here's is a way to describe it.

  • 1000 dancers assume random positions on the dance-floor.
  • Each randomly chooses one "friend" and one "enemy".
  • At each step every dancer
    • moves 0.5% closer to the centre of the floor
    • then takes a large step towards their friend
    • and a small step away from their enemy.
  • At random intervals one dancer re-chooses their friend and enemy

Randomness is deliberately injected.

Background: I had read somewhere that macro-scale behaviour of animal swarms (think of flocks of starlings or shoals of herring) is explained by each individual following very simple rules local to their vicinity, essentially 1) try to keep up and 2) try not to collide. I started trying to play with this idea in Mathematica, but it was rather slow to identify the nearest neighbours of each particle. So I wondered what would happen if each particle acted according to the locations of two other particles, regardless of their proximity. The rule was simply to move away from one and towards the other.

The contraction (x = 0.995 x) was added to prevent the particle cloud from dispersing towards infinity or drifting away from the origin. I tweaked the "towards" and "away" step sizes to strike a balance between the tendency to clump together and to spread apart (if you make the step sizes equal you get something more like a swarm of flies). With each particle's attractor and repeller fixed, the system finds a sort of dynamic equilibrium, so to keep things changing I added a rule to periodically change the attractor and repeller for one of the particles. The final adjustment was to make the "force" drop towards zero for particles at very close range. This helps to stop the formation of very tight clumps, and also prevents a division-by-zero error when a particle chooses itself as its attractor or repeller.

The description of the system as a dance was an attempt to explain the swirling pattern on the screen without using mathematical language. I'd love to see what other "dances" can be created with other simple rules.

Improve this question
$\endgroup$
0

4 Answers 4

Reset to default
21
+500
$\begingroup$

A very simple change to @Vitaliy_Kaurov' code. One of the boids becomes "it"

boids simulation with "it"

SeedRandom[-1];
n = 2000;
r := RandomInteger[{1, n}];
f := (#/(.01 + Sqrt[# . #])) & /@ (x[[#]] - x) &;
s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r];
x = RandomPoint[Disk[], n];
v = ConstantArray[{0, 0}, n];
{p, q} = RandomInteger[{1, n}, {2, n}];
it = ConstantArray[r, n]; (*everyone's friend*)

viz:

Graphics[
 {PointSize[0.005],
  Dynamic[
   If[r < 100, s; it = ConstantArray[r, n] ];
   Point[
    x = 0.995 x + 0.02 f[p] - 0.01 f[q] +
    .0002 f[it] (*everyone's friend*)
    ]
   ]
  },
 PlotRange -> 1]

draw with colors:

draw[x_, v_] :=
 With[{colors = 
    ColorData["Rainbow"][Clip[Rescale[#, {0.001, .01}]]] & /@ 
  (Norm /@
        v)},
  Graphics[
   {PointSize[0.01], Opacity[0.8],
    MapThread[
     {#1, Point[#2]} &, {colors, x}]},
   PlotRange -> 1, ImageSize -> 300]
  ]

Adding inertia to the boids by averaging current and last velocity

enter image description here

enter image description here

Graphics[
 {PointSize[0.005],
  Dynamic[
   If[r < 100, s; it = ConstantArray[r, n] ];
   Point[
    x = x = 
      0.995 x + 0.5 v + (*mean current and new velocity*)
               (v = 0.5 (.02 f[p] - 0.01 f[q] + .0002 f[it]))
    ]
   ]
  },
 PlotRange -> 1]
Improve this answer
$\endgroup$
2
  • $\begingroup$ Craig - great to hear from you! Cool extension, i feel the physicist hand,—kudos for adding the universal pull via the “it” attractor and the inertia smoothing. When I ramp up the it pull and the inertia weight, the swarm becomes noticeably more cohesive and fluid; you really see the effect once those parameters are stronger. Have you tried introducing a matching global repeller? That could produce some fascinating new dynamics. Thanks for sharing these ideas! $\endgroup$ Commented Apr 28 at 15:26
  • 1
    $\begingroup$ Hi @VitaliyKaurov!, This is fun. I tried something along the lines of it = ConstantArray[r, n]; that = ConstantArray[r, n] then ... .02 f[p] - 0.01 f[q] + .0002 f[it] - .0002 f[that] But, it wasn't very interesting. Maybe someone might want to play with the parameters. I also tried an attractor that executed a random walk--nothing there either. My intuition is that as the rules become less simple, the behavior becomes less interesting. $\endgroup$ Commented Apr 28 at 17:22
11
$\begingroup$

Just another way to explore different scenarios by binding parameters to the mouse position:

The mouse coordinates are scaled, with the h-value (horizontal axis) used as the attraction step size and the v-value (vertical axis) used as the repulsion step size.

n = 1000;
r := RandomInteger[{1, n}];
f := (#/(.01 + Sqrt[# . #])) & /@ (x[[#]] - x) &;
s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r];
x = RandomReal[{-1, 1}, {n, 2}];
{p, q} = RandomInteger[{1, n}, {2, n}];

video = DynamicModule[{pos = {0, 0}, h = 0, v = 0},
   Column[{
    Dynamic[Row[
      {Style["attraction ", Blue, Italic]
       , Style[NumberForm[h, {5, 4}], Black, Italic]
       , Style[" repulsion ", Red, Italic]
       , Style[NumberForm[v, {5, 4}], Black, Italic]}]]
    , MouseAppearance[Graphics[{PointSize[0.005]
       , Dynamic[pos = MousePosition["Graphics", pos];
        {h, v} = Rescale[pos, {-1, 1}, {0, 0.1}];
        If[r < 100, s];
        Point[x = 0.995 x + h f[p] - v f[q]]]}
      , PlotRange -> 2, ImageSize -> Medium], 👻]}, 
   Alignment -> Center]]

enter image description here

Improve this answer
$\endgroup$
3
  • $\begingroup$ Excellent idea! Very fun to explore. Could you please explain a bit more in the text which parameters you binding to the mouse and what does the slider do? $\endgroup$ Commented Apr 29 at 2:16
  • 1
    $\begingroup$ Hi @VitaliyKaurov, it’s great to see the boids idea back in action! I just removed the slider and increased the scaling upper limit instead. Also added a "ghost factor" 👻 as well :-) $\endgroup$ Commented Apr 29 at 12:39
  • 2
    $\begingroup$ @vindobona That's very clever--tying the mouse position coordinates to the parameters! $\endgroup$ Commented Apr 29 at 21:00
6
$\begingroup$

Around the time Simon Woods was inventing his code for describing the movement of birds, I was inventing a theory of the motion of stars in galaxies. I will not present this theory here but will only present data on the distribution of gravitational potential in galaxies, obtained on the basis of data on the movement of hydrogen. Figure 1 As shown above potential described by 5 parameters, therefore potential and gradient are given by

phi = 
  Function[{x, y, z}, -m/Sqrt[x^2 + y^2 + z^2] + a Log[x^2 + y^2] + 
    b (x^2 + y^2 - 2 z^2) + k Sqrt[x^2 + y^2] + phi0];
Grad[phi[x, y, z], {x, y, z}]

(*Out[]= {2 b x + (2 a x)/(x^2 + y^2) + (k x)/Sqrt[x^2 + y^2] + (
  m x)/(x^2 + y^2 + z^2)^(3/2), 
 2 b y + (2 a y)/(x^2 + y^2) + (k y)/Sqrt[x^2 + y^2] + (
  m y)/(x^2 + y^2 + z^2)^(3/2), -4 b z + (m z)/(x^2 + y^2 + z^2)^(3/2)}*)

This gradient we used to describe force in Simon's code as

ff := -# {(2 b + 2 a/(eps + #[[1]]^2 + #[[2]]^2) + m/(eps + # . #) + 
        k/Sqrt[eps + #[[1]]^2 + #[[2]]^2]), (2 b + 
        2 a/(eps + #[[1]]^2 + #[[2]]^2) + m/(eps + # . #) + 
        k/Sqrt[eps + #[[1]]^2 + #[[2]]^2]), (-4 b + 
        m/(eps + # . #))} & /@ (x[[#]] - x) &; s := 
 With[{r1 = r}, p[[r1]] = r; q[[r1]] = r];

The rest of the code we update as follows

n = 1000; dt = .1; m = .003; a = .006; b = .001; k = -.5; eps = 
 10^-6; r := RandomInteger[{1, n}];
x = RandomPoint[Sphere[], n]; v = 
 RandomReal[{-.01, .01}, {n, 3}]; {p, q} = 
 RandomInteger[{1, n}, {2, n}];
Graphics3D[{Black, PointSize[0.007], Dynamic[If[r < 100, s];
   v = v + (ff[p] - .5 ff[q]) dt;
   Point[x = .7 x + v dt + (ff[p] - .5 ff[q]) dt^2/2]]}, 
 PlotRange -> 7, Boxed -> False]

From the top we see, for example, this picture

Figure 2

While on the front we see this picture

Figure 3

These animations inspired me, and I thought that using this code we could simulate the formation of a multi-arm galaxy.

Improve this answer
$\endgroup$
3
  • 2
    $\begingroup$ Alex , outstanding - attaching astrophysics scenario to the simulation. If you'd like we can publish your notebook on this galaxy work on Community. $\endgroup$ Commented May 6 at 4:40
  • 1
    $\begingroup$ @VitaliyKaurov This is good idea! I have several dozen notebooks on astrophysics and General Relativity. I will prepare topic for Community based on my papers. $\endgroup$ Commented May 6 at 12:29
  • $\begingroup$ Excellent! Our editors will reach out to you by email. Thank you. $\endgroup$ Commented May 6 at 16:25
4
$\begingroup$

Here, the boids are moving on a spherical surface. The boids move along the great circle path between themselves and their friends or enemies. animation of boids on sphere

This is the move step:

arcMove[n1_, n2_, delta_] := 
 With[{sphericalDistance = ArcCos[n1 . n2], axis = Cross[n1, n2]},
  RotationMatrix[delta/(1 + sphericalDistance), axis] . n1
  ]

initial state:

SeedRandom[1];
n = 500;
dancers = RandomPoint[Sphere[], n];
friend = selectOther[#, n] & /@ Range[n];
enemy = selectOther[#, n] & /@ Range[n];

where

selectOther[i_, count_] := RandomChoice[DeleteCases[Range[count], i]]

Visualizing:

Dynamic[Graphics3D[{{Orange, Sphere[dancers, .02]}, Blue, Opacity[0.4],
    Sphere[]}, SphericalRegion -> True, 
  Lighting -> {{"Ambient", White}}]]

Running (I haven't played with the parameters much, hopefully someone might try that). arcMove[arcMove[n,nf,delta],ne,-delta] first rotates towards nf and then away from ne

Do[
 dancers = MapThread[
   arcMoveCompiled[arcMoveCompiled[#1, dancers[[#2]], .1], 
     dancers[[#3]], -.08] &, {dancers, friend, enemy}];
 If[
  RandomReal[] < .05,
  With[{changer = RandomInteger[{1, n}]},
   friend[[changer]] = selectOther[changer, n];
   enemy[[changer]] = selectOther[changer, n];
   ]
  ],
 500
 ]

the move step is a bit slow, so a compiled version helps:

arcMoveCompiled = 
 Compile[{{n1, _Real, 1}, {n2, _Real, 1}, {delta, _Real}},
  RotationMatrix[delta/(1 + ArcCos[n1 . n2]), Cross[n1, n2]] . n1,
  RuntimeOptions -> "Speed"
  ]

If anyone else wants to try, I used Reap and Sow to collect images from the Do[], and then exported to an animated gif. StackExchange has a limit of 2MB for animated gifs.

Improve this answer
$\endgroup$
1

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.