Posts tagged: waterfall plot

Mathematica code:
P[A_, f_, w_, h_, M_, Y_, t_] := Plot[  Table[   A*Sin[f*x + t + n*2 Pi/w] + h*n,   {n, 1, M, 1}], {x, 0, 4 Pi},   PlotStyle -> Directive[Black, AbsoluteThickness[3]],   PlotRange -> {{0, 4 Pi}, {-.3, Y}}, Axes -> False,  AspectRatio -> 5/7, ImageSize -> {700, 500}]Manipulate[ ImageRotate[  P[.35, 1, 28, .6, 57, 35, t],  -Pi/2], {t, 2 Pi, Pi/10, -Pi/10}]

Mathematica code:

P[A_, f_, w_, h_, M_, Y_, t_] :=
Plot[
Table[
A*Sin[f*x + t + n*2 Pi/w] + h*n,
{n, 1, M, 1}],
{x, 0, 4 Pi},
PlotStyle -> Directive[Black, AbsoluteThickness[3]],
PlotRange -> {{0, 4 Pi}, {-.3, Y}}, Axes -> False,
AspectRatio -> 5/7, ImageSize -> {700, 500}]

Manipulate[
ImageRotate[
P[.35, 1, 28, .6, 57, 35, t],
-Pi/2],
{t, 2 Pi, Pi/10, -Pi/10}]

Some more inspiration from Bridget Riley — think Blaze 1 (1962).
The first image is what you get after transforming the second image into log-polar coordinates.

Mathematica code:

WfPlot[  t_ ] :=
Graphics[
Table[
{AbsoluteThickness[3],
Line[
Table[
{i + If[Mod[i, 2] == 0, .5*Sin[j*2 Pi/66 + t], 0],
(-1)^i*.5 + .4*j},
 {i, 1, 19}]]},
{j, 1, 69, 1}],
PlotRange -> {{1, 19}, {.8, 27.2}},
ImageSize -> {500, 500}]


Manipulate[
WfPlot[ t ],
{t, 0, 2Pi}]

LogPolar[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]}

Manipulate[
ImageTransformtion[
WfPlot[ t ],
LogPolar[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}],
{t,0,2Pi}]

Mathematica code:
WPlot[x_, y_, h_, k_, N_, R_, m_, s_, w_, v_, t_, px_, py_] := Graphics[  Table[   {AbsoluteThickness[k],     Line[     Table[      {x*i + If[Mod[i, 2] == m, s*x*Sin[j*2 Pi/w + i*2 Pi/v + t], 0],       (-1)^i*y + h*j},     {i, 1, N}]]},   {j, 1, R, 1}],  PlotRange -> {{x + px, N*x - px}, {h - y + py, R*h - y}},   ImageSize -> {500, 700}  ]P={1, 0.5, 0.4, 4., 19, 66, 0, 0.434, 0.89, 0.32, 3.34365, 0.09, 0.418}Manipulate[ WPlot[P[[1]], P[[2]], P[[3]], P[[4]], P[[5]], P[[6]], P[[7]],           P[[8]],  P[[9]], P[[10]], t, P[[12]], P[[13]]],{t, 2Pi, 0}]

Mathematica code:

WPlot[x_, y_, h_, k_, N_, R_, m_, s_, w_, v_, t_, px_, py_] :=
Graphics[
Table[
{AbsoluteThickness[k],
Line[
Table[
{x*i + If[Mod[i, 2] == m, s*x*Sin[j*2 Pi/w + i*2 Pi/v + t], 0],
(-1)^i*y + h*j},
 {i, 1, N}]]},
{j, 1, R, 1}],
PlotRange -> {{x + px, N*x - px}, {h - y + py, R*h - y}},
ImageSize -> {500, 700}
]

P={1, 0.5, 0.4, 4., 19, 66, 0, 0.434, 0.89, 0.32, 3.34365, 0.09, 0.418}

Manipulate[
WPlot[P[[1]], P[[2]], P[[3]], P[[4]], P[[5]], P[[6]], P[[7]],
P[[8]], P[[9]], P[[10]], t, P[[12]], P[[13]]],
{t, 2Pi, 0}]

Inspired by Bridget Riley - Descending (1965)
Mathematica code:
WPlot[x_, y_, h_, k_, N_, R_, m_, s_, w_, v_, t_, px_, py_] := Graphics[  Table[   {AbsoluteThickness[k],     Line[Table[{x*i +          If[Mod[i, 2] == m, s*x*Sin[j*2 Pi/w + i*2 Pi/v + t], 0],         (-1)^i*y + h*j}, {i, 1, N}]]},   {j, 1, R, 1}],  PlotRange -> {{x + px, N*x - px}, {h - y + py, R*h - y}},   ImageSize -> {500, 700}  ]P={1, 0.5, 0.4, 4, 19, 66, 0, 0.5, 0.99, 0.94, 2.12749, 0., 0.644}Manipulate[ WPlot[P[[1]], P[[2]], P[[3]], P[[4]], P[[5]], P[[6]], P[[7]],           P[[8]],  P[[9]], P[[10]], t, P[[12]], P[[13]]],{t, 0, 2 Pi}]

Inspired by Bridget Riley - Descending (1965)

Mathematica code:

WPlot[x_, y_, h_, k_, N_, R_, m_, s_, w_, v_, t_, px_, py_] :=
Graphics[
Table[
{AbsoluteThickness[k],
Line[Table[{x*i +
If[Mod[i, 2] == m, s*x*Sin[j*2 Pi/w + i*2 Pi/v + t], 0],
 (-1)^i*y + h*j}, {i, 1, N}]]},
{j, 1, R, 1}],
PlotRange -> {{x + px, N*x - px}, {h - y + py, R*h - y}},
ImageSize -> {500, 700}
]

P={1, 0.5, 0.4, 4, 19, 66, 0, 0.5, 0.99, 0.94, 2.12749, 0., 0.644}

Manipulate[
WPlot[P[[1]], P[[2]], P[[3]], P[[4]], P[[5]], P[[6]], P[[7]],
P[[8]], P[[9]], P[[10]], t, P[[12]], P[[13]]],
{t, 0, 2 Pi}]

In July 1967, astronomers at the Cavendish Laboratory in Cambridge, observed an unidentified radio signal from interstellar space, which flashed periodically every 1.33730 seconds. This object flashed with such regularity that it was accurate enough to be used as a clock and only be off by one part in a hundred million.
It was eventually determined that this was the first discovery of a pulsar, CP-1919.  This is an object that has about the same mass as the Sun, but is the size of the San Francisco Bay at its widest (~20 kilometers) that is rotating so fast that its emitting a beam of light towards Earth like a strobing light house! Pulsars are neutron stars that are formed from the remnants of a massive star when it experiences stellar death.
A hand drawn graph plotted in the style of a waterfall plot, in the Cambridge Encyclopedia of Astronomy, later became renown for its use on the cover of the album "Unknown Pleasures"  by 1970s English band Joy Division.
Some even managed to point out the resemblance of this plot to some other waterfall plot gifs.
Also, two days ago today was Joy Divisions singer’s, Ian Curtis, birthday!
Mathematica code:
R[n_] := (SeedRandom[n]; RandomReal[])ListAnimate[ Table[  Show[  Table[   Plot[    80 - m    + .2*Sin[2 Pi*R[6*m]             + Sum[4*Sin[2 Pi*R[4*m] + t + R[2 n*m]*2 Pi]*                  Exp[-(.3*x + 30 - 1*100*R[2 n*m])^2/20],               {n, 1, 30, 1}]]    + Sum[3(1 + R[3*n*m])*Abs[Sin[t + R[n*m]*2 Pi]]*          Exp[-(x - 1*100*R[n*m])^2/20],      {n, 1, 4, 1}],  {x, -50, 150},   PlotStyle -> Directive[White, Thick],    PlotRange -> {{-50, 150}, {0, 85}},    Background -> Black, Filling -> Axis, FillingStyle -> Black, Axes -> False,    AspectRatio -> Full, ImageSize -> {500, 630}], {m, 1, 80, 1}]],{t, 0, 6.3*18/19, 6.3/19}],AnimationRunning -> False]

In July 1967, astronomers at the Cavendish Laboratory in Cambridge, observed an unidentified radio signal from interstellar space, which flashed periodically every 1.33730 seconds. This object flashed with such regularity that it was accurate enough to be used as a clock and only be off by one part in a hundred million.

It was eventually determined that this was the first discovery of a pulsar, CP-1919.  This is an object that has about the same mass as the Sun, but is the size of the San Francisco Bay at its widest (~20 kilometers) that is rotating so fast that its emitting a beam of light towards Earth like a strobing light house! Pulsars are neutron stars that are formed from the remnants of a massive star when it experiences stellar death.

A hand drawn graph plotted in the style of a waterfall plot, in the Cambridge Encyclopedia of Astronomy, later became renown for its use on the cover of the album "Unknown Pleasures"  by 1970s English band Joy Division.

Some even managed to point out the resemblance of this plot to some other waterfall plot gifs.

Also, two days ago today was Joy Divisions singer’s, Ian Curtis, birthday!

Mathematica code:

R[n_] := (SeedRandom[n]; RandomReal[])

ListAnimate[
Table[
Show[
Table[
Plot[
80 - m
 + .2*Sin[2 Pi*R[6*m]
+ Sum[4*Sin[2 Pi*R[4*m] + t + R[2 n*m]*2 Pi]*
Exp[-(.3*x + 30 - 1*100*R[2 n*m])^2/20],
{n, 1, 30, 1}]]
 + Sum[3(1 + R[3*n*m])*Abs[Sin[t + R[n*m]*2 Pi]]*
Exp[-(x - 1*100*R[n*m])^2/20],
{n, 1, 4, 1}],
  {x, -50, 150},
  PlotStyle -> Directive[White, Thick],
PlotRange -> {{-50, 150}, {0, 85}},
Background -> Black, Filling -> Axis, FillingStyle -> Black, Axes -> False,
AspectRatio -> Full, ImageSize -> {500, 630}],
 {m, 1, 80, 1}]],
{t, 0, 6.3*18/19, 6.3/19}],
AnimationRunning -> False]

Mathematica code:
R[n_] := (SeedRandom[n]; RandomReal[])G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]ListAnimate[ Show[   Table[    Plot[     100 - n +      Sum[G[20, 5, 100*R[2n],                  Sum[G[1, .15, k - R[4 n], 1, m/100 + t],                  {k, -3, 3, 1}],                 x],     {n, 1, 30, 1}],    {x, -10, 110}],    PlotStyle -> Directive[Black], PlotRange -> {{0, 90}, {0, 100.5}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {450, 600}],  {n, 0, 100, 1}]],{t, 0, 14/15, 1/15}, AnimationRunning->False]

Mathematica code:

R[n_] := (SeedRandom[n]; RandomReal[])
G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]

ListAnimate[
Show[
Table[
Plot[
100 - n +
Sum[G[20, 5, 100*R[2n],
Sum[G[1, .15, k - R[4 n], 1, m/100 + t],
{k, -3, 3, 1}],
x],
{n, 1, 30, 1}],
{x, -10, 110}],
PlotStyle -> Directive[Black], PlotRange -> {{0, 90}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {450, 600}],
{n, 0, 100, 1}]],
{t, 0, 14/15, 1/15}, AnimationRunning->False]
Mathematica code:
R[n_] := (SeedRandom[n]; RandomReal[])G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]ListAnimate[ Show[   Table[    Plot[     100 - n +      Sum[G[2, 8, 100*R[n],                  Sum[G[1, .01, k - R[2 n], 1, m/100 + t],                  {k, -3, 3, 1}],                 x],     {n, 1, 50, 1}],    {x, -10, 110}],    PlotStyle -> Directive[Black], PlotRange -> {{-10, 105}, {0, 100.5}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {500, 700}],  {n, 0, 100, 1}]],{t, 0, 14/15, 1/15}, AnimationRunning->False]

Mathematica code:

R[n_] := (SeedRandom[n]; RandomReal[])
G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]

ListAnimate[
Show[
Table[
Plot[
100 - n +
Sum[G[2, 8, 100*R[n],
Sum[G[1, .01, k - R[2 n], 1, m/100 + t],
{k, -3, 3, 1}],
x],
{n, 1, 50, 1}],
{x, -10, 110}],
PlotStyle -> Directive[Black], PlotRange -> {{-10, 105}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 700}],
{n, 0, 100, 1}]],
{t, 0, 14/15, 1/15}, AnimationRunning->False]

The second GIF is supposed to simulate what the first GIF may look like if viewed with your monitor angled downwards. It is the same as the first except the brightness was increased using Photoshop.

Mathematica code:

R[n_] := (SeedRandom[n]; RandomReal[])
G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]

ListAnimate[
Show[
Table[
Plot[
100 - n +
Sum[G[.05, 6, 100*R[n],
Sum[G[1, .01, k - R[2 n], 1, m/100 + t],
{k, -3, 3, 1}],
x],
{n, 1, 100, 1}],
{x, -10, 110}],
PlotStyle -> Directive[Black], PlotRange -> {{-10, 110}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 700}],
{n, 0, 100, 1}]],
{t, 0, .95, .5}, AnimationRunning->False]

Mathematica code:
R[n_] := (SeedRandom[n]; RandomReal[])G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]ListAnimate[ Show[   Table[    Plot[     100 - n +      Sum[G[.5, 6, 100*R[n],                  Sum[G[1, .01, k - R[2 n], 1, m/100 + t],                  {k, -3, 3, 1}],                 x],     {n, 1, 50, 1}],    {x, -10, 110}],    PlotStyle -> Directive[Black], PlotRange -> {{-10, 110}, {0, 100.5}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {500, 700}],  {n, 0, 100, 1}]],{t, 0, .95, .5}, AnimationRunning->False]

Mathematica code:

R[n_] := (SeedRandom[n]; RandomReal[])
G[A_, s_, c_, T_, x_] := A*T*Exp[-(x - c)^2/s]

ListAnimate[
Show[
Table[
Plot[
100 - n +
Sum[G[.5, 6, 100*R[n],
Sum[G[1, .01, k - R[2 n], 1, m/100 + t],
{k, -3, 3, 1}],
x],
{n, 1, 50, 1}],
{x, -10, 110}],
PlotStyle -> Directive[Black], PlotRange -> {{-10, 110}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 700}],
{n, 0, 100, 1}]],
{t, 0, .95, .5}, AnimationRunning->False]

Mathematica code:
S[n_, t_] := Sin[n* Pi/25 + t]ListAnimate[ Show[   Table[    Plot[     100 - n + Sum[(8*S[n,t] + .02)*Exp[-(x - k*5*S[n, 0])^2/Abs[.3*S[n,t]]], {k,{-1,1}}],     {x, -10, 10},    PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100.5}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {500, 750}],  {n, -10, 100, 1}]],{t, .001, 2 Pi + .001, (2 Pi + .001)/30}, AnimationRunning->False]

Mathematica code:

S[n_, t_] := Sin[n* Pi/25 + t]

ListAnimate[
Show[
Table[
Plot[
100 - n + Sum[(8*S[n,t] + .02)*Exp[-(x - k*5*S[n, 0])^2/Abs[.3*S[n,t]]], {k,{-1,1}}],
{x, -10, 10},
PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 750}],
{n, -10, 100, 1}]],
{t, .001, 2 Pi + .001, (2 Pi + .001)/30}, AnimationRunning->False]

Mathematica code:
S[n_, t_] := Sin[n*2 Pi/50 + t]ListAnimate[ Show[   Table[    Plot[     100 - n + (14Sin[t]*S[n,t] + .02)*Exp[-(x - 4Sin[t]*S[n, 0])^2/Abs[S[n,t]]],      {x, -10, 10},    PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100.5}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {500, 750}],  {n, -10, 100, 1}]],{t, .001, 2 Pi + .001, (2 Pi + .001)/40}, AnimationRunning->False]

Mathematica code:

S[n_, t_] := Sin[n*2 Pi/50 + t]

ListAnimate[
Show[
Table[
Plot[
100 - n + (14Sin[t]*S[n,t] + .02)*Exp[-(x - 4Sin[t]*S[n, 0])^2/Abs[S[n,t]]],
{x, -10, 10},
PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 750}],
{n, -10, 100, 1}]],
{t, .001, 2 Pi + .001, (2 Pi + .001)/40}, AnimationRunning->False]

Mathematica code:
S[n_, t_] := Sin[n*2 Pi/50 + t]ListAnimate[ Show[   Table[    Plot[     100 - n + (10*S[n,t] + .02)*Exp[-(x - 4.5*S[n, 0])^2/Abs[S[n,t]]],      {x, -10, 10},    PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100.5}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {500, 750}],  {n, -10, 100, 1}]],{t, .001, 2 Pi + .001, (2 Pi + .001)/30}, AnimationRunning->False]

Mathematica code:

S[n_, t_] := Sin[n*2 Pi/50 + t]

ListAnimate[
Show[
Table[
Plot[
100 - n + (10*S[n,t] + .02)*Exp[-(x - 4.5*S[n, 0])^2/Abs[S[n,t]]],
{x, -10, 10},
PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100.5}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 750}],
{n, -10, 100, 1}]],
{t, .001, 2 Pi + .001, (2 Pi + .001)/30}, AnimationRunning->False]

Mathematica code:
S[n_, t_] := Sin[n*3 Pi/50 + t]ListAnimate[ Show[   Table[    Plot[     100 - n + (20*Abs[S[n,t]] + .02)*Exp[-(x - 4*S[n, t])^2/Abs[S[n,t]]],      {x, -10, 10},    PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100}},    Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,     ImageSize -> {500, 750}],  {n, 1, 100, 1}]],{t, .001, 2 Pi + .001, (2 Pi + .001)/30}, AnimationRunning->False]

Mathematica code:

S[n_, t_] := Sin[n*3 Pi/50 + t]

ListAnimate[
Show[
Table[
Plot[
100 - n + (20*Abs[S[n,t]] + .02)*Exp[-(x - 4*S[n, t])^2/Abs[S[n,t]]],
{x, -10, 10},
PlotStyle -> Directive[Black, Thick], PlotRange -> {{-7, 7}, {0, 100}},
Filling -> Axis, FillingStyle -> White, Axes -> False, AspectRatio -> Full,
ImageSize -> {500, 750}],
{n, 1, 100, 1}]],
{t, .001, 2 Pi + .001, (2 Pi + .001)/30}, AnimationRunning->False]