This notebook contains additional material to the Mathematica GuideBooks  (Springer-Verlag, New York, 2004) http://www.MathematicaGuideBooks.org . It uses the stylesheet of the Mathematica GuideBooks, which is embedded.

Graphics Volume, Chapter 3

Consider a Chladny tone figure in the square (0,π)×(0,π) of the form

v(t;x,y)=(∑_((n^2)+(m^2)="ε"))(Subscript[c, "nm"])(e^((i(ε t+(Subscript[φ, n m])) )))cos(n x)cos(m y).

For a ε with at least eightfold degeneracy, make a t-dependent animation showing the argument of v(t;x,y) and the lines of vanishing real and imaginary parts.

With[{d = 40},
Sort[Select[Sort[Map[Rest, 
Split[Sort[Flatten[Table[{i^2 + j^2, i, j}, {i, d}, {j, d}], 1]], 
       #[[1]] === #2[[1]]&], {-2}], Length[#1] > Length[#2]&],
       Length[#] >= 8&], #1[[1]].#1[[1]] < #2[[1]].#2[[1]]&]]

We choose the first list of the last result with ε=1105.

evs = %[[1]];

Now we form a random superposition with random phases.

f[τ_][x_, y_] = Plus @@ ((Random[Real, {-1, 1}] Exp[2Pi I (τ + 
                          Random[])] Cos[#1 x] Cos[#2 y])& @@@ evs);

The function frame calculates f[τ][x, y] on a grid of x,y-values and superposes the density plots of the argument with the contour lines of vanishing real and imaginary part.

frame[τ_, pp_] := 
Module[{data = Table[Evaluate[N @ f[τ][x, y]], 
                     {y, 0., 1. Pi, 1. Pi/pp}, {x, 0., 1. Pi, 1. Pi/pp}]},
Block[{$DisplayFunction = Identity},
Show[{(* density plot of the argument *)
      ListDensityPlot[Arg[data], MeshRange -> {{0, Pi}, {0, Pi}}, 
                      FrameTicks -> None, Mesh -> False,
                      ColorFunction -> Hue, PlotRange -> {-Pi, Pi},
                      ColorFunctionScaling -> False],
      (* contour lines of vanishing real and imaginary parts *)
      ListContourPlot[#1[data], MeshRange -> {{0, Pi}, {0, Pi}},
                      Contours -> {0}, ContourShading -> False,
                      ContourStyle -> {{Thickness[0.005], GrayLevel[#2]}}]& @@@ 
                                                             {{Re, 0}, {Im, 1}}},
     PlotRange -> {{0, Pi}, {0, Pi}}]]]

Show[GraphicsArray[frame[#, 240]& /@ {0, 0.3, 0.5}]]

Here is the resulting animation.

Do[Show[#,  DisplayFunction -> $DisplayFunction]& @ frame[τ, 240], 
   {τ, 0, 1, 1/90}]