Introduction
Introduction
This is a small artistic spin off based on original elegant idea by Simon Woods and version of this idea by Jari Kirma. To review the original discussion please see the following post “Dancing with friends and enemies: boids’ swarm intelligence”
The point of this post is to show a way of artistic rendering and then video export of animations at the link above.
WARNING: Do not run simulations here for too long to avoid memory overload.
1-color simulation
1-color simulation
First lets understand the rules of the simulation.
Initial idea by Simon Woods:
Initial idea by Simon Woods:
◼
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.
Modification by Jari Kirma:
Modification by Jari Kirma:
◼
Here is a variant of this with explicitly chained friendly rings (in this case two).
◼
Enemies are still random, but not modified after creation
Jari Kirma code for video art generation
Jari Kirma code for video art generation
Taking original Jari Kirma code
In[]:=
ClearAll["`*"]$Line=0;n=1000;f:=(#/(.01+Sqrt[#.#]))&/@(x[[#]]-x)&;x=N@CirclePoints[n];p=Table[Mod[i+1,n]+1,{i,n}];q=RandomInteger[{1,n},n];
I will also add an empty list variable that will dynamically all sets of points as they evolve:
In[]:=
tmpDAT={};
If Graphics code below is evaluated it dynamically runs and accumulates tmpDAT until the cell with Graphics will be Deleted. It gives a very simple tool for watching the simulation and then stopping it when you are satisfied with its artistic form development and length. Do not run it too long to avoid memory overload. Experiment first with small run times.
In[]:=
Graphics[{PointSize[0.007],Dynamic[Point[tmpDAT=Append[tmpDAT,x];x=0.995x+0.02f[p]-0.01f[q]]]}]
Out[]=
After you stopped it count number of points’ sets:
In[]:=
tmpDAT//Length
Out[]=
226
Now you can replay animation with Manipulate:
In[]:=
Manipulate[Graphics[{PointSize[0.005],Red,Point@tmpDAT[[k]]},PlotRange->1.3,ImageSize->500,Background->Black],{{k,Length@tmpDAT},1,Length@tmpDAT,1},SaveDefinitions->True]
Out[]=
2-color simulation
2-color simulation
To make final art with 2-color swarm lets clear all variables:
In[]:=
ClearAll["`*"]$Line=0;
I will use SeedRandom to fix a particular configuration I like:
SeedRandom[3];n=5000;f:=(#/(.01+Sqrt[#.#]))&/@(x[[#]]-x)&;x=N@CirclePoints[n];p=Table[Mod[i+1,n]+1,{i,n}];q=RandomInteger[{1,n},n];
I will simply run the simulation twice and accumulate frames in 2 different lists:
tmpDAT1={};tmpDAT2={};
One will have 5K and another 10K points. Code for the simulations it almost the same besides some visual parameters -- just change from tmpDAT1 to tmpDAT2 when rerunning:
Graphics[{PointSize[0.003],Red,Dynamic[Point[tmpDAT1=Append[tmpDAT1,x];x=0.995x+0.02f[p]-0.01f[q]]]},PlotRange->2,ImageSize->720,Background->Black]
After running both simulations my number of frames is:
In[]:=
tmpDAT1//Length
Out[]=
1122
In[]:=
tmpDAT2//Length
Out[]=
1918
To amplify artistic sense I will use CHROMOSTEREOPSIS effect: https://en.wikipedia.org/wiki/Chromostereopsis and set up some random blue background:
In[]:=
annu=Disk[#,RandomReal[.03]]&/@RandomPoint[Annulus[{0,0},{1.6,3}],10000];disk=Disk[#,RandomReal[.03]]&/@RandomPoint[Disk[{0,0},.4],350];
I will color to different swarms as red (10K boids) and pink (5K boids). Below is code for Manipulate that I am NOT putting it in the notebook due to its large size, but I give code for Manipulate so you can play locally with the art design:
In[]:=
Manipulate[Graphics[{{Blue,annu,disk},PointSize[0.003],{Red,Point@tmpDAT1[[k]]},{Pink,Point@tmpDAT2[[k]]}},PlotRange->1.7,ImageSize->720,Background->Black],{{k,1122},1,1122,1}]
Use multiple CPU cores to speed it frame generation in parallel:
In[]:=
frames=ParallelTable[Graphics[{{Blue,annu,disk},PointSize[0.003],{Red,Point@tmpDAT1[[k]]},{Pink,Point@tmpDAT2[[k]]}},PlotRange->1.7,ImageSize->720,Background->Black],{k,1,2198,1}];
Use multiple CPU cores to export video in parallel:
In[]:=
Parallelize@FrameListVideo[frames,RasterSize->720,FrameRate->30]
Out[]=
By default, FrameListVideo places the new video under the “Video” directory in $WolframDocumentsDirectory.
CITE THIS NOTEBOOK
CITE THIS NOTEBOOK
Chromostereopsis art tribute to "Dancing with friends and enemies: boids' swarm intelligence”
by Vitaliy Kaurov
Wolfram Community, STAFF PICKS, July 9, 2024
https://community.wolfram.com/groups/-/m/t/3207850
by Vitaliy Kaurov
Wolfram Community, STAFF PICKS, July 9, 2024
https://community.wolfram.com/groups/-/m/t/3207850