14
$\begingroup$

Surfing on the web, I came upon this cool GIF:

animation

Does any one know how to reproduce this in Mathematica? I have some ideas myself, so I will try to answer this question as well.

$\endgroup$
  • 3
    $\begingroup$ I saw it yesterday, I should have made it, ah :P $\endgroup$ – Kuba May 10 '14 at 15:34
  • 5
    $\begingroup$ This animation is supposed to have music along with it! $\endgroup$ – Rahul May 10 '14 at 20:09
  • $\begingroup$ I never messed around with Mathematica's sound functions. It would be cool to see an answer which produces the sounds as well! $\endgroup$ – Ali May 10 '14 at 20:31
  • 1
    $\begingroup$ @RahulNarain done :) $\endgroup$ – Kuba May 11 '14 at 13:45
27
$\begingroup$

Embedded cdf with music version. code at the bottom


For full period, change max t to 200, my gif is cut in half because for some reasons I couldn't upload whole.

f[r_, t_] := Mod[-t (1 - r), 2. Pi];

dr = Pi /100.

Animate[Graphics[{
   Table[{
          AbsolutePointSize[10 # + 2 + 2 Unitize@Clip[f[#, t] - 5.5, {0, 1}]], 
          Blend[{Blend["Rainbow", #], White}, Clip[f[#, t] - 5.28, {0, 1}]], 
          Point[# {Cos@f[#, t], Sin@f[#, t]}]} &@i,
         {i, 1 - dr, 0, -dr}],
    White, Line[{{0, 0}, {2, 0}}]}, 
   PlotRange -> 1.1, Background -> Black, ImageSize -> 300], 
 {t, 0, 100}, AnimationRate -> 5]

enter image description here


more processor consuming but working smoothly - version with music:

As Öskå has noticed, it may not work on Linux.

It is not perfectly optimized, I just wonted to do this now and I hope I will have some time and motivation to improve it one day.

DynamicModule[{t, f, dt, dr, sound, graf},
 Dynamic[Refresh[
 Column[{
  graf,
  Animator[Dynamic[t, (t = #; With[{sel = Select[sound, t - dt <= #[[1]] <= t &]}, 
   If[Length[sel] != 0, EmitSound@Sound[SoundNote@sel[[1, 2]]]]]) &],
   {0, 200, dt}, AnimationRunning->False, AnimationRate->4, DisplayAllSteps->True]
  }],

   None]],
 Initialization :> (
   dt = .2;
   f[r_, t_] := Mod[-t (1 - r), 2 Pi];
   t = 0;

   dr = Pi /100;

   graf = Graphics[{
      Dynamic@Table[With[{fi = f[i, t]},
         {
          AbsolutePointSize[5 i + 2 + If[fi > 6., 3, 0]], 
          Blend[{Blend["Rainbow", i], White}, Clip[fi - 5.5, {0, 1}]],
          Point[i {Cos@fi, Sin@fi}]}],
        {i, 1 - dr, 0, -dr}],
      White, Line[{{0, 0}, {2, 0}}]},
     PlotRange -> 1.1, Background -> Black, ImageSize -> 300];

   sound = Composition[

      SortBy[#, First] &,
      {#[[1, 2]], #[[;; , 1]]} & /@ # &,
      GatherBy[#, #[[2]] &] &,
      Flatten[#, 1] &

      ]@Table[
      Thread[{(-i + 1)/dr, Range[0, 200, #] &@(2 Pi/(1 - i))}], {i, 
       1 - dr, 0, -dr}];
   )
 ]

$\endgroup$
  • $\begingroup$ So you did this at the end ). +1. $\endgroup$ – Leonid Shifrin May 10 '14 at 16:13
  • 1
    $\begingroup$ How'd you find the correct expression for the spiral? (Is there a standard expression? I don't know much about spirals...) $\endgroup$ – C. E. May 10 '14 at 16:18
  • 1
    $\begingroup$ @Pickett The only assumption I've made was to make it linear with r since there are rational relations between periods which result with nice configurations like cross or stars. $\endgroup$ – Kuba May 10 '14 at 16:19
  • 2
    $\begingroup$ And if this won't become a hot network question then I would be quite surprised :D $\endgroup$ – Yves Klett May 10 '14 at 19:26
  • 2
    $\begingroup$ Nice! Interesting music too. Stockhausen would be proud of you. $\endgroup$ – Sjoerd C. de Vries May 11 '14 at 19:23
8
$\begingroup$

Well this is my try, I could work a little bit on the color yet, but I'm pretty happy with it right-now:

Animate[
 Show[
  Graphics[
   Transpose[{
    Table[RGBColor[Sqrt[1-r^2], r Sin[θ],r Cos[θ]], {r,0.01,1,0.02}],
    Table[Disk[{r Cos[-2(1-r)θ], r Sin[-2(1-r)θ]},r/60], {r,0.01,1,0.02}]}],
  Background->Black],
 PlotRange->{{-1,1},{-1,1}}, ImageSize->1000],
{θ,0,100π,π/40},DefaultDuration->180]

enter image description here

$\endgroup$
  • $\begingroup$ @Kuba Thanks for the edit. Do you know how to export gif animations from Mathematica? I could only do it with *.swf format. $\endgroup$ – Ali May 10 '14 at 16:12

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.