Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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?

share|improve this question
    
(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 :-) –  Dr. Wolfgang Hintze Sep 21 at 17:06
1  
(at) eldo: look at that: h = Graphics[{GrayLevel@0.7, Rotate[Rectangle[], Pi/12]}, ImageSize -> 40]; gives a beautiful displacements of the outer squares. –  Dr. Wolfgang Hintze Sep 21 at 17:18

4 Answers 4

up vote 4 down vote accepted

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.

share|improve this answer
    
1000 thanks for your answer. It is much nearer to what I want :) –  eldo Sep 21 at 19:42

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

share|improve this answer
    
Thanks @ Kenny very beautyful and fun to play with :) –  eldo Sep 23 at 8:42
    
A work of art ! –  VividD Sep 30 at 8:06

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.
share|improve this answer

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

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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