10
$\begingroup$

I would like to produce an image similar to the upper half of this graphics by Victor Vasarely.

enter image description here

All I could produce so far is this dilettante image:

g = Graphics[{GrayLevel@0.7, Rectangle[]}, ImageSize -> 30];
h = Graphics[{GrayLevel@0.7, Rotate[Rectangle[], Pi/12]}, ImageSize -> 30];

Grid[{
  {g, g, g, g, g, g, g, g, g, g, g},
  {g, g, g, g, g, h, g, g, g, g, g},
  {g, g, g, g, h, h, h, g, g, g, g},
  {g, g, g, h, h, h, h, h, g, g, g},
  {g, g, h, h, h, h, h, h, h, g, g},
  {g, h, h, h, h, h, h, h, h, h, g},
  {g, g, h, h, h, h, h, h, h, g, g},
  {g, g, g, h, h, h, h, h, g, g, g},
  {g, g, g, g, h, h, h, g, g, g, g},
  {g, g, g, g, g, h, g, g, g, g, g},
  {g, g, g, g, g, g, g, g, g, g, g}},
 Background -> GrayLevel@0.2,
 Spacings -> {0.1, 0}]

enter image description here

I also tried scaled rectangles and parallelograms but to no avail: The forms don't align "properly"(equal vertical spacings).

Maybe Grid is an inept tool to get the desired effect?

How would you approach this problem?

$\endgroup$
  • $\begingroup$ (at) eldo: Honestly speaking, in the graphics of Victor Vaserely I don't see rotated rectangles, not even rhombus but "at most" paralelograms with angles progressing according to a more or less complicated rule as we move along. So, if you really want to reproduce Vasarely's graphics we need to agree on the deformation rule. (BTW, I like your graph :-) $\endgroup$ – Dr. Wolfgang Hintze Sep 21 '14 at 17:06
  • 1
    $\begingroup$ (at) eldo: look at that: h = Graphics[{GrayLevel@0.7, Rotate[Rectangle[], Pi/12]}, ImageSize -> 40]; gives a beautiful displacements of the outer squares. $\endgroup$ – Dr. Wolfgang Hintze Sep 21 '14 at 17:18
6
$\begingroup$

My first attempt, using ShearingTransform

sd[i_, j_] := 
 If[And[4 <= j <= 10, 8 - j <= i - 1 <= j, 
   j - 6 <= i - 1 <= 14 - j], -20, 0]
GraphicsGrid[
 Table[
  Graphics[{GrayLevel@0.7,
    GeometricTransformation[
     GeometricTransformation[
      Rectangle[],
      ShearingTransform[sd[i, j] Degree, {0, 1}, {1, 0}]],
     RescalingTransform[{{-1, 1}, 
       If[sd[i, j] == 0, {0, 1}, {0, 1.5}]}, {{-1, 1}, {0, 
        1}}]]}], {i, 9}, {j, 12}], Background -> GrayLevel@0.2]

Mathematica graphics

I think this meets the equal vertical spacings criterion but assumes that each of the parallelograms are sheared by the same amount, which does not appear to be correct.

$\endgroup$
  • $\begingroup$ 1000 thanks for your answer. It is much nearer to what I want :) $\endgroup$ – eldo Sep 21 '14 at 19:42
6
$\begingroup$

Your Vasarely graphic reminds me of an old Mathematica Jounal article by Flip Phillips about the work of William Kolomyjec. It's not the same effect, but may provide some amusement. The distance function d may be the following, or Norm or ChessboardDistance or ... Other parameters include scalings of colours, rotation angles, and translations.

Block[{hmax = 34, vmax = 21, d},
   Graphics[{EdgeForm[{Thin, Black}],
      Table[
         d = Min[i, j, hmax - i - 1, vmax - j - 1]/Max[hmax, vmax];
         {ColorData["FallColors", 2.2 d^0.7],
          Translate[
             Rotate[Rectangle[{i, j}], 2 d*RandomReal[{0, 1}]*\[Pi]/2],
             400 E^(-6 (1 - d)) RandomReal[{-0.1, 0.1}, 2]]},
         {i, 0, hmax - 1}, {j, 0, vmax - 1}]},
      Background -> Black]]

Kolomyjec

$\endgroup$
  • $\begingroup$ Thanks @ Kenny very beautyful and fun to play with :) $\endgroup$ – eldo Sep 23 '14 at 8:42
  • $\begingroup$ A work of art ! $\endgroup$ – VividD Sep 30 '14 at 8:06
5
$\begingroup$

First, create a matrix for shape positions:

a = ArrayPad[
  ArrayPad[DiamondMatrix[2], 1] + DiamondMatrix[3], {{1, 1}, {3, 2}}]

Then, apply geometric transformations to appropriate positions.

Graphics[{LightGray, MapIndexed[Which[
     #1 == 0, Scale[Rectangle[#2, #2 + 1], .8],
     #1 == 2, 
     GeometricTransformation[
      Translate[Scale[Rectangle[#2, #2 + 1], {.8, .85}], {0, .2}], 
      ShearingTransform[-20 Degree, {0, 1}, {1, 0}, #2]],
     #1 == 1, 
     Which[a[[Sequence @@ (Reverse[#2] + {1, 0})]] == 0 \[And] 
       a[[Sequence @@ (Reverse[#2] - {1, 0})]] == 0, 
      GeometricTransformation[
       Translate[Scale[Rectangle[#2, #2 + 1], {.8, .7}], {0, .2}], 
       ShearingTransform[-20 Degree, {0, 1}, {1, 0}, #2]],
      a[[Sequence @@ (Reverse[#2] + {1, 0})]] == 0, 
      GeometricTransformation[
       Translate[Scale[Rectangle[#2, #2 + 1], {.8, .8}], {0, .15}], 
       ShearingTransform[-20 Degree, {0, 1}, {1, 0}, #2]],
      True, 
      GeometricTransformation[
       Translate[Scale[Rectangle[#2, #2 + 1], {.8, .8}], {0, .25}], 
       ShearingTransform[-20 Degree, {0, 1}, {1, 0}, #2]]]
     ] &, Transpose[a], {2}]}, Background -> Darker[Gray, .7], 
 PlotRangePadding -> .15]

Mathematica graphics

There are five different groups of shapes:

  • the rectangles outside the diamond that are only scaled
  • the rectangles inside the diamond are scaled and sheared in four different ways:
    • the left and right corner,
    • the top edge,
    • the bottom edge and
    • the inside of the diamond.
$\endgroup$
3
$\begingroup$

Not exactly what is asked but it may be a good start too.

Alternative approach with Grid:

opt = {ImageSize -> {20, 20}, BaseStyle -> GrayLevel@.9};

Composition[
  Framed[Grid[#, Spacings -> {.3, .3}], Background -> Black] &,

  ArrayPad[#, {2, 2}, Graphics[Rectangle[], opt]] &,

  # + (DiamondMatrix[5] /. {1 -> 0, 0 -> 1}) Graphics[Rectangle[], opt] &
  ][
     DiamondMatrix[5] Graphics[ Polygon[{{0, 0}, {1, -.4}, {1, .6}, {0, 1}}], opt]
   ]

enter image description here

$\endgroup$

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.