Posts tagged: wavy

Inspired by Visual illusions based on single-field contrast asynchronies and by beesandbombs.
Mathematica code:
v[a_] :=  {{Cos[a], 0},  {0, Sin[a]},  {Sin[a], Cos[a] + Sin[a]},  {0, 2 Cos[a] + Sin[a]},  {Cos[a], 2 Cos[a] + 2 Sin[a]},  {Cos[a] + Sin[a], Cos[a] + 2 Sin[a]},  {Cos[a] + 2 Sin[a], 2 Cos[a] + 2 Sin[a]},  {2 Cos[a] + 2 Sin[a], 2 Cos[a] + Sin[a]},  {2 Cos[a] + Sin[a], Cos[a] + Sin[a]},  {2 Cos[a] + 2 Sin[a], Sin[a]},  {Cos[a] + 2 Sin[a], 0},  {Cos[a] + Sin[a], Cos[a]}}q[a_, b_, f_, w0_, w1_, w2_, w3_, t_] := {{GrayLevel[b + f*Sin[2 Pi (w0 + t)]],    Polygon[{v[a][[12]], v[a][[1]], v[a][[2]], v[a][[3]]}]},  {GrayLevel[b - f*Sin[2 Pi (w1 + t)]],    Polygon[{v[a][[3]], v[a][[4]], v[a][[5]], v[a][[6]]}]},  {GrayLevel[b - f*Sin[2 Pi (w2 + t)]],    Polygon[{v[a][[9]], v[a][[10]], v[a][[11]], v[a][[12]]}]},  {GrayLevel[b + f*Sin[2 Pi (w3 + t)]],    Polygon[{v[a][[6]], v[a][[7]], v[a][[8]], v[a][[9]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[1]], v[a][[2]], v[a][[3]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[3]], v[a][[12]], v[a][[1]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[3]], v[a][[4]], v[a][[5]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[5]], v[a][[6]], v[a][[3]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[11]], v[a][[12]], v[a][[9]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[9]], v[a][[10]], v[a][[11]]}]},  {Thick, GrayLevel[b - f], Line[{v[a][[9]], v[a][[6]], v[a][[7]]}]},  {Thick, GrayLevel[b + f], Line[{v[a][[9]], v[a][[8]], v[a][[7]]}]}}Manipulate[ With[{pr = 6, h = 2, v = 3, b = .8, f = .2, w0 = 0, w1 = 1/8, w2 = 2/8, w3 = 3/8, a = .9},  Graphics[   Table[    Translate[     Table[      Translate[       q[a, b, f, w0 + x/4 + y/4, w1 + x/4 + y/4, w2 + x/4 + y/4, w3 + x/4 + y/4, t],       y {0, Sin[a] + 2 Cos[a] + Sin[a]}],      {y, -v - 1, v, 1}],     x {2 Cos[a] + 2 Sin[a], 0}],    {x, -h - 1, h, 1}], PlotRange -> {{-pr, pr}, {-7/5 pr, 7/5 pr}}, Background -> GrayLevel[b], ImageSize -> 500]], {t, 0, .95, .05 }]

Inspired by Visual illusions based on single-field contrast asynchronies and by beesandbombs.

Mathematica code:


v[a_] :=
{{Cos[a], 0},
{0, Sin[a]},
{Sin[a], Cos[a] + Sin[a]},
{0, 2 Cos[a] + Sin[a]},
{Cos[a], 2 Cos[a] + 2 Sin[a]},
{Cos[a] + Sin[a], Cos[a] + 2 Sin[a]},
{Cos[a] + 2 Sin[a], 2 Cos[a] + 2 Sin[a]},
{2 Cos[a] + 2 Sin[a], 2 Cos[a] + Sin[a]},
{2 Cos[a] + Sin[a], Cos[a] + Sin[a]},
{2 Cos[a] + 2 Sin[a], Sin[a]},
{Cos[a] + 2 Sin[a], 0},
{Cos[a] + Sin[a], Cos[a]}}

q[a_, b_, f_, w0_, w1_, w2_, w3_, t_] :=
{{GrayLevel[b + f*Sin[2 Pi (w0 + t)]],
Polygon[{v[a][[12]], v[a][[1]], v[a][[2]], v[a][[3]]}]},
{GrayLevel[b - f*Sin[2 Pi (w1 + t)]],
Polygon[{v[a][[3]], v[a][[4]], v[a][[5]], v[a][[6]]}]},
{GrayLevel[b - f*Sin[2 Pi (w2 + t)]],
Polygon[{v[a][[9]], v[a][[10]], v[a][[11]], v[a][[12]]}]},
{GrayLevel[b + f*Sin[2 Pi (w3 + t)]],
Polygon[{v[a][[6]], v[a][[7]], v[a][[8]], v[a][[9]]}]},
{Thick, GrayLevel[b + f], Line[{v[a][[1]], v[a][[2]], v[a][[3]]}]},
{Thick, GrayLevel[b - f], Line[{v[a][[3]], v[a][[12]], v[a][[1]]}]},
{Thick, GrayLevel[b - f], Line[{v[a][[3]], v[a][[4]], v[a][[5]]}]},
{Thick, GrayLevel[b + f], Line[{v[a][[5]], v[a][[6]], v[a][[3]]}]},
{Thick, GrayLevel[b + f], Line[{v[a][[11]], v[a][[12]], v[a][[9]]}]},
{Thick, GrayLevel[b - f], Line[{v[a][[9]], v[a][[10]], v[a][[11]]}]},
{Thick, GrayLevel[b - f], Line[{v[a][[9]], v[a][[6]], v[a][[7]]}]},
{Thick, GrayLevel[b + f], Line[{v[a][[9]], v[a][[8]], v[a][[7]]}]}}

Manipulate[
With[{pr = 6, h = 2, v = 3, b = .8, f = .2, w0 = 0, w1 = 1/8, w2 = 2/8, w3 = 3/8, a = .9},
Graphics[
Table[
Translate[
Table[
Translate[
q[a, b, f, w0 + x/4 + y/4, w1 + x/4 + y/4, w2 + x/4 + y/4, w3 + x/4 + y/4, t],
y {0, Sin[a] + 2 Cos[a] + Sin[a]}],
{y, -v - 1, v, 1}],
x {2 Cos[a] + 2 Sin[a], 0}],
{x, -h - 1, h, 1}],
PlotRange -> {{-pr, pr}, {-7/5 pr, 7/5 pr}}, Background -> GrayLevel[b], ImageSize -> 500]],
{t, 0, .95, .05 }]
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}]

log-polar transforms

shown with increasing wave amplitude from top to bottom

Mathematica code:

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

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

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

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}]

Mathematica code:

Rot60 = 
Table[
Table[
RotationTransform[a, {1, 1, 0}, {0, 0, 0}][Tuples[{-1, 1}, 3][[v]]],
{v, 1, 8, 1}],
{a, 0, 2 Pi, 2 Pi/60}]

Edge := {1, 2, 4, 3, 7, 8, 6, 5, 1, 3, 4, 8, 7, 5, 6, 2}

CubeProjections[color_, pr_, b_, s_, h_, w_, m_, a_] :=
Graphics[
Table[
Translate[
{AbsoluteThickness[h], If[color == 0, Black, White],
Line[
Table[
Table[
Rot60[[1 + Mod[w (y + m*x) + a, 60]]][[Edge[[k]]]][[c]],
{c, 1, 2, 1}],
{k, 1, 16, 1}]]},
{s*x, s*y}],
{x, -6, 6, 1}, {y, -b, b, 1}],
PlotRange -> {{-pr/3, pr/3}, {-pr+1, pr-1}}, ImageSize -> 500,
Background -> If[color == 0, White, Black]
]

Manipulate[
PM = {color, pr, b, s, h, w, m, a};
CubeProjections[color, pr, b, s, h, w, m, a],
{color, 0, 1, 1}, {{pr, 17}, 1, 52}, {{b, 5}, 1, 20, 1},
{{s, 3}, 0, 5}, {{h, 1}, .01, 10},
{{w, 1}, 0, 20, 1},{{m, 1}, 0, 20, 1},
{a, 1, 60, 1}]

P = {0, 29, 20, 1.3, 2.5, 1, 0, 0}

Manipulate[
CubeProjections30[P[[1]], P[[2]], P[[3]], P[[4]], P[[5]], P[[6]],
P[[7]], a],
{a, 1, 30, 1}]

Mathematica code:
Rot =  Table[  Table[   RotationTransform[a, {1, 1, 0}, {0, 0, 0}][Tuples[{-1, 1}, 3][[v]]],  {v, 1, 8, 1}],{a, 0, 2 Pi, 2 Pi/100}]Edge := {1, 2, 4, 3, 7, 8, 6, 5, 1, 3, 4, 8, 7, 5, 6, 2}CubeProjections[color_, pr_, b_, s_, h_, w_, m_, o_] :=Graphics[ Table[  Translate[   {AbsoluteThickness[h], If[color == 0, Black, White],    Line[     Table[      Table[       Rot[[1 + Mod[w (y + m*x) + a, 100]]][[Edge[[k]]]][[c]],       {c, 1, 2, 1}],      {k, 1, 16, 1}]]},   {s*x, s*y}],  {x, -b, b, 1}, {y, -b, b, 1}], PlotRange -> {{-pr, pr}, {-pr, pr}}, ImageSize -> 500,  Background -> If[color == 0, White, Black] ]Manipulate[PM = {color, pr, b, s, h, w, m, a};CubeProjections[color, pr, b, s, h, w, m, a],{color, 0, 1, 1}, {{pr, 17}, 1, 52}, {{b, 5}, 1, 10, 1},{{s, 3}, 0, 5}, {{h, 1}, .01, 10},{{w, 1}, 0, 20, 1},{{m, 1}, 0, 20, 1},{a, 1, 100, 1}]P = {1, 28, 9, 3, 1.4, 1, 1, 30}Manipulate[CubeProjections[P[[1]],P[[2]],P[[3]],P[[4]],P[[5]],P[[6]],P[[7]],a],{a, 48, 0, -2}]



Mathematica code:

Rot = 
Table[
Table[
RotationTransform[a, {1, 1, 0}, {0, 0, 0}][Tuples[{-1, 1}, 3][[v]]],
{v, 1, 8, 1}],
{a, 0, 2 Pi, 2 Pi/100}]

Edge := {1, 2, 4, 3, 7, 8, 6, 5, 1, 3, 4, 8, 7, 5, 6, 2}

CubeProjections[color_, pr_, b_, s_, h_, w_, m_, o_] :=
Graphics[
Table[
Translate[
{AbsoluteThickness[h], If[color == 0, Black, White],
Line[
Table[
Table[
Rot[[1 + Mod[w (y + m*x) + a, 100]]][[Edge[[k]]]][[c]],
{c, 1, 2, 1}],
{k, 1, 16, 1}]]},
{s*x, s*y}],
{x, -b, b, 1}, {y, -b, b, 1}],
PlotRange -> {{-pr, pr}, {-pr, pr}}, ImageSize -> 500,
Background -> If[color == 0, White, Black]
]

Manipulate[
PM = {color, pr, b, s, h, w, m, a};
CubeProjections[color, pr, b, s, h, w, m, a],
{color, 0, 1, 1}, {{pr, 17}, 1, 52}, {{b, 5}, 1, 10, 1},
{{s, 3}, 0, 5}, {{h, 1}, .01, 10},
{{w, 1}, 0, 20, 1},{{m, 1}, 0, 20, 1},
{a, 1, 100, 1}]

P = {1, 28, 9, 3, 1.4, 1, 1, 30}

Manipulate[
CubeProjections[P[[1]],P[[2]],P[[3]],P[[4]],P[[5]],P[[6]],P[[7]],a],
{a, 48, 0, -2}]
2-D projections of rotating cubes
Mathematica code:
Rot =  Table[  Table[   RotationTransform[a, {1, 1, 0}, {0, 0, 0}][Tuples[{-1, 1}, 3][[v]]],  {v, 1, 8, 1}],{a, 0, 2 Pi, 2 Pi/100}]Edge := {1, 2, 4, 3, 7, 8, 6, 5, 1, 3, 4, 8, 7, 5, 6, 2}CubeProjections[color_, pr_, b_, s_, h_, w_, m_, o_] :=Graphics[ Table[  Translate[   {AbsoluteThickness[h], If[color == 0, Black, White],    Line[     Table[      Table[       Rot[[1 + Mod[w (y + m*x) + a, 100]]][[Edge[[k]]]][[c]],       {c, 1, 2, 1}],      {k, 1, 16, 1}]]},   {s*x, s*y}],  {x, -b, b, 1}, {y, -b, b, 1}], PlotRange -> {{-pr, pr}, {-pr, pr}}, ImageSize -> 500,  Background -> If[color == 0, White, Black] ]Manipulate[PM = {color, pr, b, s, h, w, m, a};CubeProjections[color, pr, b, s, h, w, m, a],{color, 0, 1, 1}, {{pr, 17}, 1, 52}, {{b, 5}, 1, 10, 1},{{s, 3}, 0, 5}, {{h, 1}, .01, 10},{{w, 1}, 0, 20, 1},{{m, 1}, 0, 20, 1},{a, 1, 100, 1}]P = {0, 26.7, 7, 3.5, 1.3, 5, 1, 0}Manipulate[CubeProjections[P[[1]],P[[2]],P[[3]],P[[4]],P[[5]],P[[6]],P[[7]],a],{a, 48, 0, -2}]


2-D projections of rotating cubes

Mathematica code:

Rot = 
Table[
Table[
RotationTransform[a, {1, 1, 0}, {0, 0, 0}][Tuples[{-1, 1}, 3][[v]]],
{v, 1, 8, 1}],
{a, 0, 2 Pi, 2 Pi/100}]

Edge := {1, 2, 4, 3, 7, 8, 6, 5, 1, 3, 4, 8, 7, 5, 6, 2}

CubeProjections[color_, pr_, b_, s_, h_, w_, m_, o_] :=
Graphics[
Table[
Translate[
{AbsoluteThickness[h], If[color == 0, Black, White],
Line[
Table[
Table[
Rot[[1 + Mod[w (y + m*x) + a, 100]]][[Edge[[k]]]][[c]],
{c, 1, 2, 1}],
{k, 1, 16, 1}]]},
{s*x, s*y}],
{x, -b, b, 1}, {y, -b, b, 1}],
PlotRange -> {{-pr, pr}, {-pr, pr}}, ImageSize -> 500,
Background -> If[color == 0, White, Black]
]

Manipulate[
PM = {color, pr, b, s, h, w, m, a};
CubeProjections[color, pr, b, s, h, w, m, a],
{color, 0, 1, 1}, {{pr, 17}, 1, 52}, {{b, 5}, 1, 10, 1},
{{s, 3}, 0, 5}, {{h, 1}, .01, 10},
{{w, 1}, 0, 20, 1},{{m, 1}, 0, 20, 1},
{a, 1, 100, 1}]

P = {0, 26.7, 7, 3.5, 1.3, 5, 1, 0}

Manipulate[
CubeProjections[P[[1]],P[[2]],P[[3]],P[[4]],P[[5]],P[[6]],P[[7]],a],
{a, 48, 0, -2}]
circles moving in circles


Mathematica code:
Circles[color_, X_, Y_, s_, r_, IS_] := Graphics[  Table[   {color,    Disk[{x, y} + s, r]},   {x, -X, X}, {y, -Y, Y}],  ImageSize -> IS]W[x_, y_, w_, a_, t_] :=  w ((Cos[a] + Sin[a]) x + (Sin[a] - Cos[a]) y) + t*2 PiManipulate[ Show[  Circles[Black, X, Y, 0, r, 500],  Circles[White, X, Y,   .25 r*{Cos[W[x, y, w, a, t]], Sin[W[x, y, w, a, t]]}, r/2, 500]  ],{X, 10, 100, 1}, {Y, 10, 100, 1},{{r, .5}, .1, 1}, {{w, 1}, 0, 1}, {a, 0, 2 Pi},{t, 0, 1}]Manipulate[ Show[  Circles[Black, 10, 10, 0, .6+ .2Cos[t*2Pi/4], 500],  Circles[White, 10, 10,   .25 (.6+ .2Cos[t*2Pi/4])*{Cos[W[x, y, .75, 3Pi/2, t]], Sin[W[x, y, .75, 3Pi/2, t]]},   (.6+ .2Cos[t*2Pi/4])/2, 500] ],{t, 0, 4}]
circles moving in circles

Mathematica code:

Circles[color_, X_, Y_, s_, r_, IS_] :=
Graphics[
Table[
{color,
Disk[{x, y} + s, r]},
{x, -X, X}, {y, -Y, Y}],
ImageSize -> IS]

W[x_, y_, w_, a_, t_] :=
w ((Cos[a] + Sin[a]) x + (Sin[a] - Cos[a]) y) + t*2 Pi

Manipulate[
Show[
Circles[Black, X, Y, 0, r, 500],
Circles[White, X, Y,
.25 r*{Cos[W[x, y, w, a, t]], Sin[W[x, y, w, a, t]]}, r/2, 500]
],
{X, 10, 100, 1}, {Y, 10, 100, 1},
{{r, .5}, .1, 1}, {{w, 1}, 0, 1}, {a, 0, 2 Pi},
{t, 0, 1}]

Manipulate[
Show[
Circles[Black, 10, 10, 0, .6+ .2Cos[t*2Pi/4], 500],
Circles[White, 10, 10,
.25 (.6+ .2Cos[t*2Pi/4])*{Cos[W[x, y, .75, 3Pi/2, t]], Sin[W[x, y, .75, 3Pi/2, t]]},
  (.6+ .2Cos[t*2Pi/4])/2, 500]
],
{t, 0, 4}]
Mathematica code:
Circles[Ccolor_, BGcolor_, X_, Y_, s_, r_, IS_] := Graphics[  Table[   {Ccolor,    Disk[{x, y} + s, r]},   {x, -X, X}, {y, -Y, Y}],  ImageSize -> IS, Background -> BGcolor,   PlotRange -> {{-X-1, X+1}, {-Y-1, Y+1}}]W[x_, y_, w_, a_, t_] :=  w ((Cos[a] + Sin[a]) x + (Sin[a] - Cos[a]) y) + t*2 PiManipulate[Circles[ If[color==0,White, Black],If[color==0, Black, White], X, Y, .25 r*{Cos[W[x, y, w, a, t]], Sin[W[x, y, w, a, t]]},  r/2, IS],{color,0,1,1}, {IS, {{500}, {500, 700}}},{X, 10, 100, 1}, {Y, 10, 100, 1},{{r, .5}, .1, 1},{{w, 1}, 0, 1},{a, 0, 2 Pi},{t, 0, 1}]Manipulate[ Circles[  White, Black, 10, 14,  .25 (.8)*{Cos[W[x, y, .6, 3Pi/2, t]], Sin[W[x, y, .6, 3Pi/2, t]]},  .8/2, {500,700}],{t, 0, 1}]

Mathematica code:

Circles[Ccolor_, BGcolor_, X_, Y_, s_, r_, IS_] :=
Graphics[
Table[
{Ccolor,
Disk[{x, y} + s, r]},
{x, -X, X}, {y, -Y, Y}],
ImageSize -> IS, Background -> BGcolor,
PlotRange -> {{-X-1, X+1}, {-Y-1, Y+1}}]

W[x_, y_, w_, a_, t_] :=
w ((Cos[a] + Sin[a]) x + (Sin[a] - Cos[a]) y) + t*2 Pi

Manipulate[
Circles[
If[color==0,White, Black],If[color==0, Black, White], X, Y,
.25 r*{Cos[W[x, y, w, a, t]], Sin[W[x, y, w, a, t]]},
r/2, IS],
{color,0,1,1}, {IS, {{500}, {500, 700}}},
{X, 10, 100, 1}, {Y, 10, 100, 1},
{{r, .5}, .1, 1},{{w, 1}, 0, 1},{a, 0, 2 Pi},
{t, 0, 1}]

Manipulate[
Circles[
White, Black, 10, 14,
 .25 (.8)*{Cos[W[x, y, .6, 3Pi/2, t]], Sin[W[x, y, .6, 3Pi/2, t]]},
.8/2, {500,700}],
{t, 0, 1}]

Mathematica code:
Circles[Ccolor_, BGcolor_, X_, Y_, s_, r_, IS_] := Graphics[  Table[   {Ccolor,    Disk[{x, y} + s, r]},   {x, -X, X}, {y, -Y, Y}],  ImageSize -> IS, Background -> BGcolor,   PlotRange -> {{-X-1, X+1}, {-Y-1, Y+1}}]W[x_, y_, w_, a_, t_] :=  w ((Cos[a] + Sin[a]) x + (Sin[a] - Cos[a]) y) + t*2 PiManipulate[Circles[ If[color==0,White, Black],If[color==0, Black, White], X, Y, .25 r*{Cos[W[x, y, w, a, t]], Sin[W[x, y, w, a, t]]},  r/2, IS],{color,0,1,1}, {IS, {{500}, {500, 700}}},{X, 10, 100, 1}, {Y, 10, 100, 1},{{r, .5}, .1, 1},{{w, 1}, 0, 1},{a, 0, 2 Pi},{t, 0, 1}]Manipulate[ Circles[  White, Black, 10, 14,  .25 (.5)*{Cos[W[x, y, .25, 3Pi/2, t]], Sin[W[x, y, .25, 3Pi/2, t]]},  .5/2, {500,700}],{t, 0, 1}]

Mathematica code:

Circles[Ccolor_, BGcolor_, X_, Y_, s_, r_, IS_] :=
Graphics[
Table[
{Ccolor,
Disk[{x, y} + s, r]},
{x, -X, X}, {y, -Y, Y}],
ImageSize -> IS, Background -> BGcolor,
PlotRange -> {{-X-1, X+1}, {-Y-1, Y+1}}]

W[x_, y_, w_, a_, t_] :=
w ((Cos[a] + Sin[a]) x + (Sin[a] - Cos[a]) y) + t*2 Pi

Manipulate[
Circles[
If[color==0,White, Black],If[color==0, Black, White], X, Y,
.25 r*{Cos[W[x, y, w, a, t]], Sin[W[x, y, w, a, t]]},
r/2, IS],
{color,0,1,1}, {IS, {{500}, {500, 700}}},
{X, 10, 100, 1}, {Y, 10, 100, 1},
{{r, .5}, .1, 1},{{w, 1}, 0, 1},{a, 0, 2 Pi},
{t, 0, 1}]

Manipulate[
Circles[
White, Black, 10, 14,
 .25 (.5)*{Cos[W[x, y, .25, 3Pi/2, t]], Sin[W[x, y, .25, 3Pi/2, t]]},
.5/2, {500,700}],
{t, 0, 1}]

The end of this post concludes with a visualization of a certain kind of three dimensional standing wave produced by a point source. The rest of this post will explain some of the intuition behind the modelling.

Read More

asks:
Is it possible to visualize 3 dimensional standing wave patterns with mathematica?

The end of this post concludes with a visualization of a certain kind of three dimensional standing wave produced by a point source. The rest of this post will explain some of the intuition behind the modelling.

A standing wave is what results when a traveling wave such as this

and its time-reversed analog traveling in the opposite direction

are considered together and allowed to interfere with each other constructively and de-constructively. The positive or ‘upward waving’ parts of one of the waves are cancelled out by the negative or ‘downward waving’ parts of other wave.

This is example of a 1 dimensional wave, the curve, which is ‘waving’ into a higher 2nd dimension represented by the vertical extent on the plane that the curve lies in.

In this way, a 2 dimensional wave can be visualized as a 2 dimensional surface which ‘waves’ into a higher 3rd dimension. Here is a certain kind of 2D traveling wave produced by a point source which emits symmetrical in 2 directions creating these circular shaped waves:

And a standing wave produced from the interference of an outward and inward moving wave:

Trying to continue this way in order to visualize a 3 dimensional wave results in some issues, because the 3 dimensional thing that is doing the ‘waving’ needs to wave in a higher 4th dimension which we can’t really visualize by simply drawing in the 4th dimension.

Thus far, we have been associating waviness to movement in a higher spatial dimension. Instead, assign a color to the thing that is doing the waving to represent its waviness. Doing this allows us to eliminate that higher spatial dimension needed in the previous wave visualizations, and alternatively associates this to a color dimension.

Using this method to visualize the 2 dimensional traveling wave resulting from a point source looks like this, where lighter regions can represent positive values and darker regions negative values:

Now we can visualize a 3 dimensional wave by assigning a 3 dimensional region colors according to the wave structure.

Below is a traveling wave resulting from a point source emitting symmetrically in 3 dimensions producing spherical wavefronts. One of the upper quadrants of the region has been removed in order to expose the internal structure of the wave, and the bounding box is present to allow for a better sense of depth.

The standing wave resulting from an outward and inward traveling wave would then look like this:

Increasing the size of the waving region so that it fills the bounding box looks a little more interesting. The faces of the cube show 2 dimensional projections of the 3 dimensional wave which are identical to the 2D analog.

A traveling wave:

And a standing wave:

What was exemplified here only considered a certain kind of wave, which is the most symmetric of waves. In general, a standing wave can be produced by taking any waveform and adding it to the waveform produced when the time direction is reversed.

Interactive Mathematica code: notebook, CDF


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]