Make a beautiful Moiré effect

Question

How do I make the following Moiré pattern?

I tried:

A = Plot[Table[n, {n, 1, 30}], {x, 0, 31}, 
GridLines -> {Table[n, {n, 1, 30}], None}, 
GridLinesStyle -> AbsoluteThickness[1.2], PlotStyle -> Gray, 
Axes -> False, AspectRatio -> 1]
B = Rotate[A, -30 Degree]
C = Rotate[A, -60 Degree]

Answer 1

I feel that once you start with Moire patterns, there's no ending. The way I would replicate these is by making a grid into a function (like @JasonB) but also parametrise the angle of rotation into it:

lines[t_, n_] := 
  Line /@ ({RotationMatrix[t].# & /@ {{-1, #}, {1, #}}, 
        RotationMatrix[t].# & /@ {{#, -1}, {#, 1}}} & /@ 
      Range[-1, 1, 2/n]) // Graphics;

So that you can vary the number of lines n and rotation parameter t as well. Now your image is (more or less):

lines[#, 40] & /@ Range[0, π - π/3, π/3] // Show

And you can play more with these two parameters. Here's what you get if you superimpose grids with very small relative angle differences:

lines[#, 100] & /@ Range[-π/300, π/300, π/300] // Show

Or randomising the spacing and angle of each grid:

lines[Cos[# π/30], #] & /@ RandomInteger[{1, 20}, 9] // Show

and -as an overkill- harmonically varying these two effects results in great gif potential

gif = Table[Show[{lines[0, Floor[10 + 9 Cos[t]]], lines[-2 π/3 Cos[t], 20], 
    lines[+2 π/3 Cos[t], 20]}, 
   PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}}, 
   ImageSize -> 200], {t, -π/2, π/2 - π/70, π/70}];
Export["moire.gif", gif]

---

Answer 2

Something like this:

nlines = 30;
Table[
 Overlay[
  Rotate[
     Graphics[{
       Table[{
         Line[{{0, n}, {nlines, n}}],
         Line[{{n, 0}, {n, nlines}}]},
        {n, 0, nlines}],
       Text[Style[#1, 18], {0, 0}, {-1, -1}, Background -> White]
       },
      AspectRatio -> 1,
      PlotRangePadding -> None,
      ImageSize -> 360], #2] & @@@ 
   Transpose[{(ToUpperCase /@ Alphabet[])[[;; ngrids]], 
     Most@Subdivide[\[Pi]/2, ngrids]}],
  Alignment -> Center],
 {ngrids, 3, 6}]

You can get an interesting effect if you use color in the grid. Here I'm using a repeating pattern of colors for the gridlines and it gives a pretty interesting effect (also, modified the code to not use Overlay, as it is always worth the effort to avoid that function)

With[{line = Line[{{0, n}, {30, n}}]},
 Show[
  Table[
   rt = RotationTransform[m \[Pi] / 16, {15, 15}];
   Graphics[{Table[{ColorData[110][n], rt /@ line, 
       rt /@ Map[Reverse, line, {1, 2}]},
      {n, 0, 30}]}], {m, 0, 7}], ImageSize -> 500]
 ]

or, replacing ColorData[110][n] with If[EvenQ[n], Red, Blue] gives this,

Answer 3

I like to keep things simple, so I'll skip the letter labels, but include the lines overhanging from the grid:

m = 30 (* number of mesh lines *); h = 2 (* overhang *);
lins = Join[#, Map[Reverse, #, {2}]] & @
       Outer[{##} &, ArrayPad[Range[-1, 1, 2/m], h, "Extrapolated"], {-1, 1}];

Table[Graphics[{AbsoluteThickness[1/100], 
                Table[Line[Map[RotationTransform[θ], lins, {2}]],
                      {θ, 0, π/2 - π/(2 n), π/(2 n)}]}], {n, 3, 6}] // GraphicsRow

(click on the picture to see it in its full resolution splendor)

---

The original picture had more random orientations for grids B and C. I tried using Manipulate[] to attempt to determine those rotations, but I was not successful. If you want to play around with it yourself, have at it:

DynamicModule[{θl = {0, 0, 0}}, 
              Panel[Row[{Dynamic[
                    Graphics[{AbsoluteThickness[1/100], 
                              Table[Line[Map[RotationTransform[θ], lins, {2}]],
                                    {θ, θl}]}, ImageSize -> Medium, 
                             PlotRange -> {{-3/2, 3/2}, {-3/2, 3/2}}]], 
                    Column[Table[With[{i = i}, 
                    Experimental`AngularSlider[Dynamic[θl[[i]]]]], {i, Length[θl]}]]}]]]

Answer 4

g = Graphics@GraphicsGroup[
    Table[{Line[{{x, -5}, {x, 5}}], Line[{{-5, x}, {5, x}}]},
     {x, -5, 5, .25}]
    ];
Manipulate[
 Overlay[
  Table[
   Rotate[g, i θ],
   {i, -2, 2}],
  Alignment -> Center
  ], 
 {θ, 0, π/12}]

or

g = Graphics@GraphicsGroup[
    Table[{Line[{{x, -5}, {x, 5}}], Line[{{-5, x}, {5, x}}]},
     {x, -5, 5, .25}]
    ];
Manipulate[
 Overlay[
  Table[
   Rotate[g, i .2],
   {i, -n, n}],
  Alignment -> Center
  ],
 {n, 0, 5}]

Answer 5

I remember playing around with clear plastic sheets with grid lines. Here's a way to simulate the real-time moving around of the sheets. Starting with gpap's function, change this to an image and set the alpha channel so that the white area is actually transparent. Then use GraphicsGrid to display multiple copies. Now you can move them around and rotate using the mouse:

lines[t_, n_] := Line /@ ({RotationMatrix[t].# & /@ {{-1, #}, {1, #}}, 
       RotationMatrix[t].# & /@ {{#, -1}, {#, 1}}} & /@ 
       Range[-1, 1, 2/n]) // Graphics; 
img = SetAlphaChannel[Image[lines[0, 40]], ColorNegate[Image[lines[0, 40]]]];
GraphicsGrid[{{img, img}, {img, img}}]

The real-time moving of the moire patterns is fun.