Surfing on the web, I came upon this cool GIF:
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.
$\begingroup$
$\endgroup$
4
-
3$\begingroup$ I saw it yesterday, I should have made it, ah :P $\endgroup$– KubaCommented May 10, 2014 at 15:34
-
5$\begingroup$ This animation is supposed to have music along with it! $\endgroup$– user484Commented May 10, 2014 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$– AliCommented May 10, 2014 at 20:31
-
1$\begingroup$ @RahulNarain done :) $\endgroup$– KubaCommented May 11, 2014 at 13:45
Add a comment
|
2 Answers
$\begingroup$
$\endgroup$
6
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]
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}];
)
]
-
$\begingroup$ So you did this at the end ). +1. $\endgroup$ Commented May 10, 2014 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.Commented May 10, 2014 at 16:18
-
1$\begingroup$ @Pickett The only assumption I've made was to make it linear with
rsince there are rational relations between periods which result with nice configurations like cross or stars. $\endgroup$– KubaCommented May 10, 2014 at 16:19 -
2$\begingroup$ And if this won't become a hot network question then I would be quite surprised :D $\endgroup$ Commented May 10, 2014 at 19:26
-
2$\begingroup$ Nice! Interesting music too. Stockhausen would be proud of you. $\endgroup$ Commented May 11, 2014 at 19:23
$\begingroup$
$\endgroup$
1
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]
-
$\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$– AliCommented May 10, 2014 at 16:12