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


High-res Notes: 99 1/22/13 — 6:00pm Filed under: #parquet deformation  #tilings  #Mathematica 

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

Notes: 107 1/17/13 — 6:01pm Filed under: #GIF  #Mathematica  #physics  #Image processing  #portrait  #circles  #Erwin Schrödinger 

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).

Notes: 2724 1/9/13 — 5:44pm Filed under: #GIF  #math  #knot theory  #specular holography  #MoMath  #Matthew Brand  #3D  #stereoscopic 

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}]
Notes: 197 1/7/13 — 6:00pm Filed under: #GIF  #Mathematica  #logpolar coordinates  #wavy 

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}]
Notes: 211 1/6/13 — 6:04pm Filed under: #GIF  #Mathematica  #Bridget Riley  #logpolar coordinates  #waterfall plot  #wavy 
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}]
Notes: 7561 1/4/13 — 6:10pm 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}]

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}]
Notes: 3120 1/3/13 — 9:34pm Filed under: #GIF  #Mathematica  #Bridget Riley  #waterfall plot  #wavy 
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}]]

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}]]
Notes: 146 12/31/12 — 7:07pm 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}]
Notes: 245 12/25/12 — 10:20pm Filed under: #GIF  #Mathematica  #snowflakes  #C6 

Each snowflake is algorithmically generated using some randomness to create infinitely many snowflakes where no two are exactly alike.

Mathematica code:

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

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

SnowFlake[Q_, x_, y_, R_, S_, k_, h_, o_, s_, N_, PR_, IS_] := 
 Graphics[{
   Rotate[
    Translate[
     Scale[
      Table[
       Table[
        Rotate[
         Translate[
          Scale[
           Table[
            {AbsoluteThickness[k*h^(n - 1)], Opacity[o], White,
             Line[
              {{0, 0}, H[[i]]}]},
            {i, 1, 6, 1}],
           s^(n - 1)],
          {If[n == 1, 0, rr[Q*n]], 0}],
         If[n == 1, 0, (j + rr[Q*n])*Pi/3], {0, 0}],
        {j, 0, 5, 1}],
       {n, 1, N, 1}],
      S],
     {x, y}],
    R, {x, y}]},
  PlotRange -> PR, ImageSize -> IS, Background -> Black]

Manipulate[
 SnowFlake[Q, 0, 0, rr[2 Q] Pi/3, 1, k, h, o, s, N, 2, 500],
 {Q, 1, 1000, 1}, {{k, 1}, 0, 2}, {{h, .9}, 1, 0},
 {{o, .75}, 1, 0}, {{s, .75}, 1, 0}, {{N, 10}, 1, 20, 1}]

Manipulate[
GraphicsGrid[
   Table[
    SnowFlake[Q*W, 0, 0, (-1)^(Round[rr[4 Q*W]]) (t + rr[2 Q*W]) Pi/3,
              1, 1, .85, .8, .5 + .2 rr[3 Q*W], 15, 2, 100],
   {Q, q, q+6, 1}, {W, w, w+4, 1}],
 Background -> Black, ImageSize -> {500, 700}, AspectRatio->7/5],
{q, 1, 100, 1}, {w, 1, 100, 1}, {t, 0, 1 - 1/25, 1/25}]
Notes: 1268 12/21/12 — 5:00pm Filed under: #GIF  #Mathematica  #countable infinity  #snowflakes  #C6 
gifcards: Let it snow Did this for The Daily Dot! Read more for some code: [[MORE]]rr[n_] := (SeedRandom[n]; RandomReal[])H = Table[{Cos[n*Pi/3], Sin[n*Pi/3]}, {n, 0, 5, 1}];SnowFlake[Q_, x_, y_, R_, S_, k_, h_, o_, s_, N_, PR_, IS_] := Graphics[{ Rotate[ Translate[ Scale[ Table[ Table[ Rotate[ Translate[ Scale[ Table[ {AbsoluteThickness[k*h^(n - 1)], Opacity[o], White, Line[ {{0, 0}, H[[i]]}]}, {i, 1, 6, 1}], s^(n - 1)], {If[n == 1, 0, rr[Q*n]], 0}], If[n == 1, 0, (j + rr[Q*n])*Pi/3], {0, 0}], {j, 0, 5, 1}], {n, 1, N, 1}], S], {x, y}], R, {x, y}]}, PlotRange -&gt; PR, ImageSize -&gt; IS, Background -&gt; Black]Manipulate[ Table[ SnowFlake[ Q*f, 4 rr[2 Q*f] - 2, 1.25 - 2.5 (Mod[t + rr[3 Q*f], 1]), (-1)^(Round[rr[4 Q*f]])*t*Ceiling[6 rr[4 Q*f]]*Pi/3, .04 + .03 rr[5 Q*f], .8, 1, .3, .75, 6, {{-2, 2}, {-6/5, 6/5}}, {500, 300}], {f, 1, F, 1}],{Q, 1, 100, 1}, {F, 1, 50, 1}, {t, 0, 1}]

gifcards:

Let it snow

Did this for The Daily Dot!

Read more for some code:

Read More

Notes: 90 12/21/12 — 4:23pm Filed under: #GIF  #Mathematica  #snowflakes 
Inspired by Successive Rows of Horizontal Straight Lines from Top to Bottom &amp; Vertical Straight Lines from Left to Right (1972) by Sol LeWitt. Mathematica code: BG = Polygon[ {ImageScaled[{0, 0}], ImageScaled[{1, 0}],  ImageScaled[{1, 1}], ImageScaled[{0, 1}]}, VertexColors -&gt; {RGBColor[240/255, 237/255, 222/255], RGBColor[229/255, 226/255, 211/255], RGBColor[228/255, 227/255, 209/255], RGBColor[214/255, 215/255, 199/255]}];Manipulate[ Graphics[ Table[ Rotate[ Table[ Table[ Line[ {{Mod[i + j/14 + (1 + r) t + r/2, 12], 0}, {Mod[i + j/14 + (1 + r) t + r/2, 12], 12}}], {j, -i/2, i/2, 1}], {i, 0, 12, 1}], -r*Pi/2, {6, 6}], {r, {0, 1}}], PlotRange -&gt; {{0, 11.5}, {0, 11.5}}, ImageSize -&gt; 500, Prolog -&gt; BG],{{t, 11.05}, 0, 12}]

Inspired by Successive Rows of Horizontal Straight Lines from Top to Bottom & Vertical Straight Lines from Left to Right (1972) by Sol LeWitt.

Mathematica code:

BG =
 Polygon[
 {ImageScaled[{0, 0}], ImageScaled[{1, 0}],
  ImageScaled[{1, 1}], ImageScaled[{0, 1}]}, 
 VertexColors ->
  {RGBColor[240/255, 237/255, 222/255],
   RGBColor[229/255, 226/255, 211/255], 
   RGBColor[228/255, 227/255, 209/255],
   RGBColor[214/255, 215/255, 199/255]}];

Manipulate[
 Graphics[
  Table[
   Rotate[
    Table[
     Table[
      Line[
       {{Mod[i + j/14 + (1 + r) t + r/2, 12], 0},
        {Mod[i + j/14 + (1 + r) t + r/2, 12], 12}}],
     {j, -i/2, i/2, 1}],
    {i, 0, 12, 1}],
   -r*Pi/2, {6, 6}],
  {r, {0, 1}}],
 PlotRange -> {{0, 11.5}, {0, 11.5}}, ImageSize -> 500, Prolog -> BG],
{{t, 11.05}, 0, 12}]


Notes: 125 12/13/12 — 6:00pm Filed under: #GIF  #Mathematica  #Sol LeWitt 

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}]
Notes: 543 12/4/12 — 6:30pm Filed under: #GIF  #Mathematica  #cubes  #does it sync?  #photset  #projections  #wavy  #parquet deformation 


from patternstream

Notes: 227 12/2/12 — 6:00pm Filed under: #C16  #GIF  #Mathematica  #patternstream  #photoset 
Anonymous
asks:
How long have you been coding for?

I don’t have any experience coding outside of Mathematica, and only started using it about a year ago. Even within Mathematica, a powerful and diverse programming language that lets you do much more than make neat GIFs, my experience is limited to the most basic graphic primitives. Since then this blog has basically served as a ‘progress’ blog for learning Mathematica, which has a very reasonable learning curve provided the user has some mathematical maturity.  it would be nice to try learning other languages too.

Notes: 13 12/2/12 — 1:00am Filed under: #Mathematica  #personal