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}]
Filed under: #GIF  #Mathematica  #Vasilj Godzh

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}]
Filed under: #GIF  #Mathemtica

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}]
Filed under: #GIF  #Mathematica

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}]
Filed under: #GIF  #Mathematica

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}]
Filed under: #parquet deformation  #tilings

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:

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}]
Filed under: #GIF  #Mathematica  #waterfall plot  #wavy

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

Be happy!

Mathematica code:

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

Fireworks2[IS_, pr_, x_, y_, h_, R_, P_, F_, g_, v_, u_, z_,
o_, O_, w_, d_, q_, e_, A_, k_, s_, t_] :=
Graphics[
Table[
If[t < r[R*f] s, {Black, Opacity[0], Disk[]},
Table[
Table[
{Hue[r[R*f]],
Opacity[If[a == 0,
If[t - r[R*f] s < o + r[R*f] s, O,
O*Exp[-d*(t - r[R*f] s - o)]],
If[(t - r[R*f] s - a) < q + r[R*f] s, 0,
O*Exp[-e*(t - r[R*f] s + a - q)]]]],
Disk[
{x + (v + u*r[2 R*f*n])*
Cos[2 Pi*r[f*R*n]]*(t - r[R*f] s - a),
y +
h + (v + u*r[2 R*f*n])*
Sin[2 Pi*r[f*R*n]]*(t - r[R*f] s -
a) - .5 g*(t - r[R*f] s - a)^2},
(z + .2 r[6 f*R*n])*k^a]},
{n, 1, P}],
{a, 0, A, .05}]],
{f, 1, F}],
Background -> Black, PlotRange -> pr, ImageSize -> IS]

Manipulate[
Fireworks[500, 40, 0, 9, 0, 1, 70, 3, .6,
If[t < 6, 6, 6 - .05 (t - 6)^2],
-1, .2, 3, .7, 2, .5, 0, .4,
5, .9, 1, t],
{t, 0, 11, .25}]]
Filed under: #GIF  #Mathematica  #fireworks  #2013

snowflake fractals

Mathematica code:

h[1] = Table[{Cos[n*Pi/3], Sin[n*Pi/3]}, {n, 0, 5, 1}];

h[s_, k_] := Plus @@@ Tuples[Table[s^(n)*h[1], {n, 1, k}]]

SnowFlakeFractal[s1_, s2_, N0_, N_, o_, S_, R_, pr_] :=
Graphics[
Rotate[
Scale[
{White, Opacity[o],
Table[
Rotate[
Translate[
Scale[
Table[Line[
{{0, 0}, h[1][[i]]}],
{i, 1, 6, 1}],
s1^(n - 1)],
h[s2, n]],
.5^n*Pi/3],
{n, N0, N, 1}]},
S],
R],
Background -> Black, PlotRange -> pr, ImageSize -> 500]

Manipulate[
Show[
Table[
SnowFlakeFractal[s1, s2, N0, N, o, S^F, R, pr],
{F,1,6,1}]],
{{s1, .28}, 1, 0}, {{s2, .38}, 1, 0},
{{N0, 4}, 0, 5, 1}, {{N, 5}, 0, 6, 1},
{o, 1, 0}, {{S, 1}, 2, 0}, {{R, 1}, 0, Pi/3},
{{pr, 1}, 6, .001}]

V = {
{.28, .38, .25, .48, .14},
{.26, .4, .3, .4, .14},
{.35, .4, .35, .3, .1},
{.33, .34, .35, .28, .1}
}

Table[
Manipulate[
Show[
Table[
SnowFlakeFractal[V[[i]][[1]],V[[i]][[2]],N0,N,o,V[[i]][[3]]^F,R,pr],
{F,1,6,1}]],
{pr, V[[i]][[4]]], V[[i]][[5]], -.02}],
{i,1,4,1}]
Filed under: #GIF  #Mathematica  #snowflakes  #C6