Anonymous
asks:
Could you please post your profile picture?

Here is the icon:

image

which is a crop from this photo of Erwin Schrödinger:

image

I do not know any other details such as who took it, where it was taken, and when. If anyone does know, please let me know.

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

Inspired by Vasilj Godzh

Mathematica code:
s[q_] := (SeedRandom[q]; RandomReal[])r[S_, a_, v_, w_, t_] :=  S (1 + .05 Sin[v*a] Cos[w*a] + .1 Cos[8*a] + .025 Sin[a + t])F[Q_, S_, M_, v_, w_, th_, t_] := {EdgeForm[{AbsoluteThickness[th], Black}], FaceForm[White],  Polygon[   Table[    {{0, 0},     {r[S, (a + s[Q*a]) 2 Pi/M, v, w, t] Cos[(a + s[Q*a]) 2 Pi/M],      r[S, (a + s[Q*a]) 2 Pi/M, v, w, t] Sin[(a + s[Q*a]) 2 Pi/M]},     {r[S, (a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M, v, w, t] Cos[(a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M],      r[S, (a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M, v, w, t] Sin[(a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M]}},    {a, 1, M, 1}]]}Manipulate[ Graphics[  Table[   Translate[    Reverse@     Table[      F[i*j, (1 + .3 i^1.7), 125 + 25 i,          3 + Round[9 s[i*j]], 3 + Round[9 s[2 i*j]],        .6, t + s[j] 2 Pi],      {i, 1, 4, 1}],    {17*s[j], 23.8*s[2 j]}],   {j, 1, 46, 1}],  PlotRange -> {{.5, 17.5}, {-1.2, 22.6}},   ImageSize -> {500, 700}], {t, 0, 2Pi}]

Inspired by Vasilj Godzh

Mathematica code:

s[q_] := (SeedRandom[q]; RandomReal[])

r[S_, a_, v_, w_, t_] :=
S (1 + .05 Sin[v*a] Cos[w*a] + .1 Cos[8*a] + .025 Sin[a + t])

F[Q_, S_, M_, v_, w_, th_, t_] :=
{EdgeForm[{AbsoluteThickness[th], Black}], FaceForm[White],
Polygon[
Table[
{{0, 0},
{r[S, (a + s[Q*a]) 2 Pi/M, v, w, t] Cos[(a + s[Q*a]) 2 Pi/M],
r[S, (a + s[Q*a]) 2 Pi/M, v, w, t] Sin[(a + s[Q*a]) 2 Pi/M]},
{r[S, (a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M, v, w, t] Cos[(a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M],
r[S, (a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M, v, w, t] Sin[(a + 1 + s[Q (Mod[a, M] + 1)]) 2 Pi/M]}},
{a, 1, M, 1}]]}

Manipulate[
Graphics[
Table[
Translate[
Reverse@
Table[
F[i*j, (1 + .3 i^1.7), 125 + 25 i,
3 + Round[9 s[i*j]], 3 + Round[9 s[2 i*j]],
.6, t + s[j] 2 Pi],
{i, 1, 4, 1}],
{17*s[j], 23.8*s[2 j]}],
{j, 1, 46, 1}],
PlotRange -> {{.5, 17.5}, {-1.2, 22.6}},
ImageSize -> {500, 700}],
{t, 0, 2Pi}]

Mathematica code:


G[A_, B_, s_, N_, T_, t_, th_, pr_, u_, v_] :=
Graphics[
{EdgeForm[{AbsoluteThickness[th], Black}], FaceForm[White],
Polygon[
Table[
{{0, 0},
{(Cos[u*a+t]Sin[v*a+t])Cos[a+t], (Cos[u*a+t]Sin[v*a+t])Sin[a+t]},
{(Cos[u*a+s+t]Sin[v*a+s+t])Cos[a+s+t], (Cos[u*a+s+t]Sin[v*a+s+t])Sin[a+s+t]}},
{a, B + T, A + T, 2 Pi/N}]]},
PlotRange -> {{-1.5 pr, 1.5 pr}, {-pr, pr}}, ImageSize -> 400]

Manipulate[
G[2Pi, 0, .5, 200, 0, t, .3, .7, 1, v],
{v, {3,4,5}},
{t,0,2Pi}]

Mathematica code:
G[A_, B_, s_, N_, T_, t_, pr_, th_] := Graphics[  {EdgeForm[{AbsoluteThickness[th], Black}], FaceForm[White],    Polygon[    Table[     {{0, 0},      {(Cos[4a+s*t]+Sin[4a+s*t])Cos[a+s*t], (Cos[4a+s*t]+Sin[4a+s*t]) Sin[a+s*t]},      {(Cos[4a+s+s*t]+Sin[4a+s+s*t])Cos[a+s+s*t], (Cos[4a+s+s*t]+Sin[4a+s+s*t]) Sin[a+s+s*t]}},     {a, B + T, A + T, 2 Pi/N}]]},   PlotRange -> pr, ImageSize -> 500]Manipulate[G[2Pi, 0, .75, 200, T, 0, 1.5, .3],{T,0,2Pi}]

Mathematica code:


G[A_, B_, s_, N_, T_, t_, pr_, th_] :=
Graphics[
{EdgeForm[{AbsoluteThickness[th], Black}], FaceForm[White],
Polygon[
Table[
{{0, 0},
{(Cos[4a+s*t]+Sin[4a+s*t])Cos[a+s*t], (Cos[4a+s*t]+Sin[4a+s*t]) Sin[a+s*t]},
{(Cos[4a+s+s*t]+Sin[4a+s+s*t])Cos[a+s+s*t], (Cos[4a+s+s*t]+Sin[4a+s+s*t]) Sin[a+s+s*t]}},
{a, B + T, A + T, 2 Pi/N}]]},
PlotRange -> pr, ImageSize -> 500]

Manipulate[
G[2Pi, 0, .75, 200, T, 0, 1.5, .3],
{T,0,2Pi}]

Inspired by this
Mathematica code:
Manipulate[ Graphics[  Table[   Table[    {EdgeForm[{Black, AbsoluteThickness[2.5]}], FaceForm[White],     Translate[      Polygon[       Table[{         {3.9 Sin[Pi/8 (t + V)]          + i/8 ((-1)^S*(1 + Abs[3.9 Sin[Pi/8 (t + V)]]) - 3.9 Sin[Pi/8 (t + V)]),          i/8},         {-3.9 Sin[Pi/8 (t + V)]           + i/8 ((-1)^S*(1 + Abs[3.9 Sin[Pi/8 (t + V)]]) + 3.9 Sin[Pi/8 (t + V)]),         2 - i/8},         {(-1)^S* 6 - (-1)^S*i/8, 2 - i/8},         {(-1)^S*6 - (-1)^S*i/8, i/8}},        {i, 0, 8, 1}]],      {0, -2 V}]},    {S, 0, 1}],   {V, 0, 7, 1}], ImageSize -> 500], {t, 0, 16}]

Inspired by this

Mathematica code:

Manipulate[
Graphics[
Table[
Table[
{EdgeForm[{Black, AbsoluteThickness[2.5]}], FaceForm[White],
Translate[
Polygon[
Table[{
{3.9 Sin[Pi/8 (t + V)]
+ i/8 ((-1)^S*(1 + Abs[3.9 Sin[Pi/8 (t + V)]]) - 3.9 Sin[Pi/8 (t + V)]),
i/8},
{-3.9 Sin[Pi/8 (t + V)]
+ i/8 ((-1)^S*(1 + Abs[3.9 Sin[Pi/8 (t + V)]]) + 3.9 Sin[Pi/8 (t + V)]),
2 - i/8},
{(-1)^S* 6 - (-1)^S*i/8, 2 - i/8},
{(-1)^S*6 - (-1)^S*i/8, i/8}},
{i, 0, 8, 1}]],
{0, -2 V}]},
{S, 0, 1}],
{V, 0, 7, 1}],
ImageSize -> 500],
{t, 0, 16}]
Mathematica code:
Tile[k_, rx_, ry_, x_, y_, r_] := Table[  Translate[   Rotate[    {AbsoluteThickness[k],     Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},    r, {.5, .5}],   {x, y}],  {i, 0, 1, 1}]rr[Q_] := (SeedRandom[Q]; RandomReal[])GCOS[k_, rx1_, rx2_, ry1_, ry2_, X_, Y_, Q_, t_] := Graphics[  Table[    Tile[k,        .75 + .25 Cos[2 Pi*Mod[rx1 + rx2*x/X + t, 1]],        .75 + .25 Cos[2 Pi*Mod[ry1 + ry2*y/Y + t, 1]],        x, y, Floor[3*rr[Q*x*y]] Pi/2],   {x, 1, X, 1}, {y, 1, Y, 1}],  ImageSize -> 500, PlotRange -> {{1, X + 1}, {1, Y + 1}}]Manipulate[   GCOS[2, .5, .5, .5, .5, 30, 42, 4, t],{t, .05, 1, .05}]

Mathematica code:

Tile[k_, rx_, ry_, x_, y_, r_] :=
Table[
Translate[
Rotate[
{AbsoluteThickness[k],
Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},
r, {.5, .5}],
{x, y}],
{i, 0, 1, 1}]

rr[Q_] := (SeedRandom[Q]; RandomReal[])

GCOS[k_, rx1_, rx2_, ry1_, ry2_, X_, Y_, Q_, t_] :=
 Graphics[
Table[
Tile[k,
 .75 + .25 Cos[2 Pi*Mod[rx1 + rx2*x/X + t, 1]],
 .75 + .25 Cos[2 Pi*Mod[ry1 + ry2*y/Y + t, 1]],
 x, y, Floor[3*rr[Q*x*y]] Pi/2],
{x, 1, X, 1}, {y, 1, Y, 1}],
ImageSize -> 500, PlotRange -> {{1, X + 1}, {1, Y + 1}}]

Manipulate[
GCOS[2, .5, .5, .5, .5, 30, 42, 4, t],
{t, .05, 1, .05}]
1000x1000
Mathematica code:
Tile[k_, rx_, ry_, x_, y_, r_] := Table[  Translate[   Rotate[    {AbsoluteThickness[k],     Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},    r, {.5, .5}],   {x, y}],  {i, 0, 1, 1}]rr[Q_] := (SeedRandom[Q]; RandomReal[])Manipulate[Graphics[ Table[  Tile[4, .5 + .5*x/1000, y/1000, x, y, Floor[3*rr[x*y]] Pi/2],  {x, 1, 100, 1}, {y, 1, 100, 1}], ImageSize -> 1000, PlotRange -> {{1, 101}, {1, 101}}],{r, 0, 1, .25}]

1000x1000

Mathematica code:

Tile[k_, rx_, ry_, x_, y_, r_] :=
Table[
Translate[
Rotate[
{AbsoluteThickness[k],
Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},
r, {.5, .5}],
{x, y}],
{i, 0, 1, 1}]

rr[Q_] := (SeedRandom[Q]; RandomReal[])

Manipulate[
Graphics[
Table[
Tile[4, .5 + .5*x/1000, y/1000, x, y, Floor[3*rr[x*y]] Pi/2],
{x, 1, 100, 1}, {y, 1, 100, 1}],
ImageSize -> 1000, PlotRange -> {{1, 101}, {1, 101}}],
{r, 0, 1, .25}]
Testing the new panorama feature on Tumblr with a parquet deformation—a kind of "geometrical tessellating metamorphosis". Douglas Hofstadter has a bit to say about them in Metamagical Themas.
Click the image to view in panorama mode. The original image is 4000 pixels wide.
more variants: 1, 2, 3
Mathematica code:
Tile[k_, rx_, ry_, x_, y_, r_] := Table[  Translate[   Rotate[    {AbsoluteThickness[k],     Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},    r, {.5, .5}],   {x, y}],  {i, 0, 1, 1}]rr[Q_] := (SeedRandom[Q]; RandomReal[])Manipulate[Graphics[ Table[  Tile[4, .5 + .5*x/200, r , x, y, Floor[3*rr[x*y]] Pi/2],  {x, 1, 200, 1}, {y, 1, 20, 1}], ImageSize -> 4000, PlotRange -> {{1, 201}, {1, 21}}],{r, 0, 1, .25}]

Testing the new panorama feature on Tumblr with a parquet deformation—a kind of "geometrical tessellating metamorphosis". Douglas Hofstadter has a bit to say about them in Metamagical Themas.

Click the image to view in panorama mode. The original image is 4000 pixels wide.

more variants: 1, 2, 3

Mathematica code:

Tile[k_, rx_, ry_, x_, y_, r_] :=
Table[
Translate[
Rotate[
{AbsoluteThickness[k],
Circle[{i, i}, {rx, ry}, {i*Pi, Pi/2 + i*Pi}]},
r, {.5, .5}],
{x, y}],
{i, 0, 1, 1}]

rr[Q_] := (SeedRandom[Q]; RandomReal[])

Manipulate[
Graphics[
Table[
Tile[4, .5 + .5*x/200, r , x, y, Floor[3*rr[x*y]] Pi/2],
{x, 1, 200, 1}, {y, 1, 20, 1}],
ImageSize -> 4000, PlotRange -> {{1, 201}, {1, 21}}],
{r, 0, 1, .25}]


Imagine throwing a bunch of balls up into the air at just the right place, at just the right time, with just the right speed, so that all the balls reach their maximum height at the same exact time and form a picture. Simulated here is the tumblr logo, a smiley face, and a more complicated face. Can you recognize who?

Some unrealistic physical assumptions:
- The balls don’t collide into each other.
- The balls only bounce straight up and down.

Inspired by this.

Read more for code:

Read More

nldmut:

Specular holograms by Matthew Brand currently on display at the new Museum of Mathematics in New York.

See his site for more.

The technique used by Brand to create these pieces is not one of conventional holography. He meticulously controls the unique shape of thousands of tiny optical pieces placed on a surface creating a 3D effect when the light source or viewer moves. This is essentially a mathematical problem in differential geometry and combinatorial optimization. Brand was the first person to correctly describe this technique in 2008 even though it dates back as early as the 1930s (check out his paper for details).

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