Posts tagged: logpolar coordinates



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

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

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

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

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

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

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

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]
High-res: 800x800
Mathematica code:
f[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]}ImageTransformation[ 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],f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]

High-res: 800x800

Mathematica code:

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

ImageTransformation[
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],
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]

Mathematica code:
f[x_, y_] := {Log[Sqrt[(x)^2 + (y)^2]], ArcTan[x, y]}ListAnimate[  Table[    ImageTransformation[     ImageResize[ImageTake[ImageCrop[       DensityPlot[         Sin[104.54*Abs[(x + I y)^2]],        {x, -2.5, 2.5}, {y, -2.5, 2.5}, PlotPoints -> 27,        Mesh -> False, Frame -> False, ColorFunction -> Hue, ImageSize -> 834],     800], {100 + t, 700 + t}, {100 - t, 700 - t}],{500, 500}],    f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}], {t, 0, 90, 10}],10, AnimationRunning -> False]

Mathematica code:

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

ListAnimate[
Table[
ImageTransformation[
ImageResize[ImageTake[ImageCrop[
DensityPlot[
Sin[104.54*Abs[(x + I y)^2]],
{x, -2.5, 2.5}, {y, -2.5, 2.5}, PlotPoints -> 27,
Mesh -> False, Frame -> False, ColorFunction -> Hue, ImageSize -> 834],
800], {100 + t, 700 + t}, {100 - t, 700 - t}],{500, 500}],
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}],
{t, 0, 90, 10}],
10, AnimationRunning -> False]

High-res: 800x800
Mathematica code:
f[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]}ImageTransformation[ ImageCrop[    DensityPlot[       Sin[104.54*Abs[(x + I y)^2]],     {x, -2.5, 2.5}, {y, -2.5, 2.5},     PlotPoints -> 27, Mesh -> False, Frame -> False,     ColorFunction -> Hue, ImageSize -> 834], 800],f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]

High-res: 800x800

Mathematica code:

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

ImageTransformation[
ImageCrop[
DensityPlot[
Sin[104.54*Abs[(x + I y)^2]],
{x, -2.5, 2.5}, {y, -2.5, 2.5},
PlotPoints -> 27, Mesh -> False, Frame -> False,
ColorFunction -> Hue, ImageSize -> 834],
800],
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]
Mathematica code:
f[x_, y_] := {Log[Sqrt[(x)^2 + (y)^2]], ArcTan[x, y]}ListAnimate[  Table[    ImageTransformation[     ImageResize[ImageTake[ImageCrop[       DensityPlot[         Sin[84.74*Abs[(x + I y)^2]],        {x, -10, 10}, {y, -10, 10}, PlotPoints -> 35,        Mesh -> False, Frame -> False, ColorFunction -> Hue, ImageSize -> 834],    800], {119 + t, 683 + t}, {189 - t, 753 - t}],{500, 500}],   f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}], {t, 65, 0, 5}],10, AnimationRunning -> False]

Mathematica code:

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

ListAnimate[
Table[
ImageTransformation[
ImageResize[ImageTake[ImageCrop[
DensityPlot[
Sin[84.74*Abs[(x + I y)^2]],
{x, -10, 10}, {y, -10, 10}, PlotPoints -> 35,
Mesh -> False, Frame -> False, ColorFunction -> Hue, ImageSize -> 834],
800], {119 + t, 683 + t}, {189 - t, 753 - t}],{500, 500}],
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}],
{t, 65, 0, 5}],
10, AnimationRunning -> False]

High-res: 800x800
Mathematica code:
f[x_, y_] := {Log[Sqrt[x^2 + y^2]], ArcTan[x, y]}ImageTransformation[ ImageCrop[   DensityPlot[     Sin[84.74*Abs[(x + I y)^2]],    {x, -10, 10}, {y, -10, 10},    PlotPoints -> 35, Mesh -> False, Frame -> False,    ColorFunction -> Hue, ImageSize -> 834], 800],f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]

High-res: 800x800

Mathematica code:

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

ImageTransformation[
ImageCrop[
DensityPlot[
Sin[84.74*Abs[(x + I y)^2]],
{x, -10, 10}, {y, -10, 10},
PlotPoints -> 35, Mesh -> False, Frame -> False,
ColorFunction -> Hue, ImageSize -> 834],
800],
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}]

Type 4) form constant: hexagonal lattice

Mathematica code:

h[x_, y_] := Polygon[Table[{Cos[2 Pi k/6] + x, Sin[2 Pi k/6] + y}, {k, 6}]]

HexagonalLattice[t_] :=
Graphics[
{EdgeForm[Thickness[.01]], White,
Table[
h[3 i + 3 ((-1)^j + 1)/4 + Cos[Pi/6] t, Sqrt[3]/2 j + Sin[Pi/6] t],
{i, 15}, {j, 45}]},
ImageSize -> 500, PlotRange -> {{7, 46.2}, {1.8, 39.8}}]

ListAnimate[
Table[
HexagonalLattice[t],
{t, 0, 3.105, .345}]]

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

ListAnimate[
Table[
ImageTransformation[
HexagonalLattice[t] ,
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}],
{t, 0, 3.105, .345}]]


Type 4) form constant: square lattice

Mathematica code:

SquareLattice[t_] :=
Graphics[{
Table[
Rectangle[{i + t, j + t}],
{i, -2, 42, 2}, {j, -2, 42, 2}],
Table[
Rectangle[{i + 1 + t, j + 1 + t}],
{i, -2, 42, 2}, {j, -2, 42, 2}]},
PlotRange -> {{0, 40}, {0, 40}}, ImageSize -> 500]

ListAnimate[
Table[
SquareLattice[t],
{t, 0, .9, .1}]]

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

ListAnimate[
Table[
ImageTransformation[
SquareLattice[t],
f[#[[1]], #[[2]]] &, DataRange -> {{-Pi, Pi}, {-Pi, Pi}}],
{t, 0, .9, .1}]]