24
$\begingroup$

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.

enter image description here

$\endgroup$
  • 1
    $\begingroup$ For searching purposes: this is in the style of Victor Vasarely's "Vega" series of op art. $\endgroup$ – J. M. will be back soon Nov 22 '12 at 17:46
  • 1
    $\begingroup$ Victor Vasarely --- or Vásárhelyi Győző from Pécs, Hungary $\endgroup$ – Szabolcs Nov 23 '12 at 1:09
15
$\begingroup$

Trott does give the code for this image in another volume of the series. Look on page 21 of his Mathematica Guidebook for Graphics.

$\endgroup$
  • $\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$ – Chris Degnen Nov 22 '12 at 20:56
23
$\begingroup$

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

Vasarelian art

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

$\endgroup$
15
$\begingroup$

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]

enter image description here

which comes from the following.

enter image description here

The little dots aren't precisely circles, but: meh.

$\endgroup$
11
$\begingroup$

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

image

$\endgroup$
9
$\begingroup$

How about this approach:

img = Import[
   "http://gethighnow.com/wp-content/uploads/2009/07/hermmanns-grid.jpg"];

enter image description here

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]

op-art

$\endgroup$
  • $\begingroup$ Seems both of us used the same code seed :) stackoverflow.com/a/5055736/353410 $\endgroup$ – Dr. belisarius Nov 22 '12 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$ – J. M. will be back soon Nov 22 '12 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$ – VLC Nov 22 '12 at 18:52

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.