25
$\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$
2
  • 1
    $\begingroup$ For searching purposes: this is in the style of Victor Vasarely's "Vega" series of op art. $\endgroup$ Nov 22, 2012 at 17:46
  • 1
    $\begingroup$ Victor Vasarely --- or Vásárhelyi Győző from Pécs, Hungary $\endgroup$
    – Szabolcs
    Nov 23, 2012 at 1:09

5 Answers 5

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$
1
  • $\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
24
$\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$
3
  • $\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$
    – VLC
    Nov 22, 2012 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.