# Dancing with friends and enemies: boids' swarm intelligence

GROUPS:
 Simon Woods 34 Votes 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 floorthen 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 enemyRandomness is deliberately injected. Here is the dance...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]Thanks to Vitaliy for posting this on my behalf, complete with animations :-)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.
5 years ago
28 Replies
 Daniel Lichtblau 7 Votes Very nice. I wish my frivolous entertainment were that exciting.
5 years ago
 Christopher Carlson 3 Votes That's tremendous!  Particle systems are always a lot of fun.
5 years ago
 Rodrigo Murta 5 Votes Very cool. For 3D just do:x = RandomReal[{-1, 1}, {n, 2}];(*for*)x = RandomReal[{-1, 1}, {n, 3}];And Graphics to Graphics3D.The velocity worked just nice.
5 years ago
 Vitaliy Kaurov 6 Votes Rodrigo, - nice observation! One can also rotate 3D graphics without interference with simulation. I added points up to 2000 and also added SphericalRegion -> True for nice rotation action. This simulation produces nice spiral rotational motions, like galaxy or tornado or vortex formation. I wonder why that is. n = 2000; r := RandomInteger[{1, n}]; f := (#/(.01 + Sqrt[#.#])) & /@ (x[[#]] - x) &; s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r]; x = RandomReal[{-1, 1}, {n, 3}]; {p, q} = RandomInteger[{1, n}, {2, n}]; Graphics3D[{PointSize[0.007],    Dynamic[If[r < 100, s];    Point[x = 0.995 x + 0.02 f[p] - 0.01 f[q]]]}, PlotRange -> 2, SphericalRegion -> True]
5 years ago
 Hi, i have a question concerning this intersting model-----How can i export these data as a series of TXT files of these point data per frame step!!
5 years ago
 I am fascinated by this system , especially this simple visualization. But I still do not understand , how is that possible ? Is it the symbolism ? Or how can this be so well calculated and displayed.
4 years ago
 Shenghui Yang 3 Votes This is so nice yet the code is extremely concise!
5 years ago
 Shenghui Yang 5 Votes I cannot call this perfect without some visual techno ;-) visualize the distance between the some pair of data points, scaled to 1/3 of the actual length; the bigger the circle, the farther they are apart 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}]; Dynamic[  If[r < 100, s];  x = 0.995 x + 0.02 f[p] - 0.01 f[q]; Graphics[Flatten[   Table[{ColorData["Rainbow"][Norm[x[[i]] - x[[j]]]/3],      Disk[{i, j}, Norm[x[[i]] - x[[j]]]/3]}, {i, 1, 10}, {j, i + 1,      11}]   , 1], PlotRange -> {{-1, 12}, {-1, 12}}] ]
5 years ago
 Peter Fleck 6 Votes Throwing out some probably obvious observations:The driving forces in the 'dancing clouds' seem to be buddy cliques, where all members of such a subset of dancers are friends with one another; the 'cloud tails' are chains of followers where one wants to be friends with the previous one in the chain, and the first wants to be friends with somebody in one of the buddy cliques.One should be able to show this quickly with a directed friendship graph like Graph[Table[DirectedEdge[r, p[[ r ]]], {r, 1000}].The repulsion from enemies prevents condensation into a single point, and the 'changes of mind' create the ever-changing dynamics.However to make it a choreographed dance I would assume one would need to fix the relationship structure and place the dancers in a nice pattern, initially. I wonder there how stable such dance patterns would be, as a function of the step sizes towards friends and away from enemies, whether the forming patterns would be unique, given an underlying relationship structure, and whether one could choreograph transitions between individual dance patterns, by individual step disturbances or friendship structure disturbances.But maybe I'm just taking this too far instead of just enjoying these wonderful random dances.Thank you, Simon!
5 years ago
 Szabolcs Horvát 3 Votes NetLogo is very suitable for writing these kinds of simulations.  It also has a Mathematica interface which makes it possible to drive the simulations from Mathematica and send back measurements to it.
5 years ago
 Arnoud Buzing 3 Votes Here is a video which shows a longer sequence than the animated gif above: WATCH VIDEO
5 years ago
 Rodrigo Murta 6 Votes Here is some test with colors based on velocity using 3D code. n=3000; r:=RandomInteger[{1,n}]; f:=(#/(.01+Sqrt[#.#]))&/@(x[[#]]-x)&; s:=With[{r1=r},p[[r1]]=r;q[[r1]]=r]; x=RandomReal[{-1,1},{n,3}]; {p,q}=RandomInteger[{1,n},{2,n}]; Graphics3D[{     White,     PointSize[0.002]    ,Dynamic[        If[r<200,s];        Point[y=x;x=0.995x+0.02f[p]-0.01f[q],VertexColors->(ColorData["TemperatureMap"][50Norm[#]]&/@(x-y))]    ]    },PlotRange->2,Background->Black]
5 years ago
 Daniel Lichtblau 3 Votes Simon, if you want to deal with physical neighbors you can get quite reasonable speed using a NearestFunction, created once per time step. An alternative might be to keep track of which particle is in what grid sector, but the extra coding effort could take you from frivolous entertainment to the seriously demented hobbies level.
5 years ago
 Simon Woods 3 Votes Daniel, LOL, yes it's a fine line! My rule of thumb is that when you start needing version control you're not having fun any more :-)
5 years ago
 Bernat Espigulé Pons 5 Votes Amazing! Here is my Manipulate to add extra excitement to this swarm dance. 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, 3}]; {p, q} = RandomInteger[{1, n}, {2, n}]; Manipulate[  Graphics3D[   Rotate[   {White, PointSize[0.002], Dynamic[If[r < 200, s];     Point[y = x; x = 0.995*x + ps*f[p] - qs*f[q],       VertexColors -> (ColorData["TemperatureMap"][           Color*Norm[#]] & /@ (x - y))]]},   Rotate3D, {0, 0, 1}], PlotRange -> Range, ImageSize -> {700, 500},   Background -> Black, Boxed -> False], {Rotate3D, 0, 2 Pi}, {{Range, 2}, 0.1, 5}, {{Color, 62}, 0, 100}, Delimiter, Style["Step towards their friend", Bold, Medium], {{ps, 0.02}, 0, 1}, Delimiter, Style["Step away from their enemy", Bold, Medium], {{qs, 0.01}, 0, 1}, ControlPlacement -> Left]
5 years ago
 Vitaliy Kaurov 5 Votes I actually like what Bernat did very much. It gave me an opportunity to find an interesting range of parameters where almost perfect multiple interacting ring systems can form { Step towards friend = 0.068, Step away from enemy = 0.006 }. This is pretty mesmerizing to watch:
5 years ago
 Shenghui Yang 3 Votes @Vitaliy, your example is the best illustration of blowing smoke ring ever.
5 years ago
 Bernat Espigulé Pons 3 Votes Thanks Vitaliy. Good catch! I got some tubular structures in-between yours and Woods' parameters range. Tip, the Color slider can be always adjusted to obtain a nice chromatic palette.
5 years ago
 Bernat Espigulé Pons 7 Votes ... and this is the code for generating animated GIFs using Spheres instead of Points: 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, 3}]; {p, q} = RandomInteger[{1, n}, {2, n}]; Export["Dancing_Spheres.gif",  Table[ Graphics3D[Rotate[{Yellow, Dynamic[If[r < 100, s]; Sphere[x = 0.995 x + 0.02 f[p] - 0.01 f[q], 0.04]]}, th, {0, 0, 1}], ImageSize -> {700, 500}, Background -> Black, Boxed -> False, PlotRange -> 2], {th, 0, 2 Pi, 0.03}]]For two-dimensional animations, one can use the method explained in my discussion Visualizing Animated GIFs Along The Time Dimension With Image3D to keep track of the swarm's complex dynamics. → ↑ Time
5 years ago
 Vitaliy Kaurov 5 Votes This post was discussed on Reddit which resulted in recreation of the algorithm in programming language called Processing using 1,000,000 particles and simulation running over night! Here is the link to the VIDEO:
5 years ago
 Bernat Espigulé Pons 6 Votes @Vitaliy, looks like Community is getting popular. I also did an overnight simulation the day this discussion was started. This is the compressed ouput of the original (53MB ) 200,000 particles simulation with Mathematica:The arrow of time has been reversed in this GIF. It's like traveling back to the Big Bang!
5 years ago
 Luc Barthelet 4 Votes Simon,Animal swarm: it could be you saw the original flock study which was done by my friend Craig Reynolds: http://www.red3d.com/cwr/boids/ and published in SIGGRAPH 1987...
5 years ago
 Jari Kirma 4 Votes Here is a variant of this with explicitly chained friendly rings (in this case two). Enemies are still random, but not modified after creation:n = 2000;f := (#/(.01 + Sqrt[#.#])) & /@ (x[[#]] - x) &;x = Table[{Sin[a], -Cos[a]}, {a, 0., 2 \[Pi], 2 \[Pi]/(n - 1)}];p = Table[Mod[i + 1, n] + 1, {i, n}];q = RandomInteger[{1, n}, n];Graphics[{PointSize[0.007], Dynamic[   Point[x = 0.995 x + 0.02 f[p] - 0.01 f[q]]]}, PlotRange -> 2]Amount of rings involved can be modified by adding something else than 1 to i inside Mod. 0 gives single ring, 2 three, and so on (as far as n is multiple of amount of rings).
5 years ago
 Bernat Espigulé Pons 3 Votes Improved Manipulate, 2D/3D Tab, Color Styles, Equation Labels ... Enjoy! TabView[{   "2D" -> Manipulate[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[{Opacity[opacity], PointSize[size],        Dynamic[If[r < 200, s];       Point[y = x; x = c*x + ps*f[p] - qs*f[q],         VertexColors -> (ColorData[col][color*Norm[#]] & /@ (x - y))]]}, PlotRange -> Range, ImageSize -> {700, 600},      Background -> Black], Delimiter, Style["   2D Dancing with        friends and enemies", Bold, Large], Delimiter, Style["Equation                        x = c x + ps f[p] - qs f[q]          where       \!$$\*FormBox[\(\(\\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\\$$$$f[a] = \*FractionBox[\((a - x)$$, $$0.01 + \*SqrtBox[\(\((a - \x)$$ . $$(a - x)$$\)]\)]\)\),     TraditionalForm]\)       ", Bold, Medium], Delimiter,     Dynamic[Graphics[{Style[        Text@TraditionalForm@          Style[Row[{"x = ", c "x + ", ps " f[p] -", qs "f[q]"}]],         15]}, ImageSize -> {240, 50}]], Delimiter,     Style["Step towards their friend", Bold,      Medium], {{ps, 0.02, "Step Size ps"}, 0, 1,Appearance -> "Open"}, Delimiter,     Style["Step away from their enemy", Bold,      Medium], {{qs, 0.01, "Step Size qs"}, 0, 1, Appearance -> "Open"},     Delimiter, {{c, 0.995, "Contraction c"}, 0.5, 1.1,  Appearance -> "Open"},     Delimiter, {{size, 0.015, "Point Size"}, 0.001, 0.05}, {{Range, 1, "Plot Range"}, 0.1, 5}, {{opacity, 1, "Opacity"}, 0.1, 1}, {{color, 62, "Color Scale"}, 0, 100},     Control[{{col, "SolarColors", "Color Style"},      (# -> Row[{Show[ColorData[#, "Image"], ImageSize -> 100], Spacer[10], #}]) & /@ ColorData["Gradients"], PopupMenu}],     ControlPlacement -> Left],    "3D" -> Manipulate[n = 1000;    r := RandomInteger[{1, n}];    f3d := (#/(.01 + Sqrt[#.#])) & /@ (x3d[[#]] - x3d) &;    s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r];    x3d = RandomReal[{-1, 1}, {n, 3}];    {p, q} = RandomInteger[{1, n}, {2, n}];    Graphics3D[{Opacity[opacity], PointSize[size],       Dynamic[If[r < 200, s];       Point[y = x3d; x3d = c*x3d + ps*f3d[p] - qs*f3d[q],         VertexColors -> (ColorData[col][color*Norm[#]] & /@ (x3d - y))]]}, PlotRange -> Range, ImageSize -> {700, 600},      Background -> Black, Boxed -> boxed], Delimiter,     Style["   3D Dancing with        friends and enemies", Bold, Large], Delimiter, Style["Equation                        x = c x + ps f[p] - qs f[q]          where       \!$$\*FormBox[\(\(\\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\ \\\\$$$$f[a] = \*FractionBox[\((a - x)$$, $$0.01 + \*SqrtBox[\(\((a - \x)$$ . $$(a - x)$$\)]\)]\)\),     TraditionalForm]\)       ", Bold, Medium], Delimiter,     Dynamic[Graphics[{Style[        Text@TraditionalForm@          Style[Row[{"x = ", c "x + ", ps " f[p] -", qs "f[q]"}]],         15]}, ImageSize -> {240, 50}]], Delimiter,     Style["Step towards their friend", Bold,      Medium], {{ps, 0.02, "Step Size ps"}, 0, 1, Appearance -> "Open"}, Delimiter,     Style["Step away from their enemy", Bold,      Medium], {{qs, 0.01, "Step Size qs"}, 0, 1, Appearance -> "Open"},     Delimiter, {{c, 0.995, "Contraction c"}, 0.5, 1.1, Appearance -> "Open"},     Delimiter, {{size, 0.015, "Point Size"}, 0.001, 0.05}, {{Range, 1, "Plot Range"}, 0.1, 5}, {{opacity, 1, "Opacity"}, 0.1, 1}, {{color, 62, "Color Scale"}, 0, 100},     Control[{{col, "SolarColors", "Color Style"},      (# ->Row[{Show[ColorData[#, "Image"], ImageSize -> 100],  Spacer[10], #}]) & /@ ColorData["Gradients"],       PopupMenu}], {boxed, {True, False}}, ControlPlacement -> Left]},  ControlPlacement -> Left]Thanks to Andre and Vitaliy for suggesting some of these improvements.
5 years ago
 Woah!!!