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

Make an animation of the equipotential curves of a set of randomly rotating, randomly moving, and randomly size-changing set of regular ngons.

pot[{{x0_, y0_}, {x1_, y1_}}, {x_, y_}] =
 (-Log[(x - x0)(x0 - x1) + Sqrt[(x - x0)^2 + (y - y0)^2]*
       Sqrt[(x0 - x1)^2 + (y0 - y1)^2] + (y - y0)(y0 - y1)] + 
   Log[(x - x1)(x0 - x1) + Sqrt[(x - x1)^2 + (y - y1)^2]*
       Sqrt[(x0 - x1)^2 + (y0 - y1)^2] + (y - y1)(y0 - y1)])/
  Sqrt[(x0 - x1)^2 + (y0 - y1)^2];

randomNgon generates a list of the vertices of a randomly oriented ngon (in the following, we use n between 3 and 8).

randomNgon := 
Table[Evaluate[Random[Real, {0.15, 0.6}] {Cos[φ + #], Sin[φ + #]}&[
                                                     2 Pi Random[]]],
      Evaluate[{φ, 0, 2Pi (1 - 1/#), 2Pi/#}&[
      Random[Integer, {3, 8}]]]]

For the following animation, we use 12 ngons.

SeedRandom[111]; n = 12;
initialNgons = Table[randomNgon, {n}];

For realizing the the random movements and rotations, we define a function randomFunction that generates a random function with parameter τ and period 2π.

randomFunction[d_, τ_, α_] := 
 Sum[Random[Real, {-α, α}] Cos[k τ + 2 Pi Random[]], {k, d}];

The list randomMoveDatas contains parametrized random translation vectors, scale factors, and rotation matrices.

randomMoveData :=
{(* translation vector *) Table[randomFunction[2, τ, 0.8], {2}], 
 (* scale factor *)0.2 + Abs[randomFunction[2, τ, 1.2]],
 (* rotation matrix *)
 {{Cos[#], Sin[#]}, {-Sin[#], Cos[#]}}&[randomFunction[2, τ, 2]]}

randomMoveDatas[τ_] = Table[randomMoveData, {n}];

The last random ingredient is a list charges of random function that represent the (potentially sign-changing) charges of the ngons.

charges[τ_] = Flatten[Table[randomFunction[2, τ, 1]*
                      Table[1, {Length[initialNgons[[k]]]}], {k, n}]];

For a given  τ, the function makeSegments generates the list of line segments of the ngons.

makeSegments[τ_] :=
With[{τData = randomMoveDatas[τ]}, 
Table[Partition[Append[#, First[#]], 2, 1]& @ 
          (* apply random translation, scaling, and rotation *)
          Map[(τData[[k, 1]] + τData[[k, 3]].(τData[[k, 2]] #))&, 
              initialNgons[[k]], {-2}], {k, n}] // Flatten[#, 1]&]

Given the line segments, it is straightforward to add their potential contribution.

makePotential[τ_] := (pot[#, {x, y}]& /@ makeSegments[τ]).charges[τ]

So, we have the following final function makeFrame[τ] that generates a frame of the animation.

(* sketch the ngons *)
outlinedNGons[τ_] := 
With[{mS = makeSegments[τ], 
      gs = GrayLevel /@ ((ArcTan[charges[τ]] + Pi/2)/Pi)},
     {(* edges as bold lines*)
      {Thickness[0.008], Transpose[{gs, Line /@ mS}]},
      (* thin lines from the center to the edges *)
      {Thickness[0.001], Transpose[{gs, Flatten[Function[l, 
                         Line[{#, Plus @@ l/Length[l]}]& /@ l] /@ 
       Map[First, 
       Fold[{Drop[#1[[1]], #2], Append[#1[[2]], Take[#1[[1]], #2]]}&, 
         {mS, {}}, Length /@ initialNgons][[2]], {2}]]}]}}]

makeFrame[τ_] :=
Module[{pp = 240, contours = 120, n1, n2, cp, cls, L = 1.8, k = 0},
       n1 = Round[pp^2/contours]; n2 = Round[n1/2];
       (* initial contour plot *)
       Off[ContourPlot::plnr];
       cp = ContourPlot[Evaluate[makePotential[τ]],
                       {x, -L, L}, {y, -L, L}, PlotPoints -> pp,
                       DisplayFunction -> Identity][[1]] /. 
                       (* ignore single points *) Indeterminate -> 0.; 
       On[ContourPlot::plnr];                
       (* homogeneously spaced contour line *)
       cls = Flatten[#[[n2]]& /@ Partition[Sort[Flatten[cp]], n1]]; 
       (* final contour plot *)
       ListContourPlot[cp, Contours -> cls, PlotRange -> All,
                (* color "random" consecutively with overall shift τ *)
                ColorFunction -> (Hue[Sin[τ/(2Pi) + (k++)]]&),
                ContourLines -> False, FrameTicks -> None, 
                MeshRange -> {{-L, L}, {-L, L}},
                (* the ngons in gray *) Epilog -> outlinedNGons[τ]]]

Here is the resulting animation.

Show[GraphicsArray[#]]& /@ 
Block[{$DisplayFunction = Identity, frames = 9},
      Partition[
       Table[makeFrame[τ], {τ, 0, 2Pi (1 - 1/frames), 2Pi/frames}], 3]]

frames = 150;
Do[makeFrame[τ], {τ, 0, 2Pi (1 - 1/frames), 2Pi/frames}]