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 contour plots of charged Truchet patterns. Use different color functions.

potentialφ[{x0_, y0_}, {xr_, yr_}, {x_, y_}] = 
With[{s = Sqrt[xr^2 + yr^2]}, 
(-Log[Sqrt[(x - x0)^2 + (y - y0)^2] + (x0 xr - y yr + y0 yr - x xr)/s] + 
  Log[(xr (-x + x0 + xr) + yr (-y + y0 + yr))/s +  
       Sqrt[(-x + x0 + xr)^2 + (-y + y0 + yr)^2]])/s];

makePotentialφ[{p0_, p1_}, p_] := potentialφ[p0, p1 - p0, p]

Generating a Truchet pattern, approximating its circle pieces by line segments, charging the line segments and calculating a contour plot is straightforward. We deal here with the case of all segments being charged with the same parity. The function chargedTruchetPattern generates a graphics array of contour plots of a charged Truchet pattern with 2(((L+1))^2) quarter circles, each quarter circle being approximated through ppc line segments. pp is the number of plot points for the contour plot, contourList is the list of contour values and cf is the color function whose arguments are the values of the contour values. (Because calculating the potential values is the time-consuming step, we allow for the generation of more than one contour plot once the potential values are calculated.)

chargedTruchetPattern[L_Integer, ppc_Integer, pp_, contourList_, 
                      colorFunction_] := 
Module[{lineCircleParts, 𝕣 := Random[Integer, {1, 2}],
        (*fullPotentialφ, cfφ, cpData, cls, *) α = N[Pi/100]},
(* seed random number generator *) SeedRandom[111];
(* pairs of quarter circles forming the Truchet pattern *)
lineCircleParts =  
Table[{{Circle[{i, j} + {-1, +1}/2, 1/2, {3/2, 2} Pi],
        Circle[{i, j} + {+1, -1}/2, 1/2, {1/2, 1} Pi]},
       {Circle[{i, j} + {+1, +1}/2, 1/2, {1, 3/2} Pi],
        Circle[{i, j} + {-1, -1}/2, 1/2, {0, 1/2} Pi]}}[[𝕣]], 
      {i, 0, L}, {j, 0, L}] /. 
     (* approximate quarter circles with line segments*)
      Circle[mp_, r_, {φ1_, φ2_}] :>  Partition[
            Table[mp + r {Cos[φ], Sin[φ]},  
                  {φ, φ1, φ2, Pi/4/ppc}], 2, 1] // Flatten[#, 3]&;
(* the electrostatic potential of the line segment *)
fullPotentialφ[x_, y_] = 
    Chop[Plus @@ (makePotentialφ[#, {x, y}]& /@ lineCircleParts)];
(* use ContourPlot to autocompile the function *)
(* in case a point falls onto a line segment *) Off[ContourPlot::plnr];
(* avoid spending time in rewriting the long sum *)
If[$Version >= 5, SetOptions[Compile, CompileOptimizations -> None]];
cfφ = Compile[{x, y}, Evaluate[N @ fullPotentialφ[x, y]]];
cpData = Table[Table[(* make machine numbers for all potential values *)
                     Which[MachineNumberQ[#], #, # === Indeterminate, 1., 
                           Abs[#] < 1, 0., Abs[#] > 1, 10^10., True, 1.]& @
                     Re[cfφ[x, y]], {x, -α L, (1 + α) L, (1 + 2 α) L/pp}],
                    {y, -α L, (1 + α) L, (1 + 2 α) L/pp}];  
(* make contour plots with different number of contour lines *)
Show[GraphicsArray[Function[c, SeedRandom[222];
cls = #[[Round[pp^2/c]]]& /@ 
         Partition[Sort[Flatten[cpData]], Round[pp^2/c]]; 
ListContourPlot[cpData, ContourLines -> False, 
                (* homogeneous contour spacing *) Contours -> cls, 
                 ColorFunctionScaling -> False,
                 ColorFunction -> colorFunction[cls], FrameTicks -> False,
                 DisplayFunction -> Identity]] /@ 
                 (* number of contours *) contourList]]]

Now, let us display some examples. The following plot uses a coloring according to the potential value. Blue is smallest and red is highest. We use just a small Truchet pattern with only 18 quarter circles.

SeedRandom[333];
chargedTruchetPattern[2, 4, 60, {10, 60, 60}, 
 Function[𝒸ℓ𝓈, Function[𝒸, Evaluate[Which @@ Flatten[MapIndexed[{#1, 
                                    Hue[0.76 (1 - #2[[1]]/Length[𝒸ℓ𝓈])]}&,
                                  Append[𝒸 < #& /@ 𝒸ℓ𝓈, True]]]]]]]

Here is the same potential with a random coloring.

SeedRandom[333];
chargedTruchetPattern[2, 4, 60, {10, 20, 30}, (Hue[Random[]]&)&]

The coloring of the next contour plot is alternating.

SeedRandom[222];
chargedTruchetPattern[3, 6, 60, {10, 20, 30}, 
 Function[𝒸ℓ𝓈, Function[𝒸, Evaluate[Which @@ Flatten[MapIndexed[{#1, 
              If[EvenQ[#2[[1]]], GrayLevel[0], GrayLevel[1]]}&,
                                  Append[𝒸 < #& /@ 𝒸ℓ𝓈, True]]]]]]]

We end with a larger Truchet pattern. Calculating the (361^2) potential values takes a few hours. This time we use a random coloring. We mix gray colors with hue colors.

SeedRandom[555];
chargedTruchetPattern[6, 12, 360, {10, 20, 50},
                      (* need double nested pure function here *)
                      ((If[Random[] < 1/2, GrayLevel[Random[]],
                                            Hue[Random[]]]&)&)]

One could now go on and extract all connected quarter circles and apply different charges (in magnitude and polarity) to each connected component.