Dancing with friends and enemies: boids' swarm intelligence

Message Boards 41 | 108K Views | 30 Replies | 160 Total Likes View groups... GROUPS: Posted 14 years ago 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. Reply | Flag 30 Replies 3 Posted 4 months ago Fascinating work 13 years later here is my 3 coins. It is running in real-time using GraphicsComplex instead of Point which takes advantage of GPU pipeline on WLJS Notebook frontendI could not upload a video, so here is a link. Reply | Flag 0 Posted 13 years ago What you call "frivolous entertainment," social scientists (including socio-physicists) call 'serious research.' I prefer your description, but then IMO, most social science simulations, if viewed as research (which they do), should be identified as ridiculous pseudo-science. Reply | Flag 0 Posted 13 years ago @Jari Kirma:  Great, Thanks a lot Reply | Flag 2 Posted 13 years ago @MohamedZaghloul: you can export per-frame data in the following way, in this case 100 frames: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}];Scan[If[r < 100, s]; Export["swarm_" <> ToString@# <> ".dat", x = 0.995 x + 0.02 f[p] - 0.01 f[q]] &, Range[100]]This produces files swarm_1.dat, swarm_2.dat, ... swarm_100.dat.Format of export is decided by file extension (".dat" in this case for Table format), or third parameter to Export (see documentation).You can also "play back" such a sequence of files, albeit it may be a bit slow this way:i = 1;p = {};Graphics[{PointSize[0.007],  Dynamic[With[{f = "swarm_" <> ToString@i <> ".dat"},    If[FileExistsQ[f], i++; p = Point[Import[f]], p]]]},  PlotRange -> 2] Reply | Flag 0 Posted 13 years ago 4 Posted 14 years ago 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. Reply | Flag 5 Posted 14 years ago 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). Reply | Flag 6 Posted 14 years ago 6 Posted 14 years ago 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: Reply | Flag 6 Posted 14 years ago @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! Reply | Flag 0 Posted 2 years ago Hi Vitaliy,Thank you for the nice post. Is there any application of this issue in environmental or civil engineering?Thank you for your time.Cheers, Reply | Flag 7 Posted 14 years ago