This image comes from Michael Trott's Mathematica Guidebook for Programming. It's just a chapter image though, and he doesn't show the code. I was wondering what would be the best approach to reproduce it.
-
1$\begingroup$ For searching purposes: this is in the style of Victor Vasarely's "Vega" series of op art. $\endgroup$– J. M.'s slightly less busy ♦Nov 22, 2012 at 17:46
-
1$\begingroup$ Victor Vasarely --- or Vásárhelyi Győző from Pécs, Hungary $\endgroup$– SzabolcsNov 23, 2012 at 1:09
5 Answers
Trott does give the code for this image in another volume of the series. Look on page 21 of his Mathematica Guidebook for Graphics.
-
$\begingroup$ Well, there's the code, so notwithstanding other valiant efforts, I'm accepting this answer. I will take a close look; Trott writes some awesome code. $\endgroup$ Nov 22, 2012 at 20:56
To make this thread self-contained, here's a reimplementation of Trott's method to produce art in the style of Vasarely:
Module[{e = 6, h = 8, r = 5, s = 7, circRes = 25, sqrRes = 25, circle, square, R, x},
square = Apply[Join,
Map[{sqrRes - #, #}/sqrRes &, Range[0, sqrRes]].# & /@
N[Partition[{-{1, 1}, {1, -1}, {1, 1}, {-1, 1}}/2, 2, 1, 1]]];
circle = N[Composition[Through, {Cos, Sin}] /@ Range[0, 2 Pi, 2 Pi/circRes]]/4;
x = r^2/h // N; R = x (x + h);
Graphics[Table[{{If[EvenQ[j + k], Black, White],
Polygon[TranslationTransform[{j, k}] /@ square]},
{If[EvenQ[j + k], White, Black],
Polygon[TranslationTransform[{j, k}] /@ circle]}},
{j, -s, s}, {k, -s, s}]] /.
v_ /; VectorQ[v, NumericQ] :>
Block[{nn = Norm[v], z},
z = If[nn < r, Sqrt[R - nn^2] - x, 0]; v (1 - (e - z)/(h - z))]
]
It should not be too hard to modify the code given to produce an animated version like this one; this extension is left as an exercise for the interested reader (hint: nn = Norm[v - {x0, y0}]
).
A slightly different approach,
f[t_] := t - 2 t^3
g[r_] := With[{R = 4}, If[r < R, 1 - Sqrt[1 - (r/R)^2]/3, 1]]
RegionPlot[
f[Times @@ Cos[Pi {x, y} g[Sqrt[x^2 + y^2]]]] > 0, {x, -5.5,
5.5}, {y, -5.5, 5.5}, PlotPoints -> 100]
which comes from the following.
The little dots aren't precisely circles, but: meh.
I started a different approach, but I didn't anticipate perspective issues...:)
grid = Graphics[{
EdgeForm[Black],
Table[{
Black,
Rectangle[{ x + Mod[y, 2] - .5, y - .5}, {x + Mod[y, 2] + .5,
y + .5}],
White,
Disk[{x + Mod[y, 2], y}, .25]},
{x, 1, 10, 2}, {y, 1, 10}],
Table[{
White,
Rectangle[{ x + Mod[y, 2] - .5, y - .5}, {x + Mod[y, 2] + .5,
y + .5}],
Black,
Disk[{x + Mod[y, 2], y}, .25]},
{x, 2, 9, 2}, {y, 1, 10}]
}];
ParametricPlot3D[{Cos[u] Sin[ v], Sin[u] Sin[v], Cos[v]},
{u, 0, 2 Pi}, {v, 0, Pi}, Mesh -> None, Boxed -> False,
Axes -> None, SphericalRegion -> True, PlotPoints -> 120,
Lighting -> "Neutral", PlotStyle -> Texture[grid],
Prolog -> Inset[grid]]
How about this approach:
img = Import[
"http://gethighnow.com/wp-content/uploads/2009/07/hermmanns-grid.jpg"];
f[x_, y_] :=
With[{r = N@Sqrt[(x - .5)^2 + (y - .5)^2],
a = ArcTan[x - .5, y - .5], R = .3}, rn = r*r/R;
{rn*Cos[a] + .5, rn*Sin[a] + .5}];
dist = ImageTransformation[img, f[#[[1]], #[[2]]] &];
mask[img_] :=
Graphics[{White, Rectangle[{0, 0}, {320, 320}], Black,
Disk[{160, 160}, 100]}, ImageSize -> ImageDimensions[img],
Background -> White]
mask2[img_] :=
Graphics[{Black, Rectangle[{0, 0}, {320, 320}], White,
Disk[{160, 160}, 100]}, ImageSize -> ImageDimensions[img],
Background -> Black]
hole = SetAlphaChannel[ImageAdd[dist, mask[img]], mask2[img]];
ImageCompose[img, hole]
-
$\begingroup$ Seems both of us used the same code seed :) stackoverflow.com/a/5055736/353410 $\endgroup$ Nov 22, 2012 at 17:54
-
$\begingroup$ To avoid the evaluation of trigonometric functions:
f[x_, y_] := Module[{r = N @ Norm[{x, y} - .5], R = .3, rn}, rn = r*r/R; rn Normalize[{x, y} - .5] + .5]
$\endgroup$ Nov 22, 2012 at 18:41 -
1$\begingroup$ @J.M. You're right, I just copied the function from the Neat Examples section of the documentation for
ImageTransformation[]
. $\endgroup$– VLCNov 22, 2012 at 18:52