#logpolar coordinates

[intothecontinuum]

Made in response to a recent question posted at the Mathematica Stack Exchange.

Mathematica code:

img = ImageCrop@DensityPlot[ Sin[2 x - 20 Log[2 (Sin[y]^2 + 1), 2]], {x, 0, 16 Pi}, {y, 0, 32 Pi}, PlotPoints -> 250, ColorFunction -> "SunsetColors", Frame -> False, ImageSize -> 600] LogPolar[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]} d = ImageDimensions[img][[1]] Manipulate[ ImageResize[ ImageTransformation[ ImageTake[ img, {1, 14*d/16}, {1 + (2 - 2 t)*d/32, (32 - 2 t)*d/32}], LogPolar[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}], 500], {t, 0, 6/7, 1/7}]

[intothecontinuum]

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

[intothecontinuum]

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

[intothecontinuum]

[intothecontinuum]

Phillip Stearns over at Year of the Glitch recently remixed an intothecontinuum GIF. From what I am aware of no one has ever done an edit of any of my posts before, and I have never edited anyone else. So, I did a remix of the remix, which is shown above. Its what would result from transforming his edit into log-polar coordinates.

See the original post here, and the Year of the Glitch edit here.

Mathematica code:

Remix := Import["yearoftheglitchremix.gif"] f[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]} ListAnimate[ Table[ ImageTransformation[ Part[Remix, j], f[#[[1]], #[[2]]] &, DataRange -> {{-1.2 Pi, 1.2 Pi}, {-1.2 Pi, 1.2 Pi}}], {j, 1, 18, 1}]]

[intothecontinuum]

Mathematica code:

Id[x_, y_] := {x, y} f[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]} ListAnimate[ Table[ Show[ ImageTransformation[ Graphics[ Rotate[ Table[ {If[ Mod[j, 4] == 0, Blue, If[ Mod[j, 4] == 1, Green, If[ Mod[j, 4] == 2, Pink, If[ Mod[j, 4] == 3, Yellow]]]], Thickness[.01], Line[{{j + t, 40 + t}, {j + t, -20 + t}}]}, {j, -12, 37, 1}], 1.03], PlotRange -> {{-.5, 27.5}, {-.5, 27.5}},  ImageSize -> 500, Background -> Black], f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}], ImageTransformation[ Graphics[ Table[ {Black, Disk[{13.75, 13.75}, 20, {k*Pi/19, (k + 1) Pi/19 - .3*Pi/19}]}, {k, 0, 37, 1}], PlotRange -> {{-.5, 27.5}, {-.5, 27.5}}, ImageSize -> 500, Background -> None], Id[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]], {t, 0, 2.9, .1}]]

[intothecontinuum]

Inspired by the Buddha jukebox

Mathematica code:

Id[x_, y_] := {x, y} f[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]} ListAnimate[ Table[ Show[ ImageTransformation[ Graphics[ Rotate[ Table[ {If[ Mod[j, 4] == 0, Blue, If[ Mod[j, 4] == 1, Green, If[ Mod[j, 4] == 2, Pink, If[ Mod[j, 4] == 3, Yellow]]]], Thickness[.01], Line[{{j + t, 40 + t}, {j + t, -20 + t}}]}, {j, -12, 37, 1}], .796], PlotRange -> {{-.5, 27.5}, {-.5, 27.5}},  ImageSize -> 500, Background -> Black], f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}], ImageTransformation[ Graphics[ Table[ {Darker[Red, .6], Disk[{13.75, 13.75}, 20, {k*Pi/19, (k + 1) Pi/19 - .15*Pi/19}]}, {k, 0, 37, 1}], PlotRange -> {{-.5, 27.5}, {-.5, 27.5}}, ImageSize -> 500, Background -> None], Id[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]], {t, 0, 2.7, .2}]]

[intothecontinuum]

Mathematica code:

f[x_, y_] := {Log[Sqrt[(x)^2 + (y)^2]], ArcTan[x, y]} ListAnimate[ Table[ ImageTransformation[ ImageResize[ImageTake[ImageCrop[ DensityPlot[ Sin[104.02*Abs[(x + I y)^2]], {x, -4.26, 4.26}, {y, -4.26, 4.26}, PlotPoints -> 27, Mesh -> False, Frame -> False, ColorFunction -> Hue, ImageSize -> 834], 800], {193 - t, 747 - t}, {123 + t, 677 + t}], {500, 500}], f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}], {t, 63, 0, 7}], 10, AnimationRunning -> False]