Remarks

This notebook contains exercises and the corresponding solutions in the style of the Mathematica GuideBooks. It also uses stylesheet of the Mathematica GuideBooks (© Springer-Verlag, New York, 2004).

The latest version of this notebook is available from  http://www.MathematicaGuideBooks.org.

To avoid the download of large notebooks, all outputs, graphics, and animations have been deleted. To recreate them, evaluate one solution at a time. It is highly recommended to quite and restart the kernel after each solution is fully evaluated. The code is tailored for Mathematica version 5.0.1.

Graphics Volume, Chapter 1

Given a list of real numbers {(Subscript[p, 1]),(Subscript[p, 2]),…,(Subscript[p, n])} with (∑_(k=1)^n)(Subscript[p, k])=1, interpret (Subscript[p, k]) as the probability to break a 1D stick {a,b} into k parts at k-1 randomly chosen points from the interval [a,b]. Starting with the stick {0,1}, repeatedly breaking all nontrivially broken sticks (meaning once a piece of a stick was trivially “broken” with probability (Subscript[p, 1]) into one part, it will no longer be considered for further breaking) as long as the stick piece is longer than a minimal length (Subscript[l, min]). Implement a one-liner that carries out the stick breaking. Model the breaking for the probabilities {0.5,0.5}, such that more than 1000 broken pieces result. Visualize the resulting stick pieces.

breakStick[{a_, b_}, pList_, lMin_] :=
If[(* is stick longer than minimal length? *) b - a <= lMin, {a, b}, 
   If[Length[#] === 1, {#[[1]]},
      (* break recursively *)
      breakStick[#, pList, lMin]& /@ #]&[(* random break points in [a, b] *)
       Partition[Flatten[{a, Sort[Table[Random[Real, {a, b}], 
        (* number of break points *)
        {Position[Rest[FoldList[Plus, 0, 
                  (* normalize *) pList/(Plus @@ pList)]], 
                  PatternTest[_, (* random number for break points *)
                                 Evaluate[Evaluate[# > Random[]]&]], 
                               {1}, 1][[1, 1]] - 1}]], b}], 2, 1]]]

In the following example, exactly one nontrivial breaking process occurs.

SeedRandom[8]
breakStick[{0, 1}, {1/2, 1/2}, 0]

In the next example three breaks occur and we have four pieces at the end.

SeedRandom[124]
breakStick[{0, 1}, {1/2, 1/2}, 0]

To generate 1000 pieces for the probabilities {0.5,0.5}, we need a a suitable seed. The next input searches for such a seed.

Module[{r = 1, o = 2, max = 0, maxr = 0, Λ = 10^3, λ},
 While[SeedRandom[r]; 
       λ = Length[Level[breakStick[{0, 1}, Table[1/o, {o}], 0], {-2}]];
           If[λ > max, max = λ; maxr = r]; λ < Λ, r++]; r]

To visualize the broken sticks, we display their starting and ending positions ,long the x-axis and display the time at which the break occurs vertically.

stickPieceGraphics[brokenSticks_] := 
Graphics[MapIndexed[Function[{i, p}, Line[{#, Length[p]}& /@ i]], 
                    brokenSticks, {-2}], 
        Frame -> True, PlotRange -> All];

Here is the above breaking process and two others visualized.

Show[GraphicsArray[stickPieceGraphics /@
{SeedRandom[162];  breakStick[{0, 1}, {1/2, 1/2}, 0],
 SeedRandom[ 89];  breakStick[{0, 1}, {1/3, 1/3, 1/3}, 10^-6],
 SeedRandom[  3];  breakStick[{0, 1}, {1/4, 1/4, 1/4, 1/4}, 10^-6]}]]

Take (a part of) an aperiodic tiling. Make an animation that rotates the polygons of the tiling around all inner points of the tiling.

(* avoid setting this option for each single graphic *)
SetOptions[Graphics, AspectRatio -> Automatic];

startRhombusA = {{{{1, 0}, {1, 0} + {Cos[72°], Sin[72°]}, 
                   {Cos[72°], Sin[72°]}, {0, 0}, {1, 0}}, "A"}};
                   
startRhombusB = {{{{0, 0}, {1, 0}, {1, 0} + {Cos[36°], Sin[36°]}, 
                   {Cos[36°], Sin[36°]}, {0, 0}}, "B"}};

(* some often occurring rotation matrices *)
ϕ = 1/(2 Cos[Pi/10]);
rm54  = {{ Cos[-54°], Sin[-54°]}, {-Sin[-54°], Cos[-54°]}};
rmp18 = {{ Cos[ 18°], Sin[ 18°]}, {-Sin[ 18°], Cos[ 18°]}};
rmm18 = {{ Cos[-18°], Sin[-18°]}, {-Sin[-18°], Cos[-18°]}};

ruleA := {{p1_, p2_, p3_, p4_, p1_}, "A"} :>
Module[{p5, p6, p7, p8, p9}, (* new points *)
       p5 = p4 + ϕ rm54.(p1 - p4); p6 = p4 + ϕ rmp18.(p1 - p4);
       p7 = p5 + (p1 - p4); p8 = p6 + (p3 - p4); p9 = p5 + p6 - p4;
      Sequence @@ (* delete braces *)
            {{{p5, p4, p6, p9, p5}, "A"}, {{p8, p3, p5, p9, p8}, "A"},
             {{p7, p2, p8, p9, p7}, "A"}, {{p6, p1, p7, p9, p6}, "B"}}]

ruleB := {{p1_, p2_, p3_, p4_, p1_}, "B"} :>
Module[{p5, p6, p7, p8}, (* new points *)
       p7 = p1 + ϕ rm54.(p2 - p1); p5 = p1 + ϕ rmp18.(p2 - p1);
       p6 = p2 + ϕ rmm18.(p3 - p2); p8 = p5 + p7 - p1;
       Sequence @@ (* delete braces *)
      {{{p7, p1, p5, p8, p7}, "A"}, {{p6, p4, p7, p8, p6}, "B"},
       {{p5, p2, p6, p8, p5}, "B"}}]

In the following, we use the tiling at level 6. It has 725 polygons.

s[1] = N[startRhombusA, 30];
s[i_] := s[i] = s[i - 1] /. {ruleA, ruleB}

The polygons and the types of the polygons we collect in the two list polys and polysTypes.

polys = Polygon[Drop[First[#], -1]]& /@ N[s[6]];
polysTypes = Last /@ s[6];

Out of the 790 vertices of the tiling 128 are not inner ones. We find the boundary vertices by counting how frequently the edges of all polygons occur. outerVertex[point] yields True for if point is a vertex on the boundary.

Length[vertices = Union[Level[polys, {-2}]]]

(* group identical line segments of the tiling *)
segments = Split[Sort[Sort /@ Flatten[Partition[Append[#[[1]], 
                  #[[1, 1]]], 2, 1]& /@ Take[polys, All], 1]]];
(* mark boundary polygons *)
If[Length[#] === 1, (boundaryVertex[#] = True)& /@ #[[1]]]& /@ segments;

The list polyτData contains the rotation centers, the polygons to be rotated, the rotation angles, and the colors of the polygons. The parameter τ is the animation parameter and is assumed to vary from 0 to 1.

polyτData = Table[
{(* all inner vertices *)
 DeleteCases[polys[[k]][[1]], _?boundaryVertex], polys[[k]],
 (* color the two polygon types differently *)
 If[polysTypes[[k]] === "A", 1, -1] 2Pi τ, If[polysTypes[[k]] === "A", 0, 0.78] + τ},
 {k, Length[polys]}];

The function makecoloredRotatedPolygon rotates the polygons and adds the τ-dependent coloring.

makecoloredRotatedPolygon[{mps_, poly_, φ_, c_}, τc_] := 
With[{(* rotation matrix *)
      ℛ = {{Cos[#], Sin[#]}, {-Sin[#], Cos[#]}}&[φ /. τ -> τc]},
 {Hue[c /. τ -> τc], {#, {GrayLevel[0], # /. 
                         Polygon[l_] :> Line[Append[l, First[l]]]}}&[
  (* rotate around al inner vertices *)
  Function[mp, Map[(mp + ℛ.(# - mp))&, poly, {-2}]] /@ mps]}]

rotatedTilingFrame[τ_] := 
Graphics[{Thickness[0.001],  makecoloredRotatedPolygon[#, τ]& /@ polyτData},
        AspectRatio -> Automatic, PlotRange -> {{-0.12, 1.5}, {-0.26, 1.1}}];

Here is the resulting animation.

Show[GraphicsArray[rotatedTilingFrame /@ {0, 0.3, 0.5}]]

frames = 120;
Do[Show[rotatedTilingFrame[τ]], {τ, 0, 1 - 1/frames, 1/frames}]

Take a discretized curve and draw circles through the midpoints of the lines connecting successive neighbors. Make an animation showing how the resulting collection of circles changes as the original curve morphs from one Lissajou figure to another.

frame[α_, φValues_, m_, f_:1] := 
With[{ℛ = {{ #1, #2}, {-#2, #1}}&[Cos[f α Pi/2], Sin[f α Pi/2]] // N,
      o = Length[φValues]},
Graphics[{Thickness[0.0001], (* color circles *)
MapIndexed[{Hue[α + 1.8 (#2[[1]] - 1)/m], #}&,
Reverse[Table[(* the circles *)
 Circle[ℛ.Plus[##]/2, Sqrt[#.#]&[(#1 - #2)]/2]&[#[[1]], #[[-1]]]& /@
  Table[Take[#, {i, i + n}], {i, o}]&[
         Join[#, Take[#, n]]], {n, 2, m}]&[
    (* linear interpolation between the two curves *)
    ((1 - α){Cos[5 #], Sin[3 #]} + α{Cos[3 #], Sin[5 #]})& /@ φValues]]]},
     PlotRange -> {{-1.5, 1.5}, {-1.7, 1.7}}, AspectRatio -> Automatic]]

Here are two animations. The left uses equidistant points on the curve, and the right uses 384 randomly selected points on the curve.

SeedRandom[123];
Module[{(* animation parameters *) frames = 6, circles = 17,
        φValues1 = 2Pi Range[256]/256.,
        φValues2 = 2Pi Sort[Table[Random[], {384}]]},
Do[Show[GraphicsArray[
        {frame[k/frames, φValues1, circles], 
         frame[k/frames, φValues2, circles, -1]}]],
   {k, frames}]];

SeedRandom[123];
Module[{(* animation parameters *) frames = 60, circles = 17,
        φValues1 = 2Pi Range[256]/256.,
        φValues2 = 2Pi Sort[Table[Random[], {384}]]},
Do[Show[GraphicsArray[
        {frame[k/frames, φValues1, circles], 
         frame[k/frames, φValues2, circles, -1]}]],
   {k, frames}]];

Graphics Volume, Chapter 2

Make an animation of two interlocking rotating Möbius bands having a pattern mapped onto them.

moebiusXY[{u_, ω_}, φ0_] = (* rotate segment around z-axis *)
{{Cos[ω], Sin[ω], 0}, {-Sin[ω], Cos[ω], 0}, {0, 0, 1}}.
({1, 0, 0} + (* rotate line segment *)
 {{Cos[ω/2], 0, Sin[ω/2]}, {0, 1, 0}, {-Sin[ω/2], 0, Cos[ω/2]}}.
 (u {Cos[φ0], 0, Sin[φ0]}));
 
moebiusXZ[{u_, ω_}, φ0_, ϑ_, δx_] = (* rotate band around z-axis *)
          {{Cos[ϑ], Sin[ϑ], 0}, {-Sin[ϑ], Cos[ϑ], 0}, {0, 0, 1}}.
          ({δx, 0, 0} + {#1, #3, #2}& @@ moebiusXY[{u, ω}, φ0]);

A continuous pattern on the Möbius band must be antisymmetric with respect to the variable ω around ω=π. Here we define two such functions depending on the parameter τ that are random linear combinations of trigonometric terms.

SeedRandom[1];
{randomPatternXY[τ_][u_, ω_], randomPatternXZ[τ_][u_, ω_]} = 
Table[Sum[Random[Real, {-1, 1}] Cos[k 2Pi τ + 2 Pi Random[]]*
                 Cos[(i + 1/2) ω] Sin[j u/L],
          {i, 0, 3}, {j, 0, 2}, {k, 0, 2}], {2}];

Here is the resulting animation. We rotate the initial segments of the bands and the second band, and change the pattern as we rotate.

frame[φ0_] := 
Block[{L = 1/2}, Show[(* the band in the x,y-plane *)
ParametricPlot3D[#, {u, -L, L}, {ω, 0, 2Pi},
               PlotPoints -> {90, 240}, DisplayFunction -> Identity]& /@
     {(* the band in the x,y-plane *)
      Append[moebiusXY[{u, ω}, φ0], (* the pattern *)
             {EdgeForm[], SurfaceColor[Hue[#], Hue[#], 2.6]& @ 
                          randomPatternXY[φ0/Pi][u, ω]}],
      (* the perpendicular band *)
      Append[moebiusXZ[{u, ω}, φ0, 2φ0, 1], (* the pattern *)
               {EdgeForm[], SurfaceColor[Hue[#], Hue[#], 2.6]& @ 
               randomPatternXZ[φ0/Pi][u, ω]}]},
           PlotRange -> {5/2 {-1, 1}, 5/2 {-1, 1}, 3/2 {-1, 1}}, 
           Axes -> False,  DisplayFunction -> $DisplayFunction, 
           Boxed -> False]]

Show[GraphicsArray[
      Block[{$DisplayFunction = Identity},
            frame /@ {0, Pi/4, Pi/2}], GraphicsSpacing -> 0]]

Do[frame[φ0], {φ0, 0, Pi, Pi/60}]

Map (a part of) an aperiodic tiling onto a torus. Then make an animation in which two such tori are rotating and display them together with their three projections into the coordinate planes.

tilingPolys  = 
Module[{order = 4, 𝓈 = Sqrt[2]},
(* subdivision of the rhomb *)
subdivide[Polygon[{p1_, p2_, p3_, p4_}]] :=
Module[{p5, p6, p7, p8, p9, p10}, (* new vertices *)
 p5 = p1 + (𝓈 - 1) (p2 - p1); p6 = p2 + (2 - 𝓈) (p3 - p2);
 p7 = p3 + (𝓈 - 1) (p4 - p3); p8 = p4 + (2 - 𝓈) (p1 - p4);
 p9 = p5 - p1 + p8; p10 = p6 + p7 - p3;
 (* 3 new rhombi and 4 new triangles *)
 Polygon /@ {{p1, p5, p9, p8}, {p3, p7, p10, p6},
             {p2, p9, p4, p10}, {p9, p5, p2},
             {p10, p6, p2}, {p10, p7, p4}, {p9, p8, p4}}];
(* subdivision of the triangle *)
subdivide[Polygon[{p1_, p2_, p3_}]] :=
Module[{p5, p6, p7, p8}, (* new vertices *)
 p4 = p1 + (𝓈 - 1) (p2 - p1);  p5 = p2 + 1/(𝓈 + 2) (p3 - p2);
 p6 = p2 + 1/𝓈 (p3 - p2); p7 = p3 + (𝓈 - 1) (p1 - p3);
 p8 = p6 + p7 - p3;
(* 2 new rhombi and 3 new triangles *)
 Polygon /@ {{p5, p8, p1, p4}, {p3, p7, p8, p6},
             {p5, p4, p2}, {p8, p6, p5}, {p8, p7, p1}}];
(* the initial rhomb *)  
startRhombus = Polygon[{{0, 0}, {2, 0}, {2 + 𝓈, 𝓈}, {𝓈, 𝓈}}/2];
(* polygons of the tesselation *)  
Nest[Flatten[subdivide /@ #]&, N[{startRhombus}], order]];

The next graphic shows the resulting list of triangles and quadrilaterals. The pairs of triangles facing each other along their longest side form one quadrilateral of the tiling. The left edge of the patch adjoins to its the right edge. To fit upper edge to the lower we slightly shift the patch to the right with increasing y-values. We map the resulting list of polygons polys1 onto a torus.

Show[Graphics[Function[p, 
              With[{mp = Plus @@ p[[1]]/Length[p[[1]]], f = 0.8},  
                   Polygon[mp + f (# - mp)& /@ p[[1]]]]] /@ 
     (tilingPolys1 = Apply[{#1 + (1 - Sqrt[2]/2)#2/(Sqrt[2]/2), Sqrt[2] #2}&, 
      N[tilingPolys], {-2}])],   AspectRatio -> Automatic, Frame -> True]

The function toTorus parametrizes a torus. By interpreting the {x,y}-coordinates of tilingPolys1 as φ1- and φ2-values (for fixed r and R), we map the tiling onto the torus.

(* mapping from plane to a torus *)  
toTorus[φ_, ϑ_, R_, r_] = {R Cos[φ] + r Cos[φ] Cos[ϑ], 
                           R Sin[φ] + r Sin[φ] Cos[ϑ], r Sin[ϑ]};

The function polygonToTorus cuts holes and colors the mapped polygons from the list tilingPolys1 to the torus. We color the triangles different from the quadrilaterals. In addition, we keep a copy of the 3D polygons without the holes in the expression C[…].

(* the quadrilateral *)
polygonToTorus[Polygon[{p1_, p2_, p3_, p4_}]] := 
Module[{mp = (p1 + p2 + p3 + p4)/4, f = 0.6, λ, q1, q2, q3, q4,
        sf = Sequence[SurfaceColor[RGBColor[1, 0.06, 0.1], 
                                   RGBColor[1, 0.06, 0.1], 2.5],
                      EdgeForm[], GrayLevel[0], Thickness[0.001]]},  
       (* inner points *)
       {q1, q2, q3, q4} = (mp + f (# - mp))& /@ {p1, p2, p3, p4};
       {C[sf, Polygon[{p1, p2, p3, p4}], Line[{p1, p2, p3, p4, p1}]],
       (* contracted polygons *)
        {sf, Polygon /@ {{p1, p2, q2, q1}, {p2, p3, q3, q2}, 
                         {p3, p4, q4, q3}, {p4, p1, q1, q4}},
         Line[{p1, p2, p3, p4, p1}], Line[{q1, q2, q3, q4, q1}]}}]

(* the triangle *)
polygonToTorus[Polygon[{p1_, p2_, p3_}]] := 
Module[{mp = (p2 + p3)/2, f = 0.6, q1, q2, q3,
        sf = Sequence[SurfaceColor[RGBColor[1, 0.66, 0.14], 
                                   RGBColor[1, 0.66, 0.14], 2.5],
                      EdgeForm[], GrayLevel[0.2], Thickness[0.001]]},  
       (* inner points *)
       {q1, q2, q3} = (mp + f (# - mp))& /@ {p1, p2, p3};
       {C[sf, Polygon[{p1, p2, p3}], Line[{p2, p1, p3}]],
        (* contracted polygons *)
        {sf, Polygon /@ {{p1, p2, q2, q1}, {p2, p3, q3, q2}, 
                         {p3, p1, q1, q3}},
         Line[{p2, p1, p3}], Line[{q2, q1, q3}]}}]

The function coloredTorusPolys maps the polygons polys1 to the torus. The variable ω determines the relative orientation of the tiling on the torus and by varying ω, the torus effectively rotates. We chose the radii R and rso that we can interlock the tori without intersections.

(* the polygons of the torus *)  
coloredTorusPolys[polys_, ω_] := polygonToTorus /@   
Apply[toTorus[2Pi #1 + N[ω], 2Pi #2 + N[ω], 3, 11/8]&, polys, {-2}];

Here are two pictures of the resulting tori for two values of ω.

Show[GraphicsArray[
     Graphics3D[DeleteCases[coloredTorusPolys[tilingPolys1, #], 
                       _C, Infinity], Boxed -> False]& /@ {0, Pi/2}]]

The function coloredTorusPairPolys makes two orthogonal tori. We rotate the two tori by an angle ω around the y- and z-axes.

coloredTorusPairPolys[polys_, ω_] := 
Module[{aux = coloredTorusPolys[polys, ω],
        (* rotation matrix *)
        ℛ = N[{{Cos[ω], Sin[ω], 0}, {-Sin[ω], Cos[ω], 0}, {0, 0, 1}}.
              {{Cos[ω], 0, Sin[ω]}, {0, 1, 0}, {-Sin[ω], 0, Cos[ω]}}]},
       (* shift and change orientation *)       
       {aux  /. (pl:(Polygon | Line))[l_] :> pl[{#1, #2 - 3/2, #3}& @@@ l],
        aux  /. (pl:(Polygon | Line))[l_] :> pl[{#3, #1 + 3/2, #2}& @@@ l]} /.
       (* rotate *) (pl:(Polygon | Line))[l_] :> pl[ℛ.#& /@ l]];

Show[Graphics3D[DeleteCases[
     coloredTorusPairPolys[tilingPolys1, Pi/4], _C, Infinity]], Axes -> True];

It remains to implement the projections of the torus into the coordinate planes. The function projectedPolygon does this. Instead of calculating true projections and explicitly calculating the visible polygons, the function projectedPolygon effectively calculates squinched version of the torus with a finite thickness so small that they effectively appear two-dimensional.

projectedPolygon[torusPolys_] := 
Module[{𝓅 = torusPolys, L = 8, ε = 10^-8},
(* projection into the y-z-plane *)
xP = Map[If[Head[#] === List, 
            {-L + 100 ε + ε #[[1]], #[[2]], #[[3]]}, #]&, 𝓅, {-2}];
(* projection into the x-z-plane *)
yP = Map[If[Head[#] === List, 
            {#[[1]], +L - 100 ε - ε #[[2]], #[[3]]}, #]&, 𝓅, {-2}]; 
(* projection into the x-y-plane *)
zP = Map[If[Head[#] === List, 
            {#[[1]], #[[2]], -L + 100 ε + ε #[[3]]}, #]&, 𝓅, {-2}];
(* projection plane polygons *)
cornerPolys = Polygon /@ 
{{{-L, -L, -L}, { L, -L, -L}, { L, L, -L}, {-L,  L, -L}},
 {{-L,  L, -L}, { L,  L, -L}, { L, L,  L}, {-L,  L,  L}},
 {{-L, -L, -L}, {-L,  L, -L}, {-L, L,  L}, {-L, -L,  L}}};
(* color all polygons *)
{{SurfaceColor[RGBColor[0.70, 0.06, 0.63], 
               RGBColor[0.66, 0.52, 0.89], 4], cornerPolys}, 
 (* reverse colors in projections *)
 {xP /. RGBColor[r_, g_, b_] -> RGBColor[1 - r, 1 - g, 1 - b], 
  yP /. RGBColor[r_, g_, b_] -> RGBColor[1 - g, 1 - b, 1 - r], 
  zP /. RGBColor[r_, g_, b_] -> RGBColor[1 - b, 1 - r, 1 - g]} /. 
                              GrayLevel[x_] -> GrayLevel[1 - x]}]

The function torusGraphics3D finally assembles all functions together and, for a given value of ω, generates one frame of the animation.

torusGraphics3D[ω_, opts___] := 
Module[{(* polygons on the torus *) 
        aux = coloredTorusPairPolys[tilingPolys1, ω]},
Graphics3D[{DeleteCases[aux, _C, Infinity], 
             (* the three projections *)
             projectedPolygon[List @@@ Cases[aux, _C, Infinity]]},
           opts, Boxed -> False, ViewPoint -> {3, -3, 2},
           PlotRange -> 8.3 {{-1, 1}, {-1, 1}, {-1, 1}}]]

Here is the resulting animation.

frames = 5;
Show[GraphicsArray[##]]& /@ Partition[
Table[torusGraphics3D[ω], {ω, 0, 2Pi (1 - 1/frames), 2Pi/frames}], 3]

frames = 90;
Do[Show[torusGraphics3D[ω]], {ω, 0, 2Pi (1 - 1/frames), 2Pi/frames}]

Another aperiodic pattern suited for mapping onto a torus is the labyrinth tiling [✶], [✶]. Here is the labyrinth tiling of order six shown. The three occurring polygon shapes are colored in red, green, and blue.

labyrinthPolygons[order_Integer?Positive] := labyrinthPolygons[order] = 
Module[{abChain, grid1D, grid2D},
 (* chain of two symbols from iterating a substitution *)
 abChain = Flatten[Nest[(# /. {a -> {b}, b -> {b, a, b}})&, {a}, order]];
 (* 1D grid *)
 grid1D = FoldList[Plus, 0, abChain /. {a -> 1, b -> GoldenRatio}];
 (* 2D tensor product grid *)
 grid2D = Outer[List, grid1D, grid1D];
 (* place polygons around odd-odd vertices  *)
 Flatten @ Table[If[(-1)^(i + j) === 1, {},
                    Polygon[{grid2D[[i + 1, j]], grid2D[[i, j + 1]], 
                             grid2D[[i - 1, j]], grid2D[[i, j - 1]]}]],
                 {i, 2, Length[grid1D] - 1}, {j, 2, Length[grid1D] - 1}]];

(* color according to number of different edges *)
colorQuadrilateral[p:Polygon[l_]] := {Hue[Length[Union[#.#& /@ 
   (Subtract @@@ Partition[Append[l, First[l]], 2, 1])]]/3], p}

Show[Graphics[colorQuadrilateral /@ labyrinthPolygons[6]],
     PlotRange -> All, AspectRatio -> Automatic, Frame -> True,
     FrameTicks -> False];

We now use three copies of the labyrinth tiling of order five and map it onto a torus.

quadrilaterals = labyrinthPolygons[5];
(* translation length *)
λ = Sort[Union[Level[quadrilaterals, {4}]], #1 < #2&][[-2]];
torusPattern = 
 Flatten[Table[Map[(k {λ, 0} + #)&, Flatten[quadrilaterals], {3}], {k, 0, 2}]];

Show[Graphics[colorQuadrilateral /@ torusPattern],
     PlotRange -> All, AspectRatio -> Automatic, 
     Frame -> True, FrameTicks -> None];

(* extension in x- and y-direction *)
{xM, yM} = Sort[Union[#], #1 < #2&][[-2]]& /@ 
                    Transpose[Expand[Level[torusPattern, {3}]]];
toφ1φ2Coordinates[{x_, y_}] := Sequence @@ (2Pi {x/xM, y/yM});

quadrilateral3DColor[p_Polygon] := 
             SurfaceColor[#, #, 2.6]& @ colorQuadrilateral[p][[1]]

Show[Graphics3D[{EdgeForm[{Thickness[0.0001]}], quadrilateral3DColor[#], 
   Map[toTorus[toφ1φ2Coordinates[#], 3, 1]&, #, {2}]}& /@ 
       torusPattern], Boxed -> False]

Construct and visualize a Klein bottle whose surface consists of a massive hexagonal framework.

ψ[{t_, φ_}] = 
Module[{spine2D = {Sin[t]^4, 2 (Sin[t] + Sin[2t]/3)},
        radius = 1/6 + 1/8 (Sin[2t]^2)^(1/4) (Pi/2 - t),
        𝒹1 = {0, 0, 1}, 𝓉, 𝒹2, spine3D},
        𝓉 = #/Sqrt[#.#]&[D[spine2D, t]];
        𝒹2 = Append[Reverse[𝓉] {-1, 1}, 0];
        spine3D = Append[spine2D, 0];
        spine3D + radius (Cos[φ] 𝒹1 + Sin[φ] 𝒹2)];

Next, we create the list of hexagons that we want to map onto the Klein bottle surface. The coordinates of the vertices of the hexagons cover the parametrization domain (0,π)×(0,2π). Some vertices slightly stick out of this domain to fit into the corresponding hole on the opposite edge of the parametrization domain.

hexagonCarpet = 
With[{(* number of hexagon rows and columns *) m = 17, n = 73,
      (* a unit hexagon *)
      hexagon = Line[Table[{Cos[p], Sin[p]}, {p, 0, 2Pi, 2Pi/6}]]},
      (* map hexagons into parametrization domain of the Klein bottle *)
      𝒻[{x_, y_}] = {2 Pi (x + 1)/(3(n + 1))/2, 
                     Pi (y + Cos[Pi/6])/(Cos[Pi/6](m + 1))};
     N[Map[𝒻, #, {3}], 30]& @
     (* array of hexagons *)
     Flatten[{Table[Map[# + {3i, j Cos[Pi/6]}&, hexagon, {2}], 
                     {i, 0, n}, {j, 0, 2 m, 2}],
              Table[Map[# + {3i + 3/2, j Cos[Pi/6]}&, hexagon, {2}], 
                    {i, 0, n}, {j, 1, 1 + 2m, 2}]}]];

With respect to the φ-parametrization, the sticking -out points map trivially into the corresponding holes. By the definition of a Klein bottle, this is not the case for the t-parametrization. We must account for the twist of (180^°) along the spine. The following 18 points have t-values greater than π.

wrapAroundPoints = Union[Cases[hexagonCarpet, {_?(# > Pi&), _}, {3}]];
Length[wrapAroundPoints]

We realize the twist in the Klein bottle by using the parametrization ψ({t mod π, φ}) and by stitching corresponding points appropriately together. The function ψStitched maps the hexagon edge Line[l] correctly on to the Klein bottle.

ψ1[{t_, φ_}] := If[t >= Pi, ψ[{t - Pi, φ}], ψ[{t, φ}]];
ψPs = ψ1 /@ wrapAroundPoints;

ψStitched[Line[l_]] :=
If[(* wrap around? *) Max[First /@ l] > Pi,
  Module[{mp, 𝕕},
   (* find point to connect to *)
   mp = (Plus @@ #/Length[#])&[ψ1 /@ Cases[Rest[l], {_?(# < Pi&), _}]];
   𝕕 = ψPs[[Position[#, Min[#]]&[#.#& /@ ((mp - #)& /@ ψPs)][[1, 1]]]];
   Line[MapAt[𝕕&, ψ /@ l, Position[l, {_?(# > Pi&), _}]]]],
   (* no wrap around *) Line[ψ1 /@ l]]

hexagonTiledKleinBottle is a list of polygons forming a Klein bottle made from hexagons.

hexagonTiledKleinBottle = Polygon @@@ (Map[ψStitched, hexagonCarpet] // N);

Here are two views on the resulting Klein bottle. The right graphic shows that the hexagons were correctly mapped at the transition t=π=>t-0.

Show[GraphicsArray[
Graphics3D[{EdgeForm[Thickness[0.0001]], hexagonTiledKleinBottle}, 
            Boxed -> False, ##]& @@@ {{}, {ViewPoint -> {0, -2, 0}}}]]

We continue by constructing a massive wireframe along the edges of the hexagons. Because the size of the hexagons varies across the Klein bottle surface, so should the thickness of the massive wireframe. To thicken the hexagon edges in the direction approximately normal to the surface, we find the neighboring three vertices and erect a normal on the plane formed by these three neighbors.

To find all three neighbors of a given vertex quickly, we extract all edges and sort them. Then we define the function neighbors for the 5328 vertices of the hexagons.

sortedEdgeList = (* extract and sort all edges *)
Union /@ Split[Sort[Flatten[{#, Reverse[#]}& /@ 
   Flatten[Partition[#[[1]], 2, 1]& /@ hexagonTiledKleinBottle, 1], 1]],
                                 #1[[1]] === #2[[1]]&];
                                 
(neighbors[#[[1, 1]]] = Last /@ #)& /@ sortedEdgeList;
allVertices = #[[1, 1, 1]]& /@ DownValues[neighbors];

Given a vertex and its three neighbors, the function makeTetradNormal gives the normal of the plane formed by the three neighbors.

makeTetradNormal[q_, {p1_, p2_, p3_}] := 
Module[{𝓃 = #/Sqrt[#.#]&, d1, d2, v},
       (* remove components in plane {p1, p2, p3} *)
       d1 = 𝓃[p2 - p1]; d2 = 𝓃[p3 - p1]; d2 = 𝓃[d2 - d2.d1 d1];
       v = q - p1; 𝓃[v - v.d1 d1 - v.d2 d2]]

The function theNormal gives the normal for a given vertex.

(theNormal[#] = makeTetradNormal[#, neighbors[#]])& /@ allVertices;

Now, we have all functions together to implement the function make3DBorder that for a given hexagon forms the 2×2×6 polygons forming the massive wireframe. To guarantee that the polygons fit together appropriately, we make sure that the orientation is uniform and determine the thickness of the massive wireframe from the average distance to the three neighbor vertices.

make3DBorder[Polygon[l_], α_, β_] := 
Module[{𝓃 = #/Sqrt[#.#]&, mp = Plus @@ Rest[l]/6,
        hexagonNormal, λs, pointNormals, L, ℓ, ℒ},
 (* the averaged normal of the hexagon *)
 hexagonNormal  = 𝓃[Plus @@ (𝓃[Cross[#1 - mp, #2 - mp]]& @@@ 
                                             Partition[l, 2, 1])/6];
(* average hexagon edge length/2 *)
 λs  = (Function[p, Plus @@ (Sqrt[#.#& @ (p - #)]& /@ 
                                           neighbors[p])] /@ l)/12;                              
 (* normals at the vertices *)
 pointNormals = If[hexagonNormal.# < 0, -#, #]& /@ (theNormal /@ l);
(* contracted hexagon *)
 ℓ = (mp + α (# - mp))& /@ l;   
 Table[(* move out of hexagon plane in normal directions *)
       {L, ℒ} = (# + sign β λs pointNormals)& /@ {l, ℓ};
       (* form polygons of beams *)
       MapThread[Polygon[Join[#1, Reverse[#2]]]&, 
                 {Partition[#1, 2, 1],  Partition[#2, 2, 1]}]& @@@
                                                  {{L, ℒ}, {ℓ, ℒ}}, 
       (* up and down *) {sign, -1, 1, 2}]]

Here are three original hexagons and the polygons forming the wireframe.

Module[{vertex = hexagonTiledKleinBottle[[100, 1, 1]],
        threeNeighborHexagons},
(* the polygons sharing vertex *)
threeNeighborHexagons = hexagonTiledKleinBottle[[
     Union[First /@ Position[hexagonTiledKleinBottle, vertex]]]];
(* original hexagons in red, wireframe polygons in yellow *)
Show[Graphics3D[
{{SurfaceColor[Hue[0], Hue[0], 2.1], threeNeighborHexagons},
 {SurfaceColor[Hue[0.12], Hue[0.12], 2.1], 
  make3DBorder[#, 0.8, 0.8]& /@ threeNeighborHexagons}}]]]

The list KleinBottlePolys contains the 63936 polygons forming the massive hexagonal framework wireframe.

KleinBottlePolys = make3DBorder[#, 0.86, 0.6]& /@ hexagonTiledKleinBottle;

Here are views of the resulting Klein bottle and its cross section.

Show[GraphicsArray[
Graphics3D[{EdgeForm[], SurfaceColor[Hue[0.18], Hue[0.03], 1.3], 
            KleinBottlePolys},
           ViewPoint -> {3/2, 2, 3}, ViewVertical -> {0, 1, 0}, 
           Boxed -> False, ##]& @@@ 
                    (* show all and cross section *)
                    {{}, {PlotRange -> {All, All, {0, -0.3}}}}]]

Consider 1000 random walkers on a 3D cubic lattice, each making 1000 steps. Carry out these walks and visualize the lattice points that have been visited and the ones that have not been visited.

sitesVisitedByNRandomWalkers[n_, steps_]  :=
Module[{pos, visitedQ,
        dirs = {{-1, 0, 0}, {1, 0, 0}, {0, -1, 0}, {0, 1, 0}, 
                {0, 0, -1}, {0, 0, 1}}},
       Do[pos = {0, 0, 0};
          Do[pos = pos + dirs[[Random[Integer, {1, 6}]]];
             visitedQ[pos] = True, {steps}], {n}]; 
          #[[1, 1, 1]]& /@ DownValues[visitedQ]]

We start with 100 walkers, each making 100 steps.

SeedRandom[1];
Length[visitedSites = sitesVisitedByNRandomWalkers[100, 100]] // Timing

The function makeCube returns the faces of the cube sitting at a lattice point {x,y,z}. (To avoid rational numbers, we multiply all coordinates by 2.)

makeCube[{x_, y_, z_}] :=  Map[(2{x, y, z} + #)&, 
  {{#8, #4, #2, #6}, {#8, #6, #5, #7}, {#8, #7, #3, #4}, 
   {#4, #3, #1, #2}, {#1, #3, #7, #5}, {#2, #1, #5, #6}}&[
  {-1, -1, -1}, {-1, -1, 1}, {-1, 1, -1}, {-1, 1, 1}, 
  { 1, -1, -1}, { 1, -1, 1}, { 1, 1, -1}, { 1, 1, 1}], {2}]

The outermost and the inner boundaries of the lattice points visited by the walkers are the cube faces occurring exactly once in the list of all cube faces.

makeBoundaryCubeFaces[visitedSites_] := #[[1, 2]]& /@ 
 Select[Split[Sort[{Plus @@ #/4, #}& /@ 
              Flatten[makeCube /@ visitedSites, 1]],
           #1[[1]] === #2[[1]]&], Length[#] === 1&];

boundaryCubeFaces = makeBoundaryCubeFaces[visitedSites];

To find the connected components of the surfaces, we associate the cube faces boundaryCubeFaces to all of its edges.

edges[face_] := Sort /@ Partition[Append[face, face[[1]]], 2, 1]

makeEdgesAndFaces[boundaryCubeFaces_] := 
({#[[1, 1]], Last /@ #}& /@ Split[
  Sort[Flatten[Function[f, {#, f}& /@ edges[f]] /@ 
     Take[boundaryCubeFaces, All], 1]], #1[[1]] === #2[[1]]&]);

edgesAndFaces = makeEdgesAndFaces[boundaryCubeFaces];

The function neighborFaces[edge] returns a list of all faces sharing the edge edge.

Function[{edge, faceList}, neighborFaces[edge] = faceList] @@@ edgesAndFaces;

Next, we separate the surface into its connected surface parts. The function makeConnectedSurfaces does this by selecting recursively all faces that are connected through a common edge.

makeConnectedSurfaces[] := 
Module[{faceBags = {}, counter = 0, allEdges, xMax, startEdge,
        currentFaces, newFaceBag, currentEdges, newFaces},
Off[Unset::norep];
(* as long as there are unused edges *)
While[DownValues[neighborFaces] =!= {}, 
(* all remaining edges *)
allEdges = #[[1, 1, 1]]& /@ DownValues[neighborFaces];
(* outermost edge *)
xMax = Max[Transpose[Flatten[allEdges, 1]][[1]]];
startEdge = Select[allEdges, (#[[1, 1]] === xMax || 
                              #[[2, 1]] === xMax)&, 1][[1]];
(* neighbor faces of startEdge *)
currentFaces = neighborFaces[startEdge];
neighborFaces[startEdge] =.;
newFaceBag = {};
(* extend current surface part as long as possible *)
While[
 (* the edges of the current faces *)
 currentEdges = Flatten[edges /@ currentFaces, 1] // Union;
 (* new faces on the outside *)
 newFaces = DeleteCases[Flatten[neighborFaces /@ currentEdges, 1],
                        _neighborFaces] // Union;
 newFaces =!= {},
 (* keep outer layer of faces *)
 newFaceBag = {newFaceBag, newFaces};
 (neighborFaces[#]=.)& /@ currentEdges;
 currentFaces = newFaces];
 (* keep new component *)
 faceBags = {faceBags, Union[Level[newFaceBag, {-3}]]}];
 (* return connected components *) Level[faceBags, {-4}]]

For the example under consideration, we have four components. The outermost one is clearly dominating in size.

walkSurfaces = makeConnectedSurfaces[];
{First[#], Length[#]}& /@ Split[Length /@ walkSurfaces]

Here are two graphics. The left graphic shows the outer boundary of all sites visited and the right graphic shows the not visited sites that are inside the left graphic.

(* color polygon of one surface component 
   according to distance to the origin *)
inOutColoredPolys[polys_] := 
Module[{polyDistances = {Sqrt[#.#]&[Plus @@ #/4], #}& /@ N[polys], 
        min, max},
       {min, max} = {Min[#], Max[#]}&[First /@ polyDistances];
       {SurfaceColor[#, #, 2.2]&[Hue[0.78 - 0.78 (#[[1]] - min)/(max - min)]], 
                                     Polygon[#[[2]]]}& /@ polyDistances];
                                              
(* randomly colored polygons *)
randomlyColorPolys[polys_] := 
{SurfaceColor[Hue[Random[]], Hue[Random[]], 3 Random[]], Polygon /@ polys}

showWalkSurfaces[walkSurfaces_] := 
Show[GraphicsArray[
{(* color large component according to distance to the origin *)
 Graphics3D[{EdgeForm[], inOutColoredPolys[First[walkSurfaces]]}, 
           PlotRange -> All, Boxed -> False],
 (* color inner components randomly *)
 Graphics3D[{EdgeForm[], randomlyColorPolys /@ Rest[walkSurfaces]}, 
            PlotRange -> All, Boxed -> False]}]];

showWalkSurfaces[walkSurfaces];

Now, we repeat the above calculations with 1000 walkers, each taking 1000 steps. The walks can be carried out in less than half a minute on a 2 GHz computer.

SeedRandom[1];
Length[visitedSites = sitesVisitedByNRandomWalkers[1000, 1000]] // Timing

Repeating the steps from above, we obtain now 806 connected surface components.

(* all cube faces *)
boundaryCubeFaces = makeBoundaryCubeFaces[visitedSites];
(* edges and faces *)
edgesAndFaces = makeEdgesAndFaces[boundaryCubeFaces];
(* make definitions for neighborFaces *)
Function[{edge, faceList}, neighborFaces[edge] = faceList] @@@ edgesAndFaces;
(* no longer needed *) Clear[edgesAndFaces];
walkSurfaces = makeConnectedSurfaces[];
Length[walkSurfaces]

Again, we have one large component representing the outermost visited sites and many small not visited sites in the inside. Here is a plot of the logarithm of the distribution.

ListPlot[{Length[#], Log @ First[#]}& /@ Split[Sort[Length /@ walkSurfaces]], 
         PlotRange -> All, Frame -> True, Axes -> False]

Here are the connected components.

showWalkSurfaces[walkSurfaces]

By calculating the volume and the surface area of the clusters for various number of walkers (=steps), we see that the surface roughness is approximately constant.

volumeSurfaceData = 
Table[{o, Length[#], Length[makeBoundaryCubeFaces[#]]}&[
                            sitesVisitedByNRandomWalkers[o, o]], 
      {o, 100, 1000, 100}]
      
N[Log[#3, #2]& @@@ volumeSurfaceData]

For many results on many random walkers, see [✶].

A possible 2D generalization of the classical Minkowski function from the triangles {{0,0},{1,0},{1,1}} into the triangle {{0,0},{1,0},{1,1}} is based on the following construction [✶], [✶]: Start with two copies of the triangle {{0,0},{1,0},{1,1}} and recursively subdivide them into six new triangles by inserting a new point along each edge and one point in the interior. The four new points (Subscript[p, 1])⊕(Subscript[p, 2]), (Subscript[p, 1])⊕(Subscript[p, 3]), (Subscript[p, 2])⊕(Subscript[p, 2]), and (Subscript[p, 1])⊕(Subscript[p, 2])⊕(Subscript[p, 3]), are calculated through the generalized additions (Subscript[⊕, F/B]) of the three vertices (Subscript[p, 1]), (Subscript[p, 2]), and (Subscript[p, 3])(with rational coordinates {(Subscript[p, i x])/(Subscript[r, i ]),(Subscript[p, i y])/(Subscript[r, i ])} ) of a triangle according to two possible rules:

a) the Farey addition (Subscript[⊕, F]):

{((Subscript[p, i x])/(Subscript[r, i ])),((Subscript[p, i y])/(Subscript[r, i ]))}(Subscript[⊕, F]){((Subscript[p, j x])/(Subscript[r, j])),((Subscript[p, j y])/(Subscript[r, j]))}={(((Subscript[p, i x])+(Subscript[p, j x]))/((Subscript[r, i ])+(Subscript[r, j]))),(((Subscript[p, i y])+(Subscript[p, j y]))/((Subscript[r, i ])+(Subscript[r, j])))}

a) the Bary addition (Subscript[⊕, B]):

{((Subscript[p, i x])/(Subscript[r, i ])),((Subscript[p, i y])/(Subscript[r, i ]))}(Subscript[⊕, B]){((Subscript[p, j x])/(Subscript[r, j])),((Subscript[p, j y])/(Subscript[r, j]))}={(1/2)(((Subscript[p, i x])/(Subscript[r, i ]))+((Subscript[p, j x])/(Subscript[r, j]))),(1/2)(((Subscript[p, i y])/(Subscript[r, i ]))+((Subscript[p, j y])/(Subscript[r, j])))}

and both additions being associative (Subscript[p, 1])(Subscript[⊕, F/B])(Subscript[p, 2])(Subscript[⊕, F/B])(Subscript[p, 3])=((Subscript[p, 1])(Subscript[⊕, F/B])(Subscript[p, 2]))(Subscript[⊕, F/B])(Subscript[p, 3]).

The 2D Minowski map is then the limit n->∞ of the map, that maps the two sets of identically ordered triangles after n subdivisions into each other.

For n=4 or n=5, embed the map from the first triangle into the second in (ℝ^4) and make an animation showing projections of the resulting surface projected into 3D.

FareyPlus[ps_List] := 
Module[{dens = Max /@ Denominator[ps], nums},
        nums = MapThread[Times, {dens, ps}];
      {Plus @@ (First /@ nums), Plus @@ (Last /@ nums)}/(Plus @@ dens)]

BaryPlus[ps_List] := {Plus @@ (First /@ ps), Plus @@ (Last /@ ps)}/Length[ps]

Next, given an triangle, we define its splitting into six new triangles according to the described rule.

sixNewTriangles[plus_, Polygon[{p1_, p2_, p3_}]] :=
Module[{p12 = plus[{p1, p2}], p13 = plus[{p1, p3}], p23 = plus[{p2, p3}],
        p123 = plus[{p1, p2, p3}]},
        Polygon /@ {{p1, p12, p123}, {p12, p2, p123}, {p2, p23, p123},
                    {p23, p3, p123}, {p3, p13, p123}, {p13, p1, p123}}]

Here are the first few recursive subdivisions in superimposed form for the Farey and the Bary addition.

With[{o = 4},
Show[GraphicsArray[
Function[plus, Graphics[{MapIndexed[{Hue[0.8 (#2[[1]] - 1)/(o + 1)], 
          Thickness[0.025 - 0.025 (#2[[1]] - 1)/o], #}&, 
          NestList[Flatten[sixNewTriangles[plus, #]& /@ #]&, 
                   {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, o]] /. 
                 Polygon[l_] :> Line[Append[l, First[l]]]}, 
             AspectRatio -> Automatic, Frame -> True, 
             FrameTicks -> False]] /@ {FareyPlus, BaryPlus}]]];

To better see the complicated structure of the triangulations, we color the triangles according to their smallest angles.

𝓃 = #/Sqrt[#.#]&;

minMaxAngles[Polygon[{p1_, p2_, p3_}]] := 
Module[{n12 = 𝓃[p2 - p1], n13 = 𝓃[p3 - p1], n23 = 𝓃[p3 - p2]},
       {Min[#], Max[#]}& @ ArcCos[{n12.n13, n12.n23, n13.n23}]]

angleColoredGraphics[polys_] := 
Module[{allAngles = minMaxAngles /@ N[polys], minAngle, maxAngle},
       {minAngle, maxAngle} = {Min[#], Max[#]}& [First /@ allAngles];
       Graphics[{Transpose[{Hue /@ (0.78 ((First /@ allAngles) - minAngle)/
                                      (maxAngle - minAngle)), polys}]},
                AspectRatio -> Automatic, Frame -> False]]

With[{o = 5},
Show[GraphicsArray[Function[plus, 
angleColoredGraphics[Nest[Flatten[sixNewTriangles[plus, #]& /@ #]&, 
          {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, o]]] /@ {FareyPlus, BaryPlus}]]]

Next, we construct the triangles for the animation. These are the two sets of Farey and Bary triangles in identical order.

order = 4;
trianglesFarey = Nest[Flatten[sixNewTriangles[FareyPlus, #]& /@ #]&, 
          {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, order];

trianglesBary = Nest[Flatten[sixNewTriangles[BaryPlus, #]& /@ #]&, 
          {Polygon[{{0, 0}, {1, 0}, {1, 1}}]}, order];

By joining the coordinates of the Farey and Bary triangle, we embed them into (ℝ^4).

to4DTriangle[{Polygon[{p1_, p2_, p3_}], Polygon[{q1_, q2_, q3_}]}] :=
              Polygon[{Join[p1, q1], Join[p2, q2], Join[p3, q3]}]

triangles4D = to4DTriangle /@ Transpose[{trianglesFarey, trianglesBary}];

The function project projects the triangles triangles4D into a 3D subspace orthogonal to vector.

project[triangles4D_, vector_] := 
Module[{v4 = 𝓃[vector], v3 = 𝓃[Table[Random[], {4}]],
        v2 = 𝓃[Table[Random[], {4}]], v1 = 𝓃[Table[Random[], {4}]]},
       v3 = 𝓃[v3 - v3.v4 v4];
       v2 = 𝓃[v2 - v2.v4 v4 - v2.v3 v3];
       v1 = 𝓃[v1 - v1.v4 v4 - v1.v3 v3 - v1.v2 v2];
      Map[{v1.#, v2.#, v3.#}&, triangles4D, {3}]]

Here are three random projections.

Show[GraphicsArray[
Table[SeedRandom[k];
     Graphics3D[project[triangles4D, Table[Random[Real, {-1, 1}], {4}]], 
                BoxRatios -> {1, 1, 1},  PlotRange -> All], {k, 3}]]];

For the animation, we want a smooth dependence of the projection subspace from the animation parameter. And to obtain a variety of views on the surface, we use a parametrization through 4D rotation matrices similar to the ones used in Solution 21a) of the second chapter of the Graphics volume.

(* all principle projections *)
reImPathList4D = {{1, 2, 3, 4}, {1, 2, 4, 3}, {1, 4, 2, 3},
                  {3, 4, 2, 1}, {3, 4, 1, 2}, {3, 2, 1, 4}, {1, 2, 3, 4}};

(* construct parametrized rotation matrix that rotates from aL to bL *)
makeTransitionMatrix[{aL_, bL_}, φ_] := 
Module[{m = Table[0, {4}, {4}], c = Cos[φ], s = Sin[φ],
        𝒻 = Function[{𝓂, v}, If[𝓂 === 0, 𝓂 = v], {HoldAll}]},
 (* set rotation matrix elements *)
 Do[{i, j} = {aL[[k]], bL[[k]]}; 
   If[i == j, m[[i, i]] = 1, 𝒻[m[[i, i]],  c]; 𝒻[m[[j, j]], c]; 
                             𝒻[m[[i, j]], -s]; 𝒻[m[[j, i]], s]], 
     {k, 4}]; m]

(* list of rotation matrices *)
ℛs = 
Module[{framesPerSubRotation = 18, 𝓇1, 𝓇2},
  (* all Pi/2 rotations *)
  𝓇1 = makeTransitionMatrix[#, φ]& /@ Partition[reImPathList4D, 2, 1];
  (* cumulative rotation matrix *)
  𝓇2 = FoldList[#1.#2&, IdentityMatrix[4], 𝓇1 /. φ -> Pi/2];
  Table[(* form subrotation matrices *) Table[𝓇2[[k]].𝓇1[[k]], 
                     {φ, 0, Pi/2, Pi/2/framesPerSubRotation}],
        {k, Length[reImPathList4D] - 1}] // Flatten[#, 1]& // N];

Here are some of the resulting views in the 2D Minkowski function.

Show[GraphicsArray[#]]& /@ Partition[
Function[ℛ, Graphics3D[Map[Most[ℛ.#]&, triangles4D, {3}], BoxRatios -> {1, 1, 1},
                  PlotRange -> All]] /@ ℛs[[{1, 27, 43, 54, 69, 106}]], 3]

Here is the corresponding animation.

Function[ℛ, Show[Graphics3D[Map[Most[ℛ.#]&, triangles4D, {3}], BoxRatios -> {1, 1, 1},
                  PlotRange -> All]]] /@ ℛs

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}]

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}]

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.

Numerics Volume, Chapter 1

Consider a random walk in 1D where the stepsize (Subscript[λ, n]) of the nth step depends on n. For the two functions (Subscript[λ, n])=(n^α) (α<0) and (Subscript[λ, n])=(α^n) (0<α<1), visualize the density of the resulting walker positions after the first 25 steps for various α.

varyingStepSizeRandomWalkData[λList_, max_, δ_] := 
With[{o = Length[λList]},
Compile[{}, Module[{L = Table[0, {δ}], x, k},
               Do[(* final walk position after o steps *) x = #1.λList; 
                  (* bin final walk position *)
                  k = Round[(x + max)/(2max) (δ - 1)] + 1;
                  (* count binned final walk position *)
                  L[[k]] = L[[k]] + 1, ##2];
                  L]][]&[(* left-right steps *) Table[i[k], {k, o}], 
                         (* left-right step iterators *)
                         Sequence @@ Table[{i[k], -1, 1, 2}, {k, o}]]];

The next series of graphics shows the results for (Subscript[λ, n])=(α^n). For larger α, we obtain a smooth bell-shaped curve. For smaller α, we obtain a fractal structure. For a detailed discussion of this case, see [✶].

opts = Sequence[PlotRange -> All, Frame -> True, FrameTicks -> False,
                DisplayFunction -> Identity, Axes -> False,
                PlotStyle -> {PointSize[0.0001]}];

With[{o = 25, δ = 1000}, 
Show[GraphicsArray[
    ListPlot[varyingStepSizeRandomWalkData[
              Table[#^k, {k, o}],  #/(1 - #), δ], opts]& /@ 
                      {0.4, 0.55, 1./GoldenRatio, 0.8}]]];

For (Subscript[λ, n])=(n^α), we see nested structures forming for decreasing α.

With[{o = 25, δ = 1000}, 
Show[GraphicsArray[
    ListPlot[varyingStepSizeRandomWalkData[
              Table[k^#, {k, o}],  Sum[k^#, {k, o}], δ], opts]& /@ 
                                           {-0.4, -1., -1.5, -2.}]]]

Consider the following 2D scattering system: A light ray is (potentially repeatedly) reflected in the interior region formed by three circles centered at the vertices of a regular triangle [✶], [✶], [✶]. The ray can escape through the spaces between the circles. For (at least) 200 rays starting at equidistant points along the line connecting the (centers of) two circles, in (at least) 200 discrete directions, visualize the dependence of the three possible exit points on the starting points and the starting angles. Use circles of 9/10 and 99/100 of their maximal size.

Off[General::spell]; Off[General::spell1];

threeCircleConfiguration[ρ_] := 
With[{𝓈 = N[Sqrt[3], Precision[ρ]]},
{Circle[{𝓈, -1}/2, ρ], Circle[{-𝓈, -1}/2, ρ], Circle[{0, 1}, ρ], 
 Line[{{𝓈 - ρ, -1 + 𝓈 ρ}, {ρ, 2 - 𝓈 ρ}}/2], 
 Line[{{-𝓈 + ρ, -1 + 𝓈 ρ}, {-ρ, 2 - 𝓈 ρ}}/2], 
 Line[{{𝓈 - 2ρ, -1}, {-𝓈 + 2ρ, -1}}/2]}]

Show[Graphics[threeCircleConfiguration[0.5]],
     PlotRange -> All, AspectRatio -> Automatic, Frame -> True];

Given a ray Ray[p, d] starting at the point p and moves in (normalized) direction d, the function nearestIntersection calculates the nearest intersection of this ray with a circle, or with a line segment joining the circles.

(* nearest intersection (if any) of a ray with a circle *)
nearestIntersection[Ray[p_, d_], Circle[q_, ρ_]] := 
Module[{eqs = (p - q + t d).(p - q + t d) - ρ^2, sol},
  (* next intersection if "forward" *)
  sol = Select[t /. Solve[eqs == 0, t], (Im[#] == 0 && # > 0)&];
  If[sol === {}, {}, {t, p + t d} /. t -> Min[sol]]]

(* nearest intersection (if any) of a ray with a line segment *)
nearestIntersection[Ray[p_, d_], Line[{p1_, p2_}]] := 
Module[{eqs = Thread[p1 + s (p2 - p1) == p + t d], solPre, sol},
  (* the ray is potentially parallel to the line segment *)
  solPre = Solve[eqs, {s, t}]; 
  If[solPre === {}, {}, (* crossing happens inside segment? *)
     sol = Select[{s, t} /. solPre, (0 <= #[[1]] <= 1 && 0 < #[[2]])&];
     If[sol === {}, {}, {t, p + t d} /. t -> Min[Last /@ sol]]]]

To carry out the reflection at a point on the circle, we use the function reflect.

(* reflection of a ray at the point s at a circle *)
reflect[Ray[_, d_], s_, Circle[q_, _]] := 
Module[{n = #/Sqrt[#.#]&[s - q]}, Ray[s, d - 2d.n n]]

To quickly decide if the intersection of a ray with a circle happens with the "inside" part of the circle, we define the angle ranges for the three circles.

Evaluate[angleRange /@ {1, 2, 3}] = 
         Interval /@ (Pi/3 {{2, 3}, {0, 1}, {-2, -1}});

Now, we have all functions defined that are needed to carry out one reflection (or the final escape step) for a ray. The function step does this. In general, we will have to use a few hundred digits to carry out many reflections and obtain a correct result. But to find the next individual scatterer, we can use much lower precision to speed up the calculations.

step[ρ_, {rayHP:Ray[p_, d_], lastCircle___}] :=
Module[{tCC, ray, possibleCircles, iCs, iCs1, α, result, 
        nextEvent, possibleLines, isL, isL1, tLMins, posL},
 tCC = threeCircleConfiguration[ρ];
 (* use reduced precision to find next event *)
 ray = N[rayHP, 25];
 (* next reflection is not on last circle *)
 possibleCircles = Delete[Transpose[{{1, 2, 3}, Take[tCC, 3]}],
                          {lastCircle}];
 (* potential intersection with remaining circles *)
 iCs = {#1, nearestIntersection[ray, #2]}& @@@ possibleCircles;    
 (* reflection happens on the inside circle segment *)
 iCs1 = Select[iCs, (#[[2]] =!= {} && 
            IntervalMemberQ[angleRange[#[[1]]],
                     ArcTan @@ (#[[2, 2]] - tCC[[#[[1]]]][[1]])])&];
 (* is next event a reflection? *)
 If[iCs1 =!= {}, (* next event is a reflection *)
    nextEvent = "Reflection";
    α = iCs1[[Position[#, Min[#]]&[#[[2, 1]]& /@ iCs1][[1, 1]], 1]];   
    {circleNumber, circle} = {α, tCC[[α]]}];
(* escape *)
If[nextEvent =!= "Reflection", nextEvent = "Escape";  
   (* happens only once, so test all three cases *)
   possibleLines = Transpose[{{1, 2, 3}, Take[tCC, -3]}];
   isL = {#1, nearestIntersection[ray, #2]}& @@@ possibleLines;
   isL1 = DeleteCases[isL, {_, {}}];
   tLMins = #[[2, 1]]& /@ isL1;                                 
   posL = Position[tLMins, Min[tLMins]][[1, 1]];
   result = {isL1[[posL, 1]], isL1[[posL, 2, 2]]}];
(* return result *)
If[nextEvent === "Reflection",
   (* high-precision reflection *)
    𝓈 = nearestIntersection[rayHP, circle][[2]];
   {reflect[rayHP, 𝓈, tCC[[circleNumber]]], circleNumber}, 
   result]]

The full path of a ray until it escapes (or until the ray data do not have enough precision anymore to follow the ray) can be calculated using the function rayPath.

rayPath[ρ_, ray:Ray[p_, d_]] :=
NestWhileList[step[ρ, #]&, {ray}, 
              (* stop at exit or insufficient precision *)
              ((Head[First[#]] === Ray) && (Precision[#] > 20))&]

To visualize the path of a ray, we implement the function rayPathGraphic. It colors the path from red to blue and draws a gray dot at the escape point. To concentrate on the ray path, we show only the relevant parts of the circles.

rayPathGraphic[ρ_, rayPath_, opts___] :=
With[{(* reflection points *)
      points = If[Head[#[[1]]] === Ray, #[[1, 1]], #[[2]]]& /@ rayPath,
      (* exit point *)
      exitPoint = If[Head[rayPath[[-1, 1]]] =!= Ray, 
                     {rayPath[[-1, 2]]}, {}],
       xMin = -Sqrt[3]/2 + ρ/2, xMax = Sqrt[3]/2 - ρ/2, 
       yMin = -1/2, yMax = 1 - Sqrt[3]/2 ρ, δ = (Sqrt[3] - ρ)/20}, 
Show[Graphics[
{(* the three scattering circles *)
 {Thickness[0.006], GrayLevel[0], 
  MapIndexed[Function[{x, p}, Insert[x, angleRange[p[[1]]][[1]], 3]],
           Take[threeCircleConfiguration[ρ], 3]],
  Take[threeCircleConfiguration[ρ], -3]},
 (* ray path *)
 {Thickness[0.0001], 
  MapIndexed[{Hue[0.78 (#2[[1]] - 1)/(Length[points] - 1)], Line[#1]}&, 
             Partition[points, 2, 1]]},
 (* exit point *)
 {PointSize[0.025], GrayLevel[1/2], Point /@ exitPoint}}],
     PlotRange -> {{xMin - δ, xMax + δ}, {yMin - δ, yMax + δ}}, 
     opts, AspectRatio -> Automatic, Frame -> True, FrameTicks -> False]]

Here are four example paths. The parameter for the rightmost path are chosen to give 10 internal reflections.

Show[GraphicsArray[
rayPathGraphic[1/2, rayPath[1/2, Ray[{0, -1/2}, #] // N[#, 100]&],
               DisplayFunction -> Identity]& /@
        {{0, 1}, {11, 1}, {1, 1}, (* long ray path *)
         {65690846499036600543, 33168393638474293644}}]]

Here is an animation showing the dependence of the paths from the starting angle. All paths start at the center between two circles.

With[{ε = 10^-6}, 
 Do[rayPathGraphic[4/5, rayPath[4/5, Ray[{0, -1/2}, 
                                ExpandAll[{Cos[φ], Sin[φ]}]] // N[#, 250]&]],
    {φ, ε, Pi - ε, (Pi - 2ε)/90}]]

For an easier specification of the starting points of the rays for arbitrary circle radii, we define a scaled radius (Subscript[ρ, s])=2 (3^(-1/2))ρ. So, (Subscript[ρ, s]) varies between 0 and 1. The initial position is measured with respect to the length of the line segment and ranges over the interval (-1, 1).

scaledρ[ρRel_] := Sqrt[3]/2 ρRel
      
scaledRayData[ρRel_, {ξ0_, φ0_}] :=
Module[{ρ = scaledρ[ρRel]},  
      {ρ, Ray[{ξ0 (Sqrt[3]/2 - ρ), -1/2}, {Cos[φ0], Sin[φ0]}]}]

Here are two examples of paths for different circle radii.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
Function[{ρRel, ξ0, φ0, prec}, rayPathGraphic[Sqrt[3]/2 ρRel,
         rayPath @@ N[scaledRayData[ρRel, {ξ0, φ0}], prec]]] @@@
         {{9/10, -1/2, Pi/6, 300}, {99/100, 0, Pi/6, 300}}]]];

Now, we analyze the path length on a grid in the ξ0,φ0-plane. The function exitResult returns a two element list of the form {pathLength,exitNumber}. We use circles of relative size 9/10.

exitResult[ρRel_, {ξ0_, φ0_}, prec_] :=
Module[{rP}, 
  rP = rayPath @@ N[scaledRayData[ρRel, {ξ0, φ0}], prec]; 
  {Length[rP], (* return 0 if no exit was reached *)
   If[MemberQ[Last[rP], _Ray, Infinity], 0, rP[[-1, 1]]]}]

To generate the exit number data for a dense grid in the ξ0,φ0-plane, we make use of the mirror symmetry of the circle configuration along the y-axis. The function makeξφExitData calculates the exit numbers for angles 0<φ≤π/2 explicitly and calculates the exit numbers for angles π/2≤φ<π/2 using symmetry.

makeξφExitData[er_, ρRel_, pp_, prec_] :=
Module[{φM = Pi If[EvenQ[pp], 1/2 , 1/2 - (1 - 2/pp)/pp/2], t},
 (* join data and double mirrored data *)
 Join[#, Map[Reverse, Map[{{#[[1, 1]], Pi - #[[1, 2]]}, 
             {#[[2, 1]], #[[2, 2]] /. {1 -> 2, 2 -> 1}}}&, 
            If[EvenQ[pp], Drop[#, -1], #], {2}], {0, 1}]]&[
 (* half of the data *)
 Table[{{ξ0, φ0}, er[ρRel, {ξ0, φ0}, prec]},
        {φ0, Pi/pp, φM, (φM - Pi/pp)/If[EvenQ[pp], pp/2, (pp - 1)/2]},
        {ξ0, -1 + 1/pp, 1 - 1/pp, (2 - 2/pp)/pp}]]]

Here are the path length and exit numbers for the circles of 90% their possible maximum size.

data[9/10] = makeξφExitData[exitResult, 9/10, 200, 250];

We display the path length as a density plot and the exit number we indicate by red (exit 1), green (exit 2), and blue (exit 3) squares. In case too much precision was lost in the calculation and the exit number could not be determined, we draw a white square.

exitResultGraphics[exitData_] := 
Show[GraphicsArray[
Block[{$DisplayFunction = Identity,
       opts = Sequence[Mesh -> False, PlotRange -> All,
       MeshRange -> {{-1 + 1/#, 1 - 1/#}&[Length[exitData[[1]]] - 1],
                     Pi {1/#, 1 - 1/#}&[Length[exitData] - 1]}]},
      {(* path length graphic *)
       ListDensityPlot[Log @ Map[#[[2, 1]]&, exitData, {2}], opts, 
                      ColorFunction -> GrayLevel],
       (* exit number graphic *)
       ListDensityPlot[Map[#[[2, 2]]&, exitData, {2}], opts, 
                      ColorFunction -> 
                      (If[# == 0, (* no exit found *) RGBColor[1, 1, 1],
                          MapAt[1&, RGBColor[0, 0, 0], #]]&),
                      ColorFunctionScaling -> False]}]]]

For the 9/10 circle, we see bands of equal exit numbers.

exitResultGraphics[data[9/10]]

The next two graphics show one of the longest ray paths and the cumulative distribution of all path lengths.

(* extract longest path parameters *)
extractLongestPath[data_] := Expand[Part[data, ##]& @@@ 
        Position[#, Max[#]]&[Map[#[[2, 1]]&, data, {2}]]]
        
maxData = extractLongestPath[data[9/10]]

(* function to visualize longest path and 
   cumulative path length distribution *)
showMaxDataResults[ρRel_, data_, prec_] := 
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{(* the path with the most reflections *)
 Module[{maxData = extractLongestPath[data], ξ0, φ0}, 
         {ξ0, φ0} = maxData[[1, 1]];
     rayPathGraphic[Sqrt[3]/2 ρRel,
                    rayPath @@ N[scaledRayData[ρRel, {ξ0, φ0}], prec]]],
 (* cumulative distribution of path lengths *)
 ListPlot[MapIndexed[{#2[[1]], Log[#1]}&, 
            Sort[Flatten[Map[#[[2, 1]]&, data, {2}]]]],
         PlotRange -> All]}]]];

showMaxDataResults[9/10, data[9/10], 300]

For circles of relative size 99/100, we have potentially very long paths and so need many digits to calculate the exit number. To not slow down the calculation of the exit number of shorter paths by using excessively many digits, we define a function adapativeExitResult that starts with precision prec. In case no exit can be found, adapativeExitResult iteratively doubles the precision until an exit is found.

adapativeExitResult[ρRel_, {ξ0_, φ0_}, precInit_] := 
Module[{er, prec = precInit},
       While[er = exitResult[ρRel, {ξ0, φ0}, prec]; 
             Last[er] === 0, prec = 2 prec]; er]

The next input shows an example where exitResult fails, but adapativeExitResult succeeds.

{exitResult[##], adapativeExitResult[##]}& @@
           {99/100, {121/147, 59/441 Pi}, 200}

Using a 2 GHz computer, we can now in about two hours calculate the exits on a 200×200 grid. (Because all rays are independent, this problem is, of course, ideal for parallelization.)

(data[99/100] = makeξφExitData[adapativeExitResult, 
                               99/100, 200, 250]); // Timing

Now, the bands from above have nearly disappeared and the points of a given color have nearby points of the other two colors [✶].

exitResultGraphics[data[99/100]]

showMaxDataResults[99/100, data[99/100], 800]

Take the 2D Hilbert curve from Exercise 20 of Chapter 2 of the Graphics volume and embed it in a square grid (so that the edges of the Hilbert curve are along neighboring lattice points). Assuming springs of stiffness 1 between all neighboring grid points and springs of stiffness 𝓀 along the segments of the Hilbert curve, allow the point mass lattice points to oscillate in vertical direction (outermost lattice points are kept fixed). Calculate and visualize some of the resulting eigenoscillations for various stiffnesses 𝓀.

LSystemWithFAndLAndR[axiom_, rules_, iterations_, δ_] :=
Module[{minus, plus, ℛ, last = {0, 0}, d = {1, 0}},
 minus = {{ Cos[ δ], Sin[ δ]}, {-Sin[ δ], Cos[ δ]}};
 plus  = {{ Cos[-δ], Sin[-δ]}, {-Sin[-δ], Cos[-δ]}};
 ℛ = rules /. {(a_ -> b_) -> (a :> Sequence @@ b)};
Select[Prepend[
 (Which[# == "F", last = last + d, # == "+", d = plus.d; Null,
        # == "-", d = minus.d; Null, # == "R", Null,   
        # == "L", Null]& /@ Nest[(# /. ℛ)&, axiom, iterations]),
      {0, 0}], # =!= Null&]]

order = 4; {L =  3^(order) + 1, dim = 3^(2 order)}

Show[Graphics[
 MapIndexed[{Hue[(#2[[1]] - 1)/3^(2 order)],
  Thickness[0.001], Line[#]}&, Partition[line = 
  {1, 1} + {1, -1}#& /@ LSystemWithFAndLAndR[{"-", "L"},
   {"L" -> Characters["LF+RFR+FL-F-LFLFL-FRFR+"],
    "R" -> Characters["-LFLF+RFRFR+F+RF-LFL-FR"]},
    order, 2Pi/4], 2, 1]]], AspectRatio -> Automatic, 
     Frame -> True, PlotRange -> L {{0, 1}, {0, 1}}]

To calculate the oscillations of the vertical spring network, we need the connectivity of the grid. The equation of motion for the lattice points (Subscript[u, i,j])(t) is (Subscript[(Overscript[u, ..]), i,j])(t)=∑(Subscript[k, i,j]^(i',j'))((Subscript[u, i',j'])(t)-(Subscript[u, i,j])(t)) where (Subscript[k, i,j]^(i',j')) is the stiffness of the spring that connects the lattice points {i,j} and {i',j'} and the sum extends over the four neighboring lattice points of {i,j} . Assuming (Subscript[(Overscript[u, ..]), i,j])(t)∼(e^(i ω t))(Subscript[(OverHat[u]), i,j]), the calculation of the eigenoscillations reduces to the calculation of the eigenvalues and eigenvectors of the coefficient matrix of ∑(Subscript[k, i,j]^(i',j'))((Subscript[(OverHat[u]), i',j'])-(Subscript[(OverHat[u]), i,j])).

To obtain a linear numbering of the lattice points, we number them consecutively, first in the x-, then in the y-direction.

Do[vertexNumber[{i, j}] = (j - 1) (L - 1) + i, {i, L -1}, {j, L - 1}]

Next, we find all lattice points that are connected by the Hilbert curve.

hData = Function[x, {x[[1, 1, 1]], {#1[[2]], #2}& @@@ x}] /@
Split[Sort[Flatten[{{#1, #2}, {Reverse[#1], #2}}&  @@@
 MapIndexed[{#1, 𝓀[#2[[1]]]}&, Partition[line, 2, 1]], 1]],
      (#[[1, 1]] === #2[[1, 1]])&];

Now, we assemble the coefficient matrix. It is a sparse 6561×6561 matrix with 32481 elements.

(* make rules for coefficients for neighbors *)
makeRules[{p_, ps_List}] :=
Block[{qs, pn = vertexNumber[p], ℓ = Length[ps]}, 
 qs = DeleteCases[
      Complement[(p + #)& /@ {{-1, 0}, {1, 0}, {0, -1}, {0, 1}},
                 ps], {0, _} | {L, _} | {_, 0} | {_, L}];  
 (* the nonvanishing matrix elements *)
 Flatten[{{pn, pn} -> (Plus @@ (Last /@ ps)) + (4 - ℓ) 1,
          ({pn, vertexNumber[#1]} -> -#2)& @@@ ps,
          ({pn, vertexNumber[#1]} -> -1)& /@ qs}]]

(* all coefficients *)
allRules[𝓀_] = makeRules /@ hData;
(* create sparse arrays *)
M[𝓀_] := SparseArray[Flatten[allRules[𝓀]]]

We use three different values of 𝓀: a small one, a large one, and 𝓀=1 (meaning a uniform spring network). Here are the corresponding values of extreme eigenvalues.

(* three stiffness values *)
𝓀List = {1/100, 1, 100};
Evaluate[ℳ /@ 𝓀List] = N[M /@ (Function /@ 𝓀List)];

(εRange[#] = 
Reverse[Eigenvalues[ℳ[#], 2, 
  Method -> {"Arnoldi", Criteria -> "BothEnds",  BasisSize -> 20,
             MaxIterations -> 10^4}]])& /@ 𝓀List

Given a list of eigenvectors, the function makeGraphicsArrays creates graphics arrays with the eigenoscillations of the three different spring stiffnesses adjacent.

makeGraphicsArrays[evsList_] := Show[GraphicsArray[#]]& /@ 
Map[ListDensityPlot[Partition[#, L - 1], Mesh -> False, 
       PlotRange -> All, DisplayFunction -> Identity,
       FrameTicks -> None]&, Transpose[evsList], {-2}]

Finally, we set some option values for the Arnoldi iterations (a smaller than the default tolerance is enough for visualization purposes). We use the Shift suboption to obtain eigenfunctions to different elements of the spectrum.

𝒪[λ___] := Method -> {"Arnoldi", BasisSize -> 40, 
              MaxIterations -> 10^4, Tolerance -> 10^-5,
              If[{λ} =!= {}, Shift -> λ, Sequence @@ {}]}

Here are the lowest states for the three spring networks. On the background of the 𝓀=1 springs, we see modulations due to the different spring stiffnesses along the Hilbert curve.

lowestStates = Reverse[Eigenvectors[ℳ[#], -4, 𝒪[]]& /@ 𝓀List];
makeGraphicsArrays[lowestStates];

The highest states oscillate as frequently as possible.

highestStates = Eigenvectors[ℳ[#], 4, 𝒪[]]& /@ 𝓀List;
makeGraphicsArrays[highestStates];

The eigenfunctions corresponding to central eigenvalues show a complicated behavior. The imprint of the Hilbert curve springs is clearly visible.

Do[Print["α = ", α];
middleStates = Eigenvectors[ℳ[#], 3, 𝒪[#2]]& @@@ Transpose[
                  {𝓀List, (#1 + α (#2 - #1))& @@@ (εRange /@ 𝓀List)}];
makeGraphicsArrays[middleStates], {α, 1/4, 3/4, 1/4}]

We end with two random realizations where each individual spring along the Hilbert curve has a random stiffness.

SeedRandom[1];
{ℳR[1], ℳR[2]} = (* realize random spring constant *)
Table[Block[{𝓀},  𝓀[k_] := 𝓀[k] = 10^Random[Real, {-1, 1}]; M[𝓀]], {2}];

(* lowest and highest eigenvalues *)
(εRange[#] = 
Reverse[Eigenvalues[ℳR[#], 2, 
  Method -> {"Arnoldi", Criteria -> "BothEnds",  BasisSize -> 20,
             MaxIterations -> 10^4}]])& /@ {1, 2}

The lowest states are not changed globally, but the higher states are become quickly localized due to the random spring stiffnesses.

(* lowest states *)
makeGraphicsArrays[Reverse @ Eigenvectors[ℳR[#], -2, 𝒪[]]& /@ {1, 2}]

(* intermediate states *)
makeGraphicsArrays[Reverse @ Eigenvectors[ℳR[#], +4, 𝒪[4]]& /@ {1, 2}]

(* highest states *)
makeGraphicsArrays[Reverse @ Eigenvectors[ℳR[#], +4, 𝒪[8]]& /@ {1, 2}]

We start with two function definitions for normalizing a vector and calculating the distance between two points.

𝓃 = #/Sqrt[#.#]&; ℓ = Sqrt[(#2 - #1).(#2 - #1)]&;

The vertices of a hypercube in dim dimensions.

(* the vertices of a dimD unit cube *)
vertices[dim_] := vertices[dim] = 
Flatten[Outer[List, Sequence @@ Table[{-1, 1}/2, {dim}]], dim - 1]

The (2^dum) edges of a hypercube in dim dimensions. We will use them later for visualizations.

(* the edge vertices of a dimD unit cube *)
edges[dim_] := edges[dim] = 
(* all n-tuples with one differing element *)
Map[Position[vertices[dim], #][[1, 1]]&, Union[Sort /@ Flatten[
        Table[Table[{vertices[dim][[j]], 
                     MapAt[-#&, vertices[dim][[j]], k]}, {k, dim}],
                      {j, Length[vertices[dim]]}], 1]], {2}]

And these are the dim (dim-1)(2^(dim-3))  2D faces of a hypercube in dim dimensions. We will also use them for visualizations and for minimization.

edgeToFaces[edge_] := 
(* sweep out a face by moving an edge *)
Module[{posis = Flatten[Position[Equal @@@ Transpose[edge], True]]},
       Table[Join[edge, MapAt[-#&, #, posis[[k]]]& /@ 
                  Reverse[edge]], {k, Length[posis]}]]

(* the face vertices of a dimD unit cube *)
faces[dim_] := faces[dim] = 
(* all n-tuples with two differing elements *)
Map[Position[vertices[dim], #][[1, 1]]&, #[[1, -1]]& /@ 
(* sweep out all faces and keep one of each *)
Split[Sort[{Sort[#], #}& /@ Flatten[edgeToFaces /@ 
               Map[vertices[dim][[#]]&, edges[dim], {-1}], 1]],
               #1[[1]] === #2[[1]]&], {2}]

Next we carry out the straightforward implementation of the objective function representing the cumulative relative deviation of all pairwise vertex distances. The two arguments of the function relativeVertexPositionErrorSum are two vectors in (ℝ^dim) that span a 2D hyperplane.

relativeVertexPositionErrorSum[{d1_?(VectorQ[#, NumberQ]&), d2_}] :=
Module[{dim = Length[d1], 𝒹1, 𝒹2, verticesProjected},
 (* two orthogonal vectors *)
 𝒹1 = 𝓃[d1]; 𝒹2 = 𝓃[d2 - 𝒹1.d2 𝒹1]; 
 (* the projected vertices *)
 verticesProjected = {𝒹1.#, 𝒹2.#}& /@ vertices[dim]; 
 (* sum of squares of edge length errors *)
 Sum[Abs[ℓ[verticesProjected[[i]], verticesProjected[[j]]]/
         ℓ[vertices[dim][[i]], vertices[dim][[j]]] - 1]^2, 
           {i, 2^dim}, {j, i - 1}]]

The function projectedEdgesGraphics shows the projected edges.

projectedEdgesGraphics[{d1_?VectorQ, d2_?VectorQ}, opts___] :=
Module[{dim = Length[d1], 𝒹1, 𝒹2, verticesProjected},
 (* two orthogonal vectors *)
 𝒹1 = 𝓃[d1]; 𝒹2 = 𝓃[d2 - 𝒹1.d2 𝒹1];
 (* the projected vertices *)
 verticesProjected = {𝒹1.#, 𝒹2.#}& /@ vertices[dim]; 
 (* show projected vertices and edges *)
 Graphics[{{Hue[0], Thickness[0.001], 
            Line /@ Map[verticesProjected[[#]]&, edges[dim], {-1}]},
           {GrayLevel[0], PointSize[0.02], 
            Point /@ verticesProjected}},
      opts, PlotRange -> All, AspectRatio -> Automatic]]
      
projectedEdgesGraphics[{min_?NumericQ, vals_}] := 
projectedEdgesGraphics[Partition[Last /@ vals, 
                                 Length[vals]/2], PlotLabel -> min]

Here are the results, the number of function evaluations, and the timings for the four methods "SimulatedAnnealing", "RandomSearch", "DifferentialEvolution", and "NelderMead" shown. Modulo rotations, the four projections are identical. And the minima all agree to many digits. To see the progress in finding the minimum, we define an auxiliary function relativeVertexPositionErrorSumL that keeps a list of the function values obtained.

relativeVertexPositionErrorSumL[
             {d1_?(VectorQ[#, NumberQ]&), d2_}, L_] :=
With[{res = relativeVertexPositionErrorSum[{d1, d2}]},
     L = {L, res}; res]

(* show graphic and return timings and function evaluations *)
(Show[GraphicsArray[#[[2, 2]]& /@ #]]; 
 {#[[2, 1]], #[[2, 3]], #[[1]]}& /@ #)&[
Timing[{#, ℒ[#] = {}; projectedEdgesGraphics[
 (* find optimal projection hyperplane parameters *)
 NMinimize[relativeVertexPositionErrorSumL[
                    {{d1x, d1y, d1z}, {d2x, d2y, d2z}}, 
           (* bag for values *) Unevaluated[ℒ[#]]],
                     {d1x, d1y, d1z, d2x, d2y, d2z},
           PrecisionGoal -> 2, Method -> #]], 
           (* function evaluations *) Length[Flatten[ℒ[#]]]}]& /@ 
           (* the four methods *)
            {"SimulatedAnnealing", "RandomSearch",
             "DifferentialEvolution", "NelderMead"}]

Displaying the calculated the objective function values depending on the iteration number shows that "SimulatedAnnealing" and "NelderMead" find a good minimum after less than 200 search steps. The "RandomSearch" plot shows many locations for a good projection.

convergenceListPlot[l_, opts___] := 
Module[{ℓ = Flatten[l], λ = Last[l]}, 
    Block[{$DisplayFunction = Identity}, 
       (* logarithm of absolute error *)
       ListPlot[DeleteCases[MapIndexed[{#2[[1]], #1}&, 
                 Log[10, Abs[(# - λ)& /@ ℓ]]],
                 {_, Indeterminate}], PlotRange -> All]]];

Show[GraphicsArray[#]]& /@ 
Partition[convergenceListPlot[ℒ[#], PlotLabel -> #]& /@ 
           {"SimulatedAnnealing", "RandomSearch",
            "DifferentialEvolution", "NelderMead"}, 2];

The last result suggests the use of "SimulatedAnnealing" and/or "NelderMead" for higher dimensions in the following. To speed up the calculations, we implement a compiled version of relativeVertexPositionErrorSum. We also allow for projections into 3D, 4D, … hyperspaces.

(* the main compiled function *)
cf[dim_] := cf[dim] = 
Compile[{{ds, _Real, 2}},
Module[{𝒹𝓈 = ds, λ = Length[ds], verticesProjected, 𝒱s = #},
 (* make orthogonal vectors *)
 Do[𝒹𝓈[[k]] = #/Sqrt[#.#]&[ds[[k]] - Sum[𝒹𝓈[[j]] 𝒹𝓈[[j]].ds[[k]], 
    {j, λ - 1}]], {k, λ}];
 (* the projected vertices *)
 verticesProjected = Table[𝒱s[[k]].#& /@ 𝒹𝓈, {k, Length[𝒱s]}];
 (* sum of squares of edge length errors *)
 Sum[Sum[Abs[Sqrt[#.#]&[verticesProjected[[i]] - verticesProjected[[j]]]/
             Sqrt[#.#]&[𝒱s[[i]] - 𝒱s[[j]]] - 1]^2,
        {j, i - 1}], {i, Length[𝒱s]}]]]&[vertices[dim]];
        
(* interface function to the compiled function *)
relativeVertexPositionErrorSumCF[
        {d1_?(VectorQ[#, NumberQ]&), d2__}] := cf[Length[d1]][{d1, d2}];

Here are these two methods applied to hypercubes of dimensions four, five, and six. Again, the two methods agree quite well with one another.

Do[Show[GraphicsArray[#]]&[projectedEdgesGraphics[
     NMinimize[{relativeVertexPositionErrorSumCF[
                        Table[d[j][k], {j, 2}, {k, dim}]]},
               Flatten[Table[d[j][k], {j, 2}, {k, dim}]],
               PrecisionGoal -> 2, Method -> #]]& /@ 
               {"SimulatedAnnealing", "NelderMead"}], {dim, 4, 6}]

For comparison we show projections resulring from determining principal components.

(* make a square k×k array of graphics *)
toSquareArray[l_, k_] := 
Module[{mod = Mod[Length[l], k]}, 
If[mod === 0, Partition[l, k],
   Append[Partition[l, k], Join[Take[l, -mod], 
          Table[Graphics[{}], {k - mod}]]]]]

Function[d, (* print dimension *)
 StylePrint["dim = " <> ToString[d], "PrintText"];
 (* project onto principal components *)
 Module[{svd = SingularValueDecomposition[Transpose@N[vertices[d]]][[1]]},
  Show[GraphicsArray[#]]& /@
  toSquareArray[Flatten[Table[projectedEdgesGraphics[{svd[[i]], svd[[j]]}],
                       {i, 2, d}, {j, i + 1, d}]], 6]]] /@ {6, 7}

Next we project into 3D and show the 2D faces of the resulting 3D objects as holed planes. Here are some function to show the projected 2D faces of the hypercubes.

(* quadrilateral spanned by p1, p2, p3, p4 *)
makeHoled3DPolygon[{p1_, p2_, p3_, p4_}, pp_, f_] := 
Module[{points = Table[p1 + i j/pp^2 (p1 + p3 - p2 - p4) +
                       i/pp (p2 - p1) + j/pp (p4 - p1), 
                {i, 0, pp}, {j, 0, pp}], polys},
 polys = Table[Polygon[{points[[i, j]], points[[i + 1, j]], 
                        points[[i + 1, j + 1]], points[[i, j + 1]]}], 
               {i, pp}, {j, pp}];
 makeHole[#, f]& /@ Flatten[polys]]

makeHole[Polygon[l_], f_] := (* cut a hole in a polygon *)
Module[{mp = Plus @@ l/Length[l], L}, L = (mp + f(# - mp))& /@ l;
       {MapThread[Polygon[Join[#1, Reverse[#2]]]&, 
                  Partition[Append[#, First[#]], 2, 1]& /@ {l, L} ]}]

projectedFacesGraphics3D[{d1_, d2_, d3_}, opts___] :=
Module[{dim = Length[d1], 𝒹1, 𝒹2, 𝒹3, verticesProjected},
 (* three orthogonal vectors *)
 𝒹1 = 𝓃[d1]; 𝒹2 = 𝓃[d2 - 𝒹1.d2 𝒹1]; 𝒹3 = 𝓃[d3 - 𝒹1.d3 𝒹1 - 𝒹2.d3 𝒹2]; 
 (* the projected vertices *)
 verticesProjected = {𝒹1.#, 𝒹2.#, 𝒹3.#}& /@ vertices[dim]; 
Graphics3D[{{SurfaceColor[Hue[Random[]], Hue[Random[]], 3 Random[]], 
             EdgeForm[], makeHoled3DPolygon[#, 6, 0.82]}& /@ 
             Map[verticesProjected[[#]]&, faces[dim], {-1}],
            {GrayLevel[0], PointSize[0.02], Point /@ verticesProjected}},
      opts, PlotRange -> All, BoxRatios -> Automatic]]
      
projectedFacesGraphics3D[{min_?NumericQ, vals_}] := 
projectedFacesGraphics3D[Partition[Last /@ vals, Length[vals]/3]]

These are the resulting 3D projections. We use only the "NelderMead" method.

Show[GraphicsArray[
    Table[projectedFacesGraphics3D[
      NMinimize[relativeVertexPositionErrorSumCF[
                        Table[d[j][k], {j, 3}, {k, dim}]],
             Flatten[Table[d[j][k], {j, 3}, {k, dim}]],
             PrecisionGoal -> 2, Method -> "NelderMead"]], {dim, 4, 5}]]]

We end with minimizing the area differences of all 2D faces in 2D projections. The function relativeErrorSumArea calculates the cumulative relative face area deviation.

(* the main compiled function *)
cfArea[dim_] := cfArea[dim] = 
Compile[{{d1, _Real, 1}, {d2, _Real, 1}},
Module[{𝒹1, 𝒹2, verticesProjected, p1, p2, p3, p4,
        a, b, c, 𝒜1, 𝒜2, area = 0., 𝒱s = #1, ℱs = #2},
 (* make orthogonal vectors *)
 𝒹1 = #/Sqrt[#.#]&[d1]; 𝒹2 = #/Sqrt[#.#]&[d2 - 𝒹1.d2 𝒹1]; 
 (* the projected vertices *)
 verticesProjected = {𝒹1.#, 𝒹2.#}& /@ 𝒱s; 
 (* sum of squares of face area errors *)
 Sum[{p1, p2, p3, p4} = Map[verticesProjected[[#]]&, ℱs[[i]], {-1}];
     (* split quadrilateral into two triangles *)
     {a, b, c} = Sqrt[#.#& /@ {p1 - p2, p2 - p3, p3 - p1}]; 
     𝒜1 = Sqrt[(-a + b + c) (a + b - c) (a - b + c) (a + b + c)];
     {a, b, c} = Sqrt[#.#& /@ {p3 - p4, p4 - p1, p1 - p3}];
     𝒜2 = Sqrt[(-a + b + c) (a + b - c) (a - b + c) (a + b + c)]; 
     area = (𝒜1 + 𝒜2)/4;                         
     (1/area - 1)^2, {i, Length[ℱs]}]]]&[vertices[dim], faces[dim]]
     
(* interface function to the compiled function *)
relative2DFaceAreaErrorSumCF[
        {d1_?(VectorQ[#, NumberQ]&), d2__}] := cfArea[Length[d1]][d1, d2];

This time, we obtain very symmetric projections. Again, the minima and the resulting projections agree for the two methods.

Do[Show[GraphicsArray[projectedEdgesGraphics[
 NMinimize[{relative2DFaceAreaErrorSumCF[Table[d[j][k], {j, 2}, {k, dim}]]},
           Flatten[Table[d[j][k], {j, 2}, {k, dim}]],
           PrecisionGoal -> 3, Method -> #]]& /@ 
                        {"SimulatedAnnealing", "NelderMead"}]], 
    {dim, 3, 6}]

Let the edges of an aperiodic Penrose tiling made from darts and kites be wires with finite resistances. By selecting outer and inner vertices as the current source and drains, calculate and visualize the potential and current distribution through the edge network. Use identical and random resistance values along the edges.

Off[General::"spell"]; Off[General::"spell1"];

(* the inflation rule *)
kiteDartRule = {p_, kd:("kite" | "dart")} :>
Module[{𝒻, a, b, c, d, e, f, g, h, i}, {a, b, c, d} = p;
       𝒻[a_, b_] = (a + GoldenRatio b)/(1 + GoldenRatio);
       (* construct new dart and kites *)
       Sequence @@ If[kd === "kite",
          e = 𝒻[a, c]; f = 𝒻[b, a]; g = 𝒻[d, a];
          h = a + c - d; i = a + c - b;
          {{{b, c, e, f}, "kite"}, {{d, g, e, c}, "kite"},
           {{f, e, a, h}, "dart"}, {{g, i, a, e}, "dart"}},
          (* last tile was a dart *) e = 𝒻[c, b]; f = 𝒻[c, d];
          g = b + c - a; h = d + c - a;
          {{{c, f, a, e}, "kite"}, {{e, a, b, g}, "dart"},
           {{f, h, d, a}, "dart"}}]];

(* start kite *)
pTiling[0] = {{{{0, 0}, GoldenRatio {Cos[36°], Sin[36°]},
               GoldenRatio {1, 0}, GoldenRatio {Cos[36°], -Sin[36°]}},
             "kite"}} // N[#, 30]&;
             
(* recursively apply kiteDartRule *)
pTiling[i_] := pTiling[i] = #[[1, 2]]& /@ 
 Split[Sort[{N[#[[1]]], #}& /@ (pTiling[i - 1] /. kiteDartRule)], 
            (* identical tiles? *) #1[[1]] === #2[[1]]&]

The functions edges and vertices give the edges and vertices after the oth iteration.

edges[o_] := edges[o] = Union[Sort /@ 
     Flatten[Partition[Append[#, First[#]], 2, 1]& /@ 
                         N[First /@ pTiling[o]], 1]];

vertices[o_] := vertices[o] = Union[Level[edges[o], {-2}]];

For indexing the voltages and currents, we prefer to use integers instead of approximate coordinates. So, we define the two function vertexNumber and vertexCoordinates that convert the explicit coordinates to integer numbers, back and forth.

makeVertexDefinitions[o_] :=
Do[(* cache coordinates and number of the vertices *)
   vertexNumber[o][vertices[o][[k]]] = k;
   vertexCoordinates[o][k] = vertices[o][[k]],
   {k, Length[vertices[o]]}]

allNumberedEdges[o_] := allNumberedEdges[o] =
           Map[vertexNumber[o], edges[o], {-2}];

Here are the counts of the vertices and edges for the first eight iterations. The eight iteration leads to more than 20000 equations for the current and voltages (edges and vertices).

Table[makeVertexDefinitions[o];
      {o, Length[edges[o]], Length[vertices[o]]}, {o, 8}] // 
 TableForm[#, TableHeadings -> {None, 
  StyleForm[#, FontWeight -> "Bold"]& /@ {"", "edges", "vertices"}}]&

Now we start with the first actual constellation. We use the 8th iteration and place the current source and drains at the left lower and right upper vertices.

order = 8;
{zeroVVertices[order], oneVVertices[order]} = List /@
vertexNumber[order] /@ {#[[1]], #[[-1]]}&[Sort[vertices[order]]]

Here is a sketch of this configuration.

Show[Graphics[{{Thickness[0.001], (* all edges *)
               {GrayLevel[1/2], Line[#]}& /@ edges[order]},
               (* source and drain vertices *)
               {PointSize[0.04], Hue[0], Point /@ 
                vertexCoordinates[order] /@ zeroVVertices[order]},
               {PointSize[0.04], Hue[0.76], Point /@ 
                vertexCoordinates[order] /@ oneVVertices[order]}}],
                  AspectRatio -> Automatic]

To write down the current conservation law at all vertices (the source and drain vertices are held at a fixed potential), we construct list of all edges that meet at a given vertex.

edgesAtVertices[o_] := edgesAtVertices[o] =
{#[[1, 1]], Last /@ #}& /@
Split[Sort[Flatten[{{#[[1]], #}, {#[[2]], #}}& /@ 
           allNumberedEdges[o], 1]], #1[[1]] === #2[[1]]&];

Now, we write all equations governing the current flow through the edges of the tiling. Along all edges, we have i[a, b] = (u[b] - u[a])/R[a, b] where i[a, b] is the current from vertex a to vertex b. And with all edges oriented, we can write down the current conservation equations for all nonsource and nondrain vertices. For a given network specified by the edges and the connectivity, the function makeUIEquations returns the equations for the voltage values at the vertices and for the currents through the edges. Without loss of generality (because we assume a linear relation between current and voltage), we set the source potential to zero and the drain potential to one.

makeUIEquations[numberedEdges_, edgesAtVertices_,
                {zeroVVertices_, oneVVertices_}, R_, {u_, i_}] :=
Flatten @ {
(* voltage drops across a resistor *)
i[#1, #2] == (u[#2] - u[#1])/R[#1, #2]& @@@ 
          numberedEdges,
(* current conservation at a vertex *)
Function[{vertex, edgeList}, 0 == (* all directed currents *)
 Plus @@ ((If[# === vertex, 1, -1] i[##])& @@@ edgeList)] @@@ 
    DeleteCases[edgesAtVertices, 
                (* no current conservation for 
                   source and drain vertices *)
                Alternatives @@ ({#, _}& /@ 
                Flatten[{zeroVVertices, oneVVertices}])]} /.
    (* source and drain voltage values *)
    Dispatch[Join[(u[#] -> 0)& /@ zeroVVertices, 
                  (u[#] -> 1)& /@ oneVVertices]]

We start by using identical resistance (value 1) for all edges. Here are the 20262 equations in 20262 variables.

eqs = makeUIEquations[allNumberedEdges[order], edgesAtVertices[order],
                      {zeroVVertices[order], oneVVertices[order]}, 
                      1&, {u, i}];

iuVariables[eqs_] := Cases[eqs, _u | _i, Infinity] // Union

vars = iuVariables[eqs];
Length /@ {eqs, vars}

We solve the equations with a direct call to Solve. For an efficient solution, we numericalize the equations.

(* avoid numericalizations of the variable numbering *)
SetAttributes[{u, i}, NHoldAll];
sol1 = Solve[N @ eqs, vars];

To visualize the result sol1, we implement the two functions voltagePlot and currentPlot. The first plot draws the vertices colored according to the voltage. Blue is low and red is high. The second is a plot of the magnitudes of the current along the edges. Again blue is lowest and red is highest.

voltagePlot[o_, sol_, u_] :=
Module[{λ = Cases[sol, _u, Infinity] // Union // Length, us, cs},
(* different voltage values *)
us = Union[Rationalize[SetPrecision[#, 6], 0]& @
     Sort[Last /@ Cases[sol, HoldPattern[_u -> _], Infinity]]];
(* make groups of voltage values and color function *)
cs = Round[Length[us]/10]; ipo = Interpolation[
MapIndexed[{#1, #2[[1]] - 1}&, Flatten[{0, 
    #[[Round[Length[#]/2]]]& /@ (* homogeneous coloring *)
                Partition[us, Round[Length[us]/cs]], 1}]]];
(* make graphics *)
Show[Graphics[{(* scale points *) PointSize[1/Sqrt[λ]/2], 
({Hue[0.78 (1 -  Abs[ipo[u[#]]/cs])], 
Point[vertexCoordinates[o][#]]}& /@  
      Range[Length[vertices[o]]]) /. Dispatch[sol[[1]]] /.
    (* the drain and source vertices *)
    Dispatch[Join[(u[#] -> 0)& /@ zeroVVertices[o], 
                  (u[#] -> 1)& /@ oneVVertices[o]]]}],
      AspectRatio -> Automatic]];

currentPlot[o_, sol_, i_] :=
Module[{λ = Length[Union[Cases[sol, _i, Infinity]]], is, cs},
(* different current values *)
is = Union[Rationalize[SetPrecision[#, 6], 0]& @
     (is0 = Sort[Abs[Last /@ Cases[sol, HoldPattern[_i -> _],
                 Infinity]]])];
(* make groups of voltage values and color function *)
cs = Round[Length[is]/20]; ipo = Interpolation[
MapIndexed[{#1, #2[[1]] - 1}&, Flatten[{is0[[1]], 
#[[Round[Length[#]/2]]]& /@ 
 Partition[is, Round[Length[is]/cs]], is0[[-1]]}]]];
(* make graphics *)
Show[Graphics[{(* scale line thickness *) Thickness[1/λ], 
({Hue[0.78 (1 - Abs[ipo[Abs[i @@ #]]]/cs)], 
  Line[vertexCoordinates[o] /@ #]}& /@ allNumberedEdges[o]) /. 
                                  Dispatch[sol[[1]]]}],
      AspectRatio -> Automatic]]

We unite the two last types of plots in the function voltageCurrentPlot.

(* show voltages and currents together *)
voltageCurrentPlot[o_, sol_] := 
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {voltagePlot[o, sol, u], currentPlot[o, sol, i]}]]];

Here are the resulting voltage and current distribution for our first example. Coarse grained, the voltage is an increasing function from the left lower to the right upper corner. (The voltages can be considered as a discrete approximation to the Laplace equation of the electric potential. And, as a harmonic function it cannot have a local minimum or maximum.) The currents flow mainly along the diagonal. The occasional blue edges along the diagonal area are due to nearly or exactly identical voltages at their endpoints.

voltageCurrentPlot[order, sol1];

We repeat the voltage and current calculation for the last network with random resistances. We start with a uniform distribution of the resistance values. Now, the current distribution looks less regular.

SeedRandom[1];
(* form equations *)
eqs = makeUIEquations[allNumberedEdges[order], edgesAtVertices[order],
                     {zeroVVertices[order], oneVVertices[order]}, 
                     Random[]&, {u, i}];
(* visualize solutions *)                     
voltageCurrentPlot[order, sol2 = Solve[N @ eqs, vars]]

Next, we use a more stretched out distribution with resistance values spanning eight orders of magnitude. The current from the left lower vertex to the right upper vertex occurs now along more pronounced paths instead in a more uniform manner along the diagonal. The voltage distribution looks nearly identical to the last one.

SeedRandom[2];
(* form equations *)
eqs = makeUIEquations[allNumberedEdges[order], edgesAtVertices[order],
                     {zeroVVertices[order], oneVVertices[order]}, 
                     10^Random[Real, {-4, 4}]&, {u, i}];
(* visualize solutions *)                      
voltageCurrentPlot[order, sol3 = Solve[N @ eqs, vars]]

At this point, let us check the quality of the solutions. The maximal residual is about 2×(10^(-11)).

Max[Abs[(Subtract @@@ eqs) /. Dispatch[sol3[[1]]]]]

We could now continue by making the resistance of some edges infinite by using If[Random[] < p, 1, Infinity], effectively reducing the number of potential current paths from the source to the drain, but leave this to the reader.

We continue with a configuration where we make all outer vertices are current drains and the central vertex is the source. The functions outerVertices and centralVertex calculate these vertices for a given iteration order o.

outerVertices[o_] := outerVertices[o] = 
vertexNumber[order] /@ Union[Flatten[
Select[Split[Sort[Sort /@ Flatten[
              Partition[Append[#, First[#]], 2, 1]& /@ 
                       N[First /@ pTiling[o]], 1]]],
       Length[#] == 1&], 2]];

centralVertex[o_] := centralVertex[o] =
Module[{mp = Plus @@ vertices[o]/Length[vertices[o]], distances},
       distances = Sqrt[#.#]&[mp - #]& /@ vertices[o];
       vertexNumber[o] @ vertices[o][[
              Position[distances, Min[distances]][[1, 1]]]]]

(* the outer and inner vertices for the current iteration order *)
{zeroVVertices[order], oneVVertices[order]} = 
{outerVertices[order], {centralVertex[order]}};

Here are the resulting voltage and current distributions for all edges having identical resistance values.

(* form equations *)
eqs = makeUIEquations[allNumberedEdges[order], edgesAtVertices[order],
                     {outerVertices[order], {centralVertex[order]}}, 
                     1&, {u, i}];

vars = iuVariables[eqs];
(* visualize solutions *) 
voltageCurrentPlot[order, sol4 = Solve[N @ eqs, vars]]

Using again random resistance values along the edges shows a network of current paths. The voltage distribution looks similar but has some different details.

(* use two different resistance values *)
SeedRandom[3];
(* form equations *)
eqs = makeUIEquations[allNumberedEdges[order], edgesAtVertices[order],
                     {outerVertices[order], {centralVertex[order]}}, 
                      If[Random[] < 0.1, 1, 10^6]&, {u, i}];
(* visualize solutions *) 
voltageCurrentPlot[order, sol5 = Solve[N @ eqs, vars]]

(* use continuous distribution of resistance values *)
SeedRandom[4];
(* form equations *)
eqs = makeUIEquations[allNumberedEdges[order], edgesAtVertices[order],
                     {outerVertices[order], {centralVertex[order]}}, 
                      10^Random[Real, {-4, 4}]&, {u, i}];
(* visualize solutions *) 
voltageCurrentPlot[order, sol6 = Solve[N @ eqs, vars]]

We end with a plot of the currents on a logarithmic scale.

Show[
Graphics[{Hue[#1], PointSize[0.002],
  MapIndexed[If[#1 == 0., {}, Point[{#2[[1]], Log[10, #1]}]]&,
      Sort[Abs[Last /@ Cases[#2, HoldPattern[_i -> _], 
     Infinity]]]]}]& @@@
   {{0, sol1}, {0.1, sol2}, {0.2, sol3}, {0.33, sol4}, 
    {0.44, sol5}, {0.78, sol6}},
Frame -> True, PlotRange -> {-15, 0}]

For some theoretical results about the current distribution of random resistor networks, see [✶], [✶], [✶], [✶], [✶]. For the resistance of a Sierpinski carpet, see [✶].

Collect various “interesting” 1+1 and 1+2 PDEs and PDE systems from the literature (or self-constructed ones) and visualize the qualitative shape of their solutions.

We start with a simple system of two coupled equations depending from the two independent variables t and g [✶]. Derivative terms appear only for the variable t. This means, this system is basically a parametrized coupled system of ordinary differential equations. The solution shows a spiral-like behavior.

Module[{d = 0.4,  ppL = 5000, ndsol, x, y, t, g},
ndsol = (* pseudo PDE; no derivatives with respect to g *)
NDSolve[{D[x[t, g], t] == -1/2 Sinh[2 Pi y[t, g]]/
                               (Cosh[2 Pi y[t, g]] - Cos[2 Pi x[t, g]] + d^2),
         D[y[t, g], t] == +1/2 Sin [2 Pi x[t, g]]/
                               (Cosh[2 Pi y[t, g]] - Cos[2 Pi x[t, g]] + d^2),
         x[0, g] == -1/2 + g, y[0, g] == 0}, 
        {x, y}, {t, -1, 1}, {g, 0, 1},
         Method -> {"MethodOfLines", "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> 4, 
                    "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* 3D plot of {y[t, g], y[t, g], t} *)
ParametricPlot3D[Evaluate[{x[t, g], y[t, g], t} /. ndsol[[1]]],
                 {g, 0, 1}, {t, -1/2, 1}, PlotRange -> All,
                 PlotPoints -> {240, 60}, Axes -> False]]

The following 1+2 PDE system generates interestingly structured labyrinth-like solutions [✶]. It is used to model brain growth. The model has four parameters γ, β, ν, and δ.

eqs1[{γ_, β_, ν_, δ_}] := 
 {D[ψ[t, x, y], t] == γ (η[t, x, y] - ψ[t, x, y]^3/3 + ψ[t, x, y]) + 
                      D[ψ[t, x, y], x, x] + D[ψ[t, x, y], y, y],
  D[η[t, x, y], t] == -1/γ (ψ[t, x, y] + ν + β η[t, x, y]) + 
                      δ (D[η[t, x, y], x, x] + D[η[t, x, y], y, y])}

The function ric implements random periodic initial conditions.

ric[n_, m_, seed_][x_?NumberQ, y_?NumberQ] := (SeedRandom[seed]; 
Sum[Random[Real, {-1, 1}] Cos[Random[Integer, {1, m}] 2Pi x + 2 Pi Random[]]*
                          Cos[Random[Integer, {1, m}] 2Pi y + 2 Pi Random[]],
    {j, 0, n}])

The function solveAndMakeGraphics solves the 2 PDEs and generates 3D plots of the two components.

solveAndMakeGraphics1[{γ_, β_, ν_, δ_}, {{nψ_, mψ_, seedψ_}, {nη_, mη_, seedη_}},
                     L_, T_, ppL_, do_, ndsolveOpts___, graphicsArrayOpts___] := 
Module[{ndsol},
(* solve PDE system *)
ndsol = NDSolve[Flatten[{eqs1[{γ, β, ν, δ}], 
         ψ[0, x, y] == ric[nψ, mψ, seedψ][x/L, y/L], 
         η[0, x, y] == ric[nη, mη, seedη][x/L, y/L],
         ψ[t, -L, y] == ψ[t, +L, y], ψ[t, x, -L] == ψ[t, x, +L],
         η[t, -L, y] == η[t, +L, y], η[t, x, -L] == η[t, x, +L]}],
         {ψ, η}, {t, 0, T}, {x, -L, L}, {y, -L, L}, 
         Sequence @@ {ndsolveOpts}, MaxSteps -> 10^5,
         Method -> {"MethodOfLines", "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                    "MaxPoints" -> {ppL, ppL}, "MinPoints" -> {ppL, ppL}}}];
(* make graphic of ψ and η *)
Show[GraphicsArray[
Plot3D[Evaluate[ndsol[[1, #, 2]][T, x, y]], {x, -L, L}, {y, -L, L}, 
       PlotRange -> All, PlotPoints -> 2 ppL, Mesh -> False,
       DisplayFunction -> Identity, Axes -> False,
       Axes -> {False, False, True}]& /@ {1, 2}], 
       Sequence @@ {graphicsArrayOpts}, PlotLabel -> do]]

Here are two examples of solutions. Because of the periodic boundary conditions, we use the Pseudospectral option setting.

Table[solveAndMakeGraphics1[{4.9331, 2.9971, 0.014014, 1.62681}, 
                           {{20, 4, k}, {20, 4, k + 1}},
                            100, 6, 120, Pseudospectral,
                           {PrecisionGoal -> 8, AccuracyGoal -> 8}], {k, 0, 1}]

The second example is a 1+1 PDE that is used for describing surface evolution due to step bunching [✶], [✶], [✶].

eq2[γ_] := D[h[t, z], t] == -D[h[t, z], {z, 2}] + γ D[h[t, z], {z, 3}] -
           D[h[t, z], {z, 4}] + D[D[h[t, z], z]^2, {z, 2}]

The function solveAndMakeGraphics solves the differential equation with the parameter value γ and the initial conditions ic. We use periodic boundary conditions.

solveAndMakeGraphics2[γ_, ic_, T_, pp_, do_] := 
Module[{ndsol, T1},
(* solve PDE *)
ndsol = NDSolve[{eq2[γ], h[0, z] == ic[z], h[t, -Pi] == h[t, Pi]},
                 h[t, z], {t, 0, T}, {z, -Pi, Pi}, 
                 PrecisionGoal -> 3, AccuracyGoal -> 3, 
                 MaxSteps -> 10^5, Method -> StiffnessSwitching,
 Method -> {"MethodOfLines", "SpatialDiscretization" -> {"TensorProductGrid",
            "DifferenceOrder"-> do, "MinPoints" -> pp, "MaxPoints" -> pp}}];
(* visualize solution *)            
Show[Graphics3D[      
T1 = ndsol[[1, 1, 2, 0, 1, 1, 2]];  
Plot3D[Evaluate[{Abs[h[t, z]] /. ndsol[[1]],
                 Hue[(Arg[h[t, z]] + Pi)/(2Pi) /. ndsol[[1]]]}], 
                 {z, -Pi, Pi}, {t, 0, 0.9 T1}, 
                PlotPoints -> 2 pp, Mesh -> False, PlotRange -> All, 
                DisplayFunction -> Identity]] /.
        {h_Hue :> SurfaceColor[h, h, 2.4], p_Polygon :> {EdgeForm[], p}},
        DisplayFunction -> $DisplayFunction, Lighting -> True]]

For real values of γ, the solutions smooth the original oscillations. Here are two examples.

SeedRandom[111];
Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, 
Table[solveAndMakeGraphics2[0.3, Function[z, Evaluate[
 (* random periodic real initial condition *)
 Sum[Random[Real, {-1, 1}] Cos[k z + 2 Pi Random[]], {k, 6}]]], 
     0.01, 100, "Pseudospectral"], {2}]]]]

For complex values of γ, the solutions frequently also smooth the original oscillations. But sometimes complicated patterns and singularities form. Here are two examples.

(* suppress error messages *) Off[NDSolve::eerr];
Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, 
Function[seed, SeedRandom[seed]; 
solveAndMakeGraphics2[Exp[I 2Pi Random[]], Function[z, Evaluate[
 Sum[Random[Complex, {-1 - I, 1 + I}] Cos[k z + 2 Pi Random[]], 
     {k, 0, Random[Integer, {3, 6}]}]]], 0.025, 200, 
     "Pseudospectral"]] /@ {2165915158297496362, 95157975033230510106}]]]

For exactly integrable solutions with a variety of different solutions, see [✶], [✶].

We continue with a variant of the Swift–Hohenberg equation [✶]. It is a one-parameter 1+1 PDE.

eq3[η_] :=  D[Ψ[x, t], t] + η Ψ[x, t] + D[Ψ[x, t], {x, 2}] + 
            D[Ψ[x, t], {x, 4}] +  2 Ψ[x, t] D[Ψ[x, t], x] == 0

Again, the function solveAndMakeGraphics3 solves the PDE and visualizes the solution as a contour plot. The last argument specifies the function to be displayed and the contour values.

solveAndMakeGraphics3[η_, L_, T_, ppL_, do_, {F_, cls_}] := 
Module[{ndsol},
(* solve PDE *)
ndsol = NDSolve[{eq3[η], Ψ[x, 0] == Sum[Random[Real, {-1, 1}] Sin[k x/L Pi], {k, 16}],
                     Ψ[0, t] == Ψ[L, t]},
         {Ψ}, {x, 0, L}, {t, 0, T}, MaxSteps -> 10^5,
         PrecisionGoal -> 3, AccuracyGoal -> 3, 
         Method -> {"MethodOfLines", Method -> StiffnessSwitching,
                    "SpatialDiscretization" -> 
                     {"TensorProductGrid", "DifferenceOrder" -> 6, 
                      "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* visualize solution *)            
ContourPlot[Evaluate[F[Ψ[x, t] /. ndsol[[1]]]], {x, 0, L}, {t, 0, T},
            PlotRange -> All, PlotPoints -> 300, ContourLines -> False,
            Contours -> cls, ContourStyle -> {Thickness[0.0001]},
            FrameTicks -> {True, True, False, False}, 
            ColorFunction -> (Hue[0.8 #]&)]];

Here are the solutions for two sets of parameters η and the domain size L. The left graphic shows the regions Ψ(x,t)≶0 and the right graphic shows |Ψ(x,t)|. The qualitative behaviors of the solutions are quite different.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {SeedRandom[888];
  solveAndMakeGraphics3[1.400, 180,  40, 2400, 6, {Identity, {0}}],
  SeedRandom[666];
  solveAndMakeGraphics3[0.087, 110, 100, 2400, 6, {Abs, 50}]}]]]

Next, we use a 2D version of the Swift–Hohenberg equation [✶], [✶].

eq4[ϵ_, α_] =  D[ψ[x, y, t], t] == ϵ ψ[x, y, t] - (* biLaplacian *)
                 Nest[(# + D[#, x, x] + D[#, y, y])&, ψ[x, y, t], 2]
                     α ψ[x, y, t]^2 - ψ[x, y, t]^3;

Starting with random initial condition in the inner part of the x,y-domain, yields in most cases characteristic labyrinth-like structures.

ricIUS[k_, {x_?NumberQ, y_?NumberQ}] :=
If[Max[Abs[{x, y}]] > 1/2, 0, 
   SeedRandom[ToString[N[k (x + Sqrt[2] y)]]]; Random[Real, {-1, 1}]]

solveAndMakeGraphics4[{ϵ_, α_, kSeed_}, L_, T_, ppL_, do_] := 
Module[{ndsol},
(* solve PDE *)
ndsol = NDSolve[{eq4[ϵ, α], ψ[x, y, 0] == ricIUS[kSeed, {x/L, y/L}],
                 ψ[-L, y, t] == 0, ψ[L, y, t] == 0, 
                 ψ[x, -L, t] == 0, ψ[x, L, t] == 0,
                 Derivative[1, 0, 0][ψ][-L, y, t] == 0,
                 Derivative[1, 0, 0][ψ][+L, y, t] == 0,
                 Derivative[0, 1, 0][ψ][x, -L, t] == 0,
                 Derivative[0, 1, 0][ψ][x, +L, t] == 0},
         {ψ}, {x, -L, L}, {y, -L, L}, {t, T, T}, MaxSteps -> 10^5,
         PrecisionGoal -> 2, AccuracyGoal -> 2, 
         Method -> {"MethodOfLines", Method -> Automatic,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL, ppL}, "MinPoints" -> {ppL, ppL}}}];
(* visualize solution *)   
ContourPlot[Evaluate[ψ[x, y, T] /. ndsol[[1]]], {x, -L, L}, {y, -L, L}, 
       PlotRange -> All, PlotPoints -> 160, Contours -> 20, 
       ContourLines -> False, FrameTicks -> False, 
       ColorFunction -> (Hue[0.8 #]&)]]

Here are two examples, each starting from two different random initial conditions. With a higher difference order or/and more points, we could, at the expense of a longer calculation time, obtain a more reliable solution.

Show[GraphicsArray[#]]& /@ 
Block[{$DisplayFunction = Identity},
{Table[solveAndMakeGraphics4[{1.154, 0.482, k}, 50, 15, 80, 2], {k, 2}],
 Table[solveAndMakeGraphics4[{1.135, -1.4, 3k}, 50, 20, 80, 2], {k, 2}]}];

The next PDE is of type 2+1 and has fourth order spatial derivatives [✶].

eq5[ϵ_] =  ϵ^2 D[A[x, y, t], t] ==  ϵ^2 A[x, y, t] - 
               (A[x, y, t] + 2 (D[A[x, y, t], {x, 2}] + D[A[x, y, t], {y, 2}]) +
                D[A[x, y, t], {x, 4}] + D[A[x, y, t], {x, 2}, {y, 2}] + 
                D[A[x, y, t], {y, 4}]) +
           1/3 (D[#[[1]], x] + D[#[[2]], y])&[
                 {D[A[x, y, t], x], D[A[x, y, t], y]}*
                  (D[A[x, y, t], x]^2 + D[A[x, y, t], y]^2)];

We will start with random initial conditions. The function randomPeriodicICs generates random initial conditions with boundary values that are periodic in [-1,-1]×[-1,-1].

randomPeriodicICs[k_, {x_?NumberQ, y_?NumberQ}] :=
If[x == -1. || x == 1. || y == -1. || y == 1., 1., 
   SeedRandom[ToString[N[k (E x + Pi y)]]]; Random[Real, {-1, 1}]]

Next we solve the PDE for the value ε=-0.2833. While a difference order 2 does not suffice to deal with the spatial fourth order derivative, NDSolve is smart enough to use the smallest order that will work. While carrying out the following input, we get some NDSolve::eerri messages. Taking the noncontinuous nature of the initial conditions into account, these messages are expected.

ndsol = 
Module[{ppL = 80, L = 40, T = 4, ϵ = -0.2833},
NDSolve[{eq5[ϵ], A[x, y, 0] == randomPeriodicICs[1, {x/L, y/L}],
                 A[-L, y, t] == A[L, y, t], A[x, -L, t] == A[x, L, t]},
         {A}, {x, -L, L}, {y, -L, L}, {t, 0, T}, MaxSteps -> 10^5,
         PrecisionGoal -> 2, AccuracyGoal -> 2, 
         Method -> {"MethodOfLines", Method -> StiffnessSwitching,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> 2, 
                     "MaxPoints" -> {ppL, ppL}, "MinPoints" -> {ppL, ppL}}}]];

Here are a sequence of graphics that show the evolution of the system from the random initial values to an ordered square pattern [✶].

Module[{pp = 160, L = 40, T = 4},
Show[GraphicsArray[#]]& /@ Partition[
ContourPlot[Evaluate[A[x, y, #] /. ndsol[[1]]], {x, -L, L}, {y, -L, L}, 
       PlotRange -> All, PlotPoints -> pp, Contours -> 20, 
       ContourLines -> False, DisplayFunction -> Identity,
       FrameTicks -> False, ColorFunction -> (Hue[0.8 #]&)]& /@
       (* list of times for frames *)
       Prepend[T Table[2^-k, {k, 7, 0, -1}], 0], 3]]

Our next example is the Meinhardt equation set, a coupled system of three nonlinear reaction diffusion equations [✶], [✶] that are used to model animal coats [✶]. The system has twelve numerical parameters.

eqs6[{{Da_, ρa_, κa_, Ds_, ρs_, μs_, σs_, ρY_, μY_, σY_}, {κs_, κY_}}] = 
{D[a[x, y, t], t] == Da (D[a[x, y, t], x, x] + D[a[x, y, t], y, y]) +
                     ρa (a[x, y, t]^2 s[x, y, t]/(1 + κa a[x, y, t]^2) -
                     a[x, y, t]),
 D[s[x, y, t], t] == Ds (D[s[x, y, t], x, x] + D[s[x, y, t], y, y]) +
                     σs/(1 + κs Y[x, y, t]) -  μs s[x, y, t] - 
                     ρs a[x, y, t]^2 s[x, y, t]/(1 + κa a[x, y, t]^2),
 D[Y[x, y, t], t] == ρY Y[x, y, t]^2/(1 + κY Y[x, y, t]^2) - 
                     μY Y[x, y, t] + σY a[x, y, t]};

This time we use initial conditions that are constant for two of the dependent variables and mostly constant for the third. The third variable has a nonvanishing value only on a few random points.

(* some nonvanishing point values; boundary value is 0 *)
a0IC[{A_, o_, ppL_}, {x_?NumberQ, y_?NumberQ}] := 
If[Max[Abs[{x, y}]] == 1., 0, If[Random[] < o 1/(ppL - 2)^2, A, 0]]

The function solveAndMakeGraphics6 solves the Meinhardt system and generates a contour plot of the last variable.

solveAndMakeGraphics6[{T_, L_}, pdePars_, {A_, o_}, ppL_, do_] :=
Module[{ndsol},
(* solve pde system *)
ndsol = NDSolve[{eqs6[pdePars], a[x, y, 0] == a0IC[{A, o, ppL}, {x, y}/L], 
                 s[x, y, 0] == 0, Y[x, y, 0] == 0,
                 a[-L, y, t] == a[L,  y, t], a[x, -L, t] == a[x, L, t], 
                 s[-L, y, t] == s[L,  y, t], s[x, -L, t] == s[x, L, t], 
                 Y[-L, y, t] == Y[L,  y, t], Y[x, -L, t] == Y[x, L, t]},
         {a, s, Y}, {x, -L, L}, {y, -L, L}, {t, T, T}, MaxSteps -> 10^5,
         PrecisionGoal -> 2, AccuracyGoal -> 2, 
         Method -> {"MethodOfLines", Method -> BDF, "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> ppL {1, 1}, "MinPoints" -> ppL {1, 1}}}]; 
(* make contour plot of Y[x, y]^2 *)
ContourPlot[Evaluate[Abs[Y[x, y, T]]^2 /. ndsol[[1]]], {x, -L, L}, {y, -L, L}, 
       PlotRange -> All, ContourLines -> False, FrameTicks -> False, 
       PlotPoints -> 120, Contours -> 30, ColorFunction -> (Hue[0.8 #]&)]]

Here are three examples. The first two show a Voronoi diagram-like structure and the third shows a mixture between spots and stripes. We use 80 points in each spatial direction. While this suffices to obtain a qualitatively correct solution, it does not suffice to obtain a quantitatively correct one within the specified accuracy and precision goals. For the price of larger calculation time, one could calculate a better solution.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, 
     (SeedRandom[111]; Print[#];
      solveAndMakeGraphics6[#1, #3, {#2, 20}, 80, 1])& @@@ 
 (* parameter data found by searching *)
 {{{648, 66}, 5.58964, 
   {{0.015803, 0.070456, 0.003254, 0.826182, 0.001030, 0.006167, 
     0.088085, 0.351054, 0.003161, 0.010544}, {2.07226, 3.111023}}},
  {{641, 57}, 9.0855, 
   {{0.065498, 0.247513, 0.002189, 0.391285, 0.070575, 0.005826, 
     0.458718, 0.189077, 0.001017, 0.008231}, {2.38141, 0.235835}}},
  {{437, 20}, 9.85503, 
   {{0.001890, 0.039474, 0.002056, 0.887802, 0.003273, 0.006249, 
     0.537041, 0.006767, 0.115995, 0.140463}, {3.04301, 1.058715}}}}]]]

A rich source of complicated patterns are the cubic, quintic, … complex Ginzburg–Landau equations. Here is a generalized relative of it.

eq7[d0_, cList_] := 
D[A[x, t], t] == d0 D[A[x, t], x, x] +
                 A[x, t] (Abs[A[x, t]]^Range[0, Length[cList] - 1]).cList

We start with a localized smooth initial condition. The function solveAndMakeGraphics7 solves the PDE and generates a contour plot of the absolute value of its solution.

solveAndMakeGraphics7[{d0_, cList_}, ppL_, do_] := 
Module[{T = 80, L = 60, ndsol, arg = If[# == 0., 0, Arg[#]]&,
        cOpts = Sequence[PlotPoints -> 200, Contours -> 30, 
        ContourLines -> False, FrameTicks -> False]},
 (* solve PDE *) ndsol = 
 NDSolve[{eq7[d0, cList], (* localized initial condition *)
          A[x, 0] == If[Abs[x/L] < 1/2, Cos[Pi x/L]^2, 0],  
          A[-L, t] == A[L,  t]}, {A}, {x, -L, L}, {t, 0, T}, 
          MaxSteps -> 10^5, PrecisionGoal -> 3, AccuracyGoal -> 3, 
         Method -> {"MethodOfLines", Method -> StiffnessSwitching,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* visualize solution *)
Block[{$DisplayFunction = Identity},
{(* absolute value *)
 ContourPlot[Evaluate[Abs[A[x, t] /. ndsol[[1]]]], {x, -L, L}, {t, 0, T}, 
            Evaluate[cOpts], ColorFunction -> (Hue[0.8 #]&),
            PlotRange -> All],
 (* argument *)
 ContourPlot[Evaluate[arg[A[x, t] /. ndsol[[1]]]], {x, -L, L}, {t, 0, T}, 
            Evaluate[cOpts], ColorFunction -> Hue,
            PlotRange -> {-Pi, Pi}]}]]

Here are some of the resulting solutions. We show the absolute value and the argument for six sets of parameters. Once more we use a moderate number of discretization points and the lowest order to calculate a qualitatively correct solution. Using more points (and/or other methods) will give quantitatively more reliable solutions.

Off[NDSolve::eerr]; 

Show[GraphicsArray[Transpose[#]]]& /@ 
Partition[solveAndMakeGraphics7[#, 200, 1]& /@ 
(* parameters found by random searching *) {
{ 0.562585, { 0.472726 + 0.331368 I,  0.801779 - 2.480545 I,  0.474796 - 
              0.776168 I, -2.519074 - 0.952473 I, -1.014533 + 0.210578 I}},
{ 1.112343, { 0.333686 - 0.048153 I,  0.051441 + 0.346931 I,  0.262625 + 
              0.254911 I,  0.059902 + 0.067229 I, -0.125889 + 0.072792 I}},
{-0.457228, { 0.064266 + 0.219516 I,  0.103752 + 0.492474 I,  0.042513 - 
              0.062272 I, -0.190156 - 0.219106 I, -0.182677 - 0.551021 I}},    
{ 5.078614, {-0.043256 + 0.262005 I,  0.269991 + 0.278785 I,  0.371664 - 
              0.118355 I, -0.573401 + 0.766421 I,  0.132533 + 0.425168 I}},  
{ 0.896841, {-0.004116 - 0.029930 I,  0.289541 - 0.120667 I, -0.230067 - 
              0.511332 I,  2.387745 - 0.110776 I, -1.770957 - 1.860567 I}},
{ 0.613237, { 0.188025 + 1.353056 I, -0.093262 - 1.959692 I,  0.977863 - 
              1.689762 I,  1.183884 + 0.821903 I, -2.001599 + 0.123309 I}}}, 3]
                               
On[NDSolve::eerr];

Our next example is a system of two nonlinear 1+1D PDEs [✶].

eq8[A_, B_, δ_] = 
{D[u[x, t], t] == D[u[x, t], x, x] - u[x, t] v[x, t]^2 + A (1 - u[x, t]),
 D[v[x, t], t] == δ^2 D[v[x, t], x, x] + u[x, t] v[x, t]^2 - B v[x, t]};

This time we start with a smooth localized bump in the center of the integration domain.

startBump[x_, α_, L_] := If[Abs[x/L] < 1/α, Cos[Pi/2 (x/L)/(1/α)]^3, 0]

Like always, the function solveAndMakeGraphics8 solves the PDEs and generates a graphic of the solution, concretely, a contour plot of the second component.

solveAndMakeGraphics8[{{A_, B_, δ_}, {L_, T_}, α_, do_}, ppL_] := 
Module[{ndsol}, 
(* solve PDEs *)
ndsol = NDSolve[{eq8[A, B, δ], 
                 v[x, 0] == startBump[x, α, L], u[x, 0] == 1 - startBump[x, α, L], 
                 Derivative[1, 0][u][-L, t] == 0, Derivative[1, 0][u][+L, t] == 0,
                 Derivative[1, 0][v][-L, t] == 0, Derivative[1, 0][v][+L, t] == 0},
         {u, v}, {x, -L, L}, {t, 0, T}, 
         MaxSteps -> 10^5, PrecisionGoal -> 2, AccuracyGoal -> 2, 
         Method -> {"MethodOfLines", Method -> BDF,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* visualize solution *)
ContourPlot[Evaluate[v[x, t] /. ndsol[[1]]], {x, -L, L}, {t, 0, T}, 
       PlotRange -> All, PlotPoints -> 400, Contours -> 20, 
       ContourLines -> False, FrameTicks -> False, 
       ColorFunction -> (Hue[0.8 #]&)]]

Here are three examples. The special property of these PDEs is that the localized initial structure repeatedly copies itself [✶], [✶], [✶], [✶]. (For a variety of examples of such structure in expanding domains L=L(t), see [✶], [✶], [✶].)

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      solveAndMakeGraphics8[#, 2400]& /@ 
       (* three sets of parameters *)
       {{{0.011051, 0.021635, 0.026161}, { 8, 4000}, 16, 1},
        {{0.373018, 0.095230, 0.003531}, { 5, 2000}, 29, 1},
        {{0.591115, 0.273925, 0.061422}, {10,  300}, 27, 1}}]]]

We continue with a system of two coupled nonlinear PDEs in 2+1 dimensions [✶], [✶].

eqs9[ϵ_, α_, A_] = 
{D[θ[x, y, t], t] == (ϵ^2 (D[θ[x, y, t], x, x] + D[θ[x, y, t], y, y]) -
                      θ[x, y, t]^3 + θ[x, y, t] + η[x, y, t])/α,
 D[η[x, y, t], t] == (D[η[x, y, t], x, x] + D[η[x, y, t], y, y]) -
                      θ[x, y, t] - η[x, y, t] + A};

This time, we start with a ring-shaped initial condition.

θ0[x_, y_, θ00_, L_] := (* ring-shaped elongation *)
With[{γ = 1/8}, If[L/2 - γ L <= Sqrt[x^2 + y^2] <= L/2 + γ L, 
                   Sin[3 Pi x/L] Cos[Sqrt[x^2 + y^2]/L/γ Pi/2]^2, 0]]

solveAndMakeGraphics9[{{ϵ_, α_, A_}, {L_, T_}, θ00_}, do_, ppL_] := 
Module[{ndsol},
 (* solve PDEs *)
 ndsol = NDSolve[{eqs9[ϵ, α, A], 
                 θ[x, y, 0] == θ0[x, y, θ00, L], η[x, y, 0] == 0,
                 θ[-L, y, t] == 0, θ[L, y, t] == 0, 
                 θ[x, -L, t] == 0, θ[x, L, t] == 0, 
                 η[-L, y, t] == 0, η[L, y, t] == 0, 
                 η[x, -L, t] == 0, η[x, L, t] == 0},
         {θ, η}, {x, -L, L}, {y, -L, L}, {t, T, T}, MaxSteps -> 10^5,
         PrecisionGoal -> 2, AccuracyGoal -> 2, 
         Method -> {"MethodOfLines", Method -> Automatic,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL, ppL}, "MinPoints" -> {ppL, ppL}}}];
 (* visualize η part of the solution *)
 ContourPlot[Evaluate[Abs[η[x, y, T] /. ndsol[[1]]]], {x, -L, L}, {y, -L, L}, 
       PlotRange -> All, PlotPoints -> 80, Contours -> 20, 
       ContourLines -> False, FrameTicks -> False, 
       ColorFunction -> (Hue[0.8 #]&)]]

For many parameter values the initial ring disintegrates into closed, deformed pieces. Here are four examples.

Show[GraphicsArray[#]]& /@ 
Block[{$DisplayFunction = Identity}, 
 Partition[solveAndMakeGraphics9[#, 8, 120]& /@ 
   (* four sets of parameter values *)
   {{{ 0.500521, 0.798381, -0.0086344}, { 22, 68}, -1.666285},
    {{-0.120092, 0.084926,  0.2385211}, { 13, 77}, -0.878614},
    {{ 0.503609, 1.048002, -0.0223839}, { 25, 42}, -1.632547},
    {{-1.138091, 0.023999, -0.0019694}, {173, 16} ,  1.704992}}, 2]]

We continue with a slightly nonlinear wave equation that models two different media [✶], [✶].

(* position-dependent c and ω *)
eq10[{c1_, c2_}, {ω1_, ω2_}] =
D[u[x, t], t, t] - If[x > 0, c1^2, c2^2] D[u[x, t], x, x] +
                   If[x > 0, ω1^2 Tan[u[x, t]], ω2^2 Sin[u[x, t]]] == 0;

(* two localized initial packets *)
startPackets[{𝒶_, 𝒷_}, x_] := 
 Which[Abs[x - 1/3] <= 𝒷, 𝒶 Cos[Pi/2 (x - 1/3)/𝒷]^2,
       Abs[x + 1/3] <= 𝒷, 𝒶 Cos[Pi/2 (x + 1/3)/𝒷]^2,
       True, 0];

solveAndMakeGraphicsTwoMediaWaveEquation[{{{c1_, c2_}, {ω1_, ω2_}}, 
                                 {𝒶_, 𝒷_}, {L_, T_}, g_, do_}, ppL_] := 
Module[{ndsol}, 
(* solve PDEs *)
ndsol = NDSolve[{eq10[{c1, c2}, {ω1, ω2}], 
                 u[x, 0] == startPackets[{𝒶, 𝒷}, x/L], 
                 Derivative[0, 1][u][x, 0] == 0, 
                 u[ L, t] == 0, u[-L, t] == 0},
         {u}, {x, -L, L}, {t, 0, T}, 
         MaxSteps -> 10^5, PrecisionGoal -> g, AccuracyGoal -> g, 
         Method -> {"MethodOfLines", Method -> Automatic,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* visualize solution *)
ContourPlot[Evaluate[Abs[u[x, t]] /. ndsol[[1]]], {x, -L, L}, {t, 0, T}, 
       PlotRange -> All, PlotPoints -> 240, Contours -> 20, 
       ContourLines -> False, FrameTicks -> False, 
       ColorFunction -> (Hue[0.8 #]&)]]

We clearly see reflections of the two spreading packets at the interface z=0.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
solveAndMakeGraphicsTwoMediaWaveEquation[
                    {#1, #2, {10, 12}, 3, Pseudospectral}, 81]& @@@
  (* two parameter sets *)                  
  {{{{0.51314, 0.42573}, {1.5459, 0.0775}}, { 1.9945, 0.11295}},
   {{{0.09219, 0.38770}, {1.3690, 1.8004}}, {-0.6500, 0.082157}}}]]]

Our next example is the classical scalar wave equation with a piecewise constant speed of light. But now we consider the 2+1 case. The two materials are located above and below the line z≷0.

(* 2D wave equation with position-dependent c *)
eq11[c_] = If[z > 0, 1, 1/c^2] D[u[x, z, t], t, t] == 
               D[u[x, z, t], x, x] + D[u[x, z, t], z, z];

We start with a simple localized wave packet [✶]. (For other packets, see [✶], [✶], [✶], [✶].) To avoid the use of complex arithmetic, instead of a factor exp(i k.r), we will use two packets of the form cos(k.r) and sin(k.r) and add their contributions at the end. We then display the square of the absolute value of the field.

(* field and derivative at t == 0 *)
startPacket2D[{σl_, σr_, α_, ℓ_, k0_, β_}, {x_, z_}] := 
Module[{x0 = ℓ Cos[Pi - α], z0 = ℓ Sin[Pi - α], 
       𝓀0 = k0 {Cos[-α], Sin[-α]}, 
       ξD = {Cos[-α], -Sin[-α]}, ηD = {Sin[-α], Cos[-α]}, ξd, ηd},
       ξd = ({x, z} - {x0, z0}).ξD; ηd = ({x, z} - {x0, z0}).ηD;
      (* elongated moving Gaussian packet *)
      Exp[-ξd^2/σr^2 - ηd^2/σl^2] Cos[𝓀0.{x, z} + β]]   
      
startPacket2DDerivative[{σl_, σr_, α_, ℓ_, k0_, β_}, {x_, z_}] := 
Module[{t}, D[startPacket2D[{σl, σr, α, ℓ, k0, β}, 
                     {x - Cos[α] t, z + Sin[α] t}], t] /. t -> 0]

This time, we repeatedly solve the wave equation over a certain time interval and create a visual snapshot of the state and the end of this time interval. This method allows to follow the wave packet for a longer time without saving the potentially quite large interpolating function generated by NDSolve.

solveAndMakeGraphicsListTwoMediaWaveEquation2D[
     {c_, {σl_, σr_, α_, ℓ_, k0_}, g_, do_}, {L_, T_}, ppL_, frames_] := 
Module[{ΔT = T/frames, state, pps, xy0 = L {Cos[Pi - α], Sin[Pi - α]},
        stateC, stateS}, 
(* set up PDE;
   use two initial conditions with shifted modulation to model
   a complex field  *)
{stateC, stateS} = NDSolve`ProcessEquations[{eq11[c], 
                 u[x, z, 0] == startPacket2D[{σl, σr, α, ℓ, k0, #}, {x, z}], 
                 Derivative[0, 0, 1][u][x, z, 0] == 
                 startPacket2DDerivative[{σl, σr, α, ℓ, k0, #}, {x, z}], 
                 u[ L, z, t] == 0, u[-L, z, t] == 0,
                 u[x,  L, t] == 0, u[x, -L, t] == 0},
         {u}, {x, -L, L}, {z, -L, L}, t, 
         MaxSteps -> 10^5, PrecisionGoal -> g, AccuracyGoal -> g, 
         Method -> {"MethodOfLines", Method -> Automatic,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL, ppL}, 
                     "MinPoints" -> {ppL, ppL}}}][[1]]& /@ {0, Pi/2};
(* propagate solution in time and make visualizations *)
Table[(* solve wave equation in time steps ΔT *)
   NDSolve`Iterate[stateC, j ΔT]; NDSolve`Iterate[stateS, j ΔT]; 
   (* form current solution *)
   {ppsC, ppsS} = NDSolve`ProcessSolutions[#, "Forward"]& /@ {stateC, stateS};   
   (* visualize solution *)
   Show[Graphics[ContourPlot[Evaluate[Abs[ppsC[[1, 2]]]^2] + Abs[ppsS[[1, 2]]]^2, 
                 {x, -L, L}, {z, -L, L}, Contours -> 20, 
                 ContourLines -> False, DisplayFunction -> Identity,
                 FrameTicks -> False, ColorFunction -> (GrayLevel[1 - #]&),
                 PlotRange -> All, PlotPoints -> 160, Epilog -> 
       (* lines along the reflected and refracted rays *)
       {{Hue[0], Thickness[0.008], Line[{{-L, 0}, {L, 0}}]},
        {GrayLevel[0], Thickness[0.004], 
         Line[2 {xy0, {0, 0}, L {Cos[α], Sin[α]}}]}}]],
            PlotRange -> L {{-1, 1}, {-1, 1}}, Frame -> True], {j, frames}]]

The following two rows of graphics show the temporal evolution of two packets impinging on the surface under different angles. The material on the left has a smaller phase velocity than the material on the right hand side. In the left row, one sees that a large fraction of the initial wave packet gets reflected. The two black lines represent the classical reflection law for the center of the wave packet. For larger times, the reflected wave packet is clearly to right of the ray prediction (analog to the Goos–Hänchen effect in optics [✶], [✶], [✶], [✶]).

Show[GraphicsArray[#]]& /@ Transpose[
 solveAndMakeGraphicsListTwoMediaWaveEquation2D @@@
     {{{1/Sqrt[4], {1/2, 1/2, Pi/8, 3, 12}, 3, 1}, {4, 7}, 140, 5},
      {{1/Sqrt[2], {1/2, 1/2, Pi/3, 3, 16}, 3, 1}, {4, 7}, 140, 5}}]

Show[GraphicsArray[#]]& /@ Transpose[
 solveAndMakeGraphicsListTwoMediaWaveEquation2D @@@
     {{{1/Sqrt[4], {1/2, 1/2, Pi/8, 3, 12}, 3, 1}, {4, 7}, 140, 24},
      {{1/Sqrt[2], {1/2, 1/2, Pi/3, 3, 16}, 3, 1}, {4, 7}, 140, 24}}]

For refraction on negative n materials, see [✶], [✶]. For a nonlinear reaction-diffusion system with two different media, see [✶].

We continue with the local induction approximation PDE for vortices [✶], [✶], [✶]. Given a curve X(s), where s is the arc length, the time evolution of the curve is assumed to be

((∂X(t,s))/(∂t))=(Subscript[X, s])(t,s)×(Subscript[X, s s])(t,s).

The length of a curve stays constant under this time-evolution.
Using any parametrization instead of the arc length, we obtain the similar PDE

((∂X(t,σ))/(∂t))=(((Subscript[X, σ])(t,σ)×(Subscript[X, σ σ])(t,σ))/(Sqrt[((((Subscript[X, σ])(t,σ).(Subscript[X, σ])(t,σ)))^3)])).

We define the function solveAndMakeGraphicsLIAEquation to solve the solution numerically and to display the time-evolved curve as a surface sept out.

X[t_, σ_] := {x[t, σ], y[t, σ], z[t, σ]};

eq12[α_, {t_, σ_}] = 
Thread @ (D[X[t, σ], t] == α Together @
          Cross[1/Sqrt[D[X[t, σ], σ].D[X[t, σ], σ]] D[X[t, σ], σ],
                1/Sqrt[D[X[t, σ], σ].D[X[t, σ], σ]]*
                 D[1/Sqrt[D[X[t, σ], σ].D[X[t, σ], σ]] D[X[t, σ], σ], σ]]);

solveAndMakeGraphicsLIAEquation[{curve_, σ_}, α_, ppd_, T_, ppg_, opts___] :=
Module[{ndsol, Τ},
   ndsol = (* solve local induction approximation PDE *)
    NDSolve[Flatten[{eq12[1, {t, σ}], Thread[X[0, σ] == curve],
                                      Thread[X[t, 0] == X[t, 2Pi]]}],
         {x, y, z}, {t, 0, T}, {σ, 0, 2Pi},
         MaxSteps -> 10^5, PrecisionGoal -> 4,
         (* use "Pseudospectral" because of periodic boundary conditions *)
         Method -> {"MethodOfLines", "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> "Pseudospectral", 
                    "MaxPoints" -> {ppd}, "MinPoints" -> {ppd}}}];
   Τ = ndsol[[1, 1, 2, 1, 1, 2]]; 
   (* visualize evolved curve as a parametrized surface *)
   Show[ParametricPlot3D[Evaluate[Append[X[t, σ] /. ndsol[[1]], 
                               {EdgeForm[Thickness[0.001]],
                                SurfaceColor[Hue[0.8 t/Τ], Hue[0.8 t/Τ], 2]}]],
                 {σ, 0, 2Pi}, {t, 0, Τ}, PlotPoints -> ppg,
                 DisplayFunction -> Identity] /. Polygon[l_] :> 
                 Polygon[Plus @@@ Partition[Append[l, First[l]], 2, 1]/2],
     opts, DisplayFunction -> $DisplayFunction, 
     PlotRange -> All, Axes -> False, Boxed -> False]]

Here are the evolution of two knots.

solveAndMakeGraphicsLIAEquation[
 {{Sin[σ] + 2 Sin[2σ], Cos[σ] - 2 Cos[2σ], Sin[3σ]}, σ}, 1, 120, 20, {90, 60}]

solveAndMakeGraphicsLIAEquation[
 {{Sin[σ] + 3/2 Sin[3σ], Cos[σ] - 3/2 Cos[3σ], Sin[4σ]}, σ}, 1, 120, 10, {180, 50}]

And here is the evolution of a Lissajou curve.

solveAndMakeGraphicsLIAEquation[
 {{Sin[2σ], Cos[3σ], Cos[σ]}, σ}, 1, 120, 3, {120, 50}]

By letting the curve change its topology when two curve segments are near to each other, complicated vertex tangles can be formed [✶], [✶], [✶].

We continue with a partial differential equation that contains mixed spatial and temporal derivatives. Solving such differential equations is currently not yet supported. We start with a relatively simple equation, a Born–Infeld-type wave equation [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶].

(* simplest Born–Infeld wave equation for a scalar field *)
eqBornInfeld[] := (1 + D[ϕ[x, t], x]^2) D[ϕ[x, t], t, t] - 
                   2 D[ϕ[x, t], x] D[ϕ[x, t], t] D[ϕ[x, t], x, t] -
                  (1 - D[ϕ[x, t], t]^2) D[ϕ[x, t], x, x] == 0
 
(* two smooth initial wave packets *)                                  
startPackets[β_, x_] := 
 Which[Abs[x - 1/3] <= β, Cos[Pi/2 (x - 1/3)/β]^2,
       Abs[x + 1/3] <= β, Cos[Pi/2 (x + 1/3)/β]^2, True, 0];                                  

solveAndMakeGraphicsBornInfeld[{β_, {L_, T_}, g_, do_}, ppL_] := 
Module[{ndsol}, 
(* solve PDEs *)
ndsol = NDSolve[{eqBornInfeld[], ϕ[x, 0] == startPackets[β, x/L], 
                 Derivative[0, 1][ϕ][x, 0] == 0,
                 ϕ[ L, t] == ϕ[-L, t]},
         {ϕ}, {x, -L, L}, {t, 0, T}, 
         MaxSteps -> 10^5, PrecisionGoal -> g, AccuracyGoal -> g, 
         Method -> {"MethodOfLines", Method -> Automatic,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* visualize solution *)
ContourPlot[Evaluate[ϕ[x, t] /. ndsol[[1]]], {x, -L, L}, {t, 0, T}, 
       PlotRange -> All, PlotPoints -> 240, Contours -> 20, 
       ContourLines -> False, FrameTicks -> False, 
       ColorFunction -> (Hue[0.8 #]&)]]
       
(* example solution *)       
solveAndMakeGraphicsBornInfeld[{1/6, {10, 25}, 3, Pseudospectral}, 121]

(The relativistic diffusion equation also exhibits mixed spatial and temporal derivatives [✶].)

The next example generates graphics that show how an initially localized smooth perturbation splits into peakon trains [✶], [✶], [✶], [✶].

(* peakon PDEs *)
eqPeakon[u_, {x_, t_}, α_] := 
 Function[m, D[m, t] + u[x, t] D[m, x] + 2 D[u[x, t], x] m == 0][
                                   u[x, t] - α^2 D[u[x, t], x, x]];
(* smooth initial bump *)                                  
startBump[β_, x_] := If[Abs[x] >= β, 0, Cos[Pi/2 x/β]^2];      

solveAndMakeGraphicsPeakon[{{α_, β_}, {L_, T_}, g_, do_}, ppL_] := 
Module[{ndsol, u}, 
(* solve PDEs *)
ndsol = NDSolve[{eqPeakon[u, {x, t}, α], u[x, 0] == startBump[β, x/L], 
                 u[ L, t] == u[-L, t]},
         {u}, {x, -L, L}, {t, 0, T}, 
         MaxSteps -> 10^5, PrecisionGoal -> g, AccuracyGoal -> g, 
         Method -> {"MethodOfLines", Method -> Automatic,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> do, 
                     "MaxPoints" -> {ppL}, "MinPoints" -> {ppL}}}];
(* visualize solution *)
ContourPlot[Evaluate[u[x, t] /. ndsol[[1]]], {x, -L, L}, {t, 0, T}, 
       PlotRange -> All, PlotPoints -> 240, Contours -> 20, 
       ContourLines -> False, FrameTicks -> False, 
       ColorFunction -> (Hue[0.8 #]&)]]
       
(* solutions for two parameter sets *)       
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {solveAndMakeGraphicsPeakon[{{-1.61667, 0.234245}, {121, 80}, 3, 8}, 80],
  solveAndMakeGraphicsPeakon[{{+1.31838, 0.624857}, { 62, 80}, 3, 8}, 80]}]]]

For further partial differential equations that contain mixed spatial and temporal derivatives, see [✶] (describing a the motion of a vibrating hanging shoe string).

Consider a square Koch curve of order 2. Solve the Helmholtz equation -Δ u(x,y)=(ω^2) u(x,y) in this Koch curve with Dirichlet boundary conditions. Estimate accuracy of the eigenvalues through comparison with state that is locally everywhere a product state of sine functions. Visualize some of the eigenfunctions as 3D plots and as contour plots. Visualize the values of the gradients of some of the lowest and some of the higher eigenfunctions.
Calculate the first 1000 lowest eigenvalues and compare the number of eigenfunctions n(ω) as function of ω with the asymptotic Weyl–Berry law [✶], [✶], [✶], [✶], [✶], [✶], [✶]

n(ω)~A/(4π) (ω^2)-{({{c (ω^d), for fractal boundaries}, {a /(4π)ω, for smooth boundaries.}})

The solve the eigenvalue problem of the Helmholtz equation, the piecewise horizontal and vertical boundary segments suggest a finite difference discretization of the interior of the Koch curve. To achieve a solution of sufficiently high precision, we will use higher order finite difference approximations.

Off[General::spell]; Off[General::spell1];

We start by calculating the 1D finite difference weights. For the actual 2D Koch curve problem, we use a tensor product form of these differences.

The kth element of FDWeightLists[ν][o] gives the list of length o of the weights of the function values to approximate the νth derivative at the kth point from the left through the function values at o points. It is obtained by forming an interpolating polynomial through the (symbolic) function values, differentiating this polynomial, and extracting the coefficients of the function values [✶], [✶].

FDWeightLists[ν_][o_] :=
Module[{ipo, poly}, 
       (* interpolating polynomial *) 
       ipo[x_] = InterpolatingPolynomial[Table[{x0 + k h, f[k]}, 
                                               {k, 0, o - 1}], x];
       (* loop over all o grid points *)
       Table[(* value of derivative at j-th grid point *)
           poly = Expand[h^ν Together[D[ipo[x], {x, ν}] /. x -> x0 + j h]];
           (* coefficients of function values *)
           Coefficient[poly, Table[f[k], {k, 0, o - 1}]], {j, 0, o - 1}]]

Here are two examples: the first and second derivative of a stencil of length three.

FDWeightLists[1][3]

FDWeightLists[2][3]

The function hOrder[ν, fdws] calculates the order of the approximation of the derivative (f^((ν)))(x) for the finite difference weights fdws at the point x and step size h.

hOrder[ν_, fdws_, {x_, h_}] := 
Normal[(* keep only highest order in h *) 
       Series[#, {h, 0, Position[Rest[#[[3]]], _?(# =!= 0&), 
            {1}, 1, Heads -> False][[1, 1]]}]]& /@ 
Series[(* expand in series about h == 0 *)
(* form expression approximating the derivative *)
MapIndexed[Function[{w, p}, w.Table[f[x + k h], 
               {k, 1 - p[[1]], -p[[1]] + Length[w]}]/h^ν], fdws],
       {h, 0, Length[fdws[[1]]]}]

Here are the approximation properties of the second derivative using three and five points. We see that the derivatives at the center points are approximated to an higher order.

hOrder[2, FDWeightLists[2][3], {x, h}]

hOrder[2, FDWeightLists[2][5], {x, h}]

We remark that the finite difference weights can be obtained from one of the built-in supporting functions from the NDSolve` context, namely through the function NDSolve`FiniteDifferenceDerivative.

FDWeightListsBI[ν_][o_] :=
With[{grid = Range[o]}, Coefficient[#, f /@ grid]& /@ 
     NDSolve`FiniteDifferenceDerivative[Derivative[ν], grid, 
                        f /@ grid, DifferenceOrder -> o - ν]]

(* quick check that the two functions give identical weights *)
Table[FDWeightLists[ν][o] == FDWeightListsBI[ν][o], 
      {ν, 1, 6}, {o, ν + 1, 6}] // Flatten // Union

The following graphic shows the central finite difference approximation weights for the second derivative. The graphic shows substantial changes for the first few values of α (we take a stencil of size 2α+1). As a result, we expect substantially different results for the eigenvalues for small α. Later, we will use α=3, which will give results accurate to less than 0.1% over a large ω-range.

Show[Graphics[Reverse @ Table[{Hue[(α - 1)/10], 
Line[MapIndexed[{#2[[1]] - α - 1, #1}&,
                FDWeightListsBI[2][2 α + 1][[α + 1]]]]},
                {α, 7}]], PlotRange -> All, Frame -> True]

For later convenience, we define one more finite difference weight-related function. Given a point on a 1D grid, the function stencilWeightList gives the list of weights approximating the vth derivative by using leftPoints to the left and rightPoints to the right (and the center point itself).

stencilWeightList[ν_][leftPoints_, rightPoints_] :=
        stencilWeightList[ν][leftPoints, rightPoints] = 
        FDWeightListsBI[ν][leftPoints + 1 + rightPoints][[leftPoints + 1]]

Next, we construct the Koch drum. A Koch drum is obtained by recursively applying the following rule edgeRule to the line segments of the last iteration drum. The 0th order drum is just a square.

edgeRule[{p_, q_}] := 
Module[{d = (q - p)/4, n = -Reverse[q - p]{-1, 1}/4},
       Partition[FoldList[Plus, p, {d, n, d, -n, -n, d, n, d}], 2, 1]]
       
startSquare = 
     Partition[{{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}, 2, 1];

The following graphic shows the zeroth order drum in red, the first order in green, and the second order in violet. In the following, we will calculate the eigenvibrations of the second order Koch drum. The underlying square grid that will be used to partition the interior of the drum in the following is shown too.

(* list of the first few the Koch drum iterations *)
iterationOrder = 2;
nl = NestList[Flatten[edgeRule /@ #, 1]&, startSquare, iterationOrder];

(* edge length *)
λ = 2^-(2 iterationOrder - 1);

Module[{L = 2 - 2^-iterationOrder}, 
Show[Graphics[{
 {(* background mesh *)
  Thickness[0.001], GrayLevel[0.8], {#, Map[Reverse, #, {3}]}&[
   Table[Line[{{-L, z}, {L, z}}], {z, -L, L, λ}]]},
   MapIndexed[{Hue[0.78 (#2[[1]] - 1)/
               If[iterationOrder == 0, 1, iterationOrder]],   
  Thickness[0.01/#2[[1]]], Line /@ #1}&, nl]}], 
  PlotRange -> All, AspectRatio -> Automatic, Axes -> True]]

These are the line segments forming the boundary of the Koch drum. To test if a line segment is part of the boundary, we implement the function outerEdgeQ.

drumEdges = Sort /@ nl[[-1]];
(outerEdgeQ[#] = True)& /@ drumEdges;

translateSquare[mp_, edge_, square_]  :=
With[{t = 2 ((Plus @@ edge/2) - mp)}, Map[(t + #)&, square, {-2}]]

Until now, we only have the boundary of the Koch drum. While for a boundary element method, this would be enough to calculate the eigenvalues, for a finite difference approximation, we need explicit points in the interior. The interior of the Koch drum is naturally subdivided into squares of edge lengths equal to the length of a boundary segments. We obtain all squares by starting in the center and recursively select all neighboring squares until we hit the boundary. The list allInnerSquares contains the inner squares in the form Square[midpoint, squareEdges].

(* form squares that are neighbors of a given square sq *)
neighborSquares[sq:Square[mp_, edges_]] :=
Module[{sortedEdges = Sort /@ edges, growEdges, newSquares}, 
       (* the edges of the square that are not boundaries of the drum *)
       growEdges = Complement[sortedEdges, Select[sortedEdges, outerEdgeQ]];
       newSquares = translateSquare[mp, #, sq]& /@ growEdges]

allInnerSquares = 
Module[{usedMpQ, currentSquares, squaresBag, newSquareLayer},
If[(* zeroth order is special *)
 iterationOrder === 0, {Square[{0, 0}, startSquare]},
 (* the four squares around the center *)
 currentSquares = Square[Plus @@ Flatten[#, 1]/8, #]& /@  
  (Partition[Append[#, First[#]], 2, 1]& /@ 
     ({{{ 0,  0}, { λ,  0}, { λ,  λ}, { 0,  λ}}, 
       {{-λ,  0}, { 0,  0}, { 0,  λ}, {-λ,  λ}},
       {{ 0, -λ}, { λ, -λ}, { λ,  0}, { 0,  0}}, 
       {{-λ, -λ}, { 0, -λ}, { 0,  0}, {-λ,  0}}}));
(* currently already used squares *)
 squaresBag = currentSquares;
 (usedMpQ[#[[1]]] = True)& /@ currentSquares;
(* form outside neighbor square layers as long as possible *)
While[newSquareLayer = First /@ Split[Sort[Flatten[neighborSquares /@
                                                   currentSquares]],
                                      #1[[1]] === #2[[1]]&];
      currentSquares = Complement[newSquareLayer, 
                                  Select[newSquareLayer, usedMpQ[#[[1]]]&]];
      currentSquares =!= {},
      (* update *)
      squaresBag = {squaresBag, currentSquares};
     (usedMpQ[#[[1]]] = True)& /@ currentSquares];
(* the squares forming the interior of the Koch drum *)
allInnerSquares = Flatten[squaresBag]]];

Here are all the 256 interior squares.

Show[Graphics[{(* the interior squares, colored randomly *)
               {Hue[Random[]], #}& /@ allInnerSquares /. 
                Square[mp_, edges_] :> Polygon[First /@ edges],
               (* the drum edges *)
               {GrayLevel[0], Thickness[0.005], Line /@ drumEdges}},
      AspectRatio -> Automatic]]

We generate lists of all vertices, the outer (boundary) vertices, and the strictly inner vertices.

allVertices = Union[Flatten[Last /@ allInnerSquares, 2]];
outerVertices = Union[Flatten[drumEdges, 1]];
innerVertices = Complement[allVertices, outerVertices];

To obtain a good resolution of the solution in the thin bays of the Koch drum, we will now subdivide each square into (rL^2) smaller squares. We use rL=8 in the following. L denotes the shortest distance between two neighboring discretization points.

(* order of refinement within each square *) rL = 8;
(* distance between two adjacent vertices *) L = λ/rL;

(* subdivide a square into rL×rL smaller squares *)
refineSquare[Square[mp_, edges_], rL_]  :=
Module[{p1, p2, p3, p4, d1, d2},
       {p1, p2, p3, p4} = First /@ edges;
       d1 = p2 - p1; d2 = p4 - p1;
       Table[Square[{p1 + j/rL d1 + k/rL d2, p1 + (j + 1)/rL d1 + k/rL d2,
                     p1 + (j + 1)/rL d1 + (k + 1)/rL d2, 
                     p1 + j/rL d1 + (k + 1)/rL d2}],
             {j, 0, rL - 1}, {k, 0, rL - 1}] // Flatten];

We now create lists of inner vertices innerRefinedVertices (of the small squares) and vertices boundaryVertices (of the small) squares that lie on the boundary of the drum.

allRefinedInnerSquares = Flatten[refineSquare[#, rL]& /@ allInnerSquares];
allRefinedVertices = Union[Flatten[First /@ allRefinedInnerSquares, 1]];

boundaryVertices = 
Union[Flatten[Table[#1 + j/rL (#2 - #1), {j, 0, rL}]& @@@ drumEdges, 1]];

innerRefinedVertices = Complement[allRefinedVertices, boundaryVertices];

So we have 15361 inner vertices. At these inner vertices, we will have to calculate the values of the eigenvibrations. (Due to the Dirichlet boundary conditions we are using all boundary vertex values are identically zero.)

Length /@ {allRefinedVertices, boundaryVertices, innerRefinedVertices}

Here is a sketch of the Koch drum with the inner vertices in red and the boundary vertices in black.

Show[Graphics[{{PointSize[0.004], GrayLevel[0], Point /@ boundaryVertices},
               {PointSize[0.002], Hue[0], Point /@ innerRefinedVertices}}],
     PlotRange -> All, AspectRatio -> Automatic]

Now the values of the eigenvibrations at the inner vertices have to be determined. This means that we have to find eigenvalues and eigenvectors of a d×d matrix, where for the Dirichlet boundary conditions d is the number of the interior vertices.

dimD = Length[innerRefinedVertices];

We define some functions that number the vertices, return their coordinates, and test if a vertex is an inner vertex.

(* convert between vertex coordinates and vertex number *)
Do[vertexDNumber[innerRefinedVertices[[k]]] = k;
   vertexDCoordinates[k] = innerRefinedVertices[[k]];
   isInnerDVertex[innerRefinedVertices[[k]]] = True, {k, dimD}];
   
(* is a vertex an inner vertex? *)
isInnerDVertexQ[vertex_] := isInnerDVertexQ[vertex] = 
                            TrueQ[isInnerDVertex[vertex]]

We define similar functions for the boundary vertices.

Do[boundaryVertexNumber[boundaryVertices[[k]]] = k;
   boundaryVertexCoordinates[k] = boundaryVertices[[k]];
   isBoundaryVertex[boundaryVertices[[k]]] = True, 
   {k, Length[boundaryVertices]}];
   
(* is a vertex a boundary vertex? *)
isBoundaryVertexQ[vertex_] := isBoundaryVertexQ[vertex] = 
                              TrueQ[isBoundaryVertex[vertex]]

For all inner vertices, we now define a neighborhood and approximate the Laplacian through the weighted average of the function values at neighboring vertices. The auxiliary function addVertexWeights adds the contributions of the list of finite difference weights vws for each vertex.

addVertexWeights[vws_] := 
If[Length[#] === 1, First[#], #[[1, 1]] -> (Plus @@ (Last /@ #))]& /@ 
                              Split[Sort[vws], #1[[1]] === #2[[1]]&]

For a given stencil of odd length 2α+1, the function makeNonVanishingDMatrixElements returns a list of the nonvanishing elements of the discretization of the negative of the 2D Laplace operator. We incorporate the Dirichlet boundary conditions through an antisymmetric continuation of the function across the boundary. By using an odd stencil length, we make sure that is always possible.

makeNonVanishingDMatrixElements[α_Integer] := addVertexWeights @
Module[{centerVertex, jB, swl = -stencilWeightList[2][α, α]},
Table[centerVertex = innerRefinedVertices[[k]]; 
       {{k, k} -> 2 swl[[α + 1]],
        Function[dir, jB =.;
        (* loop over neighbors *)
        Table[nextVertex = centerVertex + j L dir;
              (* neighbor is inner vertex, boundary vertex, 
                 or outer vertex *)
              Which[isInnerDVertexQ[nextVertex], 
                    {k, vertexDNumber[nextVertex]} -> swl[[α + 1 + j]], 
                    isBoundaryVertexQ[nextVertex], jB = j; Sequence @@ {},
                    True, reflectedVertex = (* reflect *)
                             centerVertex + jB L dir - (j - jB) L dir;
                    {k, vertexDNumber[reflectedVertex]} -> 
                                        -swl[[α + 1 + j]]], 
                    {j, 1, α}]] /@ (* horizontal and vertical neighbors *)
                    {{+1, 0}, {-1, 0}, {0, 1}, {0, -1}}}, 
                    (* all inner vertices *) {k, dimD}] // Flatten];

Here is the resulting sparse matrix for stencil length seven. MD7 is of dimensions 15361×15361 and has 187429 nonvanishing elements. By construction, the matrix MD7 is symmetric.

MD7 = SparseArray[makeNonVanishingDMatrixElements[3]]

(* check that MD7 is a symmetric matrix *)
Max[MD7 - Transpose[MD7]]

We visualize the nonzero elements of the resulting matrix. It is nicely banded.

Show[Graphics[{GrayLevel[0], Rectangle[#1 - 1/2, #1 + 1/2]}& @@@ 
                                    makeNonVanishingDMatrixElements[3]],
     PlotRange -> All, Frame -> True, AspectRatio -> Automatic]

To find the eigenvalues and eigenvectors of the matrix MD7, we will use the "Arnoldi" method. We obtain the extremal eigenvalues with the "BothEnds" criteria. We multiply by the square of the discretization length L to obtain the eigenvalues for the original drum.

Eigenvalues[N[MD7], 2, Method -> {"Arnoldi", Criteria -> "BothEnds",  
                                  BasisSize -> 30}]/L^2

Next, we calculate the eight lowest eigenvalues. The function drumEigensystem calculates some selected eigenvalues of the matrix MD7. We see the unique lowest eigenvalue and that the next two eigenvalues are degenerate. Because of the fourfold rotational symmetry of the Koch curve, such a degeneracy is expected.

drumEigensystem[n_, opts___] := MapAt[1/L^2 #&, Reverse /@ 
    Eigensystem[N[MD7], n, Method -> {"Arnoldi", opts, Tolerance -> 10^-10,
                BasisSize -> Abs[20 n], MaxIterations -> 10^4}], 1]

{evalsD7Low, evecsD7Low} = drumEigensystem[-8];
ListPlot[evalsD7Low, PlotRange -> All, PlotStyle -> {PointSize[0.03]},
         AxesOrigin -> {0, 0}]

We also calculate the eigenvalues near the exactly known eigenvalues of the state, that is in each subsquare a product state of sine functions [✶]. The lowest of these functions has the eigenvalue Λ=2(((π/λ))^2)≈1263.31. The following list of eigenvalues clearly suggests that the third element of evecsD7Sin1 is this state. Its eigenvalue deviates by only 0.0006% from the exact value.

Λ = 2 (Pi/λ)^2;
{evalsD7Sin1, evecsD7Sin1} = drumEigensystem[6, Shift -> Λ L^2];
(evalsD7Sin1/Λ - 1)

The next state that is a product of sine functions has eigenvalue 4Λ. The eigenvalue of the fourth state of the list deviates by about 0.04% from the exact value. This indicates that the states up to this energy are clearly precisely enough calculated for any visualization purposes we are primarily interested in.

{evalsD7Sin2, evecsD7Sin2} = drumEigensystem[6, Shift -> 4 Λ L^2];
(evalsD7Sin2/(4 Λ) - 1)

Now that we have the eigenvectors, we will visualize them. We start with 3D plots. To construct them, we just use the small squares allRefinedInnerSquares from above and add as the z-value the eigenvector components to their vertices.

(* plot a general surface with height values over the drum vertices *)
drum3DPlot[vertexValueFunction_, opts___] :=
Graphics3D[{EdgeForm[], (* add z-component from eigenvector evec *)
            Map[vertexValueFunction, 
            (* the small squares *)             
            Polygon /@ (List @@ (First /@ allRefinedInnerSquares)), {-2}],
                {GrayLevel[0], Thickness[0.006], (* drum boundary *)
                 Line /@ Map[Append[#, 0]&, drumEdges, {-2}]}},
          opts, PlotRange -> All, BoxRatios -> {1, 1, 0.4}];

(* plot Dirichlet eigenfunctions *)
eigenDVibration3DPlot[evec_, opts___] :=
With[{ev = evec/Sign[Plus @@ evec]},
     drum3DPlot[Function[v, Append[v, If[isInnerDVertexQ[v], 
                            ev[[vertexDNumber[v]]], 0]]], opts]]

Here are the eigenvibrations of the nine lowest states.

Show[GraphicsArray[#]]& /@
     Partition[eigenDVibration3DPlot /@ evecsD7Low, 2];

The 3D plots of the higher eigenvalues show generally complicated patterns of the minima and maxima. The fourth of the above states though, is very regular. It is the lowest state that is globally a product of sine functions.

Show[GraphicsArray[#]]& /@
     Partition[eigenDVibration3DPlot /@ evecsD7Sin1, 2]

Here are two higher eigenfunctions whose oscillating parts are largely concentrated in the four bay areas [✶].

Show[GraphicsArray[eigenDVibration3DPlot[
       drumEigensystem[1, Shift -> # L^2][[2, 1]]]& /@ {176.642, 525.582}]]

As an alternative to the last 3D plots and as a better visualization method for the highly oscillating higher states, we will now implement a contour plot for the Koch drum. The built-in contour plot will, of course, not work directly. Two possibilities to construct a contour plot for the semiregular shape of the Koch drum come to mind: a) Extending the Koch curve to a square array by adding vertices with value zero, and b) making independent contour plots for all of the small squares and displaying them together. We will follow the method b) in the following. (This method is more flexible and can be easily generalized to say, the triangular Koch curve) The function eigenVibrationContourPlot generates a contour graphic of the eigenvalue evec using contours contours.

(* vertex numbers inside the refined squares  *)
refinedSquareVertexArray[
 Square[mp_, {{p1_, _}, {p2_, _}, {p3_, _}, {p4_, _}}], rL_]  :=
Module[{d1 = p2 - p1, d2 = p4 - p1, vertex},
       {Table[vertex = p1 + j/rL d1 + k/rL d2;
              If[isInnerDVertexQ[vertex], vertexDNumber[vertex], 0],
              {k, 0, rL}, {j, 0, rL}],
        {Min[#], Max[#]}& /@ Transpose[{p1, p2, p3, p4}]}];
        
refinedSquareData = refinedSquareVertexArray[#, rL]& /@ allInnerSquares;

(* contour values for contours *) 
contourValues[evec_, contours_] := 
Module[{eD = Length[evec]}, (* homogeneous contour spacing *)
       #[[Round[eD/contours/2]]]& /@ 
           Partition[Sort[evec], Round[eD/contours]]]

(* contour plot inside each of the squares of the Koch drum *)
smallSquareContourPlot[evec_, {vertexArray_, meshRange_}, cvs_] :=
Module[{lcpData},
       lcpData = Map[If[# =!= 0, evec[[#]], 0.]&, vertexArray, {2}];
       Graphics[ListContourPlot[lcpData, 
       (* set options so that the single plots fit together *)
        Contours -> cvs, MeshRange -> meshRange, PlotRange -> {0, 1},
        ColorFunctionScaling -> False, ContourLines -> False, 
        ContourSmoothing -> True, ColorFunction -> GrayLevel]]]

eigenVibrationContourPlot[evec_, contours_, opts___] :=
Module[{ev = evec/Sign[Plus @@ evec], min, max, cs},
       min  = Min[ev]; max = Max[ev];
       (* scale eigenvector values to [0, 1] *)
       scaledEv = (ev - min)/(max - min);
       cvs = contourValues[scaledEv, contours];
       Block[{$DisplayFunction = Identity},
        (* make contour plots in all small squares *)
        cs = smallSquareContourPlot[scaledEv, #, cvs]& /@ refinedSquareData;
        Show[{cs, (* the Koch drum boundary *)
              Graphics[{{Hue[0], Thickness[0.008], 
                             Line /@ drumEdges}}]},
             PlotRange -> All, Frame -> False]] /. 
                               Identity -> $DisplayFunction]

Here are contour plots for the nine lowest states.

Show[GraphicsArray[#]]& /@
     Partition[eigenVibrationContourPlot[#, 30]& /@ evecsD7Low,  2]

Show[GraphicsArray[#]]& /@
     Partition[eigenVibrationContourPlot[#, 30]& /@ evecsD7Sin1, 2]

Show[GraphicsArray[#]]& /@
     Partition[eigenVibrationContourPlot[#, 30]& /@ evecsD7Sin2, 2]

Now let us look at the Weyl–Berry law. A direct call to Eigenvalues[N[MD7], -1000, …] is not realistic for most computers due to the large memory requirements (about 10 GB for a basis size of 10 times the number of eigenvalues). So, instead we will move through the spectrum and calculate 24 eigenvalues at once, align the newly calculated eigenvalues with the last batch and extract the new higher eigenvalues. Because some eigenvalues have finite multiplicity, we will align four eigenvalues. Using this method we will get the first 1000 states in about an hour with the moderate memory usage of less than 300 MB. Because the Arnoldi method gives not only the eigenvalues, but the eigenvectors too, we also form the cumulative sum of the squares of eigenvectors evecSum. And we keep a truncated version of evecSum, called evecSumSmall that sums only states for which ω≳2π/λ where λ is the length of a straight boundary segment of our Koch curve.

(* center of the next set of eigenvalues *)
nextEvalCenter[l_] := (Plus @@ Take[l, -4]/4) + 
                      (* avoid eigenvalue  *) 1/2 (l[[5]] - l[[4]])

evalNumberMax = 1000;

(* start data *)
{currentEvals, currentEvecs} = {evalsD7Low, evecsD7Low};
evalList = currentEvals; evecSum = Plus @@ (currentEvecs^2); 


While[
 (* get additional, higher eigenvalues *)
 evDim = 24;
 While[(* the next higher eigenvalues and corresponding vectors *)
 {nextEvals, nextEvecs} = 
      drumEigensystem[evDim, Shift -> L^2 nextEvalCenter[evalList]];
 (* align with last set of eigenvalues *)
 δs = #.#& /@ ((Take[evalList, {-4, -1}] - #)& /@  
                                Partition[nextEvals, 4, 1]);
 minPos = Position[δs, _?((# < 10^-6)&)];                        
 (* genuinely new eigenvalues *)
 newPosis = If[minPos =!= {{Length[δs]}} && minPos =!= {}, 
               {minPos[[1, 1]] + 4, Length[nextEvals]}, {}];
 newPosis === {}, (* in case of spectral gaps use additive shift *)  
                  evDim = Round[3/2 evDim]];
 (* update list of eigenvalues and sum of eigenvectors squared *)
 evalList = Join[evalList, Take[nextEvals, newPosis]];
 evecSum = evecSum + Plus @@ (Take[nextEvecs, newPosis]^2);
 If[Max[nextEvals] < (Pi/λ)^2, evecSumSmall = evecSum];
 (* use evalNumberMax lowest states *)
 Length[evalList] < evalNumberMax, Null]

Length[evalList]

Here are the cumulative sums of the squares of the eigenfunctions for the first 135 and all 1000 eigenfunctions. These castles over the Koch curve show a flat Thomas–Fermi interior density and pronounced spikes at the boundaries.

Show[GraphicsArray[
 Block[{DisplayFunction = Identity},
       eigenDVibration3DPlot[#, Boxed -> False]& /@ 
                               {evecSumSmall, evecSum}]]]

For the visualization of the Weyl–Berry law, we subtract the leading term A/(4π) (ω^2) to obtain a less steep curve.

{drumBoundaryLength, drumArea} = 
  {Plus @@ (Sqrt[#.#]& /@ (Subtract @@@ drumEdges)),
   Plus @@ (Sqrt[#.#]^2& /@ (Subtract @@@ (#[[2, 1]]& /@ allInnerSquares)))}

The following graphic shows that the c (ω^d) term is a good approximation for ω≲0.9 2π/λ and the a /(4π)ω term for larger ω [✶]. The fitted exponent agrees well with fractal dimension 1.5 of the Koch drum.

(* subtract volume term *)
ΔIDOS = MapIndexed[{#1, -(#2[[1]] - 1/Pi #1^2)}&, Sqrt[evalList]];
(* fit exponent *)
FindFit[Select[ΔIDOS, #[[1]] < 22&], a x^b, {{a, 0.6}, {b, 1.5}}, x]

Show[Graphics[{
{Hue[0], Thickness[0.002], Line[Table[{ω, 0.57 ω^(3/2)}, {ω, 0, 40}]]},
{Hue[0.8], Thickness[0.002], Line[Table[{ω, 32/(4Pi) ω}, {ω, 0, 60}]]},
{GrayLevel[0], PointSize[0.006], Point /@ ΔIDOS}}], 
     Frame -> True, PlotRange -> All, FrameLabel -> {"ω", "δIDOS"}]

For a boundary with more corners, we should take into account contributions 1/(128 (π^2)) for π/2 corners and -5/(1152(π^2)) for 3/2π corners [✶].

We continue with the visualization of the absolute values of the gradients for the lowest eigenstates. We use again the finite difference approximations derived above, this time for the first derivative. We now use noncentered finite difference formulas.

grad1DValue[vertex_, dir_, maxStencilWidth_, evec_] :=
Module[{jL, jR, j, α, sData, swl, vcs}, 
(* special rule for boundary vertices *)
If[isBoundaryVertexQ[vertex],
   Which[isBoundaryVertexQ[vertex + L dir] || 
         isBoundaryVertexQ[vertex - L dir], {jL, jR} = {0, 0},
         isInnerDVertexQ[vertex + L dir], {jL, jR} = {0, maxStencilWidth}, 
         isInnerDVertexQ[vertex - L dir], {jL, jR} = {maxStencilWidth, 0}],
(* go to the left and the right of an inner vertex *)
{jL, jR} = (j = 1; While[nextVertex = vertex + # j L dir;
                         j <= maxStencilWidth + 1 && 
                         isInnerDVertexQ[nextVertex], j++]; 
            j - 1)& /@ {-1, +1};     
 α = (maxStencilWidth - 1)/2; 
 (* use maxStencilPoints *)
 Which[jL > α && jR > α, {jL, jR} = {α, α},
       jL + jR > maxStencilWidth,
       If[jR >= jL, 
          jL = Min[α, jL]; jR = maxStencilWidth - jL,
          jR = Min[α, jR]; jL = maxStencilWidth - jR]]]; 
 (* the weight vector *)
 swl = stencilWeightList[1][jL, jR];
 (* approximate value of the 1D derivative *)
 vcs = Table[vertexDNumber[vertex + j L dir], {j, -jL, jR}] /.
                                           _vertexDNumber :> 0;
 (* deal special with boundary vertices *)
 Which[{jL, jR} === {0, 0}, 0, 
       vcs[[+1]] === 0, Rest[swl].evec[[Rest[vcs]]],
       vcs[[-1]] === 0, Most[swl].evec[[Most[vcs]]],
       True, swl.evec[[vcs]]]]

gradValue[vertex_, maxStencilWidth_, evec_] := Sqrt[#.#]& @
{grad1DValue[vertex, {1, 0}, maxStencilWidth, evec],
 grad1DValue[vertex, {0, 1}, maxStencilWidth, evec]}

Given a list of the absolute values of the gradient vector at the inner vertices of the Koch drum, the function eigenVibrationGrad3DPlot makes a 3D plot of the values over the Koch drum domain.

eigenVibrationGrad3DPlot[gradInnerVector_, gradBoundaryVector_, opts___] :=
     drum3DPlot[Function[v, Append[v, If[isInnerDVertexQ[v], 
                     gradInnerVector[[vertexDNumber[v]]], 
                     gradBoundaryVector[[boundaryVertexNumber[v]]]]]]]

Here are the magnitudes of the gradients for the four lowest states. The gradients have singularities due to the 270° corners of the Koch curve at some points [✶], [✶], [✶], [✶] (for better discretizations near corners, see [✶], [✶]).

(* turn of message for low order finite differences *)
Off[NDSolve`FiniteDifferenceDerivative::aord];
Off[NDSolve`FiniteDifferenceDerivative::nonopt];

Show[GraphicsArray[#]]& /@ 
Partition[eigenVibrationGrad3DPlot[
 Table[gradValue[vertexDCoordinates[k], 7, evecsD7Low[[#]]], {k, dimD}],
 Table[gradValue[boundaryVertexCoordinates[k], 7, evecsD7Low[[#]]], 
       {k, Length[boundaryVertices]}]]& /@ {1, 2, 4, 5}, 2]

We end with a small excursion into the world of eigenfunctions with Neumann boundary conditions [✶], [✶]. Now we have to take into account all boundary vertices too. This yields 17409 vertices.

dimN = Length[allRefinedVertices];

Similar to the Dirichlet case, we define various functions for numbering and checking the type of a vertex.

Do[vertexNNumber[allRefinedVertices[[k]]] = k;
   vertexNCoordinates[k] = allRefinedVertices[[k]];
   isInnerNVertex[allRefinedVertices[[k]]] = True, {k, dimN}];
   
isInnerNVertexQ[vertex_] := isInnerNVertexQ[vertex] = 
                            TrueQ[isInnerNVertex[vertex]]

This time, we also differentiate between horizontal and vertical edges.

horizontalEdges = Select[drumEdges, #[[1, 2]] == #[[2, 2]]&];
verticalEdges   = Select[drumEdges, #[[1, 1]] == #[[2, 1]]&];

{horizontalBoundaryVertices, verticalBoundaryVertices} = 
Union[Flatten[Table[#1 + j/rL (#2 - #1), {j, 0, rL}]& @@@ #, 1]]& /@ 
{horizontalEdges, verticalEdges};

Do[isHorizontalBoundaryVertex[horizontalBoundaryVertices[[k]]] = True, 
   {k, Length[horizontalBoundaryVertices]}];
   
Do[isVerticalBoundaryVertex[verticalBoundaryVertices[[k]]] = True, 
   {k, Length[verticalBoundaryVertices]}];   
   
isHorizontalBoundaryVertexQ[vertex_] := isHorizontalBoundaryVertexQ[vertex] = 
TrueQ[isHorizontalBoundaryVertex[vertex]]

isVerticalBoundaryVertexQ[vertex_] := isVerticalBoundaryVertexQ[vertex] = 
TrueQ[isVerticalBoundaryVertex[vertex]]

isBoundaryVertexQ[dir_, vertex_] := isBoundaryVertexQ[dir, vertex] = 
Which[Abs[dir] === {1, 0}, isVerticalBoundaryVertexQ[vertex],
      Abs[dir] === {0, 1}, isHorizontalBoundaryVertexQ[vertex]]

For the construction of the matrix to be diagonalized, we proceed largely as in the Dirichlet case. But this time, we continue the function symmetrically across the boundary vertices to ensure Neumann boundary conditions. We again use a stencil of length 7.

nonVanishingNMatrixElements = addVertexWeights @
Module[{maxStencilSize = 7, α, swl, centerVertex, jB},
α = (maxStencilSize - 1)/2;
swl = -stencilWeightList[2][α, α];
(tab = Table[centerVertex = allRefinedVertices[[k]]; 
       {{k, k} -> 2 swl[[α + 1]],
        Function[dir, jB =.;
        If[isBoundaryVertexQ[dir, centerVertex], jB = 0];
        Table[nextVertex = centerVertex + j L dir; 
              Which[isInnerNVertexQ[nextVertex], 
                    If[isBoundaryVertexQ[dir, nextVertex], jB = j];
                    {k, vertexNNumber[nextVertex]} -> swl[[α + 1 + j]],
                    True, (* continue symmetrically *)
                    reflectedVertex = centerVertex + jB L dir - (j - jB) L dir;
                    {k, vertexNNumber[reflectedVertex]} -> 
                                        +swl[[α + 1 + j]]], 
                    {j, 1, α}]] /@ (* horizontal and vertical neighbors *)
                    {{+1, 0}, {-1, 0}, {0, 1}, {0, -1}}}, 
                    (* all inner vertices *) {k, dimN}]) // Flatten];

We form the sparse matrix of dimension 17409×17409 with 214005 nonvanishing elements.

MN7 = SparseArray[nonVanishingNMatrixElements]

Unfortunately, because of the symmetric continuation, the resulting matrix is not symmetric. (Using a discretization scheme that has discretization points shifted by L/2, so that the boundary would lie in the middle between two points would result in a symmetric matrix [✶].)

Max[MN7 - Transpose[MN7]]

The function drumNEigensystem calculates the eigenvalues and eigenfunctions of MN7. This time we use a higher tolerance because the nonsymmetric nature of the matrix will result in numerically complex eigenvalues and eigenfunctions.

drumNEigensystem[n_, opts___] := MapAt[1/L^2 #&, Reverse /@ 
    Eigensystem[N[MN7], n, Method -> {"Arnoldi", opts, Tolerance -> 10^-12,
                BasisSize -> 20 n, MaxIterations -> 10^4}], 1]

Here are a few of the states. The lowest eigenvalue is basically zero, reflecting the u(x,y)=constant solution. As expected, some eigenvalues have small imaginary parts.

{evalsN7Low, evecsN7Low} = drumNEigensystem[12, Shift -> 0]; 
evalsN7Low

We visualize the eigenfunctions using the routine eigenNVibration3DPlot. This time, we do not show the drum outline, because the functions do not vanish on the boundary.

(* plot Neumann eigenfunctions *)
eigenNVibration3DPlot[evec_, opts___] :=
With[{ev = Re[evec]}, DeleteCases[#, _Line, Infinity]& @
     drum3DPlot[Function[v, Append[v, ev[[vertexNNumber[v]]]]], opts,
                Boxed -> False, PlotRange -> 1.01 Max[Abs[ev]] {-1, 1}]]

Here are the first few eigenfunctions.

Show[GraphicsArray[#]]& /@ Partition[
             eigenNVibration3DPlot /@ evecsN7Low[[{1, 2, 4, 5, 6, 12}]], 3]

And here are three slightly higher states that are prominently localized in the four bays.

Show[GraphicsArray[eigenNVibration3DPlot /@
              drumNEigensystem[3, Shift -> 98.8646 L^2][[2]]]]

We end here and leave it to the reader to explore more of the world of eigenvalues and eigenfunctions of 2D domains with fractal boundaries. One could now continue and investigate the distribution of the eigenvalue spacings, and the distribution of the eigenfunction values [✶], [✶], [✶], [✶]. One could calculate and analyze the eigensystems of triangular Koch drums [✶] (which are slightly less interesting, because the bay areas are less pronounced and so the eigenfunctions can not reach them easily) and other shapes (for instance the areas bounded by some of the space-filling Peano and Hilbert curves). (For experimental results on fractal Koch drums, see [✶], [✶]; for classical paths in square Koch drums, see [✶].)

Consider a quantum version of the undamped Duffing oscillator (a forced, friction-free anharmonic oscillator [✶], [✶])

i ℏ ((∂ψ(x,t))/(∂t))=-((ℏ^2)/(2m))(((∂^2)ψ(x,t))/(∂(t^2)))+(α (x^4)-β (x^2)-γ x cos(ω t))ψ(x,t)

with minimum uncertainty wave packet initial condition, localized around (Subscript[x, 0]) with mean momentum (Subscript[p, 0])

ψ(x,0)=(1/(Sqrt[(Sqrt[2 π]) (Subscript[σ, x])]))exp(-((((x-(Subscript[x, 0])))^2)/(4 (Subscript[σ, x]^2)))+((i (Subscript[p, 0]) x)/ℏ)).

For the parameters m=1, α=1/2, β=10, γ=10, ω=6, (Subscript[x, 0])=-3, (Subscript[p, 0])=10, (Subscript[σ, x])=1/4, solve the Schrödinger equation over a few periods 2π/ω and visualize the resulting ((|ψ(x,t)|)^2) for some ℏ<1 [✶], [✶], [✶].

Make an animation of the corresponding Wigner distribution [✶]

W( x,p, t)=(1/(2π ℏ))(∫_(-∞)^∞)(e^(i (p/ℏ) y))ψ(x-(y/2),t)(OverBar[ψ(x+(y/2),t)])dy

as a function of t. Color regions of positive and negative W( x,p, t) differently. W( x,p, t) obeys the differential equation [✶]

((∂ W( x,p, t))/(∂t))=-(p/m)((∂ W( x,p, t))/(∂x))-(2β x-4 α (x^3)+γ cos(ω t))((∂ W( x,p, t))/(∂p))+(ℏ^3)(α/8) x(((∂^3) W( x,p, t))/(∂(p^3))).

For the corresponding classical Duffing oscillator with the equation of motion

x''(t)-2β x(t)+4 α ((x(t))^3)=γ cos(ω t)

model the time-evolution for (10^6) particles with initial position-momentum distribution according to the above ψ(x,0). Make a corresponding animation of the time-evolution of the classical ensemble.

MinimumUncertaintyPacket[{x0_, p0_, σx_}, ℏ_] = 
1/Sqrt[Sqrt[2 Pi] σx] Exp[-(x - x0)^2/(4 σx^2) + I p0 x/ℏ];

Next, we solve the Schrödinger equation for the Duffing potential. To obtain a numerically accurate solution, we use an eighth order difference scheme and a couple thousand spatial discretization points. In addition, we will use a precision and accuracy goal of about six.

DuffingSchrödingerSolution[{ℏ_, m_, α_, β_, γ_, ω_}, {x0_, p0_, σx_}, 
                           {L_, tMax_, pag_:5}, ppL_] :=
NDSolve[{(* Schrödinger equation *)
         I ℏ D[ψ[x, t], t] == -ℏ^2/(2 m) D[ψ[x, t], {x, 2}] + 
                              (α x^4 - β x^2 - γ x Cos[ω t]) ψ[x, t],
         (* minimum uncertainty initial wave packet *)
         ψ[x, 0] == MinimumUncertaintyPacket[{x0, p0, σx}, ℏ], 
         (* Dirichlet boundary conditions *) ψ[-L, t] == 0, ψ[L, t] == 0},
         ψ, {x, -L, L}, {t, 0, tMax},
        (* option for accurate solution *)
         MaxSteps -> 10^5, PrecisionGoal -> pag, AccuracyGoal -> pag, 
         Method -> {"MethodOfLines",  Method -> StiffnessSwitching,
                    "SpatialDiscretization" -> 
                    {"TensorProductGrid", "DifferenceOrder" -> 8,
                     "MaxPoints" -> ppL, "MinPoints" -> ppL}}]

For the parameters at hand, at x=±8 the value of the Duffing potential is always greater than 1300. Taking a WKB approximation for a free particle with momentum (Subscript[p, 0]) and approximating the classical turning point to (Subscript[x, t])≈-5, this means that at x=±8, the wave function is attenuated by more than 20 orders of magnitude compared with its maximal value inside the double well. So, we can safely set ψ(x=±8,t)=0. Next, we declare the values of the parameters we will use in the following as globally visible variables. We follow the time-evolution of the packet for seven/eight periods.

(* system phase space sizes *) 
L = 8; P = 20; 
(* ℏ, m, and potential parameters *) 
ℏ = 1/3; m = 1; α = 1/2; β = 10; γ = 10;
(* wave packet parameters *) 
x0 = -3; p0 = 10; σx = 1/4; σp = ℏ/(2 σx);
(* external force and time parameters *) 
ω = 6; T = 2 Pi/ω; 𝓅 = 8; tMax = 𝓅 T;
(* animation and density plot parameters *)
framesPerPeriod = 10; pp = 256;
Δt = tMax/(𝓅 framesPerPeriod);

Using now 3600 spatial discretization points gives a solution less in than 30 minutes on a 2GHz computer.

(dsNDSol = DuffingSchrödingerSolution[{ℏ, m, α, β, γ, ω}, 
                                      {x0, p0, σx}, {L, tMax, 5.5}, 3600]) // 
                                                                      Timing

The time-dependent Duffing potential is a double well potential in which the depth/height of the two minima oscillates periodically. As a result, a wave function initially localized in one of the wells and having an average momentum comparable to the height of the middle wall of the potential, will quickly spread out over both wells. The following graphic shows this quite clearly. After each reflection as the outer potential walls, the wave function acquires a complicated interference pattern with the adiabatic bound state structure of the double well imprinted. (For the time-development of localized states in a static double-well potential, see [✶].)

DensityPlot[Evaluate[Abs[ψ[x, t]]^(1/4) /. dsNDSol[[1]]], 
            {x, -L, L}, {t, 0, tMax}, 
            PlotRange -> All, Mesh -> False, PlotPoints -> 600]

As a check for quality of solution, we check wether the wavefunction ψ is still normalized to (∫_(-L)^L)ψ(x,t)(OverBar[ψ(x,t)]) dx=1 at (Subscript[t, max]). At t=7 T, the deviation of the norm is less than 0.03%. Using precision and accuracy goal settings of 6, this error could be reduced to 0.01%. The visualizations to be created later would be visually identical, so we use the faster-to-process solution dsNDSol.

NIntegrate[Evaluate[Abs[ψ[x, tMax]]^2 /. dsNDSol[[1]]], {x, -L, L},
           MaxRecursion -> 24, PrecisionGoal -> 10] // InputForm

For comparison, here is a time evolution that starts in one well and only slowly leaks out into the neighbor well.

DensityPlot[Evaluate[Abs[ψ[x, t]]^(1/4) /. 
(* solve Schrödinger equation *)
(DuffingSchrödingerSolution[
  {0.326, 1, 0.929, 18.896, 1.767, 1.420},  
  {-1.503, 5.397, 0.476}, {7, 6, 3}, 1200])[[1]]], 
            {x, -7, 7}, {t, 0, 6}, 
            PlotRange -> All, Mesh -> False, PlotPoints -> 600];

To calculate the Wigner functions, we do not use directly its 2+1D differential equation, but rather use ψ(x,t) from above and perform a numerical Fourier transform. Given a wave functions ψ(x,t) for a fixed t, the function ΨToW generates an array of dimension d×d that approximates the Wigner functions W(t,x,p) on an equidistant grid in [-L,L]×[-P,P]. To perform the numerical Fourier transform sufficiently accurate, we use d λ points for the spatial discretization. With the notations (Subscript[y, r])=-2L+r Δy, (Subscript[p, s])=-2(Subscript[P, h])+s Δp, r=1,…,n and Δy=4L/n, Δp=4(Subscript[P, h])/n, (Subscript[P, h])=P/2, we have the following approximation of the Fourier transform through a discrete fractional Fourier transform (Subscript[ℱℱ𝒯, {α,β}])[(Subscript[{(Subscript[f, r])}, r=1,…,n])].

F(p)=(∫_(-∞)^∞)exp(i((p )/ℏ)y)f(y)dy≈(∫_(-2L)^(2L))exp(i((p )/ℏ)y)f(y)dy≈Δy(∑_(r=1)^n)exp(i((p )/ℏ)(Subscript[y, r]))f((Subscript[y, r]))
F((Subscript[p, s]))=Δy (Subscript[A, s])(Subscript[ℱℱ𝒯, {1,((4 L P)/(n π ℏ))}])[(Subscript[{(Subscript[B, r])f((Subscript[y, r]))}, r=1,…,n])]

Here (Subscript[A, s])=exp(i/ℏ( (4 L (Subscript[P, h])-Δp Δy)- Δp (2 L-Δy)s)) and (Subscript[B, r])=exp(-i/ℏ (2 (Subscript[P, h])-Δp) Δy r).

Off[Fourier::fpopt2];

ΨToW[Ψ_, {L_, P_}, ℏ_, d_, λ_] :=
Module[{𝒹 = λ d, Ph, Δy, Δp, b, As, Br, WMat, ΨL, ΨΨC, 
        tpa = Developer`ToPackedArray},
 (* fractional Fourier transform parameters *)
 Ph = P/2; Δy = 4L/𝒹; Δp = 4Ph/𝒹; b = 8. L Ph/(𝒹 π ℏ);
 Br = tpa[Table[Exp[-I/ℏ (2. Ph - Δp) Δy r], {r, 𝒹}]];
 As = tpa[Δy Table[Exp[I/ℏ ((4. L Ph - Δp Δy) - Δp (2 L - Δy) s)], {s, 𝒹}]];
 (* d×d matrix of Wigner function values *)
 Table[(* Fourier transform integrand *)
       ΨL = tpa[Table[Ψ[N[x - y/2]], {y, -2L + 4L/𝒹, 2L, 4L/𝒹}]];
       ΨΨC = ΨL Conjugate[Reverse[ΨL]];
       (* Wigner transform for fixed x *) 
       Wx = As Fourier[Br ΨΨC, FourierParameters -> {1., b}];    
       (* average over λ p-values *)
       1/(2.Pi ℏ) Plus @@@ Partition[Wx, λ],             
       {x, -L, L, 2L/(d - 1)}] // Transpose]

To display the Wigner function, we use a density plot. The Wigner function is purely real, and we color positive parts in blue and negative parts in red [✶]. The function rbColor yields the color value for 0<xM<x<xP>0. For both the quantum and the classical distribution, we will use a rescaled version to obtain a better contrast.

rbColor[x_, {xM_, xP_}] := 
With[{ξ = x/Max[Abs[{xM, xP}]]},
(* negative values in red, positive values in blue; 
   scale with largest positive or negative value *)
RGBColor[Min[If[x <= 0, 1, 1 - ξ], 1], 
         Min[If[x <= 0, 1 - Abs[ξ], 1 - Abs[ξ]], 1], 
         Min[If[x >= 0, 1, -ξ + 1], 1]]]
         
(* use a scaling to show details better *)
scaleW[W_] := Sign[W] Abs[W]^(1/4);

DuffingWignerGraphics[Ψ_, ℏ_, {L_, P_}, {d_, α_}, opts___] := 
Module[{WMat, xM, xP, WScaled},
  (* form Wigner distribution from wave function *)
  WMat = ΨToW[Ψ, {L, P}, ℏ, d, α];
  {xM, xP} = {Min[#], Max[#]}&[WScaled = scaleW[Re[WMat]]];
  (*display colored scaled Wigner distribution *)
  ListDensityPlot[WScaled, Mesh -> False, PlotRange -> All, 
                  MeshRange -> {{-L, L}, {-P, P}}, opts,
                  ColorFunction -> (rbColor[#, {xM, xP}]&),
                  ColorFunctionScaling -> False]]

Later, we will show a side-by-side animation of the time-evolution of the Wigner function and the classical distribution function. For now, we show a detailed plot of the Wigner function after three periods of the external force. The intermingled domains of red and blue show that the Wigner functions acquired a complicated inner structure already after thee periods of the driving force [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶]. The structures exist at a scale smaller than ℏ [✶], [✶], [✶], [✶], [✶], [✶].

Ψ[x_] = If[Abs[x] > L, 0. + 0. I, Evaluate[dsNDSol[[1, 1, 2]][x, 3 T]]];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
(* density and contour W == 0 graphics *)
{#, ListContourPlot[(* center part only *)
                    Map[If[Abs[#] < 0.02, 0, #]&, #[[1]], {2}],
                    Contours -> {0}, ContourShading -> False,
                    FrameTicks -> None]}&[
(* the Wigner function density plot *)
DuffingWignerGraphics[Ψ, ℏ, {8, 18}, {600, 8}, FrameTicks -> None]]]]]

Now, we come to the classical counterpart. Here are the equations of motions for the Duffing oscillator.

NewtonDuffingEquations[{m_, α_, β_, γ_, ω_}, {x_, p_}, 
                       {x0s_, p0s_, t0_}] :=
  {x'[t] == p[t]/m, p'[t] == m (2 β x[t] - 4 α x[t]^3 + γ Cos[ω t]), 
   x[t0] == x0s, p[t0] == p0s}

The overall complexity of the motion of the Duffing oscillator becomes visible by following a set of particles with initial conditions on ellipses around the origin in phase space over only 1(1/2) periods. The next graphic shows the resulting shapes of the initial ellipses [✶].

Module[{o = 24000, 𝓅 = (* 3/2 periods only *) 3/2, x0s, p0s, ndsol},
Show[Graphics[
Table[(* solve equations of motion starting with 
         initial conditions on an ellipse around {x, p} = {0, 0} *)
 {x0s, p0s} = Transpose[Table[μ {3. Cos[φ], 6. m Sin[φ]}, 
                              {φ, 0, 2Pi, 2Pi/o}]];               
 ndsol = NDSolve[NewtonDuffingEquations[{m, α, β, γ, ω}, 
                                        {x, p}, {x0s, p0s, 0}] , 
                 {x, p}, {t, 𝓅 T, 𝓅 T}, 
                 PrecisionGoal -> 8, AccuracyGoal -> 8]; 
 {Hue[0.78 (μ - 1/4)/(7/4 - 1/8)], 
  (* polygon bounding the evolved ellipse *)
  Polygon[Transpose[{x[𝓅 T], p[𝓅 T]} /. ndsol[[1]]]]},
{μ, 7/4, 1/8, -1/8}]], AspectRatio -> 1]]

We will use matrices of size 256×256 for the classical and the quantum Wigner distribution. Larger ones are of course possible, but it will take longer to calculate their values. We will generate ten frames per period T, which allows for a reasonable smooth animation. Again, more frames are possible for the price of larger calculation timings.

As the classical analog of the Wigner function time-evolution, we use (10^6) particles with initial positions and momenta according to the initial Wigner distribution. The function RandomArray from the package Statistics`ContinuousDistributions`generates arrays of normal distributed numbers quite quickly.

Needs["Statistics`ContinuousDistributions`"];

{xDist, pDist} =  NormalDistribution @@@ {{x0, σx}, {p0, σp}};

To avoid the storage of the complete trajectory interpolants, we will solve the equations of motions over a time of T/8 for 1000 particles at once, extract their final positions and momenta and keep a binned version of them in the matrices M[τ] before continuing the solution of the differential equations over the next T/8 time interval. The function counterMatrix generates a matrix of dimension pp×pp of the binned position-momentum values of a list of values xpList within the square [-L,L]×[-P,P].

counterMatrix[xpList_, L_, P_, pp_] := 
Module[{xpDiscrete = Ceiling[pp ((# + {L, P})/{2L, 2P}& /@ xpList)],
        M0 = Table[0, {pp}, {pp}], i, j}, 
        Do[If[Min[xpDiscrete[[k]]] >= 1 && Max[xpDiscrete[[k]]] <= pp,
              (* bin numbers *) {j, i} = xpDiscrete[[k]]];
           M0[[i, j]] = M0[[i, j]] + 1, {k, Length[xpDiscrete]}]; M0]

Following now one million trajectories over 8 periods of the driving force takes about 4 hours on a 2GHz computer. We will follow 1000 trajectories in parallel. This avoid the overhead of repeatedly processing the equations but does not use too much memory at one time.

Module[{o = 1000, μ = 1000, q = 100, x0s, p0s, xpList,
        M0 = Developer`ToPackedArray[Table[0, {pp}, {pp}]]},
Do[(* initialize array for time τ *) M[τ] = M0, {τ, 0, tMax, Δt}];
(* bag for {x, p}-points *)
xpBag = Table[{}, {j, μ}, {τ, 0, tMax, Δt}];  
Do[(* list of initial {x, p}-points *)
   xpList = Transpose[RandomArray[#, {o}]& /@ {xDist, pDist}];                    
   (* add values for j-th batch *) 
   M[0] = M[0] + counterMatrix[xpList, L, P, pp];   
   xpBag[[j, 1]] = Take[xpList, q];         
   (* solve ode for t-interval {0, tMax} in steps of T/framesPerPeriod *)
   Do[{x0s, p0s} = Transpose[xpList];
      ndsol = NDSolve[NewtonDuffingEquations[{m, α, β, γ, ω}, {x, p}, 
                      {x0s, p0s, τ - Δt}], {x, p}, {t, τ, τ},
                      PrecisionGoal -> 8, AccuracyGoal -> 8];
      (* update matrices *)
      xpList = Transpose[{x[τ], p[τ]} /. ndsol[[1]]];
      M[τ] = M[τ] + counterMatrix[xpList, L, P, pp];
      (* collect unbinned *)
      xpBag[[j, τ/Δt + 1]] = Take[xpList, q], {τ, Δt, tMax, Δt}], 
   {j, μ}]]; // Timing

Here are the first 50 particles of each run shown in one graphic. To color indicates the time, ranging from red (t=0) to violet (t=(Subscript[t, max])=8T). The originally localized cloud of particles follows an extremely complicated dynamics with positive Lyapunov coefficient. After a few periods, the resulting distribution has a complicated, repeatedly folded-over structure.

Show[Graphics[Reverse @
  Table[{PointSize[0.002], Hue[0.78 τ/tMax], 
               Map[Point, Transpose[xpBag][[τ/Δt + 1]], {-2}]},
        {τ, Δt, tMax, Δt}]]]

Now, we have all data together to display the animation of the time-development of the classical and quantum distribution in parallel. The function classicQuantumDistributionsGraphicsArray generates and displays a graphics array of the two distribution functions for a given τ.

classicQuantumDistributionsGraphicsArray[τ_] := 
Module[{L = 8, P = 20, λ = 12, Ψ},
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {(* classical  phase space distribution *)
  ListDensityPlot[(* scale *) M[τ]^(1/4), Mesh -> False, PlotRange -> All,
                  MeshRange -> {{-L, L}, {-P, P}},  FrameTicks -> None,
                  (* density proportional "blueness" *)
                  ColorFunction -> (RGBColor[1 - #, 1 - #, 1]&)],
 (* Wigner distribution *)    
 (* re-interpolate for fixed τ for faster value access *)   
 ΨT = FunctionInterpolation[Evaluate[If[Abs[x] > L, 0. + 0. I, 
                                       Evaluate[dsNDSol[[1, 1, 2]][x, τ]]]], 
                            {x, -2L, 2L}, InterpolationPrecision -> 8,
                            InterpolationPoints -> 8192, 
                            InterpolationOrder -> 6];
 (ℳ[τ] = (Sign[#] #^4)&[#[[1]]]; #)& @
 DuffingWignerGraphics[ΨT, ℏ, {L, P}, {pp, λ}, FrameTicks -> None]}]]]]

Using now the τ-values for which previously a snapshot of the classical distribution had been calculated, we arrive at the following animation.

Do[If[(* show only every tenth step *) IntegerQ[τ/Δt/10], 
      classicQuantumDistributionsGraphicsArray[τ],
      Block[{$DisplayFunction = Identity}, 
            classicQuantumDistributionsGraphicsArray[τ]]], 
   {τ, 0, tMax, Δt}];

Do[classicQuantumDistributionsGraphicsArray[τ], {τ, 0, tMax, Δt}];

The animation shows how increasingly complicated structures form in the Wigner distribution. As mentioned above, the resulting structures appear at a scale much smaller than ℏ. While the phase space distributions look quite different after already a few periods, the corresponding marginal distributions for x and p are much more similar to each other. The following two graphic pairs show the marginal distributions for the position and the momentum for the classical and the quantum case.

Function[Mℳ, Show[GraphicsArray[
ListPlot3D[Table[Plus @@ #1[Mℳ[τ]], {τ, 0, tMax, Δt}], 
           Mesh -> False, PlotRange -> All, Axes -> False,
           PlotLabel -> #2, DisplayFunction -> Identity]& @@@
           {{Identity, "x"}, {Transpose, "p"}}]]] /@ {M, ℳ}

And the averages of the positions and momentums do agree even better with each other. Only for times larger than the calculated ones will they start to deviate substantially. This means that the larger times displayed are in the order of the Ehrenfest time of the system [✶], [✶], [✶], [✶], [✶], [✶].

With[{T = Range[256]},
Show[GraphicsArray[ Function[{f, l},
Graphics[{{Hue[#1], Line[MapIndexed[{#2[[1]], #1}&, #/#[[1]]&[
                          Table[T.(Plus @@ f[#2[τ]]), {τ, 0, tMax, Δt}]]]]}& @@@
                                {{0.78, M}, {0.00, ℳ}}}, 
         Frame -> True, FrameTicks -> None, PlotLabel -> l]] @@@ 
         {{Identity, "x"}, {Transpose, "p"}}]]]

We could now continue and analyze the value distribution of the Wigner function [✶], but we end here.

If we would add a decoherence term to Wigner evolution, the classical and the quantum distributions would be much more similar [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶].

For other visualizations of time-dependent Wigner functions, see [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], [✶], and [✶]. For the use of the Wigner function in the time–frequency space for the classical trajectories, see [✶], [✶].

The diffraction integral for a circular aperture is [✶]

ℰ({x,y,z};a)=(1/(2π))(∫_0^(2π))(∫_0^a)ρ exp(i((ρ^3)cos(3α)-z (ρ^2)-x ρ cos(α)-y ρ sin(α)))dρ dφ

Make an animation of the curves Im(ℰ({x,y,z};a))=0 as a function of a for a small z for (x^2)+(y^2)≲10.

ℐN[{x_, y_, z_}, a_] := 
NIntegrate[ρ Exp[I (ρ^3 Cos[3 α] - z ρ^2 - x ρ Cos[α] - y ρ Sin[α])],
           {α, 0, Pi, 2Pi}, {ρ, 0, a}]

ℐN[{1, 2, 1}, 2] // Timing

Because we are interested in the values of ℰ({x,y,z};a) as a function of a, we use NDSolve with respect to a instead. This gives as values of ℰ({x,y,z};a) for all values of a at once and we only have to carry out a 1D numerical integration. We calculate the values of ℰ({x,y,z};a) on a x,y-grid in a polar coordinate system and store interpolating functions ipo. We make use of the rotational symmetry of ℰ({x,y,z};a) to calculate the values of ℰ({x,y,z};a) only in a sector.

Off[NIntegrate::"ploss"];
(* 1D integrand *)
𝒾𝓃𝓉[{x_, y_, z_}, ρ_?NumberQ] := 
NIntegrate[ρ Exp[I (ρ^3 Cos[3 α] - z ρ^2 - x ρ Cos[α] - y ρ Sin[α])],
           {α, 0, 2Pi}, PrecisionGoal -> 7,
           (* periodic integrand *) Method -> Trapezoidal]

(* parameters *)
R = 12; z = 1/10; ppφ = 16; ppr = 48; 

(* use polar coordinates to easily make use of rotational symmetry;
   x == r Cos[φ], y == r Sin[φ] *)
Do[Do[ipo[{r, φ, z}] = (* solve ODE with respect to a == ρ *)
      NDSolve[{ℰ'[ρ] == 𝒾𝓃𝓉[{r Cos[φ], r Sin[φ], z}, ρ], ℰ[0] == 0},
              ℰ, {ρ, 0, 2}, PrecisionGoal -> 4][[1, 1, 2]],
      {φ, 0, Pi/3, Pi/3/ppφ}], 
   {r, 0, R, R/ppr}]

For a given value of a, the function imZeroLinesPlot generates a plot of the lines Im(ℰ({x,y,z};a))=0.

imZeroLinesPlot[a_] :=
Module[{data, lcp, zeroImLines, (* rotation matrix *)
        ℛ = {{-1, Sqrt[3]}, {-Sqrt[3], -1}}/2.}, 
 (* data in polar coordinates *)
 data = Table[ipo[{r, φ, z}][a],
              {φ, 0, Pi/3, 2Pi/3/ppφ}, {r, 0, R, R/ppr}];
 (* contour plot of vanishing imaginary part *)
 lcp = ListContourPlot[Im[data], PlotRange -> All,
           Axes -> True, ContourShading -> False,
           DisplayFunction -> Identity,  Contours -> {0},
           MeshRange -> {{0, R}, {0, Pi/3}}];
 (* the actual contour lines *)
 zeroImLines = Cases[Graphics[lcp], _Line, Infinity];
 If[zeroImLines =!= {}, 
    (* final graphic *)
    Graphics[{{Thickness[0.002], Hue[0.78 a/2],
     (* generate the five equivalent parts *)
     {Map[ℛ.ℛ.#&, #, {-2}], Map[ℛ.#&, #, {-2}], #}&[
     {Map[{1, -1} #&, #, {-2}], #}&[
      Apply[Function[{r, φ}, {r Cos[φ], r Sin[φ]}], 
            zeroImLines, {-2}]]]},
    (* outer circle *)
    {Thickness[0.01], GrayLevel[0.5], Circle[{0, 0}, R]}},
    Frame -> True, PlotRange -> All, AspectRatio -> Automatic], 
     {}]]

Here are the curves Im(ℰ({x,y,z};a))=0 for various a shown in different colors.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{(* 2D graphic *)
 Show[Table[imZeroLinesPlot[a], {a, 2, 0, -2/12}]],
 (* 3D graphic *)
 Show[Graphics3D[
 Table[If[# === {}, {}, #[[1, 1]] /. {t_, Hue[x_], lines__} :>
           {t, Hue[x], Map[Append[#, 2x/0.78]&, {lines}, {-2}]}]&[
      imZeroLinesPlot[a]], 
      {a, 2, 0, -2/18}]], BoxRatios -> {1, 1, 3/2}, Axes -> True,
     AxesLabel -> {"x", "y", "a"}, ViewPoint -> {-1, -2, -3/4}]}]]]

And here is the corresponding animation. For an interpretation of the changing curve shape, see [✶].

Do[If[# =!= {}, Show[#, Frame -> False]]&[imZeroLinesPlot[a]],
   {a, 0, 2, 2/48}]

In its simplest form, the Cauchy–Born hypothesis states that the positions of the lattice points (atoms) of a linearly deformed elastic body is given by the linear interpolations corresponding to the bodies faces [✶], [✶], [✶], [✶], [✶]. For the simplest example of a rectangular piece of a square lattice, carry out numerical tests of the Cauchy–Born hypothesis. To model the 2D elastic body, assume linear springs between all nearest and second nearest neighbors.

shear[{x_, y_}, {{αx_, βx_}, {αy_, βy_}}] := {αx x + βx y, αy x + βy y}

Given a discretized elastic 2D body in the form of a matrix (the elements being the positions of the atoms), the function energy calculates the potential energy of the underlying spring system with lattice constants ax, ay and spring constants k1, k2. We assume that the potential energy of each spring is of the form k/2 ((Δl)^2) where Δl is the length change of the spring from its equilibrium length.

(* potential energy of a lattice with spring constants 𝓀1, 𝓀2
   and lattice constant 𝒶x_, 𝒶y *)
energy[ℒ_, {ax_, ay_}, {k1_, k2_}] :=
With[{nx = Length[ℒ[[1]]], ny = Length[ℒ]}, 
 (* horizontal and vertical springs *)
 Sum[k1/2 (𝒹[ℯ[ℒ, {ix, jy}] - ℯ[ℒ, {ix + 1, jy}]] - ax)^2, 
     {jy, 0, ny - 1}, {ix, 0, nx - 2}] +
 Sum[k1/2 (𝒹[ℯ[ℒ, {ix, jy}] - ℯ[ℒ, {ix, jy + 1}]] - ay)^2, 
     {ix, 0, nx - 1}, {jy, 0, ny - 2}] +
(* diagonal springs connecting second nearest neighbors *)
 Sum[k2/2 (𝒹[ℯ[ℒ, {ix, jy}] - ℯ[ℒ, {ix + 1, jy + 1}]] - 𝒹[{ax, ay}])^2, 
     {ix, 0, nx - 2}, {jy, 0, ny - 2}] +
 Sum[k2/2 (𝒹[ℯ[ℒ, {ix, jy}] - ℯ[ℒ, {ix - 1, jy + 1}]] - 𝒹[{ax, ay}])^2, 
     {ix, 1, nx - 1}, {jy, 0, ny - 2}]];

(* some supporting functions *) 

(* distance between two lattice points *)
𝒹[{x_, y_}] := Sqrt[x^2 + y^2];

(* extract element from the lattice *)
ℯ[ℒ_, {ix_, jy_}] := ℒ[[jy + 1, ix + 1]];

(* visualize a spring lattice *) 
latticeLines[points_] := {Line /@ points, Line /@ Transpose[points],
                          Map[Point, points, {2}]}

To test the Cauchy–Born hypothesis, we will do the following: For a given deformed spring lattice, we calculate the positions of the nonboundary atoms by linear interpolation. Then, we disturb these positions slightly and use these perturbed positions as the starting points for an energy minimization carried out by FindRoot. Because the total potential energy is just the sum of the potential energy of all springs, the potential energy is a sum of squares and we will use the especially-suited-to-this-case "LevenbergMarquardt" method option setting. The function relaxedStretchedLatticeGraphics carries out these steps. It returns a list containing the potential energy of the linearly interpolated atom positions, the potential energy found by explicit minimization, and a graphics showing the two lattice configurations. (Because we will reuse some of the variables used inside relaxedStretched2DLatticeGraphics later, we do not declare all of the variables as local to this function).

relaxedStretched2DLatticeGraphics[
 {{αx_, βx_}, {αy_, βy_}}, {{nx_, ny_}, {ax_, ay_}, {k1_, k2_}}] := 
Module[{pRule = P[xy_] :> {x[xy], y[xy]}, 
        startLattice, distortedLattice, selectVertices,
        innerVerticesRules, fm, relaxedLattice},
(* general square lattice *)
topologicalLattice = Table[P[{x, y}], {y, 0, ny - 1}, {x, 0, nx - 1}];
(* square lattice with concrete lattice constants *)
startLattice = Map[#[[1]] {ax, ay}&,  topologicalLattice, {2}];
(* stretched square lattice *)
distortedLattice = Map[shear[#, {{αx, βx}, {αy, βy}}]&, 
                       startLattice, {2}];
(* select outer and inner vertices *)
selectVertices[cdc_] := Rule @@@ cdc[Flatten[
      MapThread[List, {topologicalLattice, distortedLattice}, 2], 1],
         {P[{0 | nx - 1, _}], _} | {P[{_, 0 | ny - 1}], _}];
(* rules for fixed boundary vertices *)
boundaryVerticesRules = selectVertices[Cases];
(* rules for movable inner vertices *)
innerVerticesRules = selectVertices[DeleteCases];        
(* potential energy *)
ℰ = energy[topologicalLattice /. boundaryVerticesRules /. pRule,
           {ax, ay}, {k1, k2}];
(* initial Cauchy-Born positions *)
inits = Flatten[Transpose /@ Flatten[Take[#, {2, -2}]& /@
 Take[MapThread[List, {topologicalLattice, distortedLattice}, 2] /. 
                                           pRule, {2, -2}], 1], 1];
(* minimize potential energy *)
fm = FindMinimum[Evaluate[ℰ], Evaluate[Sequence @@ 
          ({#1, (1 + Random[Real, 10^-0 {-1, 1}]) #2}& @@@ inits)],
          Method -> "LevenbergMarquardt", MaxIterations -> 1000];
(* the relaxed lattice *)
relaxedLattice = topologicalLattice /. pRule /. fm[[2]] /.
                 (boundaryVerticesRules /. pRule);   
(* return Cauchy–Born energy, minimized energy and graphic *)          
{{ℰ /. (Rule @@@ inits), fm[[1]]},
Graphics[(* Cauchy–Born lattice in gray *)
   {{PointSize[0.022], Thickness[0.015], GrayLevel[0.8],
     latticeLines[distortedLattice]},
         (* energy-minimized lattice in blue *)
    {PointSize[0.001], Thickness[0.002], RGBColor[0, 0, 1],
     latticeLines[relaxedLattice]},
         (* lattice point distortions in red *)
    {Thickness[0.002], Hue[0], MapThread[Line[{#1, #2}]&, 
     {distortedLattice, relaxedLattice}, 2]}}, 
    AspectRatio -> Automatic, Frame -> True]}]

Using the result returned from relaxedStretched2DLatticeGraphics, the function showResult prints the two energy values and displays a graphics showing the two lattices.

showResult[args__] := 
(Print["Cauchy–Born: " <> ToString[InputForm[#1[[1]]]] <> "\n" <>
       "FindMinimum: ", ToString[InputForm[#1[[2]]]]];    
   Show[#2])& @@ relaxedStretched2DLatticeGraphics[args]

Here is a first example. We use a 6×6 lattice. The deformation is relatively small. The linearly interpolated lattice (gray lines) and the lattice found by explicit energy minimization (in blue) are identical.

showResult[{{1.1, 0.1}, {-0.1, 0.9}}, 
           {{6, 6}, {1, 1}, {1, 1}}]

Here is a larger deformation. The two lattices again agree.

showResult[{{1.6, 0.3}, {0.5, 1.5}}, {{6, 6}, {1.5, 1}, {2.5, 2}}]

But it is not difficult to find a counter example to the Cauchy–Born hypothesis. In the next example, we use again a 6×6 lattice. This time the linearly interpolated lattice (gray lines) has a considerably higher potential energy. The red lines indicate the deviations of the energy-minimized lattices positions from the linearly interpolated ones.

SeedRandom[3];
showResult[{{0.62, 0.44}, {-0.34, 1.06}}, 
           {{6, 6}, {1.98, 0.56}, {2.24, 2.34}}]

Using NMinimize we can further minimize the energy of the lattice. (FindMinimum found one local potential energy minimum, lower minima might exist elsewhere.)

NMinimize[Evaluate[ℰ], First /@ inits][[1]]

We can watch the approach to the minimum by adding damping to the spring system and letting it relax into its equilibrium state. The function solveSpringSystemODEs creates the corresponding coupled differential equations for the lattice point coordinates and solves them.

solveSpringSystemODEs[T_, γ_, δ_] :=
Module[{vars, indices, odes}, 
 (* ODE variables *)
 vars = Cases[ℰ, _x | _y, Infinity] // Union;
 indices = Union[First /@ vars];
 (* equations of motion; with damping terms *)
 odes = (#''[t] == - γ #'[t] + (-D[ℰ, #] /. 
                         xy:(_x | _y) :> xy[t]))& /@ vars;
 NDSolve[Join[odes, (* randomized initial conditions *)
              (#1[0] == (1 + δ Random[Real, {-1, 1}]) #2)& @@@ inits, 
              (#'[0] == 0)& /@ vars], vars, {t, 0, T}]];

(* the time\[Hyphen]dependent relaxing lattices *)
relaxingLattice[τ_, ndsol_] :=  topologicalLattice /. 
   boundaryVerticesRules /. P[xy_] :> {x[xy], y[xy]} /.
   xy:(_x | _y) :> xy[τ] /. ndsol[[1]]

For four different random initial conditions, we let the last spring system now relax into the equilibrium shape. Starting from different initial conditions, we see different final configurations with different final energies. The second graphic shows the time-dependence of the potential energy.

Module[{T = 20, frames = 4, o = 4, γ = 1, δ = 0.2, ndsol,
        ax = 1.98, ay = 0.56, k1 = 2.24, k2 = 2.34,
        ℰCB = 27.485, minℰ = 18.386},
  Show[GraphicsArray[#]]& /@ Transpose[Table[
  (* relax four times *)
  Table[ndsol[j] = solveSpringSystemODEs[T, γ, δ];
       (* snapshots of the relaxation process *)
        Graphics[latticeLines[relaxingLattice[τ, ndsol[j]]],
                 Frame -> False], {τ, 0, T, T/frames}], {j, o}]];
  (* time\[Hyphen]dependent potential energy *)
  Show[Graphics[
  {{Thickness[0.006], GrayLevel[0.5], Line[{{0, minℰ}, {T, minℰ}}]},
   {Thickness[0.006], GrayLevel[0.0], Line[{{0, ℰCB}, {T, ℰCB}}]},
   Table[{(* color each run differently *) Hue[0.78 (j - 1)/(o - 1)], 
         Line[Table[{τ, energy[relaxingLattice[τ, ndsol[j]],  
                               {ax, ay}, {k1, k2}]},
                    {τ, 0, T, T/25}]]}, {j, o}]},
                    Frame -> True,
        PlotRange -> {1/2 minℰ, 2 minℰ}]]]

We end with some graphics showing violations of the Cauchy–Born hypothesis for some larger lattices. (For a detailed analysis of the local shape of the deformations, see [✶].)

Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, showResult @@@
 {{{{0.63383, -0.10383}, {-0.422062, 1.36884}},
   {{16, 16}, {0.85177, 0.71945}, {1.24497, 1.48163}}},
  {{{1.11238, -0.25194}, {-0.023546, 0.519724}},
   {{16, 16}, {0.84189, 1.81386}, {0.43108, 0.99715}}},
  {{{0.89331, -0.03642}, { 0.0533719, 0.751591}},
   {{16, 16}, {0.69912, 0.68504}, {2.03383, 2.53343}}}}]]]

The Schwarz–Christoffel map from the unit disk to a nonintersecting simple polygon 𝒫 with vertices (Subscript[w, k]) is given by [✶], [✶]

f (z)=α+β(∫_0^z)(∏_(k=1)^n)(((1-(ζ/(Subscript[z, k]))))^((Subscript[α, k])-1))dζ

where f(z)∈𝒫 for |z|≤1 and f((Subscript[z, k]))=(Subscript[w, k]) and (Subscript[α, k]) π are the counterclockwise-oriented interior angles of the polygon. Calculate a numerical approximation to a Schwarz–Christoffel map for an L-shaped polygonal domain with vertices {0,2,2+i,1+i,1+2i,2i}. Visualize the resulting conformal map.

wList = {0, 2, 2 + I, 1 + I, 1 + 2 I, 2 I} - (1 + I)/2;

αList = {Pi/2, Pi/2, Pi/2, 3Pi/2, Pi/2, Pi/2}/Pi;

Show[Graphics[
  {Thickness[0.02], Line[{Re[#], Im[#]}& /@ Append[wList, First[wList]]],
   {Hue[0], PointSize[0.04], Point[{0, 0}]}},
    PlotRange -> All, AspectRatio -> Automatic, Frame -> True]]

Calculating the Schwarz–Christoffel map boils down to determining the preimages (Subscript[z, k]) of the vertices and the two constants α and β. The last two constants can be determined by prescribing the position of two vertices. We will use the two vertices on the symmetry axis Re(z)=Im(z) (the first and the fourth vertex). And taking the symmetry of the L-shaped domain into account, the only two unknowns are the points (Subscript[z, 2]) and (Subscript[z, 3]). Because the boundary of the unit disk gets mapped to the boundary of the polygon, we write (Subscript[z, k])=exp(i (Subscript[φ, k])) and we are left with determining the two values (Subscript[φ, 2]) and (Subscript[φ, 3]). For given values of  (Subscript[φ, 2]) and (Subscript[φ, 3]), the function makeSymmetriczList gives the list of all six vertices of the L-shaped polygon.

makeSymmetriczList[{φ2_, φ3_}] = 
{Exp[I 5Pi/4], Exp[I φ2], Exp[I φ3], Exp[I Pi/4],
 Exp[I Pi/4] Conjugate[Exp[-I Pi/4] Exp[I φ3]],
 Exp[I Pi/4] Conjugate[Exp[-I Pi/4] Exp[I φ2]]};

Using numerical integration, the function wValues calculates the positions of the six vertices for given values (Subscript[φ, 2]) and (Subscript[φ, 3]).

wValues[{φ2_, φ3_}] :=
Module[{zs, ws, αβSol},
 zs = makeSymmetriczList[{φ2, φ3}];
 ws = Table[NIntegrate[Evaluate @ (Times @@ ((1 - ζ/zs)^(αList - 1))), 
                       {ζ, 0, zs[[j]]}], {j, 6}];
 (* position first and fourth vertex through α and β *)
 αβSol = Solve[{wList[[1]] == α + β ws[[1]], 
                wList[[4]] == α + β ws[[4]]}, {α, β}][[1]];
 (* return linear map and mapped points *)
 {αβSol, α + β ws /. αβSol}]

Minimizing now the sum of squares of the distances of the mapped preimages of the vertices should yield a minimum with value 0 and the values of (Subscript[φ, 2]) and (Subscript[φ, 3]) for the Schwarz–Christoffel map.

g[{φ2_?NumberQ, φ3_?NumberQ}] := Plus @@ (Abs[wList - wValues[{φ2, φ3}][[2]]]^2)

fm = FindMinimum[g[{φ2, φ3}], {φ2, -1, -1.1},  {φ3, 0.5, 0.4}]

So, we obtain the following parameters and integrand for the map.

(* constants α and β for the final map *)
{αF, βF} = {α, β} /. wValues[{φ2, φ3} /. fm[[2]]][[1]];

(* the final z_k values *)
finalZs = makeSymmetriczList[{φ2, φ3} /. fm[[2]]];

(* the final integrand *)
scM[ζ_] = N[(Times @@ ((1 - ζ/finalZs)^(αList - 1)))]

To visualize the map we will not use NIntegrate, but rather NDSolve. For a given direction 𝒹, we solve the differential equation corresponding to the integral in f(z) radially outward.

solveODERadial[𝒹_] := NDSolve[{w'[t] == 𝒹 scM[𝒹 t], w[0] == 0}, w, 
                              {t, 0, 1 - 10^-10}]

(* radial distances for equi-lines *)
pp = 24;
tPoints = Join[Table[t, {t, 0, 1 - 1/pp, 1/pp}], {0.986, 0.9999}];

data = Table[ndsol = solveODERadial[Exp[I φ]];
             ((αF + βF w[#])& /@ tPoints) /. ndsol[[1]], 
             {φ, 0, 2Pi, 2Pi/360}];

(* the mapped points *)
ε = 10^-6;
data = Table[ndsol = solveODERadial[Exp[I φ]];
             ((αF + βF w[#])& /@ tPoints) /. ndsol[[1]], 
             {φ, Pi/4 + ε, 9/4 Pi - ε, (2Pi - 2 ε)/360}];

Show[Graphics[
{(* the L-shaped dpolygon *)
 {Hue[0], Thickness[0.006], Line[{Re[#], Im[#]}& /@ 
  Append[wList, First[wList]]]},
 (* equi-lines and perpendicular curves *)
 {GrayLevel[0.5], MapIndexed[If[IntegerQ[#2[[1]]], 
                                Line[{Re[#], Im[#]}& /@ #], {}]&, data]},
 {GrayLevel[0], Line[{Re[#], Im[#]}& /@ #]& /@ Transpose[data]}}], 
      PlotRange -> All, Frame -> True, AspectRatio -> Automatic]

The last graphic shows the effect of crowding: near the left lower corner, the curves perpendicular to the equi-lines cluster and in the arms the become relatively widely spaced. To get a more homogeneously spaced equi-line graphic, we will now solve the differential equation azimuthally and use ParametricPlot to get adaptively refined smooth equi-curves.

solveODEAzimuthal[ρ_, {φ1_, φ2_}] := 
With[{w0 = αF + βF NIntegrate[scM[ζ], {ζ, 0, ρ Exp[I φ1]}]}, 
     NDSolve[{w'[φ] == βF ρ I Exp[I φ] scM[ρ Exp[I φ]], w[φ1] == w0}, w, 
             {φ, φ1, φ2}]]

contract[{a_, b_}] := With[{mp = (a + b)/2, lh = (b - a)/2, δ = 1 - 10^-10},
                           {mp - δ lh, mp + δ lh}]

φRanges = contract /@ 
           Partition[Append[#, 2Pi + First[#]]&[Arg[finalZs // N]], 2, 1];

The function SmoothPlotAzimuthal generates the plots from the list of  InterpolatingFunction returned by NDSolve.

makeSmoothPlotAzimuthal[ρ_, ipo_InterpolatingFunction] := 
ParametricPlot[{Re[ipo[φ]], Im[ipo[φ]]}, Evaluate[Flatten[{φ, ipo[[1, 1]]}]],
               PlotPoints -> 120, DisplayFunction -> Identity]

makeSmoothPlotAzimuthal[ρ_, l_List] := 
    Show[makeSmoothPlotAzimuthal[ρ, #]& /@ 
                   Cases[l, _InterpolatingFunction, Infinity]]

We also display some of the perpendicular curves, namely the ones ending at the vertices of the L-shaped polygon and at the midpoints of its edges.

makeSmoothPlotRadial[𝒹_, ipo_InterpolatingFunction] := 
ParametricPlot[{Re[αF + βF ipo[t]], Im[αF + βF ipo[t]]}, 
               Evaluate[Flatten[{t, ipo[[1, 1]]}]],
               PlotPoints -> 120, DisplayFunction -> Identity,
               PlotStyle -> {{GrayLevel[0.5], Thickness[0.003]}}]

makeSmoothPlotRadial[𝒹_, l_List] := Show[makeSmoothPlotRadial[𝒹, #]& /@ 
                             Cases[l, _InterpolatingFunction, Infinity]]

(* calculate the mapped point position *)
of[φ_?NumberQ] := Module[{res},
                         Off[NIntegrate::ncvb];
                         res = αF + βF NIntegrate[scM[ζ], {ζ, 0, Exp[I φ]}];
                         On[NIntegrate::ncvb]; res];

(* calculate z-values corresponding to the midpoints of the L edges *)
edgeMidpointZs = 
(Exp[I Re[φ]] /. FindRoot[of[φ] - #1, {φ, #2[[1]], #2[[2]]},
                          PrecisionGoal -> 8])& @@@ 
Transpose[{(Plus @@@ Partition[Append[wList, First[wList]], 2, 1]/2.),
           Partition[Append[#, 2Pi + First[#]]&[Arg[finalZs // N]], 2, 1]}]

Along the curve to the midpoint of the second polygon edge, we calculate equi-line radii that are approximately homogeneously spaced.

𝒻[t_] = αF + βF (w /. solveODERadial[edgeMidpointZs[[2]]][[1]])[t];

i𝒻 = Interpolation[Table[{Re[𝒻[t]], t}, {t, 0, 1, 1/12}]];

ρs = Table[i𝒻[t], {t, Re[𝒻[0]], Re[𝒻[1]], (Re[𝒻[1]] - Re[𝒻[0]])/15}]

Now we obtain smooth, approximately homogeneously spaced equicurves up to near the polygon boundary.

Show[{Graphics[{Hue[0], Thickness[0.01], Line[{Re[#], Im[#]}& /@ 
                Append[wList, First[wList]]]}], 
      (* radial orthogonal curves *)
      Function[𝒹, makeSmoothPlotRadial[𝒹, solveODERadial[𝒹]]] /@ 
                                   Join[finalZs, edgeMidpointZs],
      (* smooth equi-cuves *)
      Function[ρ, makeSmoothPlotAzimuthal[ρ, 
                  solveODEAzimuthal[ρ, #]& /@ φRanges]] /@ 
                  (* radii for homogeneously spaced equi-lines *)           
                                         Append[Most[ρs], 0.998]},
          PlotRange -> All, AspectRatio -> Automatic,
          DisplayFunction -> $DisplayFunction];

We end with a visualization of the Schwarz–Christoffel map of a more complicated polygon.

(* vertices of a polygon in the complex plane *)
wList = With[{s = Sqrt[3]}, {1 + I s, 2 + 2 I s, 1 + 3 I s, -3 + 3 I s, 
               -2 + 2 I s, 2 I s, -2, -4, -5 - I s, -3 - 3 I s, -2 - 2 I s, 
               -3 - I s, 1 - I s, 2 - 2 I s, 4 - 2 I s, 6, 4, 3 - I s}/2];

equiAndFieldCurves[equiValues_List] := 
Module[{αList, φs, φEs, φL, β, zs, w0, eqs, ρ, ϕ1, ϕ2, ndsol, pp, 
        curve, ℛ, ω, opts, R = 1 - 10^-12},
 (* angles in units of π of the polygon *)
 αList =  1/3 {4, 2, 2, 1, 2, 5, 4, 2, 2, 1, 2, 5, 4, 2, 2, 1, 2, 5};       
 (* parameters for the Schwarz-Christoffel map *)
 φs = {1.880275011280091, 2.074403517501587, 2.084559146579438, 
       2.087831881871811, 2.087952818861801, 2.094395102393195};
 (* parameters for edge midpoints *)
 φEs = {2.056709598824023, 2.0812111099343658, 2.0875447164599064,
        2.087856604171078, 2.0882552129179253, 2.5163592862103163};
 β = 0.813037054574698 - 0.56337234858643208 I;
 (* rotation matrices *)
 Do[ℛ[k] = N[{{Cos[k 2Pi/3], Sin[k 2Pi/3]}, {-Sin[k 2Pi/3], Cos[k 2Pi/3]}}], 
    {k, 0, 2}];
 (* graphics options; allow unlimited subdivision *)
 optsG = Sequence[PlotPoints -> 100, PlotDivision -> Infinity, 
                     MaxBend -> 3, DisplayFunction -> Identity];
 (* NDSolve options *)
 optsD = Sequence[PrecisionGoal -> 12, AccuracyGoal -> 12, 
                  WorkingPrecision -> 25];                    
 (* all preimages of the 18 vertices *)
 zs = Join[Exp[I φs], Exp[2Pi I/3] Exp[I φs], Exp[4Pi I/3] Exp[I φs]];
 (* equi- and filed lines *)
 {(* equilines *)
  Table[ρ = equiValues[[j]]; ϕ1 = φs[[1]]; ϕ2 = ϕ1 + 2/3 Pi;
  (* starting value for differential equations *)
  w0 = β NIntegrate[Evaluate @ SetPrecision[(Times @@ ((1 - ζ/zs)^(αList - 1))), 30], 
                    Evaluate @ {ζ, 0, SetPrecision[ρ zs[[1]], 30]},
                    MaxRecursion -> 20, PrecisionGoal -> 14, WorkingPrecision -> 30];
  (* solve differential equation azimuthally *)
  eqs = {1/(I ρ Exp[I φ]) Y'[φ] == β (Times @@ ((1 - ρ Exp[I φ]/zs)^(αList - 1))),
         Y[ϕ1] == w0};
  ndsol = NDSolve[SetPrecision[eqs, 30], Y, {φ, ϕ1, ϕ2}, optsD];
  (* make plot of curve *)
  pp = ParametricPlot[Evaluate[{Re[Y[φ]], Im[Y[φ]]} /. ndsol[[1]]], 
                     {φ, ϕ1, ϕ2}, Evaluate[optsG]];
  (* rotate curve in other positions *)
  curve = Cases[pp, _Line, Infinity];
  Table[Map[ℛ[k].#&, curve, {-2}], {k, 0, 2}], {j, Length[equiValues]}],
 (* field lines from the origin to the 18 polygon vertices *) 
 φL = Join[φs, φEs];
 Table[ω = φL[[j]]; Clear[ρ];
 eqs = {1/(Exp[I ω]) Y'[ρ] == β (Times @@ ((1 - ρ Exp[I ω]/zs)^(αList - 1))),
        Y[0] == 0};
  (* solve differential equation radially *)
  ndsol = NDSolve[SetPrecision[eqs, 30], Y, {ρ, 0, R}, optsD];
  (* make plot of curve *)
  pp = ParametricPlot[Evaluate[{Re[Y[ρ]], Im[Y[ρ]]} /. ndsol[[1]]], 
                     {ρ, 0, R}, Evaluate[optsG]];
  curve = Cases[pp, _Line, Infinity];
  (* rotate curve in other positions *)
  Table[Map[ℛ[k].#&, curve, {-2}], {k, 0, 2}], {j, 12}]}]

Module[{(* equi-values to be used *)
        equiList = {0.1, 0.3, 0.5, 0.7, 0.88, 0.96, 0.99, 0.997, 
                    0.999, 0.9996, 0.99992, 0.99997, 0.9999988}, λ, 
                    equiCurves, fieldCurves},
       λ = Length[equiList];
       (* equi- and field curves *)
       {equiCurves, fieldCurves} = equiAndFieldCurves[equiList];
       (* make graphics *)
       Show[Graphics[
        {(* polygon in thick gray *)
         {Thickness[0.008], GrayLevel[1/2], 
          Line[{Re[#], Im[#]}& /@ Append[wList, First[wList]]]}, 
         (* field curves in black *)
         {Thickness[0.002], GrayLevel[0], fieldCurves},
         (* colored equi-curves *)
         {Thickness[0.002], MapIndexed[{Hue[0.78 (#2[[1]] - 1)/(λ - 1)], #}&, 
                                        equiCurves]}}], 
             AspectRatio -> Automatic, PlotRange -> All]];

The Banzhaf index of a voting system is defined in the following way [✶], [✶]: Given n parties (Subscript[p, k]), each having a (nonnegative) voting weight (Subscript[v, k]) (not necessary integer), (2^n)-1 possible coalitions can be formed through all subsets of the n parties. A coalition is winning, if its combined voting weight is larger than a given quota q (typically 50% or 66.67% of the sums of all weights (Subscript[ν, k])). Let ω be the total number of winning coalitions that can be formed, and let (Subscript[ω, k]) be the number of coaltions that contains the party (Subscript[p, k]). Then the Banzhaf index (Subscript[η, k]) of the party (Subscript[p, k]) is defined as (Subscript[η, k])=2(Subscript[ω, k])-ω. The normalized Banzhaf index (Subscript[(OverTilde[η]), k]) is (Subscript[(OverTilde[η]), k])=(Subscript[(OverTilde[η]), k])/(2^(n-1)). Implement a function that calculates the normalized Banzhaf indices for given party weights and quotas.

We start with implementing a functions that counts the winning coalitions in general and for each party. Because we want later apply our function to a list of 25 parties (meaning we will have to analyze 33554432 coalitions), we use the function Compile, for speed reasons. To avoid excessive memory use, we do not create a list of all possible coalitions and keep it, but rather generate and analyze the possible coalitions sequentially. Each possible coalitions corresponds naturally to the base 2 representation of an integer between 1 and (2^n)-1 (if the kth digits is a one, the party (Subscript[p, k]) is part of the coalition, otherwise not). For each quota, we compare the combined coalition power with the quotas and increment the counters for the winning coalitions. Because Compile cannot return ragged arrays, we define the subsidiary function winningCoalitionDataC that forms the nested lists of total winning coalitions and winning coalitions that the individual parties are members of.

winningCoalitionDataC[partyPowers_List, quotas_List] :=
Module[{resC = winningCoalitionDataMainC[partyPowers, quotas]},
 (* separate total number of winning coalitions from party counters *)
 Transpose[{Take[resC, Length[quotas]], 
            Partition[Drop[resC, Length[quotas]], Length[partyPowers]]}]]

winningCoalitionDataMainC =
Compile[{{partyPowers, _Real, 1}, {quotas, _Real, 1}},
Module[{o = Length[partyPowers], n = Length[quotas], L, l, weight, 
        winningCoalitionCounters, winningParticipatingCoalitionCounters}, 
        l = Array[1&, {o}]; L = Array[1&, {o}];
        (* winning coalition counters *)
        winningCoalitionCounters = Array[0&, {n}];
        winningParticipatingCoalitionCounters = Table[Array[0&, {o}], {n}];
 (* loop of all possible (2^n - 1) coalitions *)
 Do[(* coalition weight *)
    l = IntegerDigits[k, 2, o]; weight = l.partyPowers;
    (* compare colation weight with all quotas *)
    Do[If[weight > quotas[[j]], 
          (* increase coalition counters *)
          winningCoalitionCounters[[j]] =  winningCoalitionCounters[[j]] + 1;
          winningParticipatingCoalitionCounters[[j]] = 
                 winningParticipatingCoalitionCounters[[j]] + l],
       {j, n}],
    {k, 2^o}];
  (* form one list because Compile must return a tensor *)
  Join[winningCoalitionCounters, 
       Flatten[winningParticipatingCoalitionCounters]]],
                                          {{_IntegerDigits, _Integer, 1}}];

The function winningCoalitionDataMainC compiled flawlessly.

Union[Head /@ Flatten[winningCoalitionDataMainC[[4]]]]

Here is a simple example for five parties. Seven winning coalitions can be formed to reach a 2/3 majority.

winningCoalitionDataC[{5, 4, 3, 2, 1}, {10}]

Plus @@ {5, 4, 3, 2, 1}

Here is the list of EU country weights.

weightsEU = (* appriximate square root of population 
               measured in million people *)
            {9.09 (* Germany *), 7.72 (* France *), 7.69 (* U.K. *), 
             7.55 (* Italy *), 6.38 (* Spain *), 6.18 (* Poland *), 
             4.02 (* Netherlands *), 3.32 (* Greece *), 3.23 (* Portugal *), 
             3.22 (* Belgium *), 3.19 (* Czech Republic *), 3.19 (* Hungary *), 
             2.99 (* Sweden *), 2.84 (* Austria *), 2.32 (* Denmark *), 
             2.32 (* Slovakia *), 2.28 (* Finland *), 1.99 (* Ireland *), 
             1.86 (* Lithuania *), 1.53 (* Latvia *), 1.41 (* Slovenia *), 
             1.17 (* Estonia *), 0.89 (* Cyprus *), 0.67 (* Luxembourg *), 
             0.63 (* Malta *)};

To obtain a 51% majority vote, approximately 15 million winning coalitions can be formed. Analyzing all possible 33 million coalitions takes only minutes.

winningCoalitionDataC[weightsEU, {0.51 (Plus @@ weightsEU)}] // Timing

Given the counts of the winning coalitions, it is straightforward to define the Banzhaf indices.

BanzhafIndices[partyPowers_, quotas_] := 
  ((2 #2 - #1)/2^(Length[partyPowers] - 1))& @@@ 
             winningCoalitionDataC[partyPowers, quotas]

BanzhafIndicesNormalized[partyPowers_, quotas_] := 
  #/(Plus @@ #)& /@ BanzhafIndices[partyPowers, quotas]

For a 51% majority vote, the Banzhaf indices deviate substantially from the country weights. The larger countries have too much weight, and the smaller to little.

BanzhafIndicesNormalized[weightsEU, {0.51 (Plus @@ weightsEU)}] // N

To obtain a quota such that the country weights agree approximately with their Banzhaf indices, we will minimize the sum of the squares of the differences between the country weights and their Banzhaf indices. The function votingResiduals defines the square root of these sum of squares.

votingResiduals[partyPowers_, quotas_] :=
Module[{bhN = BanzhafIndicesNormalized[partyPowers, quotas], 
        sqL = #/(Plus @@ #)&[partyPowers]},
       Sqrt[Plus @@ ((# - sqL)^2)]& /@ bhN]

The function votingResidualsTable generates a list of the just-defined sums of squares for pp quotas from the interval [quota0,quota1].

votingResidualsTable[partyPowers_, {quota0_, quota1_}, pp_] :=
Module[{relQuotas = Table[q, {q, quota0, quota1, (quota1 - quota0)/pp}], 
        weightSum = Plus @@ partyPowers},
 Transpose[{relQuotas, votingResiduals[partyPowers, relQuotas weightSum]}]]

For comparison, we 10 times choose randomly 18 party weights that are uniformly, exponentially, and normally distributed. Approximate equality between the given voting power and the Banzhaf indices happens for quotas around 60% … 65%.

SeedRandom[1]

Module[{partyPowers, parties = 18, elections = 10, quotas = 50}, 
Show[GraphicsArray[
 Function[𝓅, Graphics[
  Table[partyPowers = Table[𝓅[Random[]], {parties}];
        (* random color for each party-weight list *)
        {Hue[Random[]], PointSize[0.006], Point /@ 
               votingResidualsTable[partyPowers, {0.5, 0.75}, quotas]}, 
        {elections}], 
       PlotRange -> All, Frame -> True, Axes -> False, Frame -> True]] /@
       (* uniform, exponential, and normal distribution *)
       {Identity, -Log[1 - #]&, Abs[2 + InverseErf[2 # - 1]]&}]]];

For the current EU weights, we obtain approximate equality between the given voting power and the Banzhaf indices for a quota of 62%. Zooming into the minima (right graphic) shows that 62% is an excellent approximation for the optimal quota.

(res = votingResidualsTable[weightsEU, {0.5, 0.75}, 50]); // Timing
resD = votingResidualsTable[weightsEU, {0.615, 0.625}, 25];
Show[GraphicsArray[
      ListPlot[#, PlotRange -> All, Frame -> True, Axes -> False,
               DisplayFunction -> Identity]& /@ {res, resD}]]

Because the voting weights all have two decimal digits, not a single point-minimum for the sum of squares can be found. The next graphic shows a close-up around the minimum. The optimal quota is the interval [0.6201, 0.6202] and the square root of the differences becomes about 0.000309. Also, at this resolution, the sum of squares is no longer a monotonic function to the left and right of the optimal quota.

resD = votingResidualsTable[weightsEU, {0.619, 0.621}, 100];
Show[GraphicsArray[
      ListPlot[#, PlotRange -> All, Frame -> True, Axes -> False,
               DisplayFunction -> Identity]& /@ {resD}]]

Make an animation showing how an initially localized perturbation evolves on a torus under the wave equation

(((∂^2)ψ(t;(Subscript[φ, 1]),(Subscript[φ, 2])))/(∂(t^2)))=Δ ψ(t;(Subscript[φ, 1]),(Subscript[φ, 2]))
Δ=(1/(Sqrt[g((Subscript[φ, 1]),(Subscript[φ, 2]))]))(∑_(i,j=1)^2)(∂/(∂(Subscript[φ, i])))((Sqrt[g((Subscript[φ, 1]),(Subscript[φ, 2]))])(g^(i j))((Subscript[φ, 1]),(Subscript[φ, 2]))(∂/(∂(Subscript[φ, j])))).

Here (Subscript[g, i j])((Subscript[φ, 1]),(Subscript[φ, 2])) is the metric tensor and g((Subscript[φ, 1]),(Subscript[φ, 2])) its determinant.

Use the torus parametrization x=((Subscript[r, 1])+(Subscript[r, 2])cos((Subscript[φ, 2])))cos((Subscript[φ, 1])),  y=((Subscript[r, 1])+(Subscript[r, 2])cos((Subscript[φ, 2])))sin((Subscript[φ, 1])),  z=(Subscript[r, 2])sin((Subscript[φ, 2])).

(* calculate g_ij *)
𝓍𝓎𝓏 = {(r1 + r2 Cos[φ[2]]) Cos[φ[1]], (r1 + r2 Cos[φ[2]]) Sin[φ[1]], r2 Sin[φ[2]]};
{𝓍𝓎𝓏φ1, 𝓍𝓎𝓏φ2} = D[𝓍𝓎𝓏, #]& /@ {φ[1], φ[2]};
gll = {{𝓍𝓎𝓏φ1.𝓍𝓎𝓏φ1, 𝓍𝓎𝓏φ1.𝓍𝓎𝓏φ2}, {𝓍𝓎𝓏φ1.𝓍𝓎𝓏φ2, 𝓍𝓎𝓏φ2.𝓍𝓎𝓏φ2}}

The line element has a very simple form.

g = Det[gll] // Simplify

And here is the Laplace operator in (Subscript[φ, 1]), (Subscript[φ, 2])-coordinates [✶], [✶].

(* calculate g^ij *)
guu = Factor //@ Together //@ Inverse[gll];
Sum[1/Sqrt[g] D[Sqrt[g] guu[[i, j]] D[Ψ[φ[1], φ[2]], φ[i]], φ[j]], 
    {i, 2}, {j, 2}] // FullSimplify

We will, of course, solve the wave equation numerically for the torus. In the following, we choose the parameters (Subscript[r, 1])=2 and (Subscript[r, 2])=1.

r1 = 1; r2 = 1/2;

For an animation, we have to calculate many frames. To carry out the numerical PDE solution in an memory-efficient manner, we will use the functions NDSolve`ProcessEquations and NDSolve`Iterate. The following input sets up the problem. We use an initially localized, smooth perturbation. Because of the periodic boundary conditions in (Subscript[φ, 1]), (Subscript[φ, 2]), we use the "Pseudospectral" method setting for the method of lines.

{state} = 
NDSolve`ProcessEquations[{D[u[t, φ1, φ2], t, t] == 
   1/r2^2 D[u[t, φ1, φ2], φ2, φ2] - 
   Sin[φ2]/(r1 + r2 Cos[φ2]) D[u[t, φ1, φ2], φ2] +
   1/(r1 + r2 Cos[φ2])^2 D[u[t, φ1, φ2], φ1, φ1],
  (* periodic boundary conditions in φ1, φ2 *)
  u[t, -Pi, φ2] == u[t, +Pi, φ2],
  Derivative[0, 1, 0][u][t, -Pi, φ2] == Derivative[0, 1, 0][u][t, +Pi, φ2],
  u[t, φ1, -Pi] == u[t, φ1, +Pi],
  Derivative[0, 0, 1][u][t, φ1, -Pi] == Derivative[0, 0, 1][u][t, φ1, +Pi],
  (* initial perturbation *)
  u[0, φ1, φ2] == If[Sqrt[φ1^2 + φ2^2] < 1/3 Pi, 
                 (Sign[#] #^2)&[Cos[3/2 Pi Sqrt[φ1^2 + φ2^2]/(1/3 Pi)]], 0], 
  Derivative[1, 0, 0][u][0, φ1, φ2] == 0},
  {}, t, {φ1, -Pi, Pi}, {φ2, -Pi, Pi},
  (* option settings for the numerical solution *)
  MaxSteps -> 10^5, PrecisionGoal -> 2, AccuracyGoal -> 2, 
  Method -> {"MethodOfLines", "SpatialDiscretization" -> 
              {"TensorProductGrid", "DifferenceOrder" -> "Pseudospectral", 
               "MaxPoints" -> {120, 60}, "MinPoints" -> {120, 60}}}]

To visualize the propagation of the perturbation on the torus surface, we implement a function coloredTorusPlot3D. Unperturbed regions ψ((Subscript[φ, 1]),(Subscript[φ, 2]))≈0 are shown in green, positive perturbations ψ((Subscript[φ, 1]),(Subscript[φ, 2]))>0 in red, and negative perturbations ψ((Subscript[φ, 1]),(Subscript[φ, 2]))<0 in blue. In addition, we represent the size of the perturbations as deformations of the torus in its local normal direction.

coloredTorusPlot3D[sols_, {ppφ1_, ppφ2_}, opts___] := 
Module[{α = 1/4, torusPoint, torusNormal, data, points, toColor, polys},
 (* point and normal on the torus *)
 torusPoint[{φ1_, φ2_}, r1_, r2_] = {r1 Cos[φ1] + r2 Cos[φ1] Cos[φ2],
                        r1 Sin[φ1] + r2 Sin[φ1] Cos[φ2], r2 Sin[φ2]};
 torusNormal[{φ1_, φ2_}, r1_, r2_] =  
             {Cos[φ1] Cos[φ2], Cos[φ2] Sin[φ1], Sin[φ2]};
 (* scaled perturbations *)
 data = Table[Evaluate[{{φ1, φ2}, ArcTan[25 sols[[1, 2]]]/(Pi/2)}], 
              {φ1, -Pi, Pi, 2Pi/ppφ1}, {φ2, -Pi, Pi, 2Pi/ppφ2}]; 
 (* add perturbations in normal direction *)
 points = Apply[(torusPoint[#1, r1, r2] + 
                α r2 #2 torusNormal[#1, r1, r2])&, data, {2}];
 (* color according to perturbations *)
 toColor[x_] := SurfaceColor[#, #, 2.2]&[
                RGBColor[UnitStep[x] x, 1 - Abs[x], -UnitStep[-x] x]];
 (* polygons *)
 polys = Table[{toColor[(data[[i, j, 2]] + data[[i + 1, j, 2]] + 
                         data[[i + 1, j + 1, 2]] + data[[i, j + 1, 2]])/4], 
                Polygon[{points[[i, j]], points[[i + 1, j]], 
                         points[[i + 1,j + 1]], points[[i, j + 1]]}]}, 
               {i, Length[data] - 1}, {j, Length[data[[1]]] - 1}];
 (* graphics of the torus with perturbations *)
 Graphics3D[{EdgeForm[], polys}, opts, Boxed -> False, Axes -> False,
            PlotRange -> {{-2, 2}, {-2, 2}, {-3/4, 3/4}},
            (* view toward initial perturbation *) 
            ViewPoint -> {3, 0, 2.4}]]

Now, it is straightforward to propagate the solution forward in time and to visualize the resulting wave propagation. The function waveEquationTorusAnimation generates the actual animation.

waveEquationTorusAnimation[ΔT_, frames_, DoTable_, showIt_, {ppφ1_, ppφ2_}] := 
Module[{uCurrent},
DoTable[(* visualize solution *) 
        (* solve wave equation in time steps *)
        NDSolve`Iterate[state, j ΔT];
        (* form current solution *)
        uCurrent = NDSolve`ProcessSolutions[state, "Forward"];
        showIt @ coloredTorusPlot3D[uCurrent, {ppφ1, ppφ2}],
        {j, 0, frames}]]

And here is the resulting animation. Due to the superposition of the wave contributions along different rays, we see complicated time-dependent patterns emerge. Interestingly, in the beginning the initial pulse splits into four single pulse, two traveling along the “small” circumference and two traveling along the “large” circumference. From the 2D nature of the torus surface one might expect a approximately radial propagation of the initial disturbance. So, in some sense, the wave propagation on this torus is more in (ℝ^1)×(ℝ^1) than in (ℝ^2).

Show[GraphicsArray[#]]& /@ 
     Partition[waveEquationTorusAnimation[2/3, 8, Table, Identity, {240, 120}], 3]

waveEquationTorusAnimation[1/10, 90, Do, Show, {240, 120}]

Numerics Volume, Chapter 2

Show through numeric integration that the following integral [✶], [✶]

(∫_0^∞)cos(2z)((∏_(k=1)^∞)cos((z/k)))dz

equals π/8 to 42 digits. For the numerical calculation of the infinite product, make use of the expansion

ln(cos(z))=(∑_(j=1)^∞)(((((-1))^j) (2^(2 j-1)) ((4^j)-1) )/(j (2 j)!))(Subscript[B, 2j])(z^(2j))

valid for |z|<π/2. Here the (Subscript[B, k]) are the Bernoulli numbers.

Module[{z = 1, cosT}, 
       cosT = Table[Cos[N[z, 22]/k], {k, 1000}];
       ListPlot[Log[10, Abs[1 - cosT]]]];

To speed up the calculation of the infinite product, we split it into two parts:

(∏_(k=1)^∞)cos((z/k))=((∏_(k=1)^(Subscript[k, 0]))cos((z/k)))((∏_(k=(Subscript[k, 0])+1)^∞)cos((z/k)))=((∏_(k=1)^(Subscript[k, 0]))cos((z/k)))exp((∑_(k=(Subscript[k, 0])+1)^∞)ln(cos((z/k))))

Here (Subscript[k, 0]) has to be chosen in such a way that z/((Subscript[k, 0])+1)<π/2 and the above expansion applies. The first product we calculate directly by carrying out the multiplications. For the tail part, we use the above expansion of ln(cos(x)).

(∑_(k=(Subscript[k, 0])+1)^∞)ln(cos((z/k)))=(∑_(k=(Subscript[k, 0])+1)^∞)(∑_(j=1)^∞)(((((-1))^j) (2^(2 j-1)) ((4^j)-1) )/(j (2 j)!))(Subscript[B, 2j]) ((((z/k)))^(2j))
=(∑_(j=1)^∞)(((((-1))^j) (2^(2 j-1)) ((4^j)-1) )/(j (2 j)!))(Subscript[B, 2j]) ζ(2j,(Subscript[k, 0])+1)(z^(2j))

Here ζ(s,a)=(∑_(k=a)^∞)(k^(-s)). This definition yields immediately the recursion ζ(s,a+1)=ζ(s,a)-(a^(-s)) starting with ζ(2j,1)=| (2^(2 j-1)) (π^(2 j)) (Subscript[B, 2 j])/(2 j)!|.

To calculate the last sum efficiently for many values of x, we write the terms of the sums a s a product of three terms: a (Subscript[k, 0])- and z-independent one, one that contains the (Subscript[k, 0])-dependent term and the one that contains the z-dependent one. Only the last has to be calculated for each value of z. The (Subscript[k, 0])-dependent terms we calculate recursively once. This yields the following implementation of a function makeListDefinitions that calculates kMax globally visible lists L2[k0] and the globally visible list L1 to precision prec.

$MaxExtraPrecision = 10000;

makeListDefinitions[o_, kMax_, prec_] :=
 (Clear[L1, L2, L2E];
  (* k0-independent terms *)
  L1 = Table[((-1)^j 2^(2j - 1) (4^j - 1) BernoulliB[2j])/(j (2j)!), 
             {j, o}] // N[#, prec]&; 
  (* calculate k0-dependent terms recursively *)
  L2E[1] = Table[(-1)^(j - 1) 2^(2j - 1) Pi^(2j) BernoulliB[2j]/(2j)!, {j, o}];      
  L2E[a_] := L2E[a] =  With[{temp = L2E[a - 1] - Table[(a - 1)^(-2j), {j, o}]}, 
                            (* save memory *) L2E[a - 1] =.; temp];  
  L2[k0_] := L2[k0] = L2E[k0 + 1] // N[#, prec]&;
   (* make all L2's in order *)
  Do[L2[k0], {k0, kMax}];)

Using the lists L1 and L2 calculated through a call to makeListDefinitions allows to calculate the infinite product through the function cos∞Product.

cos∞Product[z_?NumberQ, z0_:1] := 
Module[{k0 = Ceiling[Abs[z/z0]], p1, p2, z2 = z^2}, 
       If[z == 0, 1, 
          (* direct product of first cosines *)
          p1 = Product[Cos[z/k], {k, k0}]; 
          (* infinite tail approximation *)
          L3 = NestList[(# z2)&, z2, Length[L1] - 1]; 
          p2 = Exp[(L1 L2[k0]).L3]; 
          (* product of initial and tail terms *) p1 p2]]

Using 50 terms in the tail sum, we can reliably calculate the product for a visualization. The left graphic shows the product, and the right graphic shows the base 10 logarithm of its absolute value. We see an exponential decay for increasing z.

makeListDefinitions[50, 50, 50]

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
       {Plot[cos∞Product[z], {z, 0, 2Pi}, PlotRange -> All],
        Plot[Log[10, Abs[cos∞Product[z]]], {z, 0, 20 Pi}, 
             PlotRange -> All, PlotPoints -> 100]}]]]

Here is a view on the real part and the argument of the product over the complex plane.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {(* 3D plot of the real part *)            
  Plot3D[Re[cos∞Product[x + I y]], {x, -2Pi, 2Pi}, {y, -1, 1}, 
         PlotRange -> All, Mesh -> False, PlotPoints -> 200],
  (* contour plot of the argument *)
  ContourPlot[Arg[cos∞Product[x + I y]], {x, -2Pi, 2Pi}, 
              {y, -3/2, 3/2}, PlotRange -> All,
              PlotPoints -> 200, ColorFunction -> (Hue[0.78 #]&)]}]]]

To quantify the decay of the product along the real axis we fit a straight line to the successive local maxima.

Fit[Reverse[Rest[FoldList[{#2[[1]], Max[#2[[2]], #1[[2]]]}&, 
                    {-Infinity, -Infinity}, Rest[Reverse[
       Table[{z, Log[10, Abs[cos∞Product[N[z, 50]]]]},  
             {z, 0, 20 Pi, 20 Pi/111}]]]]]], {z}, z] // N

We see that Π(x)∝(10^(-2x/3)). Using this result, we define a function zMax that for a given precision goal pg for the integral under consideration, gives an upper integration limit so that the precision goal is met.

zMax[pg_] := Ceiling[3/2 pg] + (* to be save *) 10

Now, we must determine how many terms kMax to take into account in the L1, L2 lists. When calculating the actual values of the product, we must make sure to calculate each function values with a sufficient precision. The sum in the exponent becomes less precise for increasing z.

With[{ζ = 50}, ListPlot[Log[10, N @ Abs[L1 L2[ζ] Table[ζ^(2 k), {k, 50}]]]]];

Approximately, we have (Subscript[σ, k])(z)∝(10^(-2k/5)) where (Subscript[σ, k])(z) is the kth term in the sum.

Fit[Log[10, N @ Abs[L1 L2[50] Table[50^(2 k), {k, 50}]]], {k}, k]

makeListDefinitions[75, 75, 100];
Fit[Log[10, N @ Abs[L1 L2[75] Table[75^(2 k), {k, 75}]]], {z}, z]

Given the upper integration limit zMax, we define a function kMax that yields the number of needed terms kMax.

kMax[zMax_] := Ceiling[5/2 zMax] + (* to be save *) 10

Now, we have all ingredients together to define the function integrateCosProduct that carries out the numerical integration and yields a pg-digits approximation of the integral. We use the GaussKronrod method and split the integration interval into subintervals of length δZ.

integrateCosProduct[pg_, wPrec_:Automatic, 
                    δZ_:2Pi, showFunctionEvaluations_:True] := 
Module[{Z, 𝓀, H, g2, sum = 0}, 
 If[wPrec === Automatic, wp = 3 pg, wp = wPrec];
 (* calculate needed z-range and number of terms *) 
 Z = zMax[pg]; 𝓀 = kMax[Z]; H = Ceiling[Z/δZ]; 
 (* prepare fast numerical evaluation of the product *) 
 makeListDefinitions[𝓀, Ceiling[H δZ], wp];
 (* define function to integrate *)
 g2[z_?NumberQ] := Cos[2 z] cos∞Product[z];
 (* integrate g2 in intervals *) 
 Do[int = NIntegrate[g2[z], {z, j δZ, (j + 1) δZ}, 
                      WorkingPrecision -> wp, Method -> GaussKronrod, 
                      PrecisionGoal -> pg, AccuracyGoal -> pg,
                      MaxRecursion -> 8];
    sum = sum + int, {j, 0, H - 1}];
(* return integral *) N[sum, pg]]

integrateCosProduct[50]

Interestingly, the difference to π/8 is only 7.4((…10)^(-43)).

N[Pi/8, 50]

Find integers (Subscript[a, k])∈{1,2,3,4}, such that the following identity holds within 100 digits of precision.

(Subscript[a, 0])+(1/(((Subscript[a, 1])/π)+(1/(((Subscript[a, 2])/π)+(1/(((Subscript[a, 3])/π)+(1/…)))))))=(Subscript[a, 0])+((Subscript[a, 1])/π)+((Subscript[a, 2])/(π^2))+((Subscript[a, 3])/(π^3))+…

nextBestApproximation[cA_, 𝒸_, n_, o_] :=
Module[{λ = Length[cA](*, minδ, prec, cASeriesPart, 𝒸NList, cfF, 
        newTerms, L, aux, bS*)},
 (* difference between continued fraction and power series *)
 minδ = Infinity; 
 (* precision needed for a reliable calculation *)
 prec = Ceiling[Abs[Log[10, N[𝒸^(λ + n)]]]] + 20; 𝒸N = N[𝒸, prec]; 
 (* existing power series part--avoid multiple evaluation *)
 cASeriesPart = cA.(𝒸N^Range[0, λ - 1]); 
 (* powers of the constant *)
 𝒸NList = 𝒸N^Range[Length[cA], λ + n - 1];
 (* factors of the continued fraction *)
 cfF = Table[If[j == 0, 1, 𝒸N], {j, 0, λ + n - 1}];
 (* new series terms *)
 newTerms = Table[t[k], {k, n}];
 (* find best possible of the o^n possible continuations *)
 Do[L = Join[cA, newTerms];
    (* difference between continued fraction and power series *)
    aux = Abs[FromContinuedFraction[cfF L] - cASeriesPart - newTerms.𝒸NList];
    If[aux < minδ, minδ = aux; bS = L],
    (* generate iterators *)
    Evaluate[Sequence @@ ({#, o}& /@ newTerms)]]; 
 (* return best sequence continuation and difference *)
   {bS, N @ minδ}]

If we do not take enough “look ahead” terms, the process of finding the next series terms gets stuck.

NestList[nextBestApproximation[Drop[#[[1]], 
             If[Length[#[[1]]] < 2, 0, -2]], 1/Pi, 3, 4]&, 
         {{}, Infinity}, 20]

Next, we use six “look ahead” terms and discard five of them after each call to nextBestApproximation. This time, we do not get stuck so early.

NestList[nextBestApproximation[Drop[#[[1]], 
             If[Length[#[[1]]] < 5, 0, -5]], 1/Pi, 6, 4]&, 
        {{}, Infinity}, 20]

Running now the following input for several hours, we get the sequence we are looking for.

NestList[((* see progress *) Print[#]; 
          nextBestApproximation[Drop[#[[1]], 
                  Max[0, Length[#[[1]] - 7]]], 1/Pi, 8, 4])&, 
         {{}, Infinity}, 12]

πCFPSSequence = {1, 2, 1, 1, 4, 1, 3, 1, 3, 3, 3, 4, 2, 3, 3, 2, 3, 4, 3, 2, 3, 
  4, 4, 3, 2, 3, 3, 1, 2, 3, 4, 2, 4, 2, 1, 4, 1, 2, 1, 2, 2, 2, 1, 4, 1, 2, 3, 
  3, 1, 3, 3, 3, 4, 4, 1, 2, 4, 3, 4, 3, 4, 4, 3, 4, 4, 4, 1, 4, 1, 3, 4, 4, 1, 
  4, 4, 4, 3, 4, 1, 2, 3, 1, 2, 1, 3, 3, 4, 1, 2, 3, 4, 3, 3, 3, 3, 2, 2, 4, 3, 
  4, 2, 4, 3, 4, 4, 1, 3, 4, 4, 2, 1, 4, 4, 3, 4, 1, 1, 2, 2, 3, 3, 1, 1, 2, 4, 
  1, 4, 1, 3, 1, 1, 3, 3, 4, 2, 3, 4, 3, 3, 2, 1, 1, 4, 1, 1, 4, 1, 3, 1, 2, 3, 
  1, 2, 1, 4, 4, 2, 4, 3, 2, 4, 1, 2, 3, 3, 2, 1, 3, 3, 2, 3, 1, 3, 2, 3, 4, 2, 
  3, 1, 3, 3, 2, 1, 1, 1, 4, 3, 3, 4, 4, 1, 4, 1, 3, 4, 4, 1, 4, 2, 1, 4, 3, 1, 
  2, 1, 2, 4, 2, 4, 4, 2, 1, 2, 2, 1, 2, 1, 3, 4, 1, 3, 2, 2, 3, 4, 1, 3, 3, 4, 
  2, 3, 1, 2, 2, 3, 3, 1, 4, 1, 4, 1, 1, 3, 1, 4, 2, 4, 3, 1, 1, 1, 4, 2, 4, 1, 
  4, 4, 3, 3, 2, 3, 3, 2, 3, 3, 1, 1, 1, 4, 1, 1, 2, 2, 2, 4, 2, 1, 1, 2, 2, 4,
  1, 3, 4, 4, 1, 2, 1, 1, 4, 1, 2, 2, 2, 3, 3, 3, 2, 4, 3, 1, 4, 3, 3, 2, 4, 1, 
  2, 3, 3, 4, 4, 3, 1, 1, 1, 3, 3, 2, 3, 1, 2, 4, 3, 4, 3, 2, 2, 1, 1, 2, 1, 3, 
  1, 3, 3, 3, 2, 4, 2, 2, 2, 3, 4, 3, 3, 2, 2};

The sequence has about 350 terms.

Length[πCFPSSequence]

The difference between the continued fraction and the power series is less than (10^(-100)).

(* value of the continued fraction *)
cfL = MapIndexed[If[#2[[1]] === 1, 1, 1/Pi]#1&, πCFPSSequence];

(* value of the power series *)
cfS = MapIndexed[#1 (1/Pi)^(#2[[1]] - 1)&, πCFPSSequence];

(* difference *)
(FromContinuedFraction[N[cfL, 300]] - Total[cfS]) // N

FromContinuedFraction[N[cfL, 300]] // N[#, 30]&

Make 3D visualizations of the argument of the cyclotomic polynomials Arg((Subscript[C, k])(z)) over the complex z-plane.

Show[GraphicsArray[ 
Block[{k = 5, $DisplayFunction = Identity}, 
  {Plot3D[Evaluate[Arg @ Cyclotomic[8, x + I y]], 
                   {x, -2, 2},{y, -2, 2}, PlotPoints -> 60],
   ParametricPlot3D[{r Cos[φ], r Sin[φ], Arg[Cyclotomic[5, r Exp[I φ]]]}, 
                 {r, 0, 2.5}, {φ, 0, 2Pi}, PlotPoints -> 60, 
                 BoxRatios -> {1, 1, 0.6}]}]]]

The next function CyclotomicBranchCutLines calculates the curves along which the above discontinuities occur.

CyclotomicBranchCutLines[o_] :=
Module[{L = 2.5, επ = Pi 10^-8, εe = E 10^-8, cls, 
        lines, branchCutLines}, 
 (* contour plot of the curves Im[Cyclotomic[o, z]] == 0 *)
 cls = ContourPlot[Evaluate[Im @ Cyclotomic[o, x + I y]], 
                   {x, -L + επ, L}, {y, -L + εe, L}, PlotPoints -> 60, 
                   Contours -> {0}, ContourShading -> False,
                   DisplayFunction -> Identity];
 (* extract curves *)
 lines = Flatten[Partition[#[[1]], 2, 1]& /@ 
                  Cases[Graphics[cls], _Line, Infinity], 1];    
 (* select curve segments where Cyclotomic[o, x + I y] < 0 *)
 branchCutLines = Line /@ Select[lines, (#.#&[Plus @@ #/2] > 1 &&
                          Re[Cyclotomic[o, (Plus @@ #/2).{1, I}]] < 0)&]]

Here are the curves of discontinuity of Arg((Subscript[C, k])(z)) for k=1,…,36 shown. All curves originate from the unit circle, which contains the zeros of the cyclotomic polynomials.

Module[{oMax = 36},
Show[Graphics[{{GrayLevel[0.5], Thickness[0.02], Circle[{0, 0}, 1]}, 
              {Thickness[0.004],
               Table[{Hue[0.8o/oMax], CyclotomicBranchCutLines[o]}, 
                     {o, 1, oMax}]}}], PlotRange -> All, 
                     AspectRatio -> Automatic, Frame -> True]]

To avoid the steep vertical walls in the 3D graphics above, we will now partition the complex z-plane into wedges bound by the lines of discontinuity. In general, these lines will be described by complicated polynomial roots. For a visualization, it is enough to obtain the curves numerically. We do this by solving the corresponding differential equation radially outwards. The function cyclotomicArgPlot3D does this, then partitions the wedges into quadrilaterals, and finally constructs the corresponding 3D polygons.

cyclotomicArgPlot3D[o_, R_, {ppr_, ppφ_}] :=
Module[{ε = 10^-8, im, zeroArgs, ode, ndsols}, 
 (* imaginary part of the cyclotomic polynomial *)
 im = ComplexExpand[Im[Cyclotomic[o, x + I y]]];
 (* position of zeros on the unit circle *)
 zeroArgs = Sort[N[Arg[z /. Solve[Cyclotomic[o, z] == 0, z]], 30]];
 (* solve ODE for Im[Cyclotomic[o, z]] == 0 radially outwards *)
 ode = D[im /. {x -> r Cos[φ[r]], y -> r Sin[φ[r]]}, r];
 ndsols = NDSolve[{ode == 0, φ[1] == #}, φ, {r, 1, R},
                  PrecisionGoal -> 12, WorkingPrecision -> 20]& /@ zeroArgs;
 (* make wedges without discontinuities *)
 rs = Table[r, {r, 1, R, (R - 1)/ppr}];
 φTab = Flatten[φ[#] /. ndsols]& /@ rs;
 φRanges = Transpose[({#1 + ε, #2 - ε}& @@@ 
                     Partition[Append[#, First[#] + 2Pi], 2, 1])& /@ φTab];
 (* points in the wedges *)
 zs = Table[Table[rs[[k]] Exp[I φ], 
            {φ, φRanges[[j, k, 1]], φRanges[[j, k, 2]],
             (φRanges[[j, k, 2]] - φRanges[[j, k, 1]])/ppφ}],
           {j, Length[φRanges]}, {k, Length[rs]}];      
 (* points in the wedges *)
 points = Map[{Re[#], Im[#], Arg[Cyclotomic[o, #]]}&, #, {2}]& /@ zs;
 (* polygons in for the 3D plot *)
 patches = Table[Polygon[{#[[i, j]], #[[i, j + 1]],  
                          #[[i + 1, j + 1]], #[[i + 1, j]]}],
                 {i, Length[#] - 1}, {j, Length[#[[1]]] - 1}]& /@ points;
 (* polygons inside the unit circle;
    use azimuthal wedge subdivision for smooth transition *)
 pprI = Ceiling[(R - 1)/R ppr];
 zsI = Table[Table[k/pprI Exp[I φ], 
             {φ, φRanges[[j, 1, 1]], φRanges[[j, 1, 2]],
              (φRanges[[j, 1, 2]] - φRanges[[j, 1, 1]])/ppφ}],
             {j, Length[φRanges]}, {k, 0, pprI}];                      
 pointsI = Map[{Re[#], Im[#], Arg[Cyclotomic[o, #]]}&, #, {2}]& /@ zsI;
 patchesI = Table[Polygon[{#[[i, j]], #[[i, j + 1]],  
                           #[[i + 1, j + 1]], #[[i + 1, j]]}],
                 {i, Length[#] - 1}, {j, Length[#[[1]]] - 1}]& /@ pointsI;                
 (* color polygon according to argument of cyclotomic polynomial *)
 coloredPolygons = Join[patches, patchesI] /.
        p_Polygon :> {SurfaceColor[#, #, 2.2]&[
          Hue[0.78 ((Plus @@ (Last /@ N[p[[1]]])/4) + Pi)/(2 Pi)]], p};                
 (* show graphic *)
 Show[Graphics3D[{EdgeForm[], coloredPolygons}, BoxRatios -> {1, 1, 0.4},
       Axes -> False, Boxed -> False]]]

Here are the 3D graphics of  Arg((Subscript[C, 2])(z)),  Arg((Subscript[C, 3])(z)), and  Arg((Subscript[C, 4])(z)).

Show[GraphicsArray[cyclotomicArgPlot3D[#, 2.5, {36, 36}]& /@ {2, 3, 5}]];

And here is the corresponding graphic for  (Subscript[C, 11])(z).

cArg = cyclotomicArgPlot3D[11, 2.5, {36, 36}]

The last graphic tempts one to do an animation showing a rotating version of the last graphic.

frames = 60;
Do[ℛ = {{Cos[φ], Sin[φ], 0}, {-Sin[φ], Cos[φ], 0}, {0, 0, 1}} // N;
   Show[cArg /. Polygon[l_] :> Polygon[ℛ.#& /@ l]],
   {φ, 0, 2Pi (1 - 1/frames), 2Pi/frames}]

Symbolics Volume, Chapter 1

The virial series of the dD ideal Bose gas p(ρ)=(∑_(k=1)^∞)(Subscript[c, k]^((d)))(ρ^k) is defined implicitly through the two series p(z)=(∑_(k=1)^∞)(Subscript[α, k]^((d)))(z^k) and ρ(z)=(∑_(k=1)^∞)k (Subscript[α, k]^((d)))(z^k) where (Subscript[α, k]^((d)))=(k^(-d/2-1))(here p is the pressure, ρ the density, and z the fugacity) [✶], [✶], [✶], [✶], [✶]. For d=4, the series p(ρ) is conjectured to have the convergence radius (π^2)/6 (=ζ(d=4)) [✶]. Calculate a truncated form of p(ρ) and its associated diagonal Padé approximation. The smallest root of the denominator of the Padé rational function approximates the convergence radius [✶], [✶]. Confirm to three digits that the convergence radius is (π^2)/6.

makepOfρSeries[o_, d_, prec_] := 
Module[{b, zOfρSeries},
 b[k_] := k^(-d/2 - 1);
 zOfρSeries = InverseSeries[N[Sum[k b[k] z^k, {k, o}], prec] + 
                            O[z]^(o + 1), ρ];
 Normal[Sum[b[k] zOfρSeries^k, {k, o}]]];

While we can in principle get an exact result for the first terms, they grow quickly in size and no obvious pattern for a closed-form of the coefficients comes to mind.

Factor /@ makepOfρSeries[6, d, Infinity]

For even dimensions, the coefficients become rational numbers.

makepOfρSeries[12, 4, Infinity]

For explicit numeric coefficients, the series coefficients do not grow in size and we can easily calculate, say, 250 terms of the series for p(ρ).

pOfρSeries = makepOfρSeries[250, 4, 200];
(* do last terms have verified digits? *) Precision[pOfρSeries]

Applying the root test to the so-calculated series coefficients shows that the convergence radius is a number near (π^2)/6≈1.64493….

kRoots = MapIndexed[If[#1 != 0, {#2[[1]], Abs[#1]^(-1/#2[[1]])}, 
                     Sequence @@ {}]&, CoefficientList[pOfρSeries, ρ]];
ListPlot[kRoots]

SequenceLimit[Drop[Last /@ kRoots, 50], WynnDegree -> 10]

Assuming a singularity of the form (((ρ-(SuperStar[ρ])))^α), we can use the Domb–Sykes interpolation [✶] to approximate the singularity (SuperStar[ρ]). Taking the last 20 series terms into account, this results again in a value for (SuperStar[ρ]) that is different from (π^2)/6 by only 0.02%.

clρ = CoefficientList[pOfρSeries, ρ];
pairs = Partition[Take[MapIndexed[{#2[[1]], #1}&, 
                                  Rest[clρ]], All], 2, 1];
ratios = {1/#[[2, 1]], #[[2, 2]]/#[[1, 2]]}& /@ pairs;
(* interpolate term[n]/term[n - 1] as a function of 1/n *)
1/Coefficient[Fit[ratios, {1, x}, x], x, 0] - Pi^2/6 // N

Now, we form the [100/100] diagonal Padé approximation from the series pOfρSeries and extract its denominator.

Needs["Calculus`Pade`"]

pOfρApproxDen[ρ_] = Pade[pOfρSeries /. c_ ρ^k_ :> SetPrecision[c, 400] ρ^k, 
                         {ρ, 0, 100, 100}] // Denominator;

Calculating the smallest root gives an approximation for the convergence radius that deviates from (π^2)/6 by only 0.04%.

roots = Roots[SetPrecision[N[pOfρApproxDen[ρ], 120], Infinity] == 0, ρ];

Min[Abs[Cases[N[roots, 40], _?NumberQ, Infinity]]] - Pi^2/6

Consider the following approximate quadrature formula [✶]:

(∫_a^b)f(x)dx≈(∑_(k=0)^o)((Subscript[α, k]^((o)))(((∂^k)f(x))/((∂^k)x))(Subscript[|, x=a])+(Subscript[β, k]^((o)))(((∂^k)f(x))/((∂^k)x))(Subscript[|, x=((a+b)/2)])+(Subscript[γ, k]^((o)))(((∂^k)f(x))/((∂^k)x))(Subscript[|, x=b])).

Calculate the (Subscript[α, k]^((o))), (Subscript[β, k]^((o))), and (Subscript[γ, k]^((o))) for 0≤o≤10 by requiring exactness of the above approximation for polynomials of the largest possible degree. What are the errors of the resulting formulas for the integral (∫_0^(π/2))sin(x)dx?

Before trying to calculate the coefficients, we observe two obvious simplifications. From the symmetry of the integral follows (Subscript[α, k]^((o)))=(((-1))^k)(Subscript[γ, k]^((o))), and from inserting units of length follows that the (Subscript[α, k]^((o))), (Subscript[β, k]^((o))), and (Subscript[γ, k]^((o))) are proportional (((b-a))^(k+1)). The last observation is crucial in avoiding large calculations using nonnumerical quantities and reduces all calculations to solving a linear system of equations with rational coefficients.

makeQuadratureFormula[o_, (* initial degree *) d0_:1, 𝒻_:F] := 
Module[{d = d0, f, lhs, rhs, eqs, sol, solO},
While[(* quadrature formula is exact for polynomials *)
 f[x_] := Sum[c[j] x^j, {j, 0, d}];
 lhs = Integrate[f[x], {x, a, b}];
 (* the right-hand side of the quadrature formula *)
 rhs = Sum[(b - a)^(k + 1) (α[k] Derivative[k][𝒻][a] + 
                            β[k] Derivative[k][𝒻][(a + b)/2] +
                            (-1)^k α[k] Derivative[k][𝒻][b]), {k, 0, o}];
 (* solve linear system *)
 vars = Flatten[Table[{α[j], β[j]}, {j, 0, o}]];
 eqs = Flatten[CoefficientList[#, {a, b}]& /@ 
               DeleteCases[Flatten[CoefficientList[lhs - (rhs /. F -> f), 
                                   Table[c[k], {k, 0, o}]]], 0]];
 sol = Factor //@ Together //@ Solve[eqs == 0, vars]; 
 sol =!= {}, (* increase polynomial degree *) solO = sol; d++]; 
 (* format result *) Factor /@ (rhs /. solO[[1]])]

SetOptions[RowReduce, Method -> OneStepRowReduction]; 
Off[Solve::svars];

Some experimentation with makeQuadratureFormula shows that the maximal polynomial degree is 3 (o+1)-o mod 2. Taking this into account allows avoiding the looping over the polynomial degree. makeQuadratureFormula1 is the resulting function.

makeQuadratureFormula1[o_, 𝒻_:F] := 
makeQuadratureFormula[o, 3 (o + 1) - Mod[o, 2], 𝒻]

Here are the first three resulting quadrature formulas.

makeQuadratureFormula1[0]

makeQuadratureFormula1[1]

makeQuadratureFormula1[2]

Here is the resulting quadrature formula for o=10.

makeQuadratureFormula1[10]

For the integral (∫_0^(π/2))sin(x)dx, the error of the resulting formulas is approximately (10^(-4.5o)).

Table[{o, 1`50 - makeQuadratureFormula1[o] /. 
          {a -> 0, b -> Pi/2, F -> Sin}}, {o, 0, 10}] // N

For generalizations of quadrature rules that contain derivatives, see [✶].

The MacMahon master theorem states that, for an arbitrary matrix (Subscript[((Subscript[a, ij])), 1≤i,j≤d]) and indeterminates (Subscript[x, k]), the coefficients of the following expressions are identical [✶]:

[(Subscript[x, 1]^(Subscript[k, 1]))(Subscript[x, 2]^(Subscript[k, 2]))… (Subscript[x, d]^(Subscript[k, d]))]((1/(Subscript[det((Subscript[δ, ij])-(Subscript[a, ij])(Subscript[x, j])), 1≤i,j≤d])))=[(Subscript[x, 1]^(Subscript[k, 1]))(Subscript[x, 2]^(Subscript[k, 2]))… (Subscript[x, d]^(Subscript[k, d]))]((∏_(j=1)^d)((((∑_(m=1)^d)(Subscript[a, jm])(Subscript[x, m])))^(Subscript[k, j])))

Write a function that, for an explicitly given d, verifies the MacMahon master theorem for all monomials (Subscript[x, 1]^(Subscript[k, 1]))(Subscript[x, 2]^(Subscript[k, 2]))… (Subscript[x, d]^(Subscript[k, d])) with (∑_(j=1)^d)(Subscript[k, j])≤o by explicit calculation of the coefficients. Check the theorem for all 1≤d,o≤5.

checkMacMahonMasterTheorem[d_Integer?Positive, o_Integer?Positive] := 
Module[{a, x, τ, det, invDetSeries, xMonomials},
       (* list of the indeterminates *)
       xMonomials = Table[x[j], {j, d}];
       (* the determinant, make homogeneous with τ *)
       det = Det[IdentityMatrix[d] - Table[a[i, j] x[j], {i, d}, {j, d}]] /. 
                 x[j_] :> τ x[j];
       (* series of the inverse determinant in τ *)
       invDetSeries = (Series[1/det, {τ, 0, o}] // Normal // Expand) /. τ -> 1;
       (* extract coefficients of monomials in the series terms *)
       terms = Internal`DistributedTermsList[invDetSeries, xMonomials][[1]];
       (* form right-hand-side for a given exponent vector, 
          extract coefficient and subtract *)
       ((If[Union[#1] === {0}, 1, Plus @@ Cases[
           Expand[Times @@ (Table[Sum[a[i, j] x[j], {j, d}], {i, d}]^#)], 
                 _ (Times @@ (xMonomials^#1)), {If[d === 1, 0, 1]}] /. 
                      _x -> 1] - #2)& @@@ terms) // (Union[#] === {0})&]

Of course, the MacMahon master theorem holds for all 1≤d,o≤5.

Table[checkMacMahonMasterTheorem[i, j], {i, 5}, {j, 5}] // Flatten // Union

The Adler–Moser polynomials (Subscript[θ, k])(z) [✶] defined recursively through

(Subscript[θ, n]^′)(z)(Subscript[θ, n-2])(z)- (Subscript[θ, n-2]^′)(z)(Subscript[θ, n])(z)=(2 n-1) (((Subscript[θ, n-1])(z) )^2)

with the initial conditions (Subscript[θ, 0])(z)=1, (Subscript[θ, 1])(z)=z+(Subscript[c, 1]) depend on n free parameters (Subscript[c, k]), 1≤k≤n. 
The integrals ∫((((Subscript[θ, n])(z)/(Subscript[θ, n-1])(z)))^2)dz and ∫((((Subscript[θ, n-1])(z)/(Subscript[θ, n])(z)))^2)dz are rational functions and contain no logarithms [✶]. Verify this statement for the first few n.
For any generic complex values of the (Subscript[c, k]), the roots of (Subscript[θ, n-1])(z) and (Subscript[θ, n])(z) are the equilibrium positions of n(n-1)/2 positive and (n+1)(n+2)/2 negative unit charges that attract each other through a logarithmic potential in the plane [✶], [✶]. For some parametrized (Subscript[c, k]), show some such equilibrium configurations.

Off[RuleDelayed::rhs];
θ[0][z_] := 1;
θ[1][z_] := z + c[1];
θ[n_][z_] := θ[n][z_] = 
θ[n - 2][z] (c[n] + Integrate[(2 n θ[n - 1][z]^2 - θ[n - 1][z]^2)/θ[n - 2][z]^2, 
                              z]) // Together // Cancel

Here are the first few (Subscript[θ, n])(z).

θ[2][z]

θ[3][z]

θ[4][z]

The (Subscript[θ, n])(z) grow quickly in size.

θ[5][z] // Expand // Length

Replacing the (Subscript[c, k]) by (λ^(2k-1))(Subscript[c, k]) and z by λ z yields a homogeneous polynomial of order (λ^(n(n+1)/2)) [✶] .

Table[(Factor[θ[n][z] /. {z -> λ z, c[k_] :> λ^(2k - 1) c[k]}]) /.
      _Plus :> 1, {n, 0, 5}]

Despite the parameters (Subscript[c, k]) present in the (Subscript[θ, n])(z), the above given integrals are rational functions in z. Here are the first few of these integrals explicitly calculated.

Table[{n, Integrate[(θ[n - 1][z]/θ[n][z])^2, z]}, {n, 1, 3}]

Table[{n, Integrate[(θ[n][z]/θ[n - 1][z])^2, z]}, {n, 1, 3}]

For visualizing the position of the zeros of consecutive (Subscript[θ, n])(z), we implement the function chargeGraphics.

chargeGraphics[polyPair_, z_, {φ_, pp_}] := 
Module[{r1, r2}, 
Graphics[{PointSize[0.004], 
Table[{r1, r2} = NRoots[# == 0, z]& /@ polyPair;
{{Hue[0.0], Point[{Re[#], Im[#]}]& /@ Cases[r1, _?NumberQ, Infinity]},
 {Hue[0.8], Point[{Re[#], Im[#]}]& /@ Cases[r2, _?NumberQ, Infinity]}}, 
     {φ, 0, 2Pi, 2Pi/pp}]}, AspectRatio -> Automatic]];

In the following two graphics, the (Subscript[c, k]) are parametrized concentric circles and Lissajou figures.

Show[GraphicsArray[
{(* c[k] moves on concentric circles *)
 chargeGraphics[{θ[4][z], θ[5][z]} /. {c[k_] :> k Exp[I φ]}, z, {φ, 480}],
 (* c[k] moves on Lissajou figures *)
 chargeGraphics[{θ[4][z], θ[5][z]} /. 
              {c[1] :> Cos[φ] + I Sin[φ], c[2] :> Cos[2 φ] + I Sin[3 φ],
               c[3] :> Cos[5 φ] + I Sin[1 φ], c[4] :> Cos[2 φ] + I Sin[5 φ],
               c[5] :> Cos[1 φ] + I Sin[3 φ]}, z, {φ, 240}]}]]

The next two graphics use random smooth functions for the (Subscript[c, k]).

(* random, smooth, periodic function *)
𝕣 := Sum[Random[] Exp[I k (φ + 2Pi Random[])], {k, 0, 3}]

SeedRandom[111];
Show[GraphicsArray[Table[
chargeGraphics[{θ[4][z], θ[5][z]} /. 
               Table[c[k] -> 𝕣, {k, 5}], z, {φ, 600}], {2}]]]

The Yablonskii–Vorob’ev polynomials (Subscript[Q, n])(z) fulfill the following nonlinear difference-differential equation:

(Subscript[Q, n+1])(z)=((z (((Subscript[Q, n])(z))^2)-4((Subscript[Q, n])(z)(Subscript[Q, n]^″)(z)-(((Subscript[Q, n]^′)(z))^2)))/((Subscript[Q, n-1])(z))).

The initial polynomials are (Subscript[Q, 0])(z)=1 and (Subscript[Q, 1])(z)=z.

A recent article [✶] asked for a pure differential equation for the Yablonskii–Vorob’ev polynomials (Subscript[Q, n])(z). Make a polynomial ansatz for a nonlinear differential equation for the (Subscript[Q, n])(z) and determine the unknown coefficients.

Off[RuleDelayed::rhs];

Q[0][z_] := 1;
Q[1][z_] := z;
(* recursive definition *)
Q[n_][z_] := Q[n][z_] = Together[
(z Q[n - 1][z]^2 - 4 (Q[n - 1][z] Q[n - 1]''[z] - Q[n - 1]'[z]^2))/Q[n - 2][z]]

Here are the first few (Subscript[Q, n])(z).

Table[Factor @ Q[k][z], {k, 0, 5}] // TableForm

The above nonlinear difference-differential equation is of order two with respect to differentiation and is of order two with respect to differencing. So, a natural guess would be to look for a fourth order pure differential equation. We make the following ansatz:

(∑_(k,(Subscript[α, 0]),(Subscript[α, 1]),(Subscript[α, 2]),(Subscript[α, 3]),(Subscript[α, 4])=0)^d)(Subscript[c, k,(Subscript[α, 0]),(Subscript[α, 1]),(Subscript[α, 2]),(Subscript[α, 3]),(Subscript[α, 4])])(z^k)(((Subscript[Q, n])(z))^(Subscript[α, 0]))(((Subscript[Q, n]^′)(z))^(Subscript[α, 1]))(((Subscript[Q, n]^″)(z))^(Subscript[α, 2]))(((Subscript[Q, n]^((3)))(z))^(Subscript[α, 3]))(((Subscript[Q, n]^((4)))(z))^(Subscript[α, 4]))=0

Here the (Subscript[c, k,(Subscript[α, 0]),(Subscript[α, 1]),(Subscript[α, 2]),(Subscript[α, 3]),(Subscript[α, 4])])are z-independent numbers. We start with d=4 to obtain enough equations.

ansatz[Qn_, z_] := With[{d = 4, o = 4},
Sum[If[k + α0 + α1 + α2 + α3 >= o, 0, 
       c[k, α0, α1, α2, α3, α4] z^k Qn[z]^α0 * (* avoid 0^0 *)
       If[α1 == 0, 1, Qn'[z]^α1] If[α2 == 0, 1, Qn''[z]^α2]*
       If[α3 == 0, 1, Qn'''[z]^α3] If[α4 == 0, 1, Qn''''[z]^α4]],
    {k , 0, d}, {α0, 0, d}, {α1, 0, d}, 
    {α2, 0, d}, {α3, 0, d}, {α4, 0, d}]];

We get 495 equations for 290 unknowns.

Length[cls = Flatten[Table[CoefficientList[ansatz[Q[k], z], z], {k, 2, 7}]]]

Length[vars =  Union[Cases[cls, _c, Infinity]]]

We convert the equations cls into the coefficient matrix M.

M = (Plus @@ (Times @@@ Internal`DistributedTermsList[#, vars][[1]]))& /@ cls;

Next, we calculate a modular nullspace (which is faster and if a differential equation exists, it will very probably have nice small coefficients).

prime = Prime[10000];
ns = NullSpace[M, Modulus -> prime];
Length[ns]

Substituting the result in the above ansatz yields the following nonlinear fourth order differential equation.

-z (((Subscript[Q, n]^′)(z))^2)+4 (Subscript[Q, n]^((3)))(z) (Subscript[Q, n]^′)(z)-3 (((Subscript[Q, n]^(′′))(z))^2)+(Subscript[Q, n])(z) ((Subscript[Q, n]^′)(z)+z (Subscript[Q, n]^(′′))(z)-(Subscript[Q, n]^((4)))(z))=0

Factor[ansatz[𝒬[n], z] /. 
       (Rule @@@ Transpose[{vars, Mod[ns[[1]], prime, -Floor[prime/2]]}])]

We end with a quick check of the differential equation for higher order polynomials.

Table[(Qn[z] Qn'[z] - z Qn'[z]^2 + z Qn[z] Qn''[z] - 
       3 Qn''[z]^2 + 4 Qn'[z] Qn'''[z] - Qn[z] Qn''''[z] /. 
                      Qn -> Function[z, Evaluate[Q[k][z]]]) // Expand,
      {k, 30}] // Union

Find an implicit polynomial representation for the parametrized surface 𝒮 given by

{x(φ,ϑ),y(φ,ϑ),z(φ,ϑ)}={2 cos(ϑ)+(Subscript[𝒞, 3]^((1)))(φ,ϑ)cos(ϑ),2 sin(ϑ)+(Subscript[𝒞, 3]^((1)))(φ,ϑ) sin(ϑ),(Subscript[𝒞, 3]^((2)))(φ,ϑ)}

{(Subscript[𝒞, 3]^((1)))(φ,ϑ),(Subscript[𝒞, 3]^((2)))(φ,ϑ)}={((cos(φ)+tan(ϑ/4)cos(n φ) )/(1+tan(ϑ/4))),((sin(φ)-tan(ϑ/4)cos(n φ) )/(1+tan(ϑ/4)))}.

Visualize the parametrized and the implicit surface. (The parametrized form is the n=3 version of the hypocycloidal torus from Subsection 2.3.5 of the Graphics volume.)

𝒞[n_][ϑ_, φ_] = {Cos[φ] + Tan[ϑ/4] Cos[n φ],
                 Sin[φ] - Tan[ϑ/4] Sin[n φ]}/(Tan[ϑ/4] + 1);
                      
𝒮[φ_, ϑ_] = {2 Cos[ϑ] + 𝒞[3][ϑ, φ][[1]] Cos[ϑ], 
             2 Sin[ϑ] + 𝒞[3][ϑ, φ][[1]] Sin[ϑ],  𝒞[3][ϑ, φ][[2]]};

Here is the parametrized surface.

(* cut a hole in a polygon *)
makeHole[Polygon[l_], factor_] :=
Module[{mp = Plus @@ l/Length[l], L, nOld, nNew},
 L = (mp + factor(# - mp))& /@ l;
 {nOld, nNew} = Partition[Append[#, First[#]]&[#], 2, 1]& /@ {l, L};
 {MapThread[Polygon[Join[#1, Reverse[#2]]]&, {nOld, nNew}],
  Line /@ nNew}];

Show[Block[{$DisplayFunction = Identity},
      ParametricPlot3D[Evaluate[Append[𝒮[φ, ϑ], {EdgeForm[], Thickness[0.001],
                        SurfaceColor[Hue[φ/(2Pi)], Hue[φ/(2Pi)], 2.2]}]], 
                       {φ, 0, 2Pi}, {ϑ, 0, 2Pi}, PlotPoints -> 37]] /. 
                                     p_Polygon :> makeHole[p, 0.8],
     Boxed -> False, Axes -> False]

To calculate a implicit polynomial version, we write the three coordinates in the form exp(±i φ) and exp(±i ϑ) .

eqs1 = Numerator[Together[{x, y, z} - 𝒮[φ, ϑ]]] /. ϑ -> 4 θ

eqsφϑ = ExpandAll[Numerator[Together[TrigToExp[
          Numerator[Together[{x, y, z} - 𝒮[φ, ϑ]]] /. ϑ -> 4 θ]]]]

Replacing the exponentials with variables yields three equations from which the two parametrization variables X and Y are to be eliminated.

eqsXY = eqsφϑ //. {Exp[α_ φ + β_ θ] :> X^(α/I) Y^(β/I),
                   Exp[α_ φ] :> X^(α/I), Exp[β_ θ] :> Y^(β/I)}

We start by eliminating the variable X because it appears in a lower degree.

{Exponent[eqsXY, X], Exponent[eqsXY, Y]}

res1 = Cases[#, _Plus?(MemberQ[#, x, Infinity]&), Infinity]& @ 
       Factor[Resultant[eqsXY[[1]], eqsXY[[2]], X, Method -> Modular]]

(res2 = Cases[#, _Plus?(MemberQ[#, x, Infinity]&), Infinity]& @ 
       Factor[Resultant[eqsXY[[1]], eqsXY[[3]], X, Method -> Modular]]) //
                                                              Short[#, 5]&

By introducing a new variable YS via (Y^2)=Y, yields two polynomials of degree 4 and 28 in YS. Another call to Resultant yields the desired implicit representation of the hypocycloidal torus. Because of its relatively large size (1792 terms), we display it in abbreviated form only.

{res1a, res2a} = {res1[[1]], res2[[1]]} /. Y -> YS^(1/2);

res3 = Factor[Resultant[res1a, res2a, YS, 
              Method -> Subresultants]/(268435456 x^24)];
{Head[res3], Length[res3], Exponent[res3, {x, y, z}]}

Short[res3, 12]

By using two random points from the parametrized surface, we can quickly check the correctness of the derived implicit form.

res3 /. Block[{φ = Sqrt[Pi], ϑ = 1/E}, (* check to 1000 digits *)
              Rule @@@ Transpose[{{x, y, z}, N[𝒮[φ, ϑ], 1000]}]]

The following plot shows various cross sections of the implicit surface for z=constant.

Show[Table[
ContourPlot[Evaluate[N[res3 /. z -> ζ]], {x, -4, 4}, {y, -4, 4}, 
            ContourStyle -> {{Hue[0.8 ζ/4], Thickness[0.001]}}, 
            PlotPoints -> 240, DisplayFunction -> Identity,
            Contours -> {0}, ContourShading -> False], 
            {ζ, 4, 0, -4/24}],
     DisplayFunction -> $DisplayFunction]

Here is a similar plot showing various cross sections of the implicit surface for y=constant.

Show[Table[
ContourPlot[Evaluate[N[res3 /. y -> ψ]], {x, -4, 4}, {z, -2, 2}, 
            ContourStyle -> {{Hue[0.8 (ψ + 4)/8], Thickness[0.001]}}, 
            PlotPoints -> 240, DisplayFunction -> Identity,
            Contours -> {0}, ContourShading -> False], 
            {ψ, -4, 4, 8/32}],
     DisplayFunction -> $DisplayFunction]

res4 = Factor[res3 //. {x -> r Cos[φ], y -> r Sin[φ]}]/r^4;

By making contour plots for φ=constant in a cylindrical coordinate system, we can visualize how the cross section of the hypocycloidal torus changes.

(* change from Cartesian to polar coordinates *)
res4 = Factor[res3 //. {x -> r Cos[φ], y -> r Sin[φ]}]/r^4;

tab = Table[
ContourPlot[Evaluate[N[res4 /. φ -> ϕ]], {r, 0, 4}, {z, -2, 2}, 
            ContourStyle -> {{Hue[0.8 ϕ/(2Pi)], Thickness[0.001]}}, 
            PlotPoints -> 240, DisplayFunction -> Identity,
            Contours -> {0}, ContourShading -> False], 
            {ϕ, 0, 2Pi (1 - 1/24), 2Pi/24}];
            
Show[Graphics3D[Table[{Thickness[0.002], Hue[k/24],
            Apply[{#1 Cos[k/24 2Pi], #1 Sin[k/24 2Pi], #2}&,
            Cases[Graphics @ tab[[k]], _Line, Infinity], {-2}]},
           {k, 24}]]]

We end with a visualization of the 3D surface using Graphics`ContourPlot3D. We show the whole surface and the surface cut by the z=0-plane and the y=0-plane.

Needs["Graphics`ContourPlot3D`"]

Show[Graphics3D[{EdgeForm[], 
SurfaceColor[Hue[0.12], Hue[0.32], 2.6], 
({#, Map[{1, 1, -1} #&, #, {-2}]}&[Apply[{#1 Cos[#2], #1 Sin[#2], #3}&, 
        Cases[ContourPlot3D[Evaluate[N[res4]], 
                {r, 0, 4}, {φ, 0, 2Pi}, {z, 0, 2},
                MaxRecursion -> 1, PlotPoints -> {{24, 3}, {32, 3}, {12, 3}},
                DisplayFunction -> Identity], _Polygon, Infinity], {-2}]])}] /. 
     p_Polygon :> DeleteCases[makeHole[p, 0.76], _Line, Infinity]]

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {Show[%, PlotRange -> {All, All, {-2, 0}}, ViewPoint -> {0, 0, 5}],
       Show[%, PlotRange -> {All, {-4, 0}, All}, ViewPoint -> {0, 5, 0}]}]]]

Construct an approximate solution to the functional equation f(z)=α f(f(z /α)) where α=1/f(1) in the form f(z)=1+(∑_(k=1)^n)(Subscript[c, k])(z^(2k)) with f''(0)<0 [✶], [✶], [✶], [✶], [✶]. Calculate α (the second Feigenbaum constant) to 20 significant digits. Use the power series and argument reduction to plot the function f(x) in the interval [100, 100].

f[z_, cList_] := 1 + cList.z^(2 Range[Length[cList]]);

rGSeries[z_, cList_] := With[{α = 1/f[1, cList]}, f[z, cList] - 
         α f[f[z/α, cList], cList] + O[z]^(2 Length[cList] + 1)];

eqs[cList_?(VectorQ[#, NumericQ]&)] :=
Module[{δ = rGSeries[z, cList]}, 
      Table[Coefficient[δ, z, 2j], {j, Length[cList]}]]

An approximate value for (Subscript[c, 1])is -1.4.

rGSeries[z, {c1}]

Solve[CoefficientList[%, z] == 0, {c1}] // N

Adding now one (Subscript[c, k]) at a time, we can quickly calculate a 20-digit approximation for 1/f(0). To avoid large symbolic expressions of the truncated functional equation, we restrict the first argument of FindRoot to purely numeric (Subscript[c, k]).

cListT = {-3/2}; ε = 10^-6; n = 1; αOld = 0;
  
While[αNew = 1/f[1, cListT]; Abs[αNew - αOld] > 10^-12,
      n++; αOld = αNew; cList = Table[c[k], {k, n}];
      (* smallest coefficient plus some digits *)
      scale = Round[-Log[10, Abs[Last[cListT]]]] + 10; 
      (* new coefficient list *)
      cListT = Last /@ (* solve for the c_k *)
        FindRoot[eqs[cList] == 0, (* starting values *)
         Evaluate[MapIndexed[{c[#2[[1]]], (1 - ε) #1, (1 + ε) #1}&, 
                  AppendTo[cListT, Last[cListT]/10]]],
         (* use adaptive precision and goals *)         
         WorkingPrecision -> 2 scale, PrecisionGoal -> scale,
         AccuracyGoal -> {scale, Infinity}, Method -> Secant]]

N[αNew, 20]

This results agrees with the known value of α [✶], [✶].

Now we will plot the function. A direct use of the power series allows to plot the function for small x, say x≲3. By observing that in the interval [-1,1], the function f(x) is always contracting, we repeatedly apply the functional equation to bring the argument finally to a size where we can apply the power series f(x)=(α^n)(f^(((2^n))))(x/(α^n)) (here (f^((k))) stands for the kth iterate of f) [✶]. The function fCF implements a compiled version of this procedure.

(* machine number version inside the interval [-1, 1] *)
fUD[z_] = 1. - 1.5276329970363323 z^2 + 
0.1048151947874277 z^4 + 0.026705670524930787 z^6 - 
0.003527409660464297 z^8 + 0.00008160096594827505 z^10 + 
0.000025285084886512315 z^12 - 2.5563177536625283*^-6 z^14 - 
9.65122702290271*^-8 z^16 + 2.8193175723520713*^-8 z^18 - 
2.771441260107602*^-10 z^20 - 3.0292086423142963*^-10 z^22 + 
2.6739057855563045*^-11 z^24 + 9.838888060875235*^-13 z^26 - 
3.5838769501333333*^-13 z^28 + 2.063994985307743*^-14 z^30;

fCF = Compile[{z},
             Module[{α = -2.5029078750959130867, n, ζ},
                    If[Abs[z] <= 1., n = 0, (* reduce argument size *)
                       n = Ceiling[Log[-α, Abs[z]]]]; 
                    ζ = z/α^n; Do[ζ = #, {2^n}]; (α)^n ζ]]&[fUD[ζ]];

Here is a plot of f(x). It has a quite complicated structure [✶].

Plot[fCF[x], {x, -100, 100}, PlotPoints -> 200, PlotRange -> All]

We now could try to make a plot in the complex plane. Unfortunately, the last construction does not always converge because for some numbers z from the unit disk, the values f(z) become too large [✶]. Trying to use the recursion directly might not terminate. So we restrict the number of recursions in the following (to 40) and calculate the function over a domain where the recursions end quickly.

(* use larger value to obtain potentially more points *)
$RecursionLimit = 40 ;
α = 2.5029078750959130867`(* use machine arithmetic! *);
fR[z_] := -α fR[fR[z/α]] /; Abs[z] >= 1
fR[z_] := fUD[z] /; Abs[z] < 1

L = 16; pp = 240;
Off[$RecursionLimit::reclim];
data = Table[If[NumberQ[#], #, 
                (* no recursion termination *) C]&[fR[x + I y]],
             {y, -L, L, 2L/pp}, {x, -L, L, 2L/pp}];

Here is the absolute value of the Feigenbaum–Cvitanović function for the z-values where the recursion terminates within 40 iterations. It shows a very complicated behavior over the complex plane.

Show[Graphics3D[
ListPlot3D[ArcTan[Abs[data]] /. ArcTan[Abs[C]] -> -1,
           (* color cyclically with argument *)
           Map[Hue, (Arg[data] + Pi)/(2Pi), {2}], ClipFill -> None,
           PlotRange -> {0, Pi/2}, BoxRatios -> {1, 1, 0.3}, 
           Mesh -> False, DisplayFunction -> Identity,
           MeshRange -> L {{-1, 1}, {-1, 1}}]] /. 
           (* remove steep vertical polygons *)
           {p:Polygon[l_] :> If[Min[Last /@ l] < 0, {}, p],
            h_Hue :> SurfaceColor[h, h, 2.2]},
           DisplayFunction -> $DisplayFunction, Lighting -> True]

For the Feigenbaum attractor, see [✶].

The Green’s function (Subscript[G, k])(y,x;(V^((n)))) for the time-independent Schrödinger equation with a sum of delta function potentials (V^((n)))(z)=(∑_(k=1)^n)(Subscript[V, k])δ(z-(Subscript[z, k])) is defined through the equation -(∂^2)(Subscript[G, k])(y,x;(V^((n))))/∂(x^2)+V(x)(Subscript[G, k])(y,x;(V^((n))))=(k^2)(Subscript[G, k])(y,x;(V^((n)))) [✶] and fulfills the recursion [✶], [✶], [✶]

(Subscript[G, k]^((0)))(y,x;(V^((0))))=-(i/k)(e^(i k |y-x|))
(Subscript[G, k]^((j)))(y,x;(V^((j))))=(Subscript[G, k]^((j-1)))(y,x;(V^((0))))+(((Subscript[V, j])(Subscript[G, k]^((j-1)))(y,(Subscript[z, j]);(V^((j-1))))(Subscript[G, k]^((j-1)))((Subscript[z, j]),x;(V^((j-1)))))/(1-(Subscript[V, j])(Subscript[G, k]^((j-1)))((Subscript[z, j]),(Subscript[z, j]);(V^((j-1))))))
(Subscript[G, k])(y,x;(V^((0))))=(Subscript[G, k]^((n)))(y,x;(V^((0)))).

The poles of (Subscript[G, k])(y,x;(V^((n)))) in the complex k-plane indicate bound and resonant states. Make an animation that shows how the poles move in the complex k-plane for (V^((8)))(z) with the parameters (Subscript[V, j])=(e^(i ω)), 0≤ω≤2π, (Subscript[z, j])=(j-1)λ, λ∈ℝ as a function of ω.

G[0][y_, x_] := -I/k Exp[I k Abs[y - x]]
    
(* summed Dyson equation *)
G[n_][y_, x_] := G[n - 1][y, x] + V[n] G[n - 1][y, z[n]] G[n - 1][z[n], x]/
                 (1 - V[n] G[n - 1][z[n], z[n]])

We specialize to the case of equidistant potential spikes (with distance λ) of identical strength 𝒱 and cache togethered forms of the Green’s function. (Calculating these togethered forms instead of the direct ones is of course slower, but avoids an exponential increase of the size of the Green’s function.)

(* specialize to equal distance and identical strength *)
z[n_] := λ (n - 1); V[n_] := 𝒱
(* recursively cache calculated Green's functions *)
Do[G[n][y_, x_] = Together[G[n][y, x]], {n, 1, 8}]

This is the simplified form of the denominator of (Subscript[G, k]^((8)))(y,x;(V^((8)))). Its poles in the complex k-plane are the bound and resonant states of the potential. It factors into two parts.

den[k_, 𝒱_, λ_] = (If[Head[#] === Times, Collect[#, k, Factor]& /@ #, #]& @
                   Factor[Denominator[Together[G[8][0, 0]]]]) /. Abs[λ] -> λ

At k=0 , the denominator has a root of order 7 for all generic values of 𝒱 and λ.

Series[den[k, 𝒱, λ], {k, 0, 8}] // Factor

The following graphic shows the negative logarithm of the absolute value of the denominator over the i κ,λ-plane for attractive 𝒱=-1. Poles in the denominator show up as humps. For large λ (meaning the single delta potentials) are widely separated we have 8 bound states (κ<0) with exponential (in λ) separation. For smaller λ, some of the bound states merge into the “zero energy state” until only one bound state survives.

Plot3D[Evaluate[-Log @ Abs @ Re[den[I κ, -1, λ]]],
       {κ, -3, 3},  {λ, 0, 3}, PlotPoints -> 360, 
       Mesh -> False, BoxRatios -> {1, 1/2, 1/4}, 
       PlotRange -> All, ViewPoint -> {0, -3, 2.6},
       AxesLabel -> {"κ", "λ", None}]

The following graphic shows the logarithm of the absolute value of the denominator over the complex k-plane for 𝒱=i and λ = 1. Most of the resonance states lie near the real axis.

Plot3D[Evaluate[{Log @ Abs @ Re[den[kx + I ky, I, 1]],
                   Hue[(Cos[Arg[den[kx + I ky, I, 1]]] + 1)/2]}],
       {kx, -6, 6}, {ky, -2, 2},  PlotPoints -> 360 {1, 1/3}, 
       Mesh -> False, BoxRatios -> {1, 1/2, 1/4}, PlotRange -> All,
       ViewPoint -> {1, 3, 2}]

For a speedy generation of the animation frames, we generate a compiled version of the denominator. We use λ=1 in the following.

denCF = Compile[{{k, _Complex}, {𝒱, _Complex}, λ}, Evaluate[den[k, 𝒱, λ]]];

The function polePlot generates one frame of the animation for a given 𝒱=exp(i ω). The graphic shows the curves of vanishing real part in red and the curves of vanishing imaginary part in blue. The intersections are the bound and resonant states. We mark the poles by black dots. To find the intersection programmatically, we calculate the imaginary part of the denominators along the curves of vanishing real part. Because the intersections of the real and imaginary part are perpendicular (it is an analytic function in k), this will work fine. Using the endpoints of the line segments where the imaginary part changes sign as the starting points for FindRoot allows to calculate the poles. (We could have also calculated a differential equation k'(ω)=… by differentiating the denominator with respect to ω and solve this differential equation for once-calculated starting pole position for a fixed (Subscript[ω, 0]).)

polePlot[𝒱_, λ_, L_, pp_] := 
Module[{data, cpPlots, cps, segments, startPoints},
(* values of the denominator over the complex k-plane *)
data = Table[denCF[kx + I ky, 𝒱, λ], 
             {ky, -L/3, L/3, 2/3 L/(pp/3)}, {kx, -L, L, 2L/pp}];
(* contour plots of vanishing real and imaginary part *)
cpPlots = Show[cps = 
ListContourPlot[#1[data], Contours -> {0}, ContourShading -> False,
            MeshRange -> L {{-1, 1}, {-1, 1}/3}, AspectRatio -> Automatic,
            DisplayFunction -> Identity, ContourStyle -> {Hue[#2]}]& @@@
            {{Re, 0}, {Im, 0.76}}];
(* line segments of vanishing real part over the complex k-plane *)
segments = Map[{1, I}.#&, Flatten[Partition[First[#], 2, 1]& /@ 
                          Cases[Graphics[cps[[1]]], _Line, Infinity], 1], {-2}];
(* start points for the numerical root finding *)
startPoints = Plus @@@ segments[[Flatten[Position[Times @@@ 
                   Map[Sign[Im[denCF[#, 𝒱, λ]]]&, segments, {-1}], -1]]]]/2;
(* the poles *)
roots[𝒱] = Cases[FindRoot[den[k, 𝒱, λ], {k, #},
                     PrecisionGoal -> 5, AccuracyGoal -> 5]& /@ startPoints,
                   _Complex, {-1}];
(* show contour plots and poles *)
Show[{cpPlots, Graphics[{PointSize[0.01], GrayLevel[0], 
                    Point[{Re[#], Im[#]}]& /@ roots[𝒱]}]},
       DisplayFunction -> $DisplayFunction]]

Here are some of the resulting plots for various 𝒱.

polePlot[#, 1, 6, 360]& /@ {1, -I, -1}

And here is the animation. It shows how the 2×8 poles nearest to the origin take part in an exchange of their position with respect to the axis Re(k)=0. While doing this, the curves of vanishing real and imaginary parts perform a relatively complicated splitting and reuniting process. The other poles are largely uninfluenced by the changing potential.

frames = 121; 
Do[polePlot[Exp[I ω], 1, 6, 360], {ω, 0, 2Pi (1 - 1/frames), 2Pi/frames}]

The movement of the poles as the potential changed along the unit circle is shown in the following.

(* calculate zeros to be displayed in the next graphic *)
frames = 121; 
Do[Block[{$DisplayFunction = Identity},
          polePlot[Exp[I ω], 1, 6, 360]], 
         {ω, 0, 2Pi (1 - 1/frames), 2Pi/frames}]

Show[Graphics[{Hue[(Arg[#[[1, 1, 1]]] + Pi)/(2Pi)], 
               Point[{Re[#], Im[#]}]& /@ #[[2]]}& /@ DownValues[roots]],
     PlotRange -> All, AspectRatio -> Automatic]

Consider the Poynting vector |S|∼((|n×((n-v)×a)|)^2)(((1-n.v))^(-5)) from Section 2.2 of the Graphics volume. Calculate the volume of the emission cone bounded by |S|n. For a||n, find an implicit polynomial representation p(x,y,z} for the surface {x,y,z}=|S|n.

Poynting[φ_, ϑ_, v0_, α_] =
With[{(* direction *) n = {Cos[ϑ], Sin[φ] Sin[ϑ], Cos[φ] Sin[ϑ]},
      (* velocity *) v = {v0, 0, 0},
      (* acceleration *) a = {Cos[α], 0, Sin[α]}}, 
      (Cross[n, Cross[n - v, a]].Cross[n, Cross[n - v, a]])/((1 - n.v)^5)];

We obtain the volume 𝒱((Subscript[v, 0]),α) of the emission cone by carrying out the following integral:

𝒱((Subscript[v, 0]),α)∼(∫_0^π)(∫_0^(2π))(∫_0^(|S|))(r^2)sin(ϑ)dr dφ dϑ.

The r-integration is trivial and only the two angular integrations remain. Because ((|S|)^3)/3 is a rational function in cos(φ), sin(φ), cos(ϑ), and sin(ϑ), we will expand the integrand into products and integrate each term individually. For the φ-integration we have 438 terms to integrate. Because all terms are smooth functions of φ and ϑ, we calculate the indefinite integral and substitute limits. This is faster than using Integrate to calculate the definite integrals directly.

ℒ = Expand[Poynting[φ, ϑ, v0, α]^3/3];
Length[ℒ]

IndefIntφ = Integrate[#, φ]& /@ ℒ;
defIntφ = (IndefIntφ /. φ -> 2Pi) - (IndefIntφ /. φ -> 0);
Length[defIntφ]

We have 95 terms to integrate for the ϑ-integration. The resulting volume 𝒱((Subscript[v, 0]),α) is a relatively complicated function of (Subscript[v, 0]) and α.

IndefIntϑ = Integrate[# Sin[ϑ], ϑ]& /@ defIntφ;
defIntϑ = (IndefIntϑ /. ϑ -> Pi) - (IndefIntϑ /. ϑ -> 0);
emissionVolume[v0_, α_] = Factor[Together[defIntϑ]]

For (Subscript[v, 0])->1, 𝒱((Subscript[v, 0]),α) diverges as (((1-(Subscript[v, 0])))^11).

Series[emissionVolume[v0, α], {v0, 1, -9}] // Simplify

Here is a plot of the normalized 𝒱((Subscript[v, 0]),α)/𝒱((Subscript[v, 0]),0) as a function of (Subscript[v, 0]) and α.

Plot3D[emissionVolume[v0, α]/emissionVolume[v0, 0], 
       {v0, -0.8, 0.8}, {α, -Pi, Pi}, PlotRange -> All];

Now, let us derive the implicit form of |S|n for a||n. These are the three parametrized equations for x(ϑ), y(ϑ), and z(ϑ) (because of the rotational symmetry of the problem around the x-axis, we can use φ=0).

eqs = Numerator[Together[{x, y, z} - 
        Poynting[φ, ϑ, v0, 0] {Cos[ϑ], Sin[φ] Sin[ϑ], Cos[φ] Sin[ϑ]}]] /. φ -> 0

We convert the last equation into polynomial form by using the exponential representation for the trigonometric functions.

eqs1 = Numerator[Factor[Together[TrigToExp[eqs]] /. 
                 Exp[s_] :> (θ^(Coefficient[s, ϑ]/I))]]

Eliminating the parametrization variable θ yields an implicit polynomial of total degree 10 in x and z.

Resultant[eqs1[[1]], eqs1[[3]], θ, Method -> Modular] // Factor

Using the rotational symmetry, we have the following result for the surface of the emission cone.

PoyntingImplicit[{x_, y_, z_}, v0_] = Simplify[%[[-1]] /. z -> Sqrt[y^2 + z^2]]

Substituting the original expression for the Poynting vector in the last result shows its correctness.

Together[TrigToExp[PoyntingImplicit[Poynting[φ, ϑ, v0, 0]*
             {Cos[ϑ], Sin[φ] Sin[ϑ], Cos[φ] Sin[ϑ]}, v0]]]

We end with a set of contour plots of |S|n in the x,z-plane.

Show[{#, (* construct the lower half *)
      # /. Line[l_] :> Line[{1, -1}# & /@ l]}&[ 
     Table[Graphics @ 
            ContourPlot[Evaluate[PoyntingImplicit[{x, 0, z}, v0]],
              {x, -3/2, 3}, {z, 0, 3}, PlotPoints -> 160,
              Contours -> {0}, ContourShading -> False,
              ContourStyle -> {{Thickness[0.002], Hue[v0]}},
              DisplayFunction -> Identity, FrameTicks -> False],
      (* various velocity/c values *) {v0, 0, 0.5, 0.5/20}]], 
      DisplayFunction -> $DisplayFunction]

Consider the implicit equation (∑_(k=1)^(d+1))(Subscript[x, k]^2)=1 of a dD sphere in (ℝ^(d+1)). For a fixed prime p, find integer solutions (Subscript[x, k]) for (∑_(k=1)^(d+1))(Subscript[x, k]^2)=1 mod p. Symmetrize the resulting solution points {(Subscript[x, 1]),(Subscript[x, 2]),…,(Subscript[x, d+1])} with respect to the origin, then map them to the unit sphere and visualize them [✶].

spherePoints[d_Integer?(# > 1&), p_Integer?PrimeQ] := 
Module[{x, k, ffp, sffp},
(* return only explicit points *)
Developer`SetSystemOptions["ReduceOptions" -> 
                            {"DiscreteSolutionBound" -> 10^5}];
(* solve implicit sphere equation over F_p *)
ffp = Reduce[Sum[x[i]^2, {i, d}] == 1 + (* any integer k *) k p &&
              (* solutions in F_p only *)
              And @@ Table[0 <= x[i] <= p - 1, {i, d}] && 
              Element[k, Integers] && Element[Table[x[i], {i, d}], Integers], 
              Table[x[i], {i, d}], Backsubstitution -> True];
(* symmetrize ± *)
sffp = Map[If[# <= (p - 1)/2, #, # - p]&, 
           Table[x[i], {i, d}] /. {ToRules[ffp]}, {-1}];
(* map points to unit sphere *) #/Sqrt[#.#]& /@ sffp]

For points in 2D, we obtain regular ngons and some other symmetric arrangements of vertices. Here are a few examples shown.

Show[GraphicsArray[
 Table[Graphics[{PointSize[0.02], Point /@ spherePoints[2, Prime[k]]},
                AspectRatio -> Automatic, Frame -> True, FrameTicks -> False,
                PlotRange -> 1.1 {{-1, 1}, {-1, 1}}], {k, 2, 7}]]]

For points in 3D, we obtain the following point sets for small primes.

Show[GraphicsArray[
 Table[Graphics3D[{PointSize[0.01], Point /@ spherePoints[3, Prime[k]]},
                Boxed -> True,
                PlotRange -> 1.1 {{-1, 1}, {-1, 1}, {-1, 1}}], {k, 2, 7}]]]

Here are the projected points for the 3D case for some larger primes.

Show[GraphicsArray[#]]& /@
Partition[
 Table[Graphics[{PointSize[0.01], Point[Most[#]]& /@ spherePoints[3, Prime[k]]},
                AspectRatio -> Automatic, Frame -> True, FrameTicks -> False,
                PlotRange -> 1.1 {{-1, 1}, {-1, 1}}], {k, 8, 19}], 6]

Calculate and visualize some of the eigenvalues and eigenfunctions of the Helmholtz equation Δψ(x,y)=-(ω^2)ψ(x,y) in the interior of the two spectral twins bilby and hawk [✶], [✶], [✶], [✶], [✶], [✶]. Here are the shapes of the bilby and hawk. All horizontal and vertical edges have length 2 and all non-90° angles of the boundary are 45° .

Use higher order triangular finite elements (up to order 12) to discretize the problem. Compare the quality of higher order refinements with more triangles in a regular homogeneous refinement.

For a given order o, the function ShapeFunctionList returns a list of the O[o] shape functions, such that the value of the kth shape function is one at the point basePoint[o][[k]] and zero at the other base points.

𝒪[o_] := (o + 1)(o + 2)/2;

basePoints[o_] := Flatten[Table[{i, j}/o, {j, 0, o}, {i, 0, o - j}], 1]

(* calculate all shape functions of order o at once;
   store calculated list of shape functions *)
ShapeFunctionList[o_, {ξ_, η_}] := ShapeFunctionList[o, {ξ, η}] =
Module[{monomials, ℒ, sols},
  monomials[{x_, y_}] = Flatten[Table[x^i y^(j - i), 
                                      {j, 0, o}, {i, 0, j}]];
  (* form and solve equations efficiently *)
  ℒ = LinearSolve[monomials /@ basePoints[o]];
  (* use all 𝒪[o] right-hand side *)
  sols = Table[ℒ @ Table[KroneckerDelta[i, j], {i, 𝒪[o]}], {j, 𝒪[o]}];               
  (* form polynomials *)
  Evaluate[monomials[{ξ, η}].#]& /@ sols]

Calculating the 66 shape functions of order 10 can be done in a fraction of a second.

ShapeFunctionList[10, {ξ, η}]; // Timing

The function 𝒯ℐ integrates the bivariate polynomial 𝓅 over the unit triangle.

(* integrating a bivariate polynomial over the unit triangle *)
𝒯ℐ[𝓅_, {x_, y_}] := Plus @@ 
   (Function[{p, q, c}, c (p! q!) /(p + q + 2)!] @@@ (Flatten /@ 
             Internal`DistributedTermsList[𝓅, {x, y}][[1]]))

And here are the definitions for the mass and stiffness matrices. For uniformity of notations and the arguments, both have the geometry parameters J, A, B , and C as parameters.

MassMatrix[o_, {J_, A_, B_, C_}] := MassMatrix[o, {J, A, B, C}] =
Module[{M = Table[0, {𝒪[o]}, {𝒪[o]}], SL = ShapeFunctionList[o, {ξ, η}]},
       (* calculate matrix elements and fill in symmetrically *)
       Do[m = 𝒯ℐ[Expand[SL[[i]] SL[[j]]], {ξ, η}];
          M[[i, j]] = m; M[[j, i]] = m, {i, 𝒪[o]}, {j, i}]; J M]

StiffnessMatrix[o_, {J_, A_, B_, C_}] := StiffnessMatrix[o, {J, A, B, C}] =
Module[{M = Table[0, {𝒪[o]}, {𝒪[o]}], SL = ShapeFunctionList[o, {ξ, η}]},
       (* calculate matrix elements and fill in symmetrically *)
       Do[m = (A 𝒯ℐ[Expand[D[SL[[i]], ξ] D[SL[[j]], ξ]], {ξ, η}] +
               C 𝒯ℐ[Expand[D[SL[[i]], η] D[SL[[j]], η]], {ξ, η}] +
               (* for the following, the next term vanishes *)
               B 𝒯ℐ[Expand[D[SL[[i]], ξ] D[SL[[j]], η] +
                           D[SL[[i]], η] D[SL[[j]], ξ]], {ξ, η}]);
          M[[i, j]] = m; M[[j, i]] = m, {i, 𝒪[o]}, {j, i}]; M]

Here are some timings for calculating some higher-order mass and stiffness matrices that we will use later. Each requires the calculation of  (o+1) (o+2) ((o^2)+3 o+4)/8 integrations over the unit triangle. Calculating the 3×4186 integrals for the order 12 stiffness matrices takes a few minutes.

Table[{o, Timing[MassMatrix[o, {J, A, B, C}];][[1]],
          Timing[StiffnessMatrix[o, {J, A, B, C}];][[1]]}, {o, 12}]

Next let us deal with the geometrical shapes. Here are the outlines of bilby and hawk.

{triangles[bilby], triangles[hawk]} =
(* triangles expressed through vertices *)
{Evaluate[Map[Slot, {{1, 2, 3}, {3, 4, 1}, {5, 1, 4}, {1, 5, 9}, 
                     {6, 9, 5}, {6, 8, 9}, {6, 7, 8}}, {2}]]&[
     { 1, -1}, { 1, -3}, { 3, -1}, { 3,  1}, { 1,  1}, 
     {-1,  1}, {-1,  3}, {-3,  1}, {-1, -1}],
 Evaluate[Map[Slot, {{2, 9, 1}, {2, 3, 4}, {2, 4, 9}, {5, 9, 4}, 
                     {5, 8, 9}, {5, 6, 8}, {7, 8, 6}}, {2}]]&[
     { 1, -3}, { 1, -1}, { 3, -1}, { 1,  1}, {-1,  1}, 
     {-1,  3}, {-3,  3}, {-3,  1}, {-1, -1}]};

Because later we will need smaller triangles, we define a function triangleMesh that contains the o-times recursively subdivided triangles of bilby and hawk.

subdivideTriangle[{p1_, p2_, p3_}] :=
Module[{p4 = (p2 + p3)/2}, {{p4, p1, p2}, {p4, p3, p1}}]

triangleMesh[bilbyHawk_][o_] := triangleMesh[bilbyHawk][o] =
 Flatten[subdivideTriangle /@ triangleMesh[bilbyHawk][o - 1], 1];
   
triangleMesh[bilbyHawk_][0] = triangles[bilbyHawk];

Also, for later use, we define the bounding line segments of bilby and hawk.

borderLine[bilby] = {{1, -3}, {3, -1}, {3, 1}, {1, 1}, {-1, 1}, 
                     {-1, 3}, {-3, 1}, {-1, -1}, {1, -1}, {1, -3}};
                     
borderLine[hawk] = {{1, -3}, {1, -1}, {3, -1}, {1, 1}, {-1, 1}, 
                    {-1, 3}, {-3, 3}, {-3, 1}, {-1, -1}, {1, -3}};

The functions edgePointQ[bilbyHawk] calculate if a point {x, y} lies on the boundary of bilby or hawk.

edgePointQ[bilby][{x_, y_}] := (* check all edges *)
-1 <= x <= 3 && y == 1 || x == 3 && -1 <= y <= 1 ||
y == x - 4 && -3 <= y <= -1 || x == 1 && -3 <= y <= -1 ||
-1 <= x <= 1 && y == -1 || y == -x - 2 && -1 <= y <= 1 ||
y == x + 4 && 1 <= y <= 3 || x == -1 && 1 <= y <= 3

edgePointQ[hawk][{x_, y_}] := (* check all edges *)
-1 <= x <= 1 && y == 1 || x == -1 && 1 <= y <= 3 ||
-3 <= x <= -1 && y == 3 || x == - 3 && 1 <= y <= 3 ||
y == -x - 2 && -3 <= y <= 1 || x == 1 && -3 <= y <= -1 ||
1 <= x <= 3 && y == -1 || y == -x + 2 && -1 <= y <= 1

Here are triangulated versions of bilby and hawk and their outlines.

(* f0r better visibility, contract a triangle *)
contract[l_, f_] := Function[m, (m + f (# - m))& /@ l][Plus @@ l/3]

Show[GraphicsArray[
Graphics[{(* the border lines segments *)
          {GrayLevel[0], Thickness[0.02], Line[borderLine[#]]}, 
           (* triangles forming bilby and hawk *)
          {GrayLevel[0.6], Polygon[contract[#, 0.96]]}& /@ 
                                            triangleMesh[#][0],
          (* recursively subdivided triangles *)
          {Hue[Random[]], Polygon[contract[#, 0.5]]& /@ #}& /@ 
                             Partition[triangleMesh[#][4], 8]},
         AspectRatio -> Automatic, Frame -> True,
         FrameTicks -> None]& /@ {bilby, hawk}]]

For getting a couple of correct digits for the eigenvalues, we might have to subdivide the triangles. The function meshData returns a list of the finite element vertices obtained after order subdivisions of all triangles of bilby or hawk for a given finite element order femOrder. The second argument DN indicates the use of Dirichlet boundary conditions (D) or Neumann boundary conditions (N). For Dirichlet boundary conditions, all points at the boundary are eliminated because they have the value zero by definition and their values do not have to be calculated, and for Neumann boundary conditions all points are returned (Neumann boundary conditions are the most natural boundary boundary conditions for finite element discretizations). The numbered finite element vertices are returned in lists, each list containing the vertices of the triangle. Each vertex is specified in the form P[coordinates, {triangleNumber, vertexNumberInsideTriangle}, globalvertexNumber].

(* map the point {x, y} into the triangle {p1, p2, p3} *)
toTriangle[{p1_, p2_, p3_}, {x_, y_}] := p1 + (p2 - p1) x + (p3 - p1) y

meshData[{bilbyHawk_, order_}, DN_, femOrder_] :=
Module[{(* the triangulated bilby and hawk *)
        tm = triangleMesh[bilbyHawk][order], λ = 𝒪[femOrder],
        trianglePoints, relevantPointsInTriangles, numberedPoints, 
        vertexNumber}, 
 (* points in the form {coordinate, {triangleNumber, pointNumber}};
    grouped by triangles *) 
 trianglePoints = Table[Table[P[toTriangle[tm[[j]], 
                                basePoints[femOrder][[k]]], {j, k}], 
                              {k, λ}], {j, Length[tm]}]; 
 (* all shape functions base points in all triangles *)
 relevantPointsInTriangles =
 (* keep only inner points for Dirichlet boundary conditions *)
 If[DN === D, DeleteCases[trianglePoints, 
                          _?(edgePointQ[bilbyHawk][#[[1]]]&), {2}],
    (* use all points for Neumann case *) trianglePoints];                       
 (* the numbered inner points, no multiplicity *)
 numberedPoints = MapIndexed[{#2[[1]], #1}&, Union[First /@ 
                             Flatten[relevantPointsInTriangles]]];
 (* constant-time look-up for vertex numbers *)
 (vertexNumber[#2] = #1)& @@@ numberedPoints;        
 Map[Append[#, vertexNumber[#[[1]]]]&, relevantPointsInTriangles, {2}]]

Here are the numbered vertices for the simplest nontrivial case—the seventh order zero bilby triangles for Dirichlet boundary conditions with degree one basis functions. The triangles at the cusp vertices have no nontrivial vertices and appear as empty lists.

meshData[{bilby, 1}, D, 1]

Next, we have to assemble the global mass and stiffness matrices. For a given list of numbered finite element vertices numberedTrianglePoints, and a given element mass or stiffness matrix massStiffnessMatrix, the function globalMatrix does most of this. Because the resulting global matrices are rather sparse in average, we will return the matrices as sparse arrays. If needed, the sparse array can easily converted to a dense one.

globalMatrix[numberedTrianglePoints_, massStiffnessMatrix_] :=
Module[{dim, thePoints, 𝒯, j, m, a, n, b},
(* make definition for the inner points *)
 dim = Max[Last /@ Flatten[numberedTrianglePoints]];
 (* indices m, n for the triangles;
    indices a, b for the global matrix *)
 (* all points of the mesh *)
 thePoints = Flatten[numberedTrianglePoints];
 (* now loop over all points of the triangle mesh *) 
 𝒯 = Table[{j, m} = thePoints[[i, 2]]; a = thePoints[[i, 3]];
           (* loop over all vertices from the same triangle *)
           Table[n = numberedTrianglePoints[[j, l, 2, 2]]; 
                 b = numberedTrianglePoints[[j, l, 3]]; 
                 {a, b} -> massStiffnessMatrix[[m, n]],
                 {l, Length[numberedTrianglePoints[[j]]]}],
          {i, 1, Length[thePoints]}];                   
 (* return global matrix as a sparse array *)
 SparseArray[(* sum entries belonging to same vertices *)
             ((#[[1, 1]] -> (Plus @@ (Last /@ #)))& /@ 
                 Split[Sort[Flatten[𝒯]], #1[[1]] === #2[[1]]&])]]

The next graphics show the nonzero elements of the resulting elements of the global mass matrix for the original triangles for finite element orders 2 to 6. We clearly see the overlapping square block-type matrices from the individual elements,

Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, 
Table[ListDensityPlot[1 - Sign[Abs[Normal[
      globalMatrix[meshData[{bilby, 0}, D, femOrder], 
                            MassMatrix[femOrder, {4, 1, 0, 1}]]]]],
             FrameTicks -> False, Mesh -> False], {femOrder, 2, 6}]]]]

Here are two matrices from higher order subdivision (three and four). The overall banded nature of the matrices is clearly visible.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, 
Table[ListDensityPlot[1 - Sign[Abs[Normal[
      globalMatrix[meshData[{bilby, ℴ}, D, ℴ], 
                            MassMatrix[ℴ, {2^(2 - ℴ), 1, 0, 1}]]]]],
             FrameTicks -> False, Mesh -> False], {ℴ, 3, 4}]]]]

For further use, we calculate the mass and stiffness matrices ℳ and 𝒮 for various orders. For all the triangles and subdivision orders of our subdivisions of bilby and hawk, we have A=1, B=0, and C=1.

(* use values of J, A, B, and C corresponding to 
   uniform triangle subdivision implemented above *)
Do[JABCRule = Dispatch[{J -> 2^(2 - order), A -> 1, B -> 0, C -> 1}];
   (* reuse already calculated mass and stiffness matrices *)
   ℳ[femOrder][order_] = MassMatrix[femOrder, 
                                     {J, A, B, C}] //. JABCRule;
    𝒮[femOrder][order_] = StiffnessMatrix[femOrder, 
                                          {J, A, B, C}] //. JABCRule, 
   {femOrder, 1, 12}]

Here are some assembly timings, dimensions, and number of nonvanishing matrix elements for the resulting global matrices for various subdivision and finite element orders. The subdivision order 6, finite element order 6 global matrices are of dimensions 7849×7849. And a subdivision order 4, finite element order 12 global matrix is also of dimensions 7849×784, but has 818353 nonvanishing elements.

Table[{order, femOrder,
       Timing[{Dimensions[#][[1]], Length[ArrayRules[#]] - 1}& @   
       globalMatrix[meshData[{bilby, order}, D, femOrder], 
                    ℳ[femOrder][order]]]},
      {order, 6}, {femOrder, 6}]

Now we are ready to test the isospectrality numerically. For a given subdivision order order and a given finite element order femOrder, we now construct the pair of global mass and stiffness matrices bilbyHawkFEMMatrices.

bilbyHawkFEMMatrices[{bilbyHawk_, order_}, DN_, femOrder_] :=
(globalMatrix[meshData[{bilbyHawk, order}, DN, femOrder], 
                               #[femOrder][order]]& /@ {𝒮, ℳ})

We will use the Arnoldi method to calculate the eigenvalues (and the eigenvectors) to make efficient use of the sparse structure of the matrices and to deal with larger matrices. At this stage, we numericalize the global mass and stiffness matrices. The function bilbyHawkEigenvalues calculates the eigenvalues. We allow for options opts to extract higher eigenvalues conveniently.

bilbyHawkEigenvalues[{{bilbyHawk_, order_}, DN_, femOrder_}, 
                     n_, opts___] :=
Module[{M, S},
(* global mass and stiffness matrix *)
{S, M} = bilbyHawkFEMMatrices[{bilbyHawk, order}, DN, femOrder];
(* return eigenvalues in increasing order *)
Reverse @ Eigenvalues[N[{S, M}], n,
                Method -> {"Arnoldi", opts, Tolerance -> 10^-8,
                BasisSize -> Min[Abs[20 n], Dimensions[M]],
                                  MaxIterations -> 10^5}]]

We start with the original seven triangles of bilby and hawk and use a sixth order finite element approximation.

bilbyHawkEigenvalues[{{bilby, 0}, D, 6}, -6]

bilbyHawkEigenvalues[{{hawk, 0}, D, 6}, -6]

The first six eigenvalues agree quite well. Using the sixth subdivision and linear finite elements gives considerably worse results (although the matrix dimension is nearly twice as large). But the actual values of bilby and hawk eigenvalues agree perfectly with each other. The weak performance of low-order finite elements for domains with reentrant corners is a well-known weakness of the finite element method.

bilbyHawkEigenvalues[{{bilby, 6}, D, 1}, -6]

bilbyHawkEigenvalues[{{hawk, 6}, D, 1}, -6]

Because the finite element approximation is basically a variational solution, the resulting values bound the Dirichlet eigenvalues from above. We obtain a few correct digits of the eigenvalues by using higher order triangle subdivisions. In addition, we can extrapolate the sequence of eigenvalues [✶]. The correct value of the first eigenvalue to ten digits is 2.537949998… [✶]. With just seven of the order twelve elements, we obtain the lowest eigenvalue accurate to more 0.0001%.

Table[bilbyHawkEigenvalues[{{bilby, 0}, D, fo}, -1][[1]], {fo, 2, 12}]

Table[bilbyHawkEigenvalues[{{bilby, 1}, D, fo}, -1][[1]], {fo, 2, 12}]

Table[bilbyHawkEigenvalues[{{bilby, 2}, D, fo}, -1][[1]], {fo, 2, 12}]

Assuming that the eigenvalues λ obey a femOrder dependence λ=(Subscript[λ, 0])+(∑_k)(Subscript[c, k])  (femOrder^(-k)), we can refine our predicted value of the lowest eigenvalue. The resulting error is now less than 0.0001%.

Module[{λs = %, l = Length[%], eqs, sol, c, λ0},
 eqs = Table[λ0 + Sum[c[j] fo^-(j + 2), {j, l - 1}] == 
             Rationalize[λs[[k]], 0] /. fo -> k, {k, l}];
 sol = Solve[eqs, Join[{λ0}, Table[c[j], {j, l - 1}]]];
 N[λ0 /. sol[[1]]]]

Because bilby and hawk can be constructed from right angles isosceles triangles, there exist eigenfunctions that are finite linear combinations of products of sine functions and have nodes along coinciding triangle edges. The smallest such eigenvalue for bilby and hawk is ((1^2)+(((1+1))^2))(((π/2))^2)=5/4(π^2). Here we find the numerical eigenvalue nearest to this value and its relative error.

{#, # - 5/4 Pi^2}&[
  bilbyHawkEigenvalues[{{bilby, 1}, D, 12}, 1, Shift -> 12.337][[1]]]

And here are the first few eigenvalues for Neumann boundary conditions. For the solution ψ(x,y)=constant, we have a zero eigenvalue. Again, we see the isospectrality of the bilby and hawk.

bilbyHawkEigenvalues[{{bilby, 0}, N, 6}, -6]

bilbyHawkEigenvalues[{{hawk, 0}, N, 6}, -6]

For mixed boundary conditions (some of the edges have Dirichlet, and some of the edges have Neumann boundary conditions), see [✶].

For visualizing the eigenmodes we need the eigenvectors. The next input defines the function bilbyHawkEigenvectors in an analogous way to the function bilbyHawkEigenvalues. Again, we use the Arnoldi method option in Eigenvectors.

DownValues[bilbyHawkEigenvectors] = 
(* reuse code from above *) DownValues[bilbyHawkEigenvalues] /. 
    {bilbyHawkEigenvalues -> bilbyHawkEigenvectors,
     Eigenvalues -> Eigenvectors};

We start with some 3D plots of the eigenmodes. To obtain good graphics for low subdivision orders of bilby and hawk, we define a triangle subdivision mask that will be applied to each triangle.

subdividedTriangleMask[o_] := subdividedTriangleMask[o] =
Module[{sd, ts, allPoints, dp},
       (* subdivide a triangle into four *)
       sd[{p1_, p2_, p3_}] := 
       With[{p12 = (p1 + p2)/2, p23 = (p2 + p3)/2, p31 = (p3 + p1)/2},
            {{p1, p12, p31}, {p12, p2, p23}, {p23, p3, p31}, 
             {p12, p23, p31}}];
       (* iterate subdivision *)      
       ts = Nest[Flatten[sd /@ #, 1]&, {{{0, 0}, {1, 0}, {0, 1}}}, o];
       (* all points of the subdivision *) 
       allPoints = Union[Flatten[ts, 1]];
       (* identify identical points in the subdivision *)
       dp = Dispatch[MapIndexed[(#1 -> #2[[1]])&, allPoints]];
       (* return list of relative point coordinates and triangles *)
       {allPoints,
        Function[Evaluate[Map[Slot, Polygon /@ ts /. dp, {-1}]]]}]

Now, we define the function eigenfunctionsGraphics3D that generates a 3D plot of the eigenfunctions over bilby and hawk. The argument opp denotes the order of the triangle subdivisions for visualizations and colorFunction is a pure function that will be applied to assign a color to each triangle.

eigenfunctionsGraphics3D[{{bilbyHawk_, order_}, DN_, femOrder_}, 
                         evec_, opp_, colorFunction_, opts___] :=
Module[{(* get triangles *)
        tm = triangleMesh[bilbyHawk][order], λ = numKnots[femOrder],
        (* scale eigenvector *)
        evecN = evec/Plus @@ evec, numberedTrianglePoints = 
                       meshData[{bilbyHawk, order}, DN, femOrder],
        basePointsT, polygonFunction, polys, ST, STF}, 
 (* form the approximate eigenfunctions within a triangle *)
 Do[ST[j][{ξ_, η_}] = Join[toTriangle[tm[[j]], {ξ, η}], {Plus @@ 
    ((evecN[[#[[3]]]]*
      ShapeFunctionList[femOrder, {ξ, η}][[#[[2, 2]]]])& /@ 
                                   numberedTrianglePoints[[j]])}],
    {j, Length[tm]}];
 STF = ST;                 
 (* refinement template *)
 {basePointsT, polygonFunction} = subdividedTriangleMask[opp];    
 (* construct polygons *)
 polys = Table[polygonFunction @@ (STF[j] /@ basePointsT), 
               {j, Length[tm]}];      
 (* return Graphics3D object *)
 {min, max} = {Min[evecN], Max[evecN]};
 (* scaled z-coordinate of polygons *)
 scaledZ[Polygon[l_]] := ((Plus @@ (Last /@ l)/4) - min)/(max - min);
 (* make graphics *)
 Graphics3D[{EdgeForm[], Map[{colorFunction[scaledZ[#]], #}&, polys, {2}],
            {Thickness[0.008], GrayLevel[0], 
             Line[Append[#, 0]& /@ borderLine[bilbyHawk]]}}, 
            opts, PlotRange -> All, BoxRatios -> {1, 1, 0.33},
            BoxStyle -> {Thickness[0.002], GrayLevel[0.5]}]]

Here are some examples of the eigenfunctions.

evecsDBilby = bilbyHawkEigenvectors[{{bilby, 3}, D, 4}, -9];
evecsDHawk = bilbyHawkEigenvectors[{{hawk, 3}, D, 4}, -9];

Do[Show[GraphicsArray[
  eigenfunctionsGraphics3D[{{#1, 3}, D, 4}, #2[[j]], 3, 
                SurfaceColor[Hue[0.78 (1 - #)], 
                             Hue[0.78 # + 0.12], 2.2]&]& @@@
       {{bilby, evecsDBilby}, {hawk, evecsDHawk}}]], {j, 1, 9}];

As already mentioned, the relatively poor performance of the low-order finite element eigenvalues above can be traced back to the reentrant corners of bilby and hawk. There the gradient diverges. With a slight change of the function eigenfunctionsGraphics3D, we can easily display the magnitudes of the gradient vectors over bilby and hawk.

DownValues[eigenfunctionsGradGraphics3D] = 
DownValues[eigenfunctionsGraphics3D] /. 
HoldPattern[eigenfunctionsGraphics3D] :> eigenfunctionsGradGraphics3D /.
(* modify code *)
HoldPattern[Module[{args__}, body_]] :> Module[{args, ξηdx, ξηdy}, body] /.
HoldPattern[STF = ST] :>
 Do[(* chain rule parts in derivative change from {x, y} -> {ξ, η} *)
   {ξηdx, ξηdy} = {D[#, x], D[#, y]}&[{ξ, η} /. 
    Solve[{x, y} == toTriangle[tm[[j]], {ξ, η}], {ξ, η}][[1]]];
    (* norm of gradient *)
    STF[j][{ξ_, η_}] = Join[Most[ST[j][{ξ, η}]], 
         {Sqrt[#.#]&[{ξηdx.#, ξηdy.#}&[({D[#, ξ], D[#, η]}&[
                     ST[j][{ξ, η}][[-1]]])]]}], {j, Length[tm]}];

While the Lagrange element-based calculations give a continuous solution, it is not continuously differentiable. As a result, the following gradient plots have discontinuities along the finite element boundaries. But the following graphics nevertheless clearly show the divergence of the gradient at the reentrant boundary vertices for the first three of the just-visualized eigenfunctions.

Do[Show[GraphicsArray[
  eigenfunctionsGradGraphics3D[{{#1, 3}, D, 4}, #2[[j]], 3, 
                SurfaceColor[Hue[0.78 (1 - #)], 
                             Hue[0.78 # + 0.12], 2.2]&]& @@@
       {{bilby, evecsDBilby}, {hawk, evecsDHawk}}]], {j, 1, 3}];

And here are the corresponding eight lowest nontrivial eigenfunctions eigenfunctions for the Neumann case (the lowest eigenfunction is just a constant).

evecsNBilby = bilbyHawkEigenvectors[{{bilby, 3}, N, 4}, -9];
evecsNHawk = bilbyHawkEigenvectors[{{hawk, 3}, N, 4}, -9];

Do[Show[GraphicsArray[
  eigenfunctionsGraphics3D[{{#1, 3}, N, 4}, #2[[j]], 3, 
                SurfaceColor[Hue[0.78 (1 - #)], 
                             Hue[0.78 # + 0.12], 2.2]&]& @@@
       {{bilby, evecsNBilby}, {hawk, evecsNHawk}}]], {j, 2, 9}];

Contour plots are a better way to visualize higher states. The complicated pattern of minima and maxima is visible at once, without some of the minima and maxima covered by others. To make a contour plot inside the bilby and hawk polygons, we cannot use ListContourPlot directly because it expects a rectangular array of data. While the points of the triangle subdivisions and the finite element base points lie on a Cartesian tensor product grid, they do not fill a rectangle. We could either supplement with function values zero or make individual contour plots in each (subdivided) triangle. First, we will follow the last possibility.

(* function to insert points along the edges of a polygon *)
insertAdditionalPoints[Polygon[l_], ε_] := 
  Module[{n, λ}, Polygon[Join @@ (Function[s, 
               (* segment small enough? *)
               If[(λ = Sqrt[#. #]&[Subtract @@ s]) <= ε, s, 
         (* insert more points *)
         n = Floor[λ/ε] + 1; (* form segments *)
         Table[# + i/n (#2 - #1), {i, 0, n - 1}]& @@ s]] /@ 
                   Partition[Append[l, First[l]], 2, 1])]]

eigenfunctionsContourGraphics[{{bilbyHawk_, order_}, DN_, femOrder_}, 
                               evec_, pp_, zeroContourQ_] :=
Module[{tm = triangleMesh[bilbyHawk][order], λ = numKnots[femOrder],
        evecN = evec/Plus @@ evec, numberedTrianglePoints = 
                         meshData[{bilbyHawk, order}, DN, femOrder],
       mp = {1/3, 1/3}, ε = 10^-12, 𝒸, ST, SF}, 
{min, max} = {Min[evecN], Max[evecN]};        
evecN1 = (evecN - Min[evecN])/(Max[evecN] - Min[evecN]);      
(* form the approximate eigenfunctions within a triangle;
   compile for speed *) 
Do[ST[j] = Compile[{ξ, η}, Evaluate[Plus @@ ((evecN[[#[[3]]]]*
         ShapeFunctionList[femOrder, {ξ, η}][[#[[2, 2]]]])& /@ 
                                   numberedTrianglePoints[[j]])]],
   {j, Length[tm]}];
(* make contour plots within each triangle *)
cps = Table[(* parametrize triangle with rectangular domain *)
            tab = Table[If[ξ === 1, Table[ST[j][1, 0], {pp + 1}],
                        Table[ST[j][ξ, η], {η, 0, 1 - ξ, (1 - ξ)/pp}]], 
                        {ξ, 0, 1, 1/pp}];
            (* options for the two ListContourPlot calls *)
            copts =  Sequence[MeshRange -> {{0, 1}, {0, 1}}, 
                PlotRange -> {min, max}, ColorFunctionScaling -> False,
                ContourSmoothing -> True, DisplayFunction -> Identity];
             (* make contour plot; use some absolute coloring function *)
            cp = ListContourPlot[Transpose[tab], copts, 
                 Contours -> 50, ContourLines -> False, 
                 ColorFunction -> (GrayLevel[(max - #)/(max - min)]&)];
             (* make contour plot of zero0value curve *)
            cpZeroLines = If[zeroContourQ, 
            ListContourPlot[Transpose[tab], copts, Contours -> {0}, 
                 ContourLines -> True, ContourShading -> False,
                 ContourStyle -> {{Thickness[0.004], RGBColor[0, 0, 1]}}], {}];    
            (* make Graphics object *)
            gr = Show[Graphics /@ {cp, cpZeroLines}]; 
            gr1 = gr /. p_Polygon  :> 
                        (* insert points along edges *)
                        insertAdditionalPoints[p, 2^-order/12];    
            (* map to triangle; expand upper polygons *)
            cM = Count[gr, _Polygon, Infinity];            
            ξη[{ξ_, η_}] := {ξ, η (1 - ξ)};
            xy[{ξ_, η_}] = toTriangle[tm[[j]], {ξ, η}];
            expandT[{ξ_, η_}] := mp + (1 + (𝒸++) ε) ({ξ, η} - mp);
            gr1 /. Polygon[l_] :> 
                   (𝒸 = 0; Polygon[xy /@ expandT /@ ξη /@ l]) /.
                   Line[l_] :> Line[xy /@ ξη /@ l],
          {j, Length[tm]}];   
 (* the border *)
 borderGraphics = Graphics[{Hue[0], Thickness[0.008], 
                            Line[borderLine[bilbyHawk]]}];               
 (* form one Graphics object from all contour plots *)
 Show[Append[cps, borderGraphics],
      PlotRange -> All, Frame -> False, AspectRatio -> Automatic] /.  
                            (DisplayFunction -> Identity) -> 
                            (DisplayFunction -> $DisplayFunction)]

Here are the contour plot equivalents of the above 3D plots for bilby.

Show[GraphicsArray[#]]& /@ Partition[
  Block[{$DisplayFunction = Identity}, 
  eigenfunctionsContourGraphics[{{bilby, 3}, D, 4}, #, 4, False]& /@
                                          Take[evecsDBilby, 6]], 3]

The zeroth Neumann eigenfunction is constant and the contour plot shows just the numerical uncertainties. Now, we also show the nodal lines [✶].

Show[GraphicsArray[#]]& /@ Partition[
  Block[{$DisplayFunction = Identity}, 
  eigenfunctionsContourGraphics[{{bilby, 3}, D, 4}, #, 4, True]& /@
                                    Take[evecsDBilby, {2, 7}]], 3]

For applying methods more adapted to the reentrant corners of bilby and hawk to calculate their eigensystems, see [✶]; for experimental data about their eigensystems, see [✶].

For higher states, it is faster and more convenient to use one call to ListContourPlot. For even orders of the triangle subdivision, all triangle vertices lie on a Cartesian x,y tensor product grid (for odd orders, rotating bilby and hawk by π/4 will make the vertices lie on such a grid). We start by creating a square matrix with the function values to be used in ListContourPlot.

eigenfunctionsMat[{{bilbyHawk_, order_}, DN_, femOrder_}, evec_, pp_] :=
Module[{tm = triangleMesh[bilbyHawk][order], λ = numKnots[femOrder],
        evecN = evec/Plus @@ evec, numberedTrianglePoints = 
                         meshData[{bilbyHawk, order}, DN, femOrder],
       ST, toInteger, toIntegerCoordinates, lcpM, δ = 2/2^(order/2)/pp}, 
(* form the approximate eigenfunctions within a triangle;
   compile for speed *) 
Do[ST[j] = Compile[{ξ, η}, Evaluate[Plus @@ ((evecN[[#[[3]]]]*
         ShapeFunctionList[femOrder, {ξ, η}][[#[[2, 2]]]])& /@ 
                                   numberedTrianglePoints[[j]])]],
   {j, Length[tm]}];
(* physical coordinates to grid numberings *)
toIntegerCoordinates[{x_, y_}] := ({x, y} + 3)/δ + 1;
(* empty matrix *)
lcpM = Table[0, {6/δ + 1}, {6/δ + 1}]; 
(* fill in matrix *)
Do[(* go through all triangles *)
   Do[(* pp (1 + pp) points inside each triangle *)
      {a, b} = toIntegerCoordinates[toTriangle[tm[[j]], {ξ, η}]];
      lcpM[[a, b]] = ST[j][ξ, η], {ξ, 0, 1, 1/pp}, {η, 0, 1 - ξ, 1/pp}],
      {j, Length[tm]}]; lcpM]

The function eigenfunctionsContourGraphicsHolistic takes the matrix returned by eigenfunctionsMat and generates a contour plot of the eigenfunctions of bilby and hawk. We cover the parts of the matrix that represent points outside of bilby or hawk with the white polygons outerCoverPolygon.

{outerCoverPolygon[bilby], outerCoverPolygon[hawk]} = Polygon /@ 
 {{{3, 1}, {-1, 1}, {-1, 3}, {-3, 1}, {-1, -1}, {1, -1}, {1, -3}, {3, -1}, 
   {3, -3}, {-3, -3}, {-3, 3}, {3, 3}}, {{-1, 3}, {-1, 1}, {1, 1}, {3, -1}, 
   {1, -1}, {1, -3}, {-3, 1}, {-3, -3}, {3, -3}, {3, 3}, {-1, 3}}};

eigenfunctionsContourGraphicsHolistic[{{bilbyHawk_, order_}, DN_, femOrder_}, 
                                      {evec_, F_}, pp_] :=
Module[{M0, lcp, coverGraphics, borderGraphics}, 
 (* matrix with elongation values *)
 M0 = eigenfunctionsMat[{{bilbyHawk, order}, DN, femOrder}, evec, pp];
 (* make contour plot *)
 lcp = ListContourPlot[Map[F, Transpose[M0], {2}], 
                  PlotRange -> All, DisplayFunction -> Identity,
                  MeshRange -> {{-3, 3}, {-3, 3}}, ContourLines -> False,
                  Contours -> 36];  
 (* cover the outside with white polygons *)
 coverGraphics = Graphics[{GrayLevel[1], outerCoverPolygon[bilbyHawk]}];
 borderGraphics = Graphics[{Hue[0], Thickness[0.008], 
                            Line[borderLine[bilbyHawk]]}];       
 (* make resulting graphic *)
 Show[{lcp, coverGraphics, borderGraphics},
      DisplayFunction -> $DisplayFunction, Frame -> False]]

Here are some of the higher states for the Dirichlet case shown. This time, we show the fourth root of the absolute value of the amplitudes to mimick the appearance of the sand in Chladny figures. The second pair of graphics shows again a state that can be written as a product of sine functions inside each of the seven order zero triangles.

evecsDBilby = bilbyHawkEigenvectors[{{bilby, 4}, D, 10}, 8, Shift -> 101];
evecsDHawk  = bilbyHawkEigenvectors[{{hawk,  4}, D, 10}, 8, Shift -> 101];

Do[Show[GraphicsArray[
     Block[{$DisplayFunction = Identity}, 
     eigenfunctionsContourGraphicsHolistic[{{#1, 4}, D, 10}, 
                                {#2[[j]], Abs[#]^(1/4)&}, 12]& @@@
                             {{bilby, evecsDBilby}, {hawk, evecsDHawk}}]]],
   {j, 8}];

We end with the corresponding graphics for the Neumann case.

evecsNBilby = bilbyHawkEigenvectors[{{bilby, 4}, N, 10}, 8, Shift -> 101];
evecsNHawk  = bilbyHawkEigenvectors[{{hawk,  4}, N, 10}, 8, Shift -> 101];

Do[Show[GraphicsArray[
     Block[{$DisplayFunction = Identity}, 
     eigenfunctionsContourGraphicsHolistic[{{#1, 4}, N, 10}, 
                                {#2[[j]], Abs[#]^(1/4)&}, 12]& @@@
                             {{bilby, evecsNBilby}, {hawk, evecsNHawk}}]]],
   {j, 8}];

After dealing with the inside of these two isospectral drums, one could continue and investigate the Helmholtz (scattering) problem for the outside. See [✶] for some initial results.

Consider the quotient q=(Subscript[z, 1])/(Subscript[z, 2]), where the (Subscript[z, 1]), (Subscript[z, 2]) are random complex numbers chosen with uniform probability from the square {1+i,2+i,2+2i,1+2i} in the complex plane. Calculate the probability distribution function p(Re(q),Im(q)) analytically.

{qRe, qIm} = 
Simplify[ComplexExpand[#[(x1 + I y1)/(x2 + I y2)], 
                    TargetFunctions -> {Re, Im}]]& /@ {Re, Im}

It is straightforward to calculate exact expressions for the averages of the real and imaginary parts of q. Intuitively one would expect the average value of q to be approximately 1. This is the case to a remarkable precision.

{qrAv, qiAv} = 
(Integrate[#, {y2, 1, 2}, {x2, 1, 2}, {y1, 1, 2}, {x1, 1, 2},
           GenerateConditions -> False] // 
           TrigToExp // FullSimplify)& /@ {qRe, qIm}

N[%]

It is also possible to calculate exactly the variances for the real and imaginary parts. This time, we obtain considerably more complicated expressions containing polylogarithmic functions. From the numerical values of the variances, we expect a half width of about 0.2 for the real and the imaginary part.

(FullSimplify[Integrate[FullSimplify[
 (* split off last integration and simplify before *)
 Integrate[#, {x2, 1, 2}, {y1, 1, 2}, {x1, 1, 2},
           GenerateConditions -> False]], {y2, 1, 2}] /. 
            xA -> qrAv]& /@ (({qRe, qIm} - {qrAv, qiAv})^2)) //
                     (* for a shorter result *) TraditionalForm

N[Sqrt[%], 22]  // N

Using quantifier elimination it is also easily possible to calculate bounds for the range of nonvanishing values for the quotient q. We find 1/2≤Re(q)≤2 and 1-φ≤Im(q)≤φ-1.

Function[reim, Function[lg, 
Exists[{x1, y1, x2, y2}, 
      Element[{x1, y1, x2, y2, q}, Reals] && 
              1 < x1 < 2 && 1 < y1 < 2 &&
              1 < x2 < 2 && 1 < y2 < 2, lg[q, reim]] // 
               Resolve] /@ {Less, Greater}] /@ {qRe, qIm}

Next, we carry out a numerical simulation that uses ten million pairs of random numbers. We use the compiled function qCF for carry simulation.

qCF = Compile[{{n, _Integer}, {pp, _Integer}},
        Module[{m = Table[0, {pp + 1}, {pp + 1}], q, qr, qi, 
                i, j, q0 = {0, -1}, λq = {2, 2}, norm}, 
            Do[(* form the quotient of the two random numbers *)
               q = Random[Complex, {1 + I, 2 + 2 I}]/ 
                   Random[Complex, {1 + I, 2 + 2 I}];
               {qr, qi} = {Re[q], Im[q]}; 
               (* discretize and count *)
               {j, i} = Round[({qr, qi} - q0)/λq pp] + 1;
               m[[i, j]] = m[[i, j]] + 1, {n}]; 
               norm = Plus @@ Flatten[Sign[m]];
               (* return normalized result *)
               m/n norm]];

The following graphic of the modelled probability distribution agrees quantitatively with the above-calculated parameters.

ListPlot3D[qCF[10^7, 60], PlotRange -> All,
           MeshRange -> {{0, 5/2}, {-1, 1}}, Mesh -> False]

Now, we calculate the exact probability distribution function. The bivariate distribution is given as the following four-fold integral:

p((Subscript[q, r]),(Subscript[q, i]))=(∫_1^2)(∫_1^2)(∫_1^2)(∫_1^2)δ((Subscript[q, r])-(((Subscript[x, 1]) (Subscript[x, 2])+(Subscript[y, 1]) (Subscript[y, 2]))/((Subscript[x, 2]^2)+(Subscript[y, 2]^2))))δ((Subscript[q, i])-(((Subscript[x, 2]) (Subscript[y, 1])-(Subscript[x, 1]) (Subscript[y, 2]))/((Subscript[x, 2]^2)+(Subscript[y, 2]^2))))d(Subscript[x, 1])d(Subscript[y, 1])d(Subscript[x, 2])d(Subscript[y, 2]).

Using the well known integration rules for the Dirac delta function, it is straightforward to carry out the integration over (Subscript[x, 1]) and (Subscript[y, 1]).

(* carry out integration over x1 *)
solx1 = x1 /.  Solve[qr - qRe == 0, x1][[1]];
fd1 = -D[qr - qRe, x1];
int1 = 1/fd1 UnitStep[solx1 - 1] UnitStep[2 - solx1];
(* carry out integration over y1; independent factor *)
qiP = (qi - qIm /. x1 -> solx1);
soly1 = y1 /. Solve[qiP == 0, y1][[1]] ;
fd2 = -D[qiP, y1];
int2 = 1/fd2 UnitStep[soly1 - 1] UnitStep[2 - soly1] // Simplify;
(* unite results *)
int3 = (int1 /. y1 -> soly1) int2 // Simplify

This leaves us with the following double integral:

p((Subscript[q, r]),(Subscript[q, i]))=(∫_1^2)(∫_1^2)((Subscript[x, 2]^2)+(Subscript[y, 2]^2)) θ((Subscript[q, r])(Subscript[x, 2])-(Subscript[q, i]) (Subscript[y, 2])-1) θ(2-(Subscript[q, r]) (Subscript[x, 2])+(Subscript[q, i]) (Subscript[y, 2])) θ(2-(Subscript[q, i])(Subscript[x, 2])-(Subscript[q, r])(Subscript[y, 2])) θ((Subscript[q, i])(Subscript[x, 2])+(Subscript[q, r]) (Subscript[y, 2])-1)d(Subscript[x, 2])d(Subscript[y, 2]).

We subdivide the (Subscript[x, 2]),(Subscript[y, 2]),(Subscript[q, r]),(Subscript[q, i])-space into cells using cylindrical algebraic decomposition. Because we are interested only in cells of finite 4D Lebesgue measure, we use the function Experimental`GenericCylindricalAlgebraicDecomposition. This function ignores boundaries having a vanishing 4D Lebesgue measure. Inside each cell, all four arguments of the Heaviside functions will have arguments of definite signs. This will allow to ignore the Heaviside theta function for process of integration.

dC[{x2_, y2_}, {qr_, qi_}] := 
   -1 + qr x2 - qi y2 > 0 &&  2 - qr x2 + qi y2 > 0 &&
    2 - qi x2 - qr y2 > 0 && -1 + qi x2 + qr y2 > 0 &&
	1 < x2 < 2 && 1 < y2 < 2

cad = ((Experimental`GenericCylindricalAlgebraicDecomposition[
                    dC[{x2, y2}, {qr, qi}], {qr, qi, x2, y2}][[1]] /. 
                    (* expand all cells to use explicit description *)
                       Inequality -> inequality) // LogicalExpand) /. 
                                            inequality -> Inequality;
Length[cad]

We obtained 229 cells. Here are the parametrizations for the first two cells.

Take[cad, 2]

Now it is straightforward to carry out the remaining two integrations over (Subscript[x, 2]) and (Subscript[y, 2]). The function doThex2y2Integration integrates (Subscript[x, 2]^2)+(Subscript[y, 2]^2) over each cell and adds Heaviside functions to restrict the (Subscript[q, r]) and (Subscript[q, i]) values appropriately.

doThex2y2Integration[a_And] := 
Module[{ix2, iy2, iqr, iqi, sInt1, dsInt1, sInt2, dsInt2, res},
 (* the variable ranges *)
 {ix2, iy2, iqr, iqi} = Cases[a, HoldPattern[
            Inequality[_, _, #, _, _]]][[1]]& /@ {x2, y2, qr, qi};
 (* carry out the x3=2 and y2 integration *)
 sInt1 = Integrate[x2^2 + y2^2, y2];
 dsInt1 = (sInt1 /. y2 -> iy2[[-1]]) - (sInt1 /. y2 -> iy2[[+1]]);
 sInt2 = Integrate[dsInt1, x2];
 dsInt2 = (sInt2 /. x2 -> ix2[[-1]]) - (sInt2 /. x2 -> ix2[[+1]]);
 (* canonicalize result *)
 res = Factor //@ Together[dsInt2];
 If[(iqr && iqi), Evaluate @ res, 0]]

Here is the result for the first cell.

doThex2y2Integration[cad[[1]]]

It is now a matter to seconds to obtain a closed-form expression for the distribution function.

q𝒫[qr_, qi_] = Plus @@ (doThex2y2Integration /@ cad);

q𝒫[qr_, qi_] = Plus @@
(Function[p, If @@ {p[[1, 1]], Together[Plus @@ (#[[2]]& /@ p)], 0}] /@ 
    Split[List @@ (doThex2y2Integration /@ cad), (#1[[1]] === #2[[1]])&]);

Piecewise the distribution function is a rational function. Overall, we obtain 45 different rational functions.

𝓅s = Union[(List @@ q𝒫[qr, qi]) /. If[_, i_, _] :> i];
𝓅s // Length

Here are three of them.

Take[𝓅s, 3]

Some of the rational function are quite complicated—they are quotients of two total degree 15 polynomials.

{First[#], Length[#]}& /@ Split[Sort[
   Exponent[({Numerator[#], Denominator[#]}& /@ 𝓅s) /. 
                              {qr -> C, qi -> C}, C]]]

The global maximum of p((Subscript[q, r]),(Subscript[q, i])) is p(1,0)=14/3.

To visualize the various rational functions, we number each of the 45 rational functions.

q𝒫C[qr_, qi_] = Evaluate //@ (q𝒫[qr, qi] /. If[cond_, int_, 0] -> 
                   If[cond, {int, Position[𝓅s, int][[1, 1]]}, {0, 0}]);
                   
(* unite If's with identical first condition *)                   
q𝒫C[qr_, qi_] = q𝒫C[qr, qi] //. 
    If[Inequality[qrl_, Less, qr, Less, qru_] && qip1_, r1__] +
    If[Inequality[qrl_, Less, qr, Less, qru_] && qip2_, r2__] :>
    If[Inequality[qrl,  Less, qr, Less, qru], 
       If[qip1, r1] + If[qip2, r2], {0, 0}];

By continuity, we could now continue the distribution functions to the boundaries. For a visualization, it is sufficient to avoid hitting the boundaries. We achieve this by using a slightly asymmetric plot domain.

data = Module[{ε = 1/Pi 10^-6, pp = 241}, N[#, 22]& @ 
       Table[q𝒫C[N[qr, 22], N[qi, 22]], {qi, -1, 1 + ε, (2 + ε)/pp},
                          {qr, 0, 5/2 + ε, (5/2 + ε)/pp}]];

Here is a plot of the resulting probability distribution function. We use a different (randomly chosen) color for each of the 45 rational functions covering the plane.

randomColor[0] := RGBColor[0, 0, 0];
randomColor[x_] := randomColor[x] = ToColor[Hue[Random[]], RGBColor]

Show[Graphics3D[
 ListPlot3D[Map[First, data, {2}], 
            Map[randomColor[Round[#]]&, Map[Last, data, {2}], {2}], 
            PlotRange -> All, MeshRange -> {{0, 5/2}, {-1, 1}},
            Mesh -> False, DisplayFunction -> Identity]] /. 
                                  h_Hue :> SurafeColor[h, h, 2.8],
     DisplayFunction -> $DisplayFunction]

Consider a level three Gosper curve from Chapter 2 of the Graphics volume. Assuming harmonically bound point masses at the vertices (the two outermost points are kept fixed) and springs of a given stiffness along the straight line segments of the Gosper curve, the resulting object is a 2D vibrating system. For small elongations, calculate the resulting eigenoscillations for identical stiffnesses and random stiffnesses. Starting with one inner vertex initially elongated, visualize how the vibrations propagate through the spring chain in the two cases.

LSystemWithlAndr[axiom_, rules_, iterations_, δ_] :=
Module[{m, p, c = Cos[δ], s = Sin[δ], ℛ, ℓ = {0, 0}, 𝒹 = {1, 0}},
 m = {{ c, s}, {-s, c}}; p = {{ c, -s}, { s, c}};
 ℛ = rules /. {(a_ -> b_) -> (a :> Sequence @@ b)};
 Select[Prepend[
 (Which[# == "l", ℓ = ℓ + 𝒹,  # == "r", ℓ = ℓ + 𝒹,
        # == "+", 𝒹 = p.𝒹; Null, # == "-", 𝒹 = m.𝒹; ]& /@
       Nest[(# /. ℛ)&, axiom, iterations]), {0, 0}], # =!= Null&]]

Gosper[i_Integer] := Gosper[i] = LSystemWithlAndr[
{"l"}, {"l" -> Characters["l+r++r-l--ll-r+"],
        "r" -> Characters["-l+rr++r+l--l-r"]}, i, Pi/3]

Next, we join the adjacent parallel line segments into one.

(* are the three points p1, p2, p3 on one straight line? *)
oneOneLineQ[{p1_, p2_, p3_}] := oneOneLineQ[{p1, p2, p3}] =
With[{𝓃 = Sqrt[#.#]&}, 
     Expand[𝓃[p3 - p1] - (𝓃[p2 - p1] + 𝓃[p3 - p2])] === 0]

order = 3;
gosperLine = Gosper[order] //. {a___, p1_, p2_, p3_, b___} :>
              {a, p1, p3, b} /; oneOneLineQ[{p1, p2, p3}];

Here is the resulting Gosper curve with 293 inner vertices. We color each line segment differently. For later use, we mark one central point.

{𝒹 = Length[gosperLine], dim = 𝒹 - 2}

Position[#, Min[#]]&[
Function[mp, (mp - #).(mp - #)& /@ gosperLine][
         Plus @@ gosperLine/Length[gosperLine]]][[1, 1]]

(* position of one central vertex *)
m = Which[order == 1, 4, order == 2, 15, 
          order == 3, 113, order == 4, 791];
(* or use point nearest to center:
Position[#, Min[#]]&[
Function[mp, (mp - #).(mp - #)& /@ gosperLine][
         Plus @@ gosperLine/Length[gosperLine]]][[1, 1]] *)          
(* show straight line segments of the Gosper curve *)
Show[Graphics[{{Hue[Random[]], Thickness[0.002], Line[#]}& /@ 
                Partition[gosperLine, 2, 1],
               {PointSize[0.03], Point[gosperLine[[m]]]}}], 
     AspectRatio -> Automatic]

Giving the first vertex the index 0, allows to conveniently refer to the 293 movable vertices by their number vertexNumber.

Do[vertexNumber[gosperLine[[k]]] = k - 1;
   vertexCoordinates[k - 1] = gosperLine[[k]],
   {k, Length[gosperLine]}]

To calculate the eigenoscillations of the Gosper spring chain, we make the ansatz (Subscript[(Overscript[u, ..]), j])(t)∼(e^(i ω t))(Subscript[(OverHat[u]), j]) in the equations of motions (Subscript[(Overscript[u, ..]), j])(t)=(Subscript[k, j ])f((Subscript[u, j-1])(t),(Subscript[u, j])(t))+(Subscript[k, j+1 ])f((Subscript[u, j+1])(t),(Subscript[u, j])(t))-κ (Subscript[u, j])(t) . Here (Subscript[u, j])(t) is the elongation of the jth vertex, (Subscript[k, j]) is the stiffness of the jth spring connecting the vertices j-1 and j , f((Subscript[u, j-1])(t),(Subscript[u, j])(t)) is the force exerted by the j+1th vertex on the jth vertex, and κ accounts for the harmonic bounds at the original positions of the vertices along the Gosper curve. Here the forces defined.

F[k_] := force[{k, k + 1}] + force[{k, k - 1}] + force[{k}]

force[{i_, j_}] := 
Module[{p0i = vertexCoordinates[i], 
        p0j = vertexCoordinates[j], pi, pj},
        pi = p0i + {x[i], y[i]}; pj = p0j + {x[j], y[j]};
        𝓀[Max[{i, j}]] #/Sqrt[#.#]&[pj - pi]*
         (Sqrt[#.#]&[pj - pi] - Sqrt[#.#]&[p0j - p0i])]
         
(* harmonic bound to the original vertices *)
force[{k_}] := -κ {x[k], y[k]};

For small elongations, we keep only terms linear in the (Subscript[(OverHat[u]), j])={(Subscript[x, j]),(Subscript[y, j])}.

FLinearized[k_] := Normal[
   Series[F[k] /. xy:(_x | _y) :> ε xy, {ε, 0, 1}]]/ε /.
  (* endpoints *) {x[0 | 𝒹 - 1] -> 0, y[0 | 𝒹 - 1] -> 0}

This is the linearized force exerted on the second vertex.

FLinearized[2] // Collect[#, {_x, _y}]&

Forming the coefficient matrix of the {(Subscript[x, j]),(Subscript[y, j])}. In this matrix of dimension 2d×2d we first take the coefficients of the (Subscript[x, j]) and then the coefficients of the (Subscript[y, j]).

coefficientRules[𝓀_, κ_] = 
Module[{υ, xC, yC},
 (* extract x[j], y[j] and coefficient *)
 υ[p_Plus] := υ /@ (List @@ p); υ[l_List] := υ /@ l;
 υ[f_. x[j_]] := {j, f}; υ[f_. y[j_]] := {dim + j, f}; υ[0] := {};
 Flatten[Table[{xC, yC} = Collect[FLinearized[k], {_x, _y}];
               (* matrix entries *)
               {({k, #1} -> #2)& @@@ υ[xC],
               (* y[] after all the x[] *)
               ({dim + k, #1} -> #2)& @@@ υ[yC]}, {k, dim}]]];

(* form matrix from rules of nonvanishing elements *)
makeMatrix[𝓇:rules_] := 
Module[{𝓂 = Table[0, {#}, {#}]&[Max[First /@ rules]]},
      (* insert nonvanishing matrix elements *)
       Do[𝓂[[𝓇[[i, 1, 1]], 𝓇[[i, 1, 2]]]] = 
          𝓂[[𝓇[[i, 1, 1]], 𝓇[[i, 1, 2]]]] + 𝓇[[i, 2]],
          {i, Length[𝓇]}]; 𝓂]

Here are two coefficient matrices. The first M[1] uses constant spring stiffnesses and the second M[2] uses random ones with the same mean as the values of the first one (we could also use some negative spring constants [✶]) .

M[1] = makeMatrix[coefficientRules[2&, 1]];

SeedRandom[1];
M[2] = makeMatrix[
        coefficientRules[(SeedRandom[#]; 4 Random[])&, 
                         2 Random[]]];

Do[{evals[j], evecs[j]} = Eigensystem[N[M[j]]], {j, 2}]

Here are the two spectra and eigenvectors visualized. The first half are the nontrivial global modes and the second half are the superpositions of local modes due to the harmonic bounds at the lattice points and perpendicular movements. (The two intermediate modes in M[1] arise from the two endpoints.) In the case of random spring constants, we clearly see localized modes.

Do[Show[GraphicsArray[
   Block[{$DisplayFunction = Identity},
         {ListPlot[-evals[j]], ListDensityPlot[Re[evecs[j]], 
           Mesh -> False, FrameTicks -> None]}]]], {j, 2}]

The localization properties of the modes can be demonstrated by considering the overlap with the situation of all vertices are initially elongated in direction {cos(φ),sin(φ)}. The following graphics show the value of the scalar product of the modes with the initial elongation as a function of φ.

Show[GraphicsArray[
Graphics3D[{PointSize[0.002], 
Table[(* all initial positions are equal *)
      initialVector = Join[#, #]&[Table[Cos[φ], {dim}]];
      (* show overlaps *)
      MapIndexed[{Hue[#2[[1]]/dim], Point[{#2[[1]], φ, Re @ #1}]}&,
           initialVector.#& /@ evecs[#]], {φ, 0., 2.Pi, 2Pi/10}]},
     BoxRatios -> {2, 1, 1}, Axes -> True]& /@ {1, 2}]]

Now, we consider the time-dependence of an inner vertex initially elongated. The scalar products of the eigenvectors with this initial state are shown in the following two graphics.

(* one vertex is initially elongated *)
initialVector = MapAt[-1&, Table[0, {2dim}], m - 1] // N;
(* form scalar products *)
Do[coeffs[j] = (initialVector.#& /@ evecs[j]), {j, 2}];
(* show scalar products *)
Show[GraphicsArray[
 ListPlot[Re[coeffs[#]], PlotRange -> All, DisplayFunction -> Identity,
          PlotStyle -> {PointSize[0.01]}]& /@ {1, 2}]]

The time dependent elongation of all vertices follows from the superposition (Subscript[u, j])(t)=(∑_(k=1)^d)(Subscript[c, k]^((j)))(e^(i (Subscript[ω, k]) t)) where the (Subscript[c, k]^((j))) is the scalar product of the kth eigenvector with the initial elongation vector.

evI[j_][t_] := Plus @@ (Times @@@ Transpose[
               {coeffs[j] Cos[Sqrt[Abs[evals[j]]] t], evecs[j]}])

Here are the resulting time-dependent elongations shown. In the equal stiffness case, we see a constant speed propagation of the perturbation. After the two end vertices of the chain are reached, reflections occur. In the random stiffness case, the perturbation stays largely localized over the same time.

Show[GraphicsArray[Table[
(* elongation values *)
T = Table[Sqrt[Re[#.#]]& /@ Transpose[Partition[evI[j][t], dim]],
          {t, 0, 600, 2}];
(* homogeneously spaced elongation values *)
cls = #[[Round[Length[#]/2]]]& /@
         Partition[Sort[Flatten[Chop[T, 10^-12]]], dim];   
(* color function *)
cf[j][x_] = Which @@ Flatten[Append[
             MapIndexed[{x < #1, GrayLevel[(#2[[1]] - 1)/Length[cls]]}&, 
                        cls], {True, GrayLevel[1]}]];   
(* generate homogeneously colored density plot *)
ListDensityPlot[T,  PlotRange -> All, ColorFunction -> cf[j], 
                Mesh -> False, DisplayFunction -> Identity,
                MeshRange -> {{1, dim}, {0, 600}}], {j, 2}]]]

We end with an animation of the spread of the initial elongation.

frame[vec_, opts___] :=
Module[{mima, vecS, segments, elongs, colors}, 
 (* scaled elongation vectors *)
 vecS = Join[{{0, 0}}, Transpose[Partition[vec, dim]], {{0, 0}}];
 (* line along elongated vertices *)
 segments = Line /@ Partition[gosperLine + 1/2 vecS, 2, 1];
 elongs = #/Max[#]&[Sqrt[#.#]& /@ Re[vecS]]; 
 (* color segments according to elongation *)
 colors = Hue /@ (Plus @@@ Partition[elongs, 2, 1]/2);                
 (* make graphics *)
 Graphics[{{PointSize[0.03], Point[gosperLine[[m]]]},
           Transpose[{colors, segments}]}, 
           (* use uniform plot range *) PlotRange -> 
           ((# + {-1, 1})& /@ ({Min[#], Max[#]}& /@ 
            Transpose[gosperLine])), opts, 
            AspectRatio -> Automatic]];

Do[Show[GraphicsArray[Table[frame[evI[j][t]], {j, 2}]]],
   {t, 0, 600, 120}]

Do[Show[GraphicsArray[Table[frame[evI[j][t]], {j, 2}]]],
   {t, 0, 600, 5}]

In exercise 35 of Chapter 1 of the Symbolics volume, the average distance of two randomly chosen points from within the unit square was calculated. Now, calculate the probability distribution 𝓅(d) for the occurring lengths 0≤d≤(2^(1/2 )).

cf = Compile[{{n, _Integer}, {bins, _Integer}},
            Module[{tab = Table[0, {bins}], λ, b},
                   Do[λ = Sqrt[(Random[] - Random[])^2 + 
                               (Random[] - Random[])^2];
                      b = Ceiling[bins λ/Sqrt[2]];
                      tab[[b]] = tab[[b]] + 1, {n}];
                    tab/n]];

The resulting distribution is relatively broad with a maximum around d≈0.5.

lcp = With[{bins = 100, n = 10^8}, 
ListPlot[MapIndexed[{Sqrt[2] #2[[1]]/bins, bins/Sqrt[2] #1}&, 
                    cf[n, bins]], PlotStyle -> PointSize[0.006]]];

The exact distribution is given by the following integral

𝓅(λ)=(∫_0^1)(∫_0^1)(∫_0^1)(∫_( 0)^1)δ(λ-(Sqrt[((((Subscript[x, 2])-(Subscript[x, 1])))^2)+((((Subscript[y, 2])-(Subscript[y, 1])))^2)])) d(Subscript[y, 2])d(Subscript[y, 1])d(Subscript[x, 2])d(Subscript[x, 1])

Mathematica cannot carry out even the innermost integration symbolically.

𝒹[{x1_, y1_}, {x2_, y2_}] := Sqrt[(x1 - x2)^2 + (y1 - y2)^2]

Integrate[DiracDelta[λ - 𝒹[{x1, y1}, {x2, y2}]], {y1, 0, 1 - x1}]

So we will use the well known formula (∫_ℐ)δ(y-f(x))dx=(∫_ℐ)(∑_k)δ(y-(Subscript[x, k]))/|f'((Subscript[x, k]))|dx where the (Subscript[x, k]) are the zeros of f(x) in the interval ℐ. For the integrand under consideration, we have up to two zeros.

sol = Solve[λ - 𝒹[{x1, y1}, {x2, y2}] == 0, y2] // Simplify

The denominator absolute value is identical for the two roots.

{int1y2, int2y2} = (1/D[λ - 𝒹[{x1, y1}, {x2, y2}], y2] /. # // 
                                  Simplify[#, λ > 0]&)& /@ sol

inty2 = int1y2;

For carrying out the various integration, we subdivide the (Subscript[x, 1])-(Subscript[x, 2])-(Subscript[y, 1]) space into regions of identical sign of the root expression (this automatically ensures the existence of the roots).

cond1 = 0 < x1 < 1 && 0 < x2 < 1 && 0 < y1 < 1 &&
        0 < sol[[1, 1, 2]] < 1 && λ > 0;

cad1 = CylindricalDecomposition[cond1, {λ, x1, x2, y1}];

We group the resulting regions with respect to the λ-domains.

expandCAD[cad_] := 
{#[[1, 1]], Rest /@ #}& /@ Split[List @@ #, #1[[1]] == #2[[1]]&]& @ 
  DeleteCases[cad  //. a_ && (b_ || c_) :> (a && b) || (a && c) /. 
                                                 LessEqual -> Less,
              _?(MemberQ[#, _Equal, Infinity]&)]

Here is the subdivision corresponding to the first root.

cad1R = expandCAD[cad1]

And here is the subdivision corresponding to the second root.

cond2 = 0 < x1 < 1 && 0 < x2 < 1 && 0 < y1 < 1 &&
        0 < sol[[2, 1, 2]] < 1 && λ > 0;

cad2 = CylindricalDecomposition[cond2, {λ, x1, x2, y1}];
cad2R = expandCAD[cad2]

We have four λ-intervals.

{First /@ cad1R, First /@ cad2R}

λIntervals = %[[1]];

Now, we must carry out the remaining three integrations for the four λ-domains. The function x1x2y1Integration iteratively forms the indefinite integral and then calculates the values at the upper and lower limit to obtain the value of the definite integral. We do the definite integration manually to avoid that Mathematica spends time on checking the integration range for singularities and discontinuities; because the integration domains were constructed to ensure a smooth dependence in their inside, this is not needed.

x1x2y1Integration[cad_, startIntegrand_] :=
Module[{𝒟ℒ, 𝓋2, x1L, x1U, 𝓋3, x2L, x2U, 𝓋4, y1L, y1U},
 (* form difference of integral at upper limit minus
    integral at lower limit *)
 𝒟ℒ = (Limit[#1, #2[[1]] -> #2[[3]], Direction -> +1] - 
       Limit[#1, #2[[1]] -> #2[[2]], Direction -> -1])&;     
 (* integration regions *)
 {{𝓋2, x1L, x1U}, {𝓋3, x2L, x2U}, {𝓋4, y1L, y1U}} = 
            cad /. Inequality[a_, Less, b_, Less, c_] :>
                                 {b, a, c} /. And -> List;
 (* carry out the three integrations *)
 Fold[𝒟ℒ[Integrate[#1, #2[[1]]], #2]&, startIntegrand, 
      {{𝓋4, y1L, y1U}, {𝓋3, x2L, x2U}, {𝓋2, x1L, x1U}}]]

Summing up the contributions for all (Subscript[x, 1])-(Subscript[x, 2])-(Subscript[y, 1])regions belonging to a given λ-domain gives the probability distribution we are looking for.

sumUp[λRange_] := 
  Simplify[Plus @@ #, λRange]& @ (x1x2y1Integration[#, inty2]& /@
   Flatten[Last /@ Cases[{cad1R, cad2R}, {λRange, _}, Infinity]])

The resulting distribution has different functional form in the two intervals [0,1] and [1,(2^(1/2))].

{𝓅[{0, 1/2}], 𝓅[{1/2, 1}], 𝓅[{1, Sqrt[5]/2}], 𝓅[{1, Sqrt[5]/2}]} = 
                                           sumUp /@ λIntervals

Here is a graphic of the resulting distribution. The earlier calculated numerical values agree excellently with the theoretical curve. The resulting curve is continuous differentiable at λ=1 (the second derivative is discontinuous).

Plot[Which[0 < λ < 1, 𝓅[{0, 1/2}], 1 < λ < Sqrt[2], 𝓅[{1, Sqrt[5]/2}]], 
     {λ, 0, Sqrt[2]}, Prolog -> {PointSize[0.009], Hue[0],
                                 Cases[lcp, _Point, Infinity]},
     PlotStyle -> {{Thickness[0.002], GrayLevel[0.8]}}];

𝓅D[λ_] := UnitStep[λ] UnitStep[1 - λ] 2 λ (Pi + λ (λ - 4)) + 
          UnitStep[λ - 1] UnitStep[Sqrt[2] - λ]*
            (2 λ (Pi - 2 - λ^2 + 4 Sqrt[λ^2 - 1] - 4 ArcTan[Sqrt[λ^2 - 1]]))

By construction, the distribution is normalized to 1.

Integrate[𝓅[{0, 1/2}], {λ, 0, 1}] + Integrate[𝓅[{1, Sqrt[5]/2}], {λ, 1, Sqrt[2]}]

The maximum occurs at (Subscript[d, max])≈0.48. Interestingly, the maximum of the distribution has nearly exactly the same distance from 0.5 as the expectation value (the maximum is slightly less than 0.5 and the maximum is slightly larger than 0.5.)

{#, N @ #}& @ Min[λ /. Solve[D[𝓅[{0, 1/2}], λ] == 0, λ]]

{(2 + Sqrt[2] + 5 ArcSinh[1])/15 - 1/2, 
 1/2 -  (4 - Sqrt[16 - 3 Pi])/3} // N

We end by calculating once more the expectation value. Using the obtained form of the distribution directly results in a complicated expression containing hypergeometric functions for the expectation value.

av1 = Integrate[λ S[{0, 1/2}], {λ, 0, 1}]

av2 = Integrate[λ 𝓅[{1, Sqrt[5]/2}], {λ, 1, Sqrt[2]}]

Calculating the last integral through the indefinite integral yields a result in elementary functions.

(* form indefinite integral *)
intλ = Integrate[λ 𝓅[{1, Sqrt[5]/2}], λ]

Forming the indefinite integral yields once more the result from solution 35a.

av2b = Limit[intλ, λ -> Sqrt[2], Direction -> 1] - 
       Limit[intλ, λ -> 1, Direction -> -1];

av1 + av2b // FullSimplify

Consider the 2D eigenvalue problem -Δ (Subscript[u, λ])(x,y)=λ (Subscript[u, λ])(x,y) on a square S. The boundary conditions on two edges and the two adjacent half edges are homogeneous Dirichlet conditions, meaning  (Subscript[u, λ])(x,y)(Subscript[|, (∂_D)S])=0 (so-called mixed or hybrid boundary conditions [✶], [✶]). On the remaining two half edges that meet at a vertex, the boundary condition is a homogeneous Robin condition (1-α)∂(Subscript[u, λ])(x,y)/∂n+α (Subscript[u, λ])(x,y)(Subscript[|, (∂_D)S])=0. Make an animation showing how some of the higher states change as α varies from 1 to 0 (meaning from homogeneous Dirichlet conditions of the half edge to homogeneous Neumann conditions). Use a finite element discretization to solve the 2D eigenvalue problem.

(∫_S)∇u(x,y).∇v (x,y)dx dy+(α/(1-α))(∫_((∂_D)S)) u(x,y) v(x,y) ds=(Underscript[λ∫, S]) u(x,y) v(x,y) dx dy,

where we assume that the homogeneous Dirichlet conditions are strictly fulfilled.

A convenient discretization of the square is the subdivision into smaller squares. And a convenient shape function basis set are biquadratic polynomials with knot points at the vertices, the edge midpoints, and the center of a square.

Evaluate[Table[p[k], {k, 9}]] = 
           {{0, 0}, {2, 0}, {2, 2}, {0, 2}, {1, 0}, {2, 1}, {1, 2}, {0, 1}, {1, 1}}/2;

Here are the explicit forms of the nine shape functions.

Table[shapeFunction[m, {ξ_, η_}] =
 Factor[Sum[c[i, j] ξ^i η^j, {i, 0, 2}, {j, 0, 2}] /.
   Solve[Table[(Sum[c[i, j] ξ^i η^j, {i, 0, 2}, {j, 0, 2}] /. 
      Thread[{ξ, η} -> p[k]]) == KroneckerDelta[m, k], {k, 9}],  
         Flatten[Table[c[i, j], {i, 0, 2}, {j, 0, 2}]]][[1]]], {m, 9}]

Here are the nine shape functions graphically hown.

Show[GraphicsArray[#]]& /@ Partition[
Table[Plot3D[Evaluate[shapeFunction[m, {ξ, η}]], {ξ, 0, 1}, {η, 0, 1}, 
             PlotRange -> All, ColorFunction -> GrayLevel, Axes -> True,
             DisplayFunction -> Identity], {m, 9}], 3];

Next, we must calculate the mass matrix, the stiffness matrix, and the boundary line integral matrix for our nine shape functions. Later, we will use subsquares of edge length δ, so the Jacobian is (δ^2).

𝒥 = δ^2;

Here is the mass matrix.

ℳℳ = 𝒥 Table[Integrate[shapeFunction[m, {ξ, η}] shapeFunction[n, {ξ, η}],
                         {ξ, 0, 1}, {η, 0, 1}], {m, 9}, {n, 9}];

The calculation of the stiffness matrix is straightforward too.

(* unit square coordinates as a function of real coordinates *)
ξ[{x_, y_}] := (x - x1)/δ (* with δx = δ = (x2 - x1) *);
η[{x_, y_}] := (y - y1)/δ (* with δy = δ = (y4 - y1) *);

(* shape parameter values *)
{𝒜, 𝒞, ℬ} = 
{D[ξ[{x, y}], x]^2 + D[ξ[{x, y}], y]^2,
 D[η[{x, y}], x]^2 + D[η[{x, y}], y]^2,
 D[ξ[{x, y}], x] D[η[{x, y}], x] + D[ξ[{x, y}], y] D[η[{x, y}], y]} 𝒥

𝒮ℳ = 
With[{sf = shapeFunction[#, {ξ, η}]&},
 Table[𝒜 Integrate[D[sf[m], ξ] D[sf[n], ξ], {ξ, 0, 1}, {η, 0, 1}] +
       𝒞 Integrate[D[sf[m], η] D[sf[n], η], {ξ, 0, 1}, {η, 0, 1}],
        {m, 9}, {n, 9}]];

And here is the matrix for the boundary line integrals.

ℬℳ = Table[0, {m, 9}, {n, 9}];

Function[{ξη, args, nodes}, (ℬℳ[[##]] = 
 δ Integrate[shapeFunction[#1, args] shapeFunction[#2, args],
                         {ξη, 0, 1}])& @@@ 
  (* points that are connected *)
  ({{#1, #1}, {#2, #2}, {#3, #3}, {#1, #2}, {#2, #1}, 
    {#1, #3}, {#3, #1}, {#2, #3}, {#3, #2}}& @@ nodes)] @@@
    {{ξ, {ξ, 1}, {3, 4, 7}}, {ξ, {ξ, 0}, {1, 5, 2}},
     {η, {1, η}, {2, 3, 6}}, {η, {0, η}, {1, 4, 8}}};

Next, we subdivide our original square [-1,1]×[-1,1] into subsquares of edge length δ. The function makeSubSquares generates the subsquares and the function pointList maps the knot points into the subsquares.

makeSubSquares[δ_] := 
 Table[Polygon[{{x, y}, {x + δ, y}, {x + δ, y + δ}, {x, y + δ}}],
        {x, -1, 1 - δ, δ}, {y, -1, 1 - δ, δ}] // Flatten[#, 1]&;

pointList[Polygon[{{x1_, y1_}, {x2_, y2_}, {x3_, y3_}, {x4_, y4_}}]] :=
             ({x1, y1} + {#1 (x2 - x1), #2 (y4 - y1)})& @@@ Array[p, 9]

Now, we classify all discretization points into interior, boundary, and Robin-boundary points. The function makeVertexAssignments subdivides the initial square with Robin boundary conditions according to the test robinPointQ (each boundary point is subjected to this test) into (𝒹^2) squares and generates list of vertices for the interior points, and the Robin-boundary points. For later use, it makes various variable names globally visible. This allows to reuse them easily in various functions.

makeVertexAssignments[𝒹_, robinPointQ_] := 
Module[{subSquarePoints, allVertices, boundaryVertices},
(* global variables *)
Clear[subSquares, allNonDirichletVertices, dirichletVertices, 
      robinVertices, λ, δ, nonDirichletVertexQ, robinVertexQ];
δ = 2/𝒹;
(* form subsquares and mapped points *)
subSquares = makeSubSquares[δ];
subSquarePoints = pointList /@ subSquares;
allVertices = Union[Level[subSquarePoints, {-2}]];
(* all boundary vertices *)
boundaryVertices = Cases[allVertices, {-1, _} | {+1, _} | {_, -1} | {_, +1}];
robinVertices = Select[boundaryVertices, robinPointQ];
(* make functions for Robin-boundary points *)
Do[robinVertexQ[robinVertices[[j]]] = True,
   {j, Length[robinVertices]}];
dirichletVertices = Complement[boundaryVertices, robinVertices];
allNonDirichletVertices = Complement[allVertices, dirichletVertices];
λ = Length[allNonDirichletVertices];
(* make functions for inner and Robin-boundary points *)
Do[nonDirichletVertexQ[allNonDirichletVertices[[j]]] = True;
   coordinateVertex[j] = allNonDirichletVertices[[j]];
   vertexNumber[allNonDirichletVertices[[j]]] = j, 
   {j, λ}];
Do[nonDirichletVertexQ[dirichletVertices[[j]]] = False;
   coordinateVertex[λ + j] = dirichletVertices[[j]];
   vertexNumber[dirichletVertices[[j]]] = λ + j, 
   {j, Length[dirichletVertices]}]]

Here is graphic showing the Dirichlet boundary points in green, the Robin boundary points in red, and all non-Dirichlet points in gray. The subsquares are bounded by blue lines.

(* function to visualize point assignments *)
discretizationGraphics[] := 
Show[Graphics[{
 {RGBColor[0, 0, 1], subSquares /. Polygon[l_] :> Line[Append[l, First[l]]]},
 {PointSize[0.02], RGBColor[0, 1, 0], Point /@ dirichletVertices},
 {PointSize[0.012], RGBColor[1, 0, 0], Point /@ robinVertices},
 {PointSize[0.006], GrayLevel[0.4], Point /@ allNonDirichletVertices}}], 
      PlotRange -> All, AspectRatio -> Automatic, Frame -> True];

robinPointQ[{x_, y_}] := (0 < x <= 1 && y == 1) || 
                         (0 < y <= 1 && x == 1)
makeVertexAssignments[12, robinPointQ]

discretizationGraphics[]

For the solution of the eigenvalue problem through finite elements, we must assemble the global mass and stiffness matrices. The function makeSparseMatrix generates the global mass matrix, stiffness matrix, and the boundary integral matrix arising from the Robin boundary conditions. To assemble the matrix, we use the global values of the functions subSquares, vertexNumber, nonDirichletVertexQ, and robinVertexQ. Because the resulting matrices are sparse and large, we generate them as sparse arrays.

(* add elements *)
makeMatrix[values_] := ((List @@ #[[1, 1]]) -> (Plus @@ (Last /@ #)))& /@ 
                        Split[Sort[values], #1[[1]] == #2[[1]]&]

makeSparseMatrix[criteria_, ℳ_] :=
Module[{L = {}},
 (* loop over all subsquares *)
 Do[xyPoints = pointList[subSquares[[k]]];
   (* loop over all nine points in a subsquare *)
   Do[(* for interior and Robin-boundary points, add contributions *)
      If[criteria[xyPoints[[a]]] && criteria[xyPoints[[b]]],
         {i, j} = vertexNumber /@ xyPoints[[{a, b}]];
         L = {L, C[i, j] -> ℳ[[a, b]]}], {a, 9}, {b, 9}],
     {k, Length[subSquares]}];
SparseArray[makeMatrix @ Flatten[L], λ {1, 1}, 0]]

We unite the generation of the three matrices in the function sparseMatrixTriple.

sparseMatrixTriple[] := makeSparseMatrix @@@
 {{nonDirichletVertexQ, 𝒮ℳ}, {nonDirichletVertexQ, ℳℳ}, {robinVertexQ, ℬℳ}}

We obtain matrices of size 552×552 for the above discretization example.

Dimensions /@ sparseMatrixTriple[]

Next, we define some functions for the visualizations of the eigenfunctions. The function eigenFunctionListPlot3D generates a 3D plot of the eigenfunction.

(* z-coordinate for the 3D plot is eigenvector value *)
zCoordinate[{x_, y_}, evec_] := 
            If[nonDirichletVertexQ[{x, y}], evec[[vertexNumber[{x, y}]]], 0]

(* array of z-coordinates *)
valueTable[evec_] := 
Module[{subsubSquarePoints = Table[{x, y}, {x, -1, 1, δ}, {y, -1, 1, δ}]},
       Map[Append[#, zCoordinate[#, evec]]&, subsubSquarePoints, {-2}]]

eigenFunctionListPlot3D[evec_] :=
Module[{subsubSquarePolygons = 
        Table[Polygon[{{x, y}, {x + δ, y}, {x + δ, y + δ}, {x, y + δ}}],
        {x, -1, 1 - δ, δ}, {y, -1, 1 - δ, δ}] // Flatten[#, 1]&, polys},
 (* form four polygons for each subsquare *)
 polys = Map[{#[[1]], #[[2]], zCoordinate[#, evec]}&, 
             subsubSquarePolygons, {-2}];
  (* make 3D graphics *)
 Graphics3D[{EdgeForm[], polys}, 
            PlotRange -> All, BoxRatios -> {1, 1, 0.4}]]

For higher, more rapidly changing states, a contour plot is typically better suited for visualizations. This time, we show (by default) the absolute value of the eigenfunctions through gray levels and the nodal lines as thin red lines.

(* values for cl homogeneously spaced contours *)
homContours[data_, cl_] := 
With[{λ = Length[Flatten[data]]},
    #[[Round[λ/cl]]]& /@ Partition[Sort[Flatten[data]], Round[λ/cl]]]

eigenFunctionListContourPlot[evec_, f_:Abs] :=
Module[{subsubSquarePoints = Table[{x, y}, {y, -1, 1, δ}, {x, -1, 1, δ}],
        data1, data2, lcp1, lcp2},
 (* prepare data *)
 data1 =  Map[zCoordinate[#, evec]&, subsubSquarePoints, {-2}];
 data2 =  Map[f, data1, {2}];
 (* make graphics *)
 Block[{$DisplayFunction = Identity}, 
 data1a = Take[data1, {2, -2}, {2, -2}];
 (* nodal lines *)
 lcp1 = ListContourPlot[data1a, PlotRange -> All, ContourLines -> True, 
                 ContourShading -> False, Contours -> {0},
                 ContourStyle -> {Hue[0], Thickness[0.004]},
                 MeshRange -> {{-1 + δ, 1 - δ}, {-1 + δ, 1 - δ}}];
 (* absolute value (or f of) the eigenfunctions *)
 lcp2 = ListContourPlot[data2, PlotRange -> All, Frame -> True, 
                 ContourLines -> False, MeshRange -> {{-1, 1}, {-1, 1}},
                 Contours -> homContours[data2, Round[Sqrt[Length[evec]]]],
                 ContourStyle -> {Thickness[0.002]}];
 Show[{lcp2, lcp1, (* border *)
       Graphics[{Thickness[0.01], RGBColor[0, 0, 1], 
                  Line[{{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}]}]},
      Frame -> False]]]

Before implementing the animation, we visualize some example eigenfunctions for various parts of the square’s boundary having Robin boundary conditions. The function exampleBoundaryGraphics generates the mass, stiffness, and boundary matrices, and solves the eigenvalue for the list of α-values αs for the lowest eigenvalues and for eigenvalues of approximate size shift. The lowest eigenfunctions we display as 3D plots, and the higher ones as contour plots.

exampleBoundaryGraphics[robinCondition_, 𝒹_, αs_, shift_] :=
Module[{nEvs = 3, evOpts, A, B, Ar, evals, evecs},
 evOpts = Sequence["Arnoldi", BasisSize -> 50, MaxIterations -> 10^4,
                              Tolerance -> 10^-8];
 (* generate matrices *)
 makeVertexAssignments[𝒹, robinCondition]; 
 {A, B, Ar} = sparseMatrixTriple[];
 (* show problem discretized structure *)
 Show[Block[{$DisplayFunction = Identity}, discretizationGraphics[]],
      Frame -> False];
 (* show higher eigenfunctions for various α-values *)
 Function[α, Print["α = ", N @ α]; ABPair = N[{A + α/(1 - α) Ar, B}];
  (* calculate and show lowest eigenfunctions for various α-values *)
  {evals, evecs} = Reverse /@ 
  Eigensystem[ABPair, 3, Method -> {evOpts, Shift -> 0}];
  Show[GraphicsArray[eigenFunctionListPlot3D /@ evecs]];
  (* calculate and show higher eigenfunctions for various α-values *)
  {evals, evecs} = Reverse /@ 
  Eigensystem[ABPair, nEvs, Method -> {evOpts, Shift -> shift}];
  Show[GraphicsArray[#]]& /@ 
      Partition[eigenFunctionListContourPlot[Abs[#]]& /@ evecs, 3]] /@ αs]

In the first example, the middle third of one edge has Robin boundary conditions.

robinPointQ[{x_, y_}] := y == 1 && -1/3 < x < 1/3;
exampleBoundaryGraphics[robinPointQ, 50, {0, 0.5, 0.99}, 200]

In the second example, one half of each edges has Robin boundary conditions. This time, we show higher states.

robinPointQ[{x_, y_}] := x == -1 && y < 0 || x == +1 && y > 0 ||
                         y == -1 && x > 0 || y == +1 && x < 0;
exampleBoundaryGraphics[robinPointQ, 50, {0, 0.5, 0.99}, 600]

In the third example, two diagonally opposite half edge has Robin boundary conditions.

robinPointQ[{x_, y_}] := x == -1 && y < 0 || x == +1 && y > 0;
exampleBoundaryGraphics[robinPointQ, 50, {0, 0.5, 0.99}, 600]

In the fourth example, the middle thirds of all four edges have Robin boundary conditions.

robinPointQ[{x_, y_}] := 
     x == -1 && -1/3 < y < 1/3 || x == +1 && -1/3 < y < 1/3 ||
     y == -1 && -1/3 < x < 1/3 || y == +1 && -1/3 < x < 1/3;
exampleBoundaryGraphics[robinPointQ, 50, {0, 0.5, 0.99}, 600]

A typical feature of all of the last examples are the existence of relatively large areas of uniform patterns [✶].

And in the last example, we assign the Robin boundary condition randomly to all vertices.

robinPointQ[{x_, y_}] := randomRobinValue[{x, y}];
(* remember which points are Robin-boundary points *)
randomRobinValue[{x_, y_}] := 
      randomRobinValue[{x, y}] = Random[Integer] === 0
exampleBoundaryGraphics[robinPointQ, 50, {0, 0.5, 0.99}, 600]

Now, we return to our animation problem. To get an idea where and how fast the transition from Dirichlet to Neumann boundary condition is reflected in the eigensystems, we use a relatively crude discretization and calculate and visualize the lowest eigenvalues. We parametrize α through α=1-(10^(Subscript[α, E])) to easily span a large range of α-values.

robinPointQ[{x_, y_}] := (0 < x <= 1 && y == 1) || 
                         (0 < y <= 1 && x == 1)
makeVertexAssignments[7, robinPointQ];
{A, B, Ar} = sparseMatrixTriple[];
Dimensions[A]

Show[Graphics[{PointSize[0.003],
Table[α = 1 - 10^αExp;
     Point[{αExp, #}]& /@ 
     (Take[Eigenvalues[N @ Normal[{A + α/(1 - α) Ar, B}]], -12]/Pi^2),  
      {αExp, 0, -2.5, -1/200}]}], Frame -> True, PlotRange -> {-1, 5}]

We see that most of the transition happens for -2<(Subscript[α, E])<0. For Neumann boundary conditions (α=0), all states are nondegenerate, for Dirichlet boundary conditions (α->1), states become degenerate. We also see level crossing (this is possible because it is a 2D problem).

For the actual animation we will use (60^2) subsquares. This results in matrices of size 14280×14280.

robinPointQ[{x_, y_}] := (0 < x <= 1 && y == 1) || 
                         (0 < y <= 1 && x == 1)
makeVertexAssignments[60, robinPointQ];
{A, B, Ar} = sparseMatrixTriple[];
Dimensions[A]

Here are the points visualized.

discretizationGraphics[]

We will use states with energies (λ-values) around 1010. To make sure that the calculated eigensystems are reliable, we compare the calculate spectrum for the nearly-Dirichlet case of α=0.999999999. The eigenvalues deviate about 0.1% from the exact values.

α = 1 - 10.^-9;
evals = Eigenvalues[N @ {A + α/(1 - α) Ar, B}, 12, Method -> {"Arnoldi",   
                                   BasisSize -> 240, MaxIterations -> 10^4,
                                   Tolerance -> 12, Shift -> 1010}]/(Pi^2/4) // Reverse

Select[Sort[Flatten[Table[k^2 + l^2, {k, 50}, {l, 50}]]], (Min[%] - 3 < # < Max[%] + 3)&]

Now, we can implement the animation for varying α. For each α, we calculate a few eigensystems. Because the eigenvalues of the states change with α, we use a dynamically averaged value for the Shift option of Eigensystem. To select the “corresponding” eigenvectors, we cannot rely on the eigenvalues because they become degenerate. So, we form the overlap between the last eigenvector and the newly calculated eigenvectors for the next value of α. The state with the highest overlap is selected. We will show the α-dependence for three states.

We start with the Neumann case.

(* number of eigensystems to calculate for each value of α *) o = 25;
ABPair = {A, B};
eigensystem = Eigensystem[ABPair // N, o, Method -> {"Arnoldi",   
                                   BasisSize -> 240, MaxIterations -> 10^4,
                                   Tolerance -> 10^-8, Shift -> 1010}];
                                   
currentEvals = eigensystem[[1]][[{14, 13, 12}]];
currentEvecs = eigensystem[[2]][[{14, 13, 12}]];

Next, we loop over the α-values and store the resulting contour plots in the list animationFrames.

animationFrames[framesToShow_] := 
With[{allFrames = 60},
Module[{l1 = Table[αExp, {αExp, 0, 3, 1/allFrames}], l2,
        αExpValuesToShow, overlaps, maxOverlapPositions},
(* which α-values to display *)
αExpValuesToShow = If[framesToShow === All, l1, 
    l2 = Table[αExp, {αExp, 0, 3, 3/framesToShow}];
    Function[s, Sort[{N[Abs[s - #]], #}& /@ l1][[1, 2]]] /@ l2]; 
Do[α = 1 - 10^-αExp;
   (* calculate eigenvalues and eigenvectors *)
   ABPair = {A + α/(1 - α) Ar, B};
   currentShift = Plus @@ currentEvals/Length[currentEvals];
   eigensystem = Eigensystem[ABPair // N, o, Method -> {"Arnoldi",   
                                 BasisSize -> 240, MaxIterations -> 10^4,
                                 Tolerance -> 10^-8, Shift -> currentShift}];
   (* form overlaps with last set of eigenvectors *)
   overlaps = Table[Abs[currentEvecs[[k]].#]& /@ eigensystem[[2]], {k, 3}]; 
   (* select α-continued eigenvectors *)
   maxOverlapPositions = Flatten[Position[#, Max[#]]& /@ overlaps];
   {currentEvals, currentEvecs} = #[[maxOverlapPositions]]& /@ eigensystem;
   (* store eigenvalues and overlaps *)
   evData[αExp] = {currentEvals, currentEvecs};
   overlapData[αExp] = {overlaps, maxOverlapPositions};
   (* make contour plots of eigenfunctions *)
   If[MemberQ[αExpValuesToShow, αExp],
    Show[GraphicsArray[eigenFunctionListContourPlot /@ currentEvecs],
        PlotLabel -> N[αExp]]],
   {αExp, 0, 3, 3/allFrames}]]];

animationFrames[5]

Here are some of the eigenfunctions for various α.

animationFrames[All]

The following two graphics show the α-dependence of the eigenvalues (left) and the  α-dependence of the overlaps for the three selected states. Overall the overlap integrals are nearly 1, but show clear dips around α-values where two eigenvalues become nearly degenerate.

With[{colors = {RGBColor[1, 0, 0], RGBColor[0, 1, 0], RGBColor[0, 0, 1]}},
 Show[GraphicsArray[
 {Graphics[Transpose[{colors,
             Line /@ Transpose[Table[{αExp, #}& /@ evData[αExp][[1]],
                                     {αExp, 0, 3, 3/60}]]}], Frame -> True],
  Graphics[Transpose[{colors,
            Line /@ Transpose[Table[{αExp, #}& /@ (Table[#1[[j]][[#2[[j]]]], 
            {j, 3}]& @@ overlapData[αExp]), {αExp, 0, 2, 3/60}]]}], 
           Frame -> True]}]]]

For the eigenfunctions of an equilateral triangle with Robin boundary conditions, see [✶]. For isospectral domains with mixed Dirichlet and Neumann boundary conditions, see [✶]. For general considerations of the mixed boundary value case, see [✶].

Recently a divergence-free generalization of the classical WKB approximation was suggested [✶]. Starting from the classical Schrödinger equation -ψ''(x)+V(x)ψ(x)=ε ψ(x), one obtains after making the ansatz ψ(x)~exp(φ(x)) the Riccati equation φ''(x)+((φ'(x))^2)=(Subscript[𝒦, ε])(x), where (Subscript[𝒦, ε])(x)=ε-V(x). Differentiating this equation repeatedly and substituting the second derivatives back after each differentiation step yields an equation of the form (φ^((N)))(x)+(Subscript[𝓅, N])(φ'(x),(Subscript[𝒦, ε]^((k)))(x)).
The quantization condition of the Nth order generalized WKB approximation is then

(1/(2π i))(∮_𝒞)y((Subscript[𝒦, (Subscript[ε, n])]^((k)))(x))dx=n+1-(1/2)(Subscript[δ, N,2])

where y((Subscript[𝒦, (Subscript[ε, n])]^((k)))(x)) is a solution of (Subscript[𝓅, N])(y((Subscript[𝒦, (Subscript[ε, n])]^((k)))(x)),(Subscript[𝒦, (Subscript[ε, n])]^((k)))(x))=0 and the N-dependence of (Subscript[ε, n]) is not shown explicitly.

The integration path is enclosing two branch points along the real axis, and no other singularities of any kind and the sheet has to be chosen in such a way, that y=y(x) is real-valued as x->∞.

For the harmonic oscillator (Subscript[𝒦, ε])(x)=ε-(x^2), check if the first eight quantization conditions result in the well-known ground state eigenvalue (Subscript[ε, 0])=1.

(* Riccati for of the Schrödinger equation *)
eqSR = φ''[x] + φ'[x]^2 + 𝒦[x];
(* replace second derivative with first and 𝒦 *)
rule = Solve[eqSR == 0, Derivative[2][φ][x]][[1]];
(* n-th order equation *)
eq[𝒩_] := Nest[(D[#, x] /. rule)&, eqSR, 𝒩 - 2] // Expand

Here are the first few differential equations.

Table[eq[𝒩], {𝒩, 2, 6}]

The integrand of the quantization condition is easily obtained from the last equations by ignoring the highest derivative and replacing the first derivative by a new variable.

ae[𝒩_] := Collect[(#/Coefficient[#, y[x], 𝒩])&[
                  eq[𝒩]  /. {Derivative[𝒩][φ][x] -> 0, 
                  φ'[x] -> y[x]}], y[x], Factor]

Here are the first few integrands.

Table[ae[𝒩], {𝒩, 2, 6}] /. y𝒦_[x] -> y𝒦

We now specialize to the harmonic oscillator potential. This is value of 𝒦 for the harmonic oscillator expressed as a pure function.

𝒦Function[ε_, x_] := ε - x^2

These are the resulting harmonic oscillator quantization integrands.

ahoQC[𝒩_, ε_, {ξ_, η_}] := ae[𝒩] /. 
          𝒦 -> Function[x, Evaluate[𝒦Function[ε, x]]] /. {x -> ξ, y[x] -> η}

Table[ahoQC[𝒩, ε, {x, y}], {𝒩, 2, 6}]

For a given ε, we must calculate the branch points and other singularities in the complex x-plane for a given quantization condition integrand of order N (which is just an algebraic curve). Two branch points are on the real axis and are needed for the contour integration. But we also need the locations of the other singularities to make sure that we do not enclose any of them in the contour. The function branchPointsAndPoles calculates the branchpoints and other singularities for a given polynomial in w and z.

branchPointsAndPoles[poly_, {w_, z_}] := 
Module[{bpSol, branchPoints, poly1, singularityCondition, singularities},
 (* branch points as multiple roots that connect sheets *)
 bpSol = Solve[Resultant[poly, D[poly, w], w] == 0, z];
 branchPoints = N[#, 50]& @ If[bpSol == {}, {}, z /. bpSol];
 (* all singularities *)
 poly1 = poly /. w -> w[z];
 singularityCondition = Numerator[Together[(1/D[w[z], z] /. 
                          Solve[D[poly1, z] == 0, D[w[z], z]][[1]])]];
 sSol = Solve[Resultant[singularityCondition, poly1, w[z]] == 0, z];
 singularities = N[#, 50]& @ If[sSol == {}, {}, z /. sSol];
 (* poles are non-branch point singularities *)
 {N[branchPoints, 30], 
  Complement[N[singularities, 30], N[branchPoints, 30]]}]

A quick look at the branch points in the Re(y),Im(y),ε-space. We see multiple branch points along the real axis for larger n.

Show[GraphicsArray[#]]& /@ Partition[
Table[(* complex x-planes as a function of ε vertically *)
Graphics3D[Table[{Hue[0.8 ε/2], Point[{Re[#], Im[#], ε}]& /@ 
                  branchPointsAndPoles[ahoQC[𝒩, ε, {x, y}], {y, x}][[1]]},
                  {ε, 0, 2, 1/50}], PlotRange -> All, BoxRatios -> {1, 1, 1},
          PlotLabel -> " 𝒩 = " <> ToString[𝒩]], {𝒩, 2, 7}], 2]

To calculate the contour integral (Subscript[ℐ, n])=(∮_𝒞)(Subscript[𝓅, n])(y,(Subscript[𝒦, ε]^((k)))(x))dx efficiently, and to avoid any problems with crossing branch cuts, we will not use NIntegrate, but instead solve the differential equation ∂(Subscript[ℐ, n])(t)∂t=y((Subscript[𝒦, ε]^((k)))(x)) along the contour 𝒞 parametrized by t. Because the integrand is a solution of an algebraic equation (with x as the second variable and ε as a parameter), we calculate y((Subscript[𝒦, ε]^((k)))(x)) by solving the differential equation ∂(Subscript[𝓅, N])(y((Subscript[𝒦, (Subscript[ε, n])]^((k)))(x)),(Subscript[𝒦, (Subscript[ε, n])]^((k)))(x))/∂x=0 along the curve 𝒞. The two differential equations can be solved simultaneously. This ensures automatically that we are always on the same sheet. No branch cuts even exist in this approach, just branch points which have to be included or excluded in the contour.

Now, we have to carry out integration numerically along an ellipse enclosing (the) two branch points on the real axis and having half axes a and b. We start on the real axis with real argument for y. There might be more than one choice for the y values, as well for the branch points, so we try all possible ones. (The condition (Subscript[y, n])(x->∞)->∞ does not uniquely sort out one sheet from the Riemann surface; this condition can be fulfilled on more than one sheet.) The function makeNDSolveInput sets up the differential equations to be solved.

(* select positive real solutions *)
positivSolutions[poly_, y_] :=  
Select[y /. Solve[poly == 0, y], (Im[#] == 0 && Re[#] > 0)&]

makeNDSolveInput[𝒩_, ε_, {t_, 𝓎_, ℐ_}] :=
Module[{(*branchPoints, poles, realLineBranchPoints, 
        smallestVerticalDistanceSingularity, bE, aEs, ξ, 𝓎Ints, a, b*)},
 (* calculate branch points and potential poles *)
 {branchPoints, poles} = branchPointsAndPoles[ahoQC[𝒩, ε, {x, y}], {y, x}];
  realLineBranchPoints = Select[branchPoints, (Im[#] == 0 && Re[#] > 0)&]; 
  smallestVerticalDistanceSingularity = 
          Min[Abs[Select[Flatten[{branchPoints, poles}], Im[#] != 0&]]];
 (* ellipse parameters so that only the two branch points
    on the real axis are enclosed *)
 bE =  If[smallestVerticalDistanceSingularity == Infinity, 1, 
          smallestVerticalDistanceSingularity/10];
 aEs = Plus @@@ Partition[Append[realLineBranchPoints, 
                                 2 Max[realLineBranchPoints]], 2, 1]/2;
 ξ[τ_] := a Cos[τ] + I b Sin[τ];
 (* differential equations for y_N and quantization integral
    along the ellipse *)
 odes = {D[ℐ[x], x] == 𝓎[x], D[ahoQC[𝒩, ε, {x, 𝓎[x]}], x] == 0} /. 
         Derivative[1][f_][x] :> 1/D[ξ[t], t] Derivative[1][f][t] /.
         {𝓎[x] -> 𝓎[t], ℐ[x] -> ℐ[t]} /. x -> ξ[t];
 (* add initial conditions so that y_N is real positive on the real axis *)
 NDSolveFirstArguments = Flatten[#, 1]& @ 
 (* all possible ellipses *)
 Table[𝓎Ints = positivSolutions[ahoQC[𝒩, ε, {aEs[[k]], y}], y];
       Table[print["{aE, y0} = ", {aEs[[k]], 𝓎Ints[[i]]} // N];
             Join[odes /. {a -> aEs[[k]], b -> bE}, 
                  {ℐ[0] == 0, 𝓎[0] == 𝓎Ints[[i]]}], {i, Length[𝓎Ints]}],
       {k, Length[aEs]}]]

Here is one of the resulting ODE systems for N=3.

makeNDSolveInput[3, 1, {t, y1, I1}][[-1]] // N

It remains to carry out the numerical integration of the differential equations. For a given quantization order, and a given ε, we calculate the quantization integrals. We use high-precision arithmetic to solve the differential equations to ensure the correctness of the result. Calculating the left-hand side of the quantization conditions should, for the ground state (Subscript[ε, 0])=1, yield the result 1/2 for N=2, and 1 else. (If we would not know the energies (Subscript[ε, n]), then we would have to carry out an additional root finding process.)

contourIntegralValues[𝒩_, ε_] :=
Module[{odes, ndsols, y1, I1},
 (* y_N and quantization integral ODEs *)
 odes = makeNDSolveInput[𝒩, ε, {t, y1, I1}];
 (* make sure numerical solution is reliable *)
 ndsols = NDSolve[#, {y1, I1}, {t, 0, -2Pi},
                  PrecisionGoal -> 15, WorkingPrecision -> 25]& /@ odes;
 I1[-2Pi]/(2Pi I) /. ndsols]

Here is the classical WKB case—we obtain the value 1/2.

contourIntegralValues[2, 1] // Chop[#, 10^-8]&

We obtain the value 1 for exactly one pair of branch points for the cases N=3,4,5,6.

contourIntegralValues[3, 1] // Chop[#, 10^-8]&

contourIntegralValues[4, 1] // Chop[#, 10^-8]&

contourIntegralValues[5, 1] // Chop[#, 10^-8]&

contourIntegralValues[6, 1] // Chop[#, 10^-8]&

But the cases N=7,8 do not give a 1 for any of the contours. The “best” contours give a result that is off by a few percent.

contourIntegralValues[7, 1] // Chop[#, 10^-8]&

contourIntegralValues[8, 1] // Chop[#, 10^-8]&

Calculate the value of the integral

(Subscript[ℐ, n])=(∫_0^1)(∫_0^1)…(∫_0^1)(∫_0^1)(e^(|1-(Subscript[x, n])|))(e^(|(Subscript[x, n])-(Subscript[x, n-1])|))… (e^(|(Subscript[x, 3])-(Subscript[x, 3])|)) (e^(|(Subscript[x, 2])-(Subscript[x, 1])|))(e^(|(Subscript[x, 1])-0|))d(Subscript[x, n])d(Subscript[x, n-1])… d(Subscript[x, 2])d(Subscript[x, 1])

for 2≤n≤10. Is it possible to calculate (Subscript[ℐ, 100])?

integrand[n_] := Product[Exp[Abs[x[k] - x[k - 1]]], {k, 1, n + 1}] /.
                                         {x[0] -> 0, x[n + 1] -> 1};
                                         
iterators[n_] := Table[{x[k], 0, 1}, {k, n}];

Here is the resulting integral for n=4.

integrand[4]

(HoldForm[Integrate[##]]& @@ {integrand[6], Sequence @@ iterators[6]}) /.
                               x[k_] :> Subscript[x, k] // TraditionalForm

The built-in Integrate can do such integrals, but they are quite slow.

ReleaseHold[%] // Timing

The time required to calculate these integrals grows quite fast with n, so obtaining a value for n=10 seems not possible through a direct call to Integrate. So, we will implement our own integration routine for this special integral. We will split each absolute value into two parts that do not contain absolutes values anymore (the first and last exponents need no splitting, they have constant sign over the integration region [0,1]). This gives us (2^(n-1)) n-dimensional integrals.

(* thread over sums *)
removeAbs[p_Plus, k_] := removeAbs[#, k]& /@ p

(* split integration region into two for each variable *)
removeAbs[integrate[body_, iterators_], k_] :=
With[{(* first and last exponent need only one region *)
      body1 = body /. {Abs[x[1]] -> x[1], 
              Abs[1 - x[Length[iterators]]] -> 1 - x[Length[iterators]]}},
 integrate[body1 /. Abs[x[k] - x[k - 1]] :> x[k - 1] - x[k], 
           MapAt[{x[k], 0, x[k - 1]}&, iterators, k]] +
 integrate[body1 /. Abs[x[k] - x[k - 1]] :> x[k] - x[k - 1], 
           MapAt[{x[k], x[k - 1], 1}&, iterators, k]] ]

splitIntegrals[n_] := Fold[removeAbs, integrate[integrand[n], iterators[n]], 
                           Range[2, n]] // ExpandAll;

Here are the eight abs-free integrals for n=4.

splitIntegrals[4]

We convert the multiple integrals into explicit iterated integrals.

splitIntegrals[6][[4]] /. integrate[integrand_, iterators_] :> 
                          FoldList[integrateInd, integrand, Reverse[iterators]]

To carry out a single integral of the multivariate integral, we define a function integrateInd. Because the integrands are smooth and free of singularities, we can just evaluate the indefinite integral (which is fast) and substitute limits.

integrateInd[f_, {x_, x0_, x1_}] := 
     If[(* integrand does not contain integration variable? *)
        FreeQ[f, x, Infinity], (x1 - x0) f, 
        (* avoid size swell by applying Together *)
        Together[((# /. x -> x1) - (# /. x -> x0))&[Integrate[f, x]]]]

integrateInd[f_, {x_, x0_, x1_}] := 
     If[(* integrand does not contain integration variable? *)
        FreeQ[f, x, Infinity], Together[(x1 - x0) f], 
        (* avoid size swell by applying Together *)
        Together[((# /. x -> x1) - (# /. x -> x0))&[Integrate[f, x]]]]

Now we have all ingredients together to define the function absMultiIntegral that calculates the original integral in dimension n.

absMultiIntegral[n_] := 
 splitIntegrals[n] /. integrate[integrand_, iterators_] :> 
     Fold[integrateInd, integrand, Reverse[iterators]] // Together

Now we can carry out the integrals much faster (although still with exponentially in n growing times).

Table[{n, absMultiIntegral[n] // Timing}, {n, 2, 10}]

We can achive a further speed-up by recognizing that we can write (Subscript[ℐ, n])=(Subscript[(OverTilde[ℐ]), n])(1), where (Subscript[(OverTilde[ℐ]), n])(1) obeys the recursion relation (Subscript[(OverTilde[ℐ]), n])(x) =(∫_0^1)exp(|x-y|)(Subscript[(OverTilde[ℐ]), n-1])(y) dy. This allows to do only two integrals per integration variable. The next function intR implements this recursive approach. At each stage, we keep (Subscript[(OverTilde[ℐ]), n])(x) fully expanded.

(* save dynamic values for intR[n][x_] *)
Off[RuleDelayed::rhs];

intR[n_][x_] := intR[n][x_] = (* thread integration over sums and expand *)
ExpandAll[Exp[ x] ((# /. y -> x) - (# /. y -> 0))&[
             Integrate[# Exp[-y], y]& /@  intR[n - 1][y]] +
          Exp[-x] ((# /. y -> 1) - (# /. y -> x))&[
             Integrate[# Exp[+y], y]& /@  intR[n - 1][y]]]

(* initial value *)
intR[1][x_] := Exp[2 - x]/2 - Exp[x]/2 + x Exp[x]

The recursive approach allows to calculate (Subscript[ℐ, 10]) in about one second.

(* do recursion step by step *)
(Do[intR[n][x], {n, 2, 10}]; Together[intR[10][1]]) // Timing

And in a approximately an hour it is now possible to calculate (Subscript[ℐ, 100]). Assumping that the calculation time t depends on n in the form c (n^α), we can estimate the time needed to calculate (Subscript[ℐ, 100])by extrapolating from the quickly computable first 30 values of (Subscript[ℐ, n]).

(* calculation times as a function of n *)
timeData = Table[{n, Timing[intR[n][x]][[1, 1]]}, {n, 11, 30}];
(* parameter fitting an assumed timing of the form t[α] = Exp[c] n^α *)
{c, α} = CoefficientList[Fit[Log @ timeData, {1, n}, n], n];
Sum[Exp[c] n^α, {n, 100}] Second

This means that in approximately an hour it is now possible to calculate (Subscript[ℐ, 100]).

Do[(* to see some progress *)
   Print[{k, Timing[Length[intR[k][x]]]}], {k, 31, 100}] // Timing;
   
intR[100][1]

Here are the leading terms in e of the result for (Subscript[ℐ, 100])=2.2825… (10^16):
 1/2^100 E^101 + 97/2^100 E^99+ 3533/(2^98 3) E^97 + 103745/(2^96 3^2) E^95 +
 240415611/(2^100 5 7) E^93 + …

Given a 1D holonomic mechanical system with a conserved quantity K(x(t), v(t)), (v(t)=x'(t)), the Kobussen–Leubner–Lopez [✶] formula allows for the construction of a Lagrangian L(x,v) through L(x,v)=v ∫K(x,v)/(v^2)dv. (Given a Lagrangian, unique equations of motion follow, but given the equations of motion, the Lagrangian is nonunique [✶].) For a one-dimensional harmonic oscillator, the energy ε=m (v^2)/2+m (ω^2)(x^2)/2 is a conserved quantity. Using the Kobussen–Leubner–Lopez formula for powers of the energy (ε^n) (n∈(SuperPlus[ℕ])) yields the Lagrangian [✶]

(Subscript[L, n])(x,v)=(m/2)(∑_(k=0)^n)(1/(2k-1))(({{n}, {k}}))((((ω^2)(x^2)))^(n-k))(v^(2k)).

The solution of the Euler–Lagrange equations of (Subscript[L, n])(x,v) are the well known harmonic oscillations of the one-dimensional harmonic oscillator. But the phase space trajectories derived from the Hamiltonian (Subscript[H, n])(x,p), where (Subscript[H, n])(x,p)=((ε(x, v(x,p)))^n), and p=∂L/∂v are for n>1 different curves than the well-known circles of the one-dimensional harmonic oscillator [✶]. For n>1, calculate and visualize some of the phase space trajectories following from (Subscript[H, n])(x,p) via x'(t)=∂H(x(t),p(t))/∂p(t) and p'(t)=-∂H(x(t),p(t))/∂x(t).

The function implicitHamiltonianEquation calculates the implicit equation for the Hamiltonian. (We set m=ω=1 in the following.)

implicitHamiltonianEquation[n_, H_, {x_, p_}] := 
With[{L = 1/2 Sum[Binomial[n, k] (x^2)^(n - k) v^(2k)/(2k - 1), {k, 0, n}]},
     (* eliminate v *)
     Resultant[H - (1/2)^n (v^2 + x^2)^n, p - D[L, v], v] // 
                                             Together // Factor // Numerator]

Here are the first three polynomials (Subscript[𝓅, n])(x,p,H).

Table[implicitHamiltonianEquation[n, H, {x, p}], {n, 3}]

As described, the equations of motions are obtained from implicit differentiation.

HamiltonianEquationsOfMotion[n_, H_, {x_, p_}, t_] :=
With[{𝓅 = implicitHamiltonianEquation[n, H[x[t], p[t]], {x[t], p[t]}]},
     (* differentiate implicitly, then solve for derivatives of H *)
     {x'[t] == +Solve[D[𝓅, p[t]] == 0, D[H[x[t], p[t]], p[t]]][[1, 1, 2]],
      p'[t] == -Solve[D[𝓅, x[t]] == 0, D[H[x[t], p[t]], x[t]]][[1, 1, 2]]}]

For n=1, we recover the well-known equations of motion for the harmonic oscillator.

HamiltonianEquationsOfMotion[1, H, {x, p}, t]

For n=2, we obtain considerably more complicated equations. They contain the Hamiltonian H, a conserved quantity.

HamiltonianEquationsOfMotion[2, H, {x, p}, t]

Now, we must deal with the initial conditions for x and p. We will prescribe values for x(0) and p(0). This fixes the value of H, but not necessary uniquely, because H appears in (Subscript[p, n]) nonlinearly. We use high-precision arithmetic to calculate the starting values and to solve the differential equaion to obtain numerically reliable solutions.

HValues[n_, {x0_, p0_}, wp_: 30] :=
Module[{H, NHs, x, p, t, x0E = Rationalize[x0, 0], 
        p0E = Rationalize[p0, 0],dens}, 
       (* numerically solve for H *)
       NHs = N[Solve[implicitHamiltonianEquation[n, H, {x0E, p0E}] == 0, H], wp];
       (* eliminate potential zeros in the denominators of the derivatives of H *)
       dens = Denominator[Last /@ HamiltonianEquationsOfMotion[n, H, {x, p}, t]] //.
                   ξ_[t] :> ξ /. _H :> H;      
       (* esort in such a manner that real solutiosn come first *)
       Sort[#[[1, 2]]& /@ Select[NHs, FreeQ[dens /. # /. {x -> x0E, p -> p0E},
                                       _?(# == 0&)]&], Abs[Im[#1]] < Abs[Im[#2]]&]]

Generically, for real x(0), p(0), we have one real value for H. Here is an example.

HValues[4, {2, 2}] // N

Now, we are ready to solve the equations of motion numerically.

Clear[nDSolveHO];
nDSolveHO[n_, {x_, p_}, {x0_, p0_}, T_, k_:All, wp_:20] :=
Module[{hs},
       (* starting values *)
       hs = HValues[n, {x0, p0}, wp + 10];
       (* solve equations of motion for all starting values *)
       NDSolve[Join[HamiltonianEquationsOfMotion[n, H, {x, p}, t] /. H[__] -> #,
                    {x[0] == x0, p[0] == p0}],
               {x, p}, {t, 0, T}, WorkingPrecision -> wp, MaxSteps -> 10^5,
               PrecisionGoal -> 10, AccuracyGoal -> 10]& /@ Take[hs, k]]

To visualize the phase space trajectories, we use the function phaseSpaceTrajectories. It generates graphics of the real and imaginary parts of the phase space trajectories.

phaseSpaceTrajectories[n_, {x0_, p0_}, T_, k_:All, wp_:20] := 
Module[{ndsols = nDSolveHO[n, {x, p}, {x0, p0}, T, k, wp]},
        λ = Length[ndsols]; 
       GraphicsArray[Function[reIm, 
           (* plot real and imaginary parts of the parametrized trajectories *)
           ParametricPlot[Evaluate[reIm @ {x[t], p[t]} /. ndsols],
                          {t, 0, T}, PlotRange -> All, 
                          PlotPoints -> Round[T 100], AspectRatio -> 1,
                          DisplayFunction -> Identity, PlotLabel -> reIm,
                          Frame -> True, Axes -> False,
                          PlotStyle -> Table[Hue[0.8 j/λ], 
                                                 {j, 0, λ - 1}]]] /@ {Re, Im}]]

For n=1, we have just one possible phase space trajectory, a circle (an ellipse).

Show @ phaseSpaceTrajectories[1, {2, 2}, 2Pi]

For n=2, we have three trajectories, one real one, and two coinciding complex one. The real one is displayed in red. The period is now doubled. The complex trajectory is more complicated.

Show @ phaseSpaceTrajectories[2, {2, 2}, 4Pi]

For n=2, we have five trajectories, one real one, and two pairs of coinciding complex one. The real one is again displayed in red. The period is four times the one from the n=1 case.  Again, the complex trajectories are more complicated.

Show @ phaseSpaceTrajectories[3, {2, 2}, 8Pi]

For n=3, we have seven trajectories, one real one, and three pairs of coinciding complex one. The real one is again displayed in red. The period is eight times the one from the n=1 case. And again, the complex trajectories are more complicated.

Show @ phaseSpaceTrajectories[4, {2, 2}, 16Pi]

We end here with n=4. Higher order complex trajectories become more and more complicated.

We end with displaying the phase space trajectories corresponding to the real trajectories for n=1,2,3 in one graphic. The different shape and size of the trajectories is clearly visible.

Show[Table[phaseSpaceTrajectories[n, {1/100, 1}, 2^n 2Pi, 1][[1, 1]] /. 
                          (* recolor to red (n = 1) to blue (n = 4) *) 
                                  Hue[0] :> Hue[(n - 1)/4], {n, 1, 4}],
     DisplayFunction -> $DisplayFunction, PlotRange -> All]

We could now continue and use complex starting values for x(0) and p(0) and solve the equations of motion in the complex t-plane to obtain still more complicated trajectories.

Symbolics Volume, Chapter 2

Consider the following Hénon–Heiles-type potential (compared to the classical Hénon–Heiles-type potential, the additional (r^4) term guarantees confinement of the quantum mechanical problem)

V(x,y)=α ((((x^2)+(y^2)))^2)+β ((x^2)+(y^2))+γ ((x^3)-3x (y^2))=α (r^4)+β (r^2)+γ cos(3φ)(r^3).

For some values of the parameters α, β, and γ, and various initial conditions, calculate some of the classical trajectories. Visualize these trajectories and construct the corresponding Poincaré plots.

Also, calculate and visualize [✶], [✶] some of the energy eigenfunctions of the corresponding time-independent Schrödinger equation [✶], [✶]

(-((ℏ^2)/(2M))(Subscript[Δ, x,y])+V(x, y))(Subscript[Ψ, μ])(x, y)=(Subscript[ε, μ])(Subscript[Ψ, μ])(x, y)

by expanding the (Subscript[Ψ, μ])(x, y)=(∑_(m,n))(Subscript[c, m,n]^((μ)))(Subscript[ψ, n,m])(x, y) into the eigenfunctions (Subscript[ψ, n,m]) of the 2D harmonic oscillator

(-((ℏ^2)/(2M))(Subscript[Δ, r])+(M/2)ω ((|r|)^2))(Subscript[ψ, n,m])(r,φ)=(-((ℏ^2)/(2M))((1/r)(∂/(∂r))(r (∂/(∂r)))+(1/(r^2))((∂^2)/(∂(φ^2))))+(M/2)ω (r^2))(Subscript[ψ, n,m])(r,φ)
=(Subscript[ε, n,m])(Subscript[ψ, n,m])(r,φ)

for some values of the parameters α, β, and γ. The normalized eigenfunctions of the 2D harmonic oscillator in polar coordinates are (here (Subscript[|n,m⟩, r]) denotes the radial eigenfunctions with quantum numbers n and m and (Subscript[|m⟩, φ]) denotes the azimuthal eigenfunction with quantum number m).

⟨r,φ|n,m⟩=(Subscript[⟨φ|m⟩, φ])(Subscript[⟨r|n,m⟩, r])=(Subscript[ψ, n,m])(r,φ)=(Subscript[Φ, m])(φ)(Subscript[R, n,m])(r)
(Subscript[Φ, m])(φ)=(Subscript[⟨φ|m⟩, φ])=(1/(Sqrt[2π]))(e^(i m φ))
(Subscript[R, n,m])(r)=(Subscript[⟨r|n,m⟩, r])=((Sqrt[2])/L)(Sqrt[((n!)/((n+|m|)!))]) ((((r/L)))^(|m|)) (e^(-(1/2) (((r/L))^2))) (Subscript[L, n]^(|m|))(((((r/L)))^2))

⟨(Subscript[n, 2]),(Subscript[m, 2])|(Subscript[n, 1]),(Subscript[m, 1])⟩=(∫_0^(2π))(∫_0^∞)(Subscript[ψ, (Subscript[n, 1]),(Subscript[m, 1])])(r,φ)(OverBar[(Subscript[ψ, (Subscript[n, 2]),(Subscript[m, 2])])(r,φ)])r dr=1

and the eigenvalues are (Subscript[ε, n,m])=(2 n+|m|+1) ℏ ω [✶]. Here n=0,1,… and m=…,-2,-1,0,1,2,…. and L=(((ℏ/(M ω)))^(1/2)).

(* the generalized Hénon-Heiles potential *)
V[{x_, y_}, {α_, β_, γ_}] := α Sqrt[x^2 + y^2]^4 +
            β Sqrt[x^2 + y^2]^2 + γ (x^3 - 3 x y^2)

Show[GraphicsArray[
Block[{L1 = 6, L2 = 8, $DisplayFunction = Identity}, 
{(* contour plot of a concrete potential realization *)
 ContourPlot[Evaluate[V[{x, y}, {1, -6, -4}]], 
            {x, -L1, L1}, {y, -L1, L1}, PlotPoints -> 240, 
            Contours -> 60, ContourLines -> True, 
            (* inner contours more pronounced *)
            ContourStyle -> Table[{GrayLevel[x]}, {x, 0, 1, 1/60}],
            ColorFunction -> (GrayLevel[ArcCos[#]/(Pi/2)]&)],
 (* V(x,y) == 0 curves of the potential *)
 Show[Table[
 ContourPlot[Evaluate[V[{x, y}, {1, -6, γ}]], 
             {x, -L2, L2}, {y, -L2, L2},
             PlotPoints -> 240, Contours -> {0},
             ContourStyle -> {{Hue[0.78 (γ + 8)/16]}}, 
             ContourShading -> False], {γ, -8, 8}]]}]]]

Next, we visualize some of the classical trajectories. The function path calculates the path (trajectory) {x(t),y(t)} of a point particle in the potential V(x,y) with initial conditions {x(t),y(t)}={x0,y0}, {x'(t),y'(t)}={vx0,vy0}.

path[{x0_, y0_}, {vx0_, vy0_}, {α_, β_, γ_}, T_] :=
   NDSolve[(* equations of motion *)
   {x'[t] == vx[t], vx'[t] == -D[V[{x[t], y[t]}, {α, β, γ}], x[t]],
    y'[t] == vy[t], vy'[t] == -D[V[{x[t], y[t]}, {α, β, γ}], y[t]],
    x[0] == x0, y[0] == y0, vx[0] == vx0, vy[0] == vy0},
   {x, y, vx, vy}, {t, 0, T}, MaxSteps -> 10^6]

We visualize the path using the function pathPlots. For a given path pathSol (returned from the function path), this function generates the four parametric plots {x'(t),y'(t)}, {x(t),x'(t)}, {y(t),y'(t)}, and {x'(t),y'(t)},

pathPlots[pathSol_] :=
Module[{X, Y, VX, VY},
  (* extract value lists for positions and velocities *)
  {X, Y, VX, VY} = 
      Transpose[Partition[#[[2, 4, 2]], 2]][[1]]& /@ pathSol[[1]];
Show[GraphicsArray[
  ListPlot[Transpose[#], PlotJoined -> True,
         PlotStyle -> {Thickness[0.002], GrayLevel[0]},
         PlotRange -> All, (* for uniformity *) AspectRatio -> 1,
         DisplayFunction -> Identity, FrameTicks -> False,
         Frame -> True, PlotLabel -> #2, Axes -> False]& @@@ 
         (* the four pairs of functions for the parametric plots *)
         {{{X, Y}, {x, y}}, {{X, VX}, {x, Subscript[v, x]}},
          {{Y, VY}, {y, Subscript[v, y]}},
          {{VX, VY}, {Subscript[v, y], Subscript[v, xy]}}}]]]

Here are some of the trajectories and their phase plots shown.

vβδData =
(* parameter sets for various types of classical motion *)
{{{-1475/496,    66/041}, {   19/003, - 326/221}},
 {{ 5043/515,   906/235}, {-1200/157, -3576/569}},
 {{ 2923/321,  1517/404}, { 1690/317, -  23/021}},
 {{- 524/147,  2272/567}, {-  58/043,     9/035}},
 {{ 6097/823, -2230/233}, {- 648/271, -   1/107}},
 {{ 2305/634, - 221/133}, { 5874/959,  1287/458}},
 {{  753/106,   349/150}, {- 665/624, -5509/732}}};

pathPlots[path[{0, 0}, #2, {1, Sequence @@ #1}, 50]]& @@@ vβδData

Here are 3D plots of some of the trajectories in x,y,(Subscript[v, x])-space.

pathPlot3D[pathSol_] :=
Module[{X, Y, VX, VY, trajectory, λ},
  (* extract value lists for positions and velocities *)
  {X, Y, VX, VY} = 
      Transpose[Partition[#[[2, 4, 2]], 2]][[1]]& /@ pathSol[[1]];
  (* path in x,y,vx-space *) 
  xyvxPath = Transpose[{X, Y, VX}]; λ = Length[xyvxPath];    
Show[Graphics3D[{Thickness[0.002],
       (* color path from red to blue *)
       MapIndexed[{Hue[0.78 #2[[1]]/λ], Line[#1]}&, 
                   Partition[xyvxPath, 2, 1]]}],
     BoxRatios -> {1, 1, 1}, Axes -> True,
     AxesLabel -> {"x", "y", Subscript[v, x]}]]

Show[GraphicsArray[
Block[{$DisplayFunction = Identity}, 
pathPlot3D[path[{0, 0}, #2, {1, Sequence @@ #1}, 100]]& @@@ 
                                    vβδData[[{1, 6, 7}]]]]]

Some of the trajectories look regular, and some look chaotic [✶], [✶], [✶], [✶]. Displaying their Poincaré plots confirms this [✶], [✶]. For a given pathSol returned from the function path, the function poincareSection generates the Poincaré plot of the variables {ξ,η} for ζ(t)=0.

poincareSection[pathSol_, {ξ_, η_}, ζ_] :=
Module[{ζL, tL, tζL, tζLPairs, ts, points}, 
 (* find times where ζ vanishes *)
 ζL = Transpose[Partition[(ζ /. pathSol[[1]])[[4, 2]], 2]][[1]];
 tL = (ζ /. pathSol[[1]])[[3, 1]];
 tζL = Transpose[Partition[#, 2, 1]& /@ {tL, ζL}];
 tζLPairs = Select[tζL, (#[[2, 1]] #[[2, 2]] < 0)&];
 (* use linear interpolation *)
 ts = (#1[[1]] + #2[[1]]/(#2[[1]] - #2[[2]])*
       (#1[[2]] - #1[[1]]))& @@@ tζLPairs;
 (* {ξ, η} at the times ts *)
 points = ({ξ[#], η[#]}& /@ ts) /. pathSol[[1]];
 (* form Poincare plot graphics *)
 Graphics[{PointSize[0.003], Point /@ points},
       PlotRange -> All, AspectRatio -> 1, Frame -> True, 
       FrameTicks -> False, PlotLabel -> {ξ, η}, Axes -> False]]

For a given path, the function poincarePlots shows the four Poincaré plots {x,y} at x'(t)=0, {x,y} at y'(t)=0, {x',y'} at x(t)=0, and {x',y'} at x(t)=0.

poincarePlots[pathSol_] := 
Show[GraphicsArray[poincareSection[pathSol, #1, #2]& @@@
{{{x, y}, vx}, {{x, y}, vy}, {{vx, vy}, x}, {{vx, vy}, y}}]]

Here are the Poincaré plots corresponding to the above parametric and phase plots. To obtain enough intersections of the coordinate planes with the trajectory, we now propagate to the much larger time t=5000.

poincarePlots[path[{0, 0}, #2, 
                   {1, Sequence @@ #1}, 5000]]& @@@ vβδData

(For closed-form solutions of the classical Hénon–Heiles potential, see [✶], [✶], [✶].)

We continue with the quantum mechanical treatment of the generalized Hénon–Heiles potential. To calculate the quantum mechanical eigenfunctions, we have to diagonalize the Hamiltonian corresponding to V(x,y) in a truncated 2D harmonic oscillator basis. We write the matrix elements as a sum of the harmonic oscillator diagonal terms and perturbation terms. (This avoids the need for the explicit calculation of the matrix elements of the kinetic part in exchange for the anyway-to-be-calculated matrix element of the (r^2) term.) So we have (using the notations (Subscript[H, 0]) and (Subscript[V, 0]) for the Hamiltonian and the potential of the 2D harmonic oscillator) the following expression for a generic matrix element:

⟨(Subscript[n, 1]),(Subscript[m, 1])|-((ℏ^2)/(2M))Δ+V|(Subscript[n, 2]),(Subscript[m, 2])⟩=⟨(Subscript[n, 1]),(Subscript[m, 1])|(Subscript[H, 0])+V-(Subscript[V, 0])|(Subscript[n, 2]),(Subscript[m, 2])⟩
=(2(Subscript[n, 1])+(Subscript[m, 1])+1)(Subscript[δ, (Subscript[m, 1]),(Subscript[m, 2])])(Subscript[δ, (Subscript[n, 1]),(Subscript[n, 2])])ℏ ω+⟨(Subscript[n, 1]),(Subscript[m, 1])|V-((M )/2)(ω^2)(r^2)|(Subscript[n, 2]),(Subscript[m, 2])⟩=
(2(Subscript[n, 1])+m+1)(Subscript[δ, (Subscript[m, 1]),(Subscript[m, 2])])(Subscript[δ, (Subscript[n, 1]),(Subscript[n, 2])])ℏ ω+ ⟨(Subscript[n, 1]),(Subscript[m, 1])|α (r^4)+β (r^2)-((M )/2)(ω^2)(r^2)|(Subscript[n, 2]),(Subscript[m, 2])⟩+
⟨(Subscript[n, 1]),(Subscript[m, 1])|γ cos(3φ)(r^3)|(Subscript[n, 2]),(Subscript[m, 2])⟩.

The φ-independent potential term is diagonal in the angular quantum numbers (Subscript[m, 1]) and (Subscript[m, 2]).

⟨(Subscript[n, 1]),(Subscript[m, 1])|α (r^4)+β (r^2)-((M )/2)(ω^2)(r^2)|(Subscript[n, 2]),(Subscript[m, 2])⟩= (Subscript[(Subscript[δ, (Subscript[m, 1]),(Subscript[m, 2])]) , r])(Subscript[⟨(Subscript[n, 1]),(Subscript[m, 1])|α (r^4)+β (r^2)-((M )/2)(ω^2)(r^2)|(Subscript[n, 2]),(Subscript[m, 2])⟩, r]).

The φ-dependent potential term factors into an angular and an radial part.

⟨(Subscript[n, 1]),(Subscript[m, 1])|cos(3φ)(r^3)|(Subscript[n, 2]),(Subscript[m, 2])⟩ =(Subscript["", φ])(Subscript[(Subscript[⟨(Subscript[m, 1])|cos(3φ)|(Subscript[m, 2])⟩, φ])   , r])(Subscript[⟨(Subscript[n, 1]),(Subscript[m, 1])|γ (r^3)|(Subscript[n, 2]),(Subscript[m, 2])⟩, r]).

We anticipate (from the corresponding 1D examples of Chapter 2) needing a few hundred angular and a few hundred radial basis states of the harmonic oscillator. This means we will have in the order of a few (10^4) product basis states and the resulting Hill matrix will have in the order (10^9) matrix elements. Calculating (or storing and manipulating) (10^9) matrix elements individually is, of course, hopeless. However, being an exercise, we anticipate that for a given set of quantum numbers (Subscript[n, 1]), (Subscript[m, 1]), only finitely many states |(Subscript[n, 2]),(Subscript[m, 2])⟩ will have nontrivial matrix elements with V(x,y). These nonvanishing matrix elements we will use to create and diagonalize a sparse matrix. Calculating explicit forms of these matrix elements is the next step.

Instead of using the complex-valued eigenfunctions exp(±i m φ), we will use the real-valued ones cos (m φ) and sin(m φ). While this slightly complicates some of the following calculations, we gain two advantages: a) Because the potential V(x, y) is mirror symmetric with respect to the x-axis, so will be the eigenfunctions. This means in the eigenfunction expansions we can use a smaller matrix size to take a fixed number of basis states into account. b) All arithmetic needed will only operate on real numbers, which is considerably faster than complex number calculations. An additional small benefit of the division in even and odd states is the possibility to optimize the graphics constructions later when we visualize the eigenfunctions.

The basic angular orthogonality integrals are

(∫_0^(2π))cos((Subscript[m, 1])φ)cos((Subscript[m, 2])φ)dφ=(1+(Subscript[δ, (Subscript[m, 1]),0]))(Subscript[δ, (Subscript[m, 1]),(Subscript[m, 2])])π     for (Subscript[m, 1]), (Subscript[m, 2])=0,1,2,…

(∫_0^(2π))sin((Subscript[m, 1])φ)sin((Subscript[m, 2])φ)dφ=(Subscript[δ, (Subscript[m, 1]),(Subscript[m, 2])])π     for (Subscript[m, 1]), (Subscript[m, 2])=1,2,…

and the basic radial orthogonality integral is

(∫_0^∞)(t^λ) (e^(-t)) (Subscript[L, (Subscript[n, 1])]^λ)(t) (Subscript[L, (Subscript[n, 2])]^λ)(t)dt=((((Subscript[n, 1])+λ+1)! )/((Subscript[n, 1])!))(Subscript[δ, (Subscript[n, 1]),(Subscript[n, 2])]).

To reduce products of powers of r with the Laguerre polynomials to this standard form, we make use of the following two recursion relations for associated Laguerre polynomials (Subscript[L, n]^λ)(z) [✶]:

z (Subscript[L, n]^λ)(z)=-(n+λ) (Subscript[L, n-1]^λ)(z)+(2 n+λ+1) (Subscript[L, n]^λ)(z)-(n+1) (Subscript[L, n+1]^λ)(z)
(Subscript[L, n]^(λ+1))(z)=(λ+n) (Subscript[L, n-1]^λ)(z)+(z-n) (Subscript[L, n]^λ)(z).

Off[General::spell1]; Off[General::spell1];

Here are the even and odd eigenfunctions of the 2D harmonic oscillator. Because later we will set ℏ=M=1, we do not include these variables as arguments in the left-hand sides of the corresponding function definitions for R, ψEven, and ψOdd. We will set a value for ω later globally (to avoid a cluttered notation we also do not use ω as an explicit argument).

(* natural length scale *)
L = Sqrt[ℏ/(M ω)];

(* angular momentum eigenfunctions *)
ΦOdd[m_, φ_] = 1/Sqrt[Pi] Sin[m φ];
(* normalization for even states with m = 0 is special *)
ΦEven[m_, φ_] = (1 - (1 - 1/Sqrt[2])  KroneckerDelta[m]) *
                1/Sqrt[Pi] Cos[m φ];

(* radial momentum eigenfunctions *)
R[n_, m_, r_] := Sqrt[2]/L Sqrt[n!/(n + m)!] (r/L)^m*
                 Exp[-(r/L)^2/2] LaguerreL[n, m, (r/L)^2];
    
(* 2D eigenfunctions *)
ψOdd[n_, m_, r_, φ_] := ΦOdd[m, φ] R[n, m, r];
ψEven[n_, m_, r_, φ_] := ΦEven[m, φ] R[n, m, r];

Without loss of generality, we can later set ℏ=M=1. While the eigenfunctions are complete for every values of ω, we will not set ω to a specific value, but rather keep it as a parameter that will allow to radially expand and contract the basis.

Here is a quick check of the correctness and normalization of the eigenfunctions.

SchrödingerOperatorHO2D[ψ_, {r_, φ_}] :=
-ℏ^2/(2 M) (1/r D[r D[ψ, r], r] + 1/r^2 D[ψ, φ, φ]) + 1/2 M ω^2 r^2 ψ

Block[{psi},
Table[psi = ψEven[n, m, r, φ]; 
      (* check if Schrödinger equation is fulfilled *)
      Expand[SchrödingerOperatorHO2D[psi, {r, φ}] - 
      (2n + Abs[m] + 1) ℏ ω psi] == 0, {n, 0, 2}, {m, 0, 2}]] //
                                                Flatten // Union

Block[{ℏ = 1, M = 1, ω = 1},
Table[(* check normalization of eigenfunctions *)
      Integrate[ψEven[n1, m1, r, φ] ψEven[n2, m2, r, φ] r, 
                {φ, 0, 2Pi}, {r, 0, Infinity}] ==
      KroneckerDelta[n1, n2] KroneckerDelta[m1, m2],
      {n1, 0, 2}, {m1, 0, 2}, {n2, 0, n1}, {m2, 0, m1}]] //
                                               Flatten // Union

As a side step, let us have a quick look at the radial eigenfunctions. For increasing n and m, the eigenfunctions extend further radially outwards.

Block[{M = 1, ℏ = 1, ω = 1},
 Show[Graphics3D[
      Table[{Hue[0.8 m/(3 n)], 
             Line[Table[Evaluate[{r, n, R[n, m, r]^2}], 
                        {r, 0, 10, 1/10}]]},
            {n, 0, 8}, {m, (* odd states *) 1, 3 n}]],
            BoxRatios -> {2.4, 1, 1}, PlotRange -> All,
            Axes -> True, AxesLabel -> {"r", "n", ψ^2}]]

The next graphic shows the position of the maxima of R[n, m, r] for a fixed n=12 as a function of m.

radialMaxima[n_, m_, rMax_] :=
Block[{M = 1, ℏ = 1, ω = 1},
Point[{#[[2, 1]], Log[#[[2, 2]]]}]& /@ 
Select[Partition[Plot[Evaluate[R[n, m, r]^2], {r, 0, rMax},
                      PlotPoints -> 20,
                      DisplayFunction -> Identity][[1, 1, 1, 1]], 
                 3, 1], (#[[1, 2]] < #[[2, 2]] > #[[3, 2]])&]]

Block[{n = 12},
Show[Graphics[
      Table[{Hue[0.8 m/(8n)], radialMaxima[n, m, 16]},
            {m, 1, 8n, 4}]], PlotRange -> {0, -5}, Axes -> True]]

We have to decide which harmonic oscillator eigenfunctions to include in the truncated basis. We have a doubly infinite set of eigenfunctions. The above graphics showed that for an increasing n, the eigenfunctions expand increasingly radially outwards. The generalized Hénon–Heiles potential is bounded in asymptotically increasing in every direction due to the (r^4) term. This means, all the energy eigenfunctions will be well localized in the corresponding classically allowed region. So we fix an energy εo, and take all eigenfunctions having an energy less than or equal to εo into account. We sort these selected eigenfunctions by energy, and in case of degeneracy, by increasing m. The functions numberEvenBasisFunctions and numberOddBasisFunctions carry out this selection and ordering process. They create the globally visible functions efNumber and nmNumbers and the variable dim. For a given pair of quantum numbers n, m, the function efNumber returns the position of this state in the basis. For a given position 1, 2, …, in the basis state, the function nmNumbers returns the pair of quantum numbers n, m. dim is the dimension of the basis. (For a cleaner, “ production code” quality programming one could export pure functions with a dispatched rule table in the body for efNumber, to keep all parts modular and well separated. But for the purpose of visualizing some eigenstates, which is the sole goal of this exercise, the current approach is appropriate.)

numberEvenBasisFunctions[εo_] :=
Module[{energyOrderedQuantumNumbers, nmPairs},
 (* order pairs of quantum numbers {n, m} by energy *)
 energyOrderedQuantumNumbers = 
  {#[[1, 2]], Sort[First /@ #]}& /@ Split[Sort[Select[Flatten[
  Table[{{n, m}, 2 n + m + 1}, 
        {n, 0, εo/2}, {m, 0, εo}], 1], #[[-1]] <= εo&],
        #1[[-1]] < #2[[-1]]&], #1[[-1]] == #2[[-1]]&];
 (* export the functions efNumber and nmNumbers the number dim *)
 Clear[efNumber, nmNumbers]; 
 (efNumber[#1] = #2; nmNumbers[#2] = #1)& @@@
 MapIndexed[{#1, #2[[1]]}&, nmPairs =
            Flatten[Last /@ energyOrderedQuantumNumbers, 1]];
 dim = Length[nmPairs]]

(* no m == 0 states in the odd functions *)
DownValues[numberOddBasisFunctions] =
 DownValues[numberEvenBasisFunctions] /.
  {numberEvenBasisFunctions -> numberOddBasisFunctions,
   HoldPattern[{m, 0, εo}] :> {m, 1, εo}};

Here is an example of the ordered n,m quantum numbers up to energy 12ℏω. The odd basis misses the states with m=0.

numberEvenBasisFunctions[12];
nmNumbers /@ Range[dim]

numberOddBasisFunctions[12];
nmNumbers /@ Range[dim]

The number of basis states grows quadratically with the energy εo. With energies in the few hundreds, we have a few ten thousand basis states.

(* count even and odd  basis sizes as a function of εo *)
Function[εo, {εo, numberEvenBasisFunctions[εo]; dim,
                  numberOddBasisFunctions[εo]; dim}] /@
                      {1, 5, 10, 50, 100, 200, 250, 500}

Because of the virial theorem, the average squared distance of the state ⟨r,φ|n,m⟩ is proportional to the energy (Subscript[ε, n,m]). This means that the ordering of the states carried out by the functions numberEvenBasisFunctions and numberEvenBasisFunctions can model states efficiently with an approximately known spatial extension.

rSquareMean[{n_, m_}] := 
Block[{M = 1, ℏ = 1, ω = 1},
      (* mean square spatial extension *)
      Integrate[r^2 R[n, m, r]^2 r, {r, 0, Infinity}]]

numberEvenBasisFunctions[12];
rSquareMean /@ (nmNumbers /@ Range[dim])

We use the sorted-by-energy states for making one more graphic—the integrated local density of states as a function of the radius and the energy up to (Subscript[ε, max])=36. The left graphic shows the integrated (over the energy) local density of states. The emergence of the classical limit is clearly visible. The right graphic shows the oscillations (due to the oscillating nature of the Laguerre polynomials) of the density of states better by subtracting the nonoscillating Thomas–Fermi contribution (∼(ε-V(r))θ(ε-V(r))) [✶].

Block[{εMax = 36, rMax = 10, (* avoid 0^0 *) rMin = 10^-6, 
       ppr = 160, ℏ = 1, M = 1, ω = 1,
       nmGroups, ψData, ldos, polysH, polysV, opts},
 (* the eigenfunctions up to energy εMax *)
 numberEvenBasisFunctions[εMax];
 nmGroups = Map[Last, Split[{2#1 + #2 + 1, {##}}& @@@ 
                (nmNumbers /@ Range[dim]), #1[[1]] === #2[[1]]&], {2}];
 (* summed squared eigenfunctions times r *)
 ψData = FoldList[Plus, Table[0, {r, rMin, rMax, (rMax - rMin)/ppr}],  
          (* sum eigenfunctions for a fixed energy *) Plus @@@ 
           Apply[Table[If[#2 === 0, 1/2, 1] R[#1, #2, N[r]]^2, 
                 {r, rMin, rMax, (rMax - rMin)/ppr}]&, nmGroups, {2}]];
 (* local density of states *)
 ldos = MapIndexed[{rMin + (#2[[2]] - 1)/ppr (rMax - rMin), 
                    #2[[1]] - 1, #1}&, ψData, {2}]; LD = ldos;
 polysH = (* horizontal polygons *)
 Table[Polygon[{ldos[[k, i]], ldos[[k, i + 1]],
                ldos[[k, i + 1]] + {0, 1, 0},
                ldos[[k, i]] + {0, 1, 0}}], 
       {k, Length[ldos]}, {i, Length[ldos[[k]]] - 1}];
 polysV = (* vertical polygons *)
 Table[Polygon[{ldos[[k, i]], ldos[[k, i + 1]],
                ldos[[k + 1, i + 1]], ldos[[k + 1, i]]}], 
       {k, Length[ldos] - 1}, {i, Length[ldos[[k]]] - 1}];
 (* graphics of the local density of states *)
 opts = Sequence[PlotRange -> All, Axes -> True, 
                 BoxRatios -> {2, 2, 1}];
 Show[GraphicsArray[
 {(* total integrated density of states *)
  Graphics3D[{EdgeForm[], polysH, polysV}, 
             AxesLabel -> {"r", "ε", "𝒟"}, opts],
  (* oscillating part of the total integrated density of states *)
  Graphics3D[{EdgeForm[], polysH, polysV} /. 
   Polygon[l_] :> Polygon[Function[{r, ε, 𝒟}, 
    (* with subtracted Thomas-Fermi contribution *)
    {r, ε, 𝒟 - 1/2 (ε - r^2/2) UnitStep[ε - r^2/2]}] @@@ l], 
             AxesLabel -> {"r", "ε", "δ𝒟"}, opts]}]]]

Next, we calculate the actual matrix elements. We start by calculating the matrix elements arising from the azimuthal eigenfunctions. For the φ-independent parts of the potential the matrix elements are obviously (Subscript[δ, (Subscript[m, 1]),(Subscript[m, 2])]). For the φ-dependent part, the function φMatrixElement calculates matrix elements in the form of Kronecker delta functions.

φMatrixElement[{Φ1_, Φ2_}, {m1_, m2_}, φPart_, φ_] := 
   TrigReduce[Φ1 φPart Φ2] /. (* emulate integration *)
   (* argument of Cos must vanish for nonvanishing integral *)
   Cos[x_] :> With[{𝓂2 = m2 /. Solve[x == 0, m2][[1]]},
                    2 Pi KroneckerDelta[m2, 𝓂2]] // Expand

For the odd-odd matrix elements, we see nonvanishing terms of the form (Subscript[δ, (Subscript[m, 1]),(Subscript[m, 1])±3]) and (Subscript[δ, 1,2]) and, because of symmetry (Subscript[δ, 2, 1]).

φMatrixElement[{ΦOdd[m1, φ], ΦOdd[m2, φ]}, {m1, m2}, Cos[3 φ], φ]

For a specific value of (Subscript[m, 1]), the function MEOddφList returns a list of the values of (Subscript[m, 2]) so that we have a nonvanishing matrix element and its value.

MEOddφList[m1_?Positive] :=
Cases[{{3 - m1, -1/2}, {m1 + 3, 1/2}, {m1 - 3, 1/2}}, {_?Positive, _}]

The even-even matrix elements have a similar structure. Because (Subscript[Φ, 0]^((e)))(φ) is now nonvanishing, we have also terms of the form (Subscript[δ, 0,3]) and (Subscript[δ, 3,0]) (which, because of the different normalization for m=0, are slightly different from (Subscript[δ, (Subscript[m, 1]),(Subscript[m, 1])±3]).

φMatrixElement[{ΦEven[m1, φ], ΦEven[m2, φ]}, {m1, m2}, 
               Cos[3 φ], φ] // Simplify

For a specific value of (Subscript[m, 1]), the function MEEvenφList returns a list of the values of (Subscript[m, 2]) so that we have a nonvanishing matrix element and its value.

MEEvenφList[m1_?NonNegative] :=
Cases[{If[m1 == 0, {3, 1/Sqrt[2]}, {}],
       If[m1 == 3, Sequence @@ {{0, 1/Sqrt[2]}, {m1 + 3, 1/2}}, {}],
       If[m1 != 0 && m1 != 3, 
          Sequence @@ {{3 - m1, 1/2}, {m1 + 3, 1/2}, {m1 - 3, 1/2}}, {}]},
      {_?NonNegative, _}]

The matrix elements between the even and the odd states vanish for the cos(3φ) potential part.

TrigReduce[ΦEven[m1, φ] Cos[3 φ] ΦOdd[m2, φ]] /. _Sin -> 0

Next, we calculate the integrals arising from the radial part of the matrix elements of the potential. For the φ-independent potential part (meaning (Subscript[m, 1])=(Subscript[m, 2])=m), we have the two integrals (∫_0^∞)(r^ε)(Subscript[R, (Subscript[n, 1]),m])(r)  (Subscript[R, (Subscript[n, 2]),m])(r) r dr with ε=2 and ε=4. After a change of variables r->L (z^(1/2)) these reduce to the following type integral [✶], [✶]

(∫_0^(∞ ))(r^ε)(Subscript[R, (Subscript[n, 1]),m])(r)  (Subscript[R, (Subscript[n, 2]),m])(r) r dr=(L^ε)(Sqrt[(((Subscript[n, 1])!(Subscript[n, 2])!)/(((Subscript[n, 1])+|m|)!((Subscript[n, 2])+|m|)!))]) (∫_0^(∞ ))(z^(ε/2))(e^(- (z^2))) (z^m)(Subscript[L, (Subscript[n, 1])]^m)(z)(Subscript[L, (Subscript[n, 2])]^m)(z) dz.

For the φ-dependent potential part (meaning (Subscript[m, 2])=(Subscript[m, 1])±3 or (Subscript[m, 2])=(Subscript[m, 1])±1), we have the two integral (∫_0^∞)(r^3)(Subscript[R, (Subscript[n, 1]),m])(r)  (Subscript[R, (Subscript[n, 2]),m±μ])(r) r dr with μ=3 and μ=1 (for some special states (Subscript[n, 1,2])=1,2). Carrying out again the change of variables r->L (z^(1/2)) these integrals reduces to the following (shown are only the cases of positive μ, the cases of negative μ follow from a simple shift in m).

(∫_0^(∞ ))(r^3)(Subscript[R, (Subscript[n, 1]),m])(r)  (Subscript[R, (Subscript[n, 2]),m+μ])(r) r dr=(L^((3+μ)/2))(Sqrt[(((Subscript[n, 1])!(Subscript[n, 2])!)/(((Subscript[n, 1])+m)!((Subscript[n, 2])+m+μ)!))]) (∫_0^(∞ ))(z^((3+μ)/2))(e^(- (z^2))) (z^m)(Subscript[L, (Subscript[n, 1])]^m)(z)(Subscript[L, (Subscript[n, 2])]^(m+μ))(z) dz

Using the above recursion relations for z (Subscript[L, n]^λ)(z) and (Subscript[L, n]^(λ+1))(z) repeatedly, we now reduce the last two integrals to standard integrals of the orthogonality type (∫_0^∞)(t^λ) (e^(-t)) (Subscript[L, n]^λ)(t) (Subscript[L, p]^λ)(t)dt∼(Subscript[δ, n,p]).

The two functions LaguerreReduceRule1 and LaguerreReduceRule2 apply the two recursion relations repeatedly.

(* remove power prefactor by shifting Laguerre order *)
LaguerreReduceRule1 = z^(μ_ + k_Integer) LaguerreL[n_, μ_, z] :> 
  -(n + μ) z^(μ + k - 1) LaguerreL[n - 1, μ, z] +  
   (1 + 2 n + μ) z^(μ + k - 1) LaguerreL[n, μ, z] -
   (n + 1) z^(μ + k - 1) LaguerreL[n + 1, μ, z];

(* remove shifted parameter by shifting Laguerre order *)
LaguerreReduceRule2 = LaguerreL[n_, μ_ + i_Integer, z] :> 
   (n + (μ + i - 1))/z LaguerreL[n - 1, μ + i - 1, z] + 
   (z - n)/z LaguerreL[n, μ + i - 1, z];

Here is an example showing the two functions at work. We canonicalize the expression (z^(m+4))(Subscript[L, n]^(m+2)). The summands after expansion all have the desired form (z^m)(Subscript[L, ν]^m)(z).

Collect[Expand[z^(m + 4) LaguerreL[n, m + 2, z] //. 
                      LaguerreReduceRule2] //. LaguerreReduceRule1,
        _LaguerreL, Factor]

The function LaguerreOverlapIntegral forms the actual overlap integral (∫_0^∞)zrPart (e^(-z)) (Subscript[L, (Subscript[n, 1])]^m)(z) (Subscript[L, (Subscript[n, 2])]^(m+i))(z)dz.

LaguerreOverlapIntegral[{{n1_, m_}, {n2_, m_ + i_.}}, zrPart_] := 
Collect[(* apply the two recursion relations *)
        Expand[Expand[zrPart LaguerreL[n2, m + i, z] //. 
                      LaguerreReduceRule2] //. LaguerreReduceRule1],
        _LaguerreL, Factor] /. 
        (* use basic orthogonality integral *)
        z^μ_ LaguerreL[n_, μ_, z] :> 
         (n1 + μ)!/n1! KroneckerDelta[n1, n] /. μ -> m

The function δRule finally expresses (Subscript[n, 2]) as a function of (Subscript[n, 1]) in the Kronecker symbols. This allows, for a given (Subscript[n, 1]), to explicitly list all nonvanishing matrix elements.

δRule[expr_] := (List @@ Collect[Expand[expr], 
                                 _KroneckerDelta, Factor]) /.
 a_ KroneckerDelta[n1_, ν_] :> ({n2, a} /. Solve[n1 == ν, n2][[1]]);

Now, we have all tools together to efficiently evaluate the radial matrix elements of the potential. The function MEr calculates the radial integrals belonging to the α (r^4)+β (r^2) potential part.

MEr[n1_, n2_, m_, rPart_] := 
Sqrt[n1!/(n1 + m)!] Sqrt[n2!/(n2 + m)!]*
 L^(Exponent[rPart, r]) LaguerreOverlapIntegral[{{n1, m}, {n2, m}}, 
                                         z^m z^(Exponent[rPart, r]/2)]

For later use in the construction of the sparse global Hill matrix, we write all nonvanishing matrix elements in the form {(Subscript[n, 2])((Subscript[n, 1])), value((Subscript[n, 1]))}. These are the corresponding matrix elements for the quadratic potential term.

MErList1[{n1_, m_}] = 
   δRule[(-M/2 ω^2 + β) MEr[n1, n2, m, r^2]] // PowerExpand

Here are the matrix elements for the quartic potential term.

MErList2[{n1_, m_}] = δRule[α MEr[n1, n2, m, r^4]] // PowerExpand

The function MEr3 calculates the nonvanishing radial overlap integrals for the potential part γ (r^3) and (Subscript[m, 2])=(Subscript[m, 1])±3.

MEr3[n1_, n2_, m_, rPart_] := 
Sqrt[n1!/(n1 + m)!] Sqrt[n2!/(n2 + m + 3)!]*
 L^(Exponent[rPart, r] - 3)*
    LaguerreOverlapIntegral[{{n1, m}, {n2, m + 3}}, 
                            z^m z^(Exponent[rPart, r]/2)]

Here are these nonvanishing matrix elements.

MErListP3[{n1_, m_}] = δRule[γ MEr3[n1, n2, m, r^6] ] // PowerExpand

After some changes of variables, the case (Subscript[m, 2])=(Subscript[m, 1])-3 reduces to the case (Subscript[m, 2])=(Subscript[m, 1])+3.

MErListM3[{n1_, m_}] = δRule[γ MEr3[n1, n2, m, r^6] /.
               {n1 -> n2, n2 -> n1, m -> m - 3}] // PowerExpand

The function MEr12 finally calculates the nonvanishing radial overlap integrals for the potential part γ (r^3) and (Subscript[m, 2])=(Subscript[m, 1])±1.

MEr12[n1_, n2_, m_, rPart_] := 
Sqrt[n1!/(n1 + m)!] Sqrt[n2!/(n2 + m + 1)!]*
 L^(Exponent[rPart, r] - 1)*
    LaguerreOverlapIntegral[{{n1, m}, {n2, m + 1}}, 
                                         z^m z^(Exponent[rPart, r]/2)]

Here are these nonvanishing matrix elements.

MErListP12[{n1_, m_}] = δRule[γ MEr12[n1, n2, m, r^4] ] // PowerExpand

MErListM12[{n1_, m_}] = δRule[γ MEr12[n1, n2, m, r^4] /.
               {n1 -> n2, n2 -> n1, m -> m - 1}] // PowerExpand

Now, we join the last results, and incorporate the values of the angular overlap integrals. For given quantum numbers (Subscript[n, 1]) and (Subscript[m, 1]), the functions nonvanishingOddMatrixElements and nonvanishingOddMatrixElements return a list of all nonvanishing matrix elements of the form {{(Subscript[n, 2])((Subscript[n, 1])), (Subscript[m, 2])((Subscript[n, 1]))}, matrixElement}. We now set ℏ=M=1, but keep ω still as a symbolic parameter. Because the even and odd case have similar structures, we define an intermediate function nonvanishingMatrixElements.

(* treat even and odd case uniformly *)
nonvanishingMatrixElements[{n1_, m1_}, {𝒻1_, 𝒻2_, ℊ_, 𝒽_}, 
                           {α_, β_, γ_}, ω_] =
 (* incorporate φ-matrix element values as prefactors *)
 Join[(* return in the form {n2(n1, m1), m2(m1)}, matrixElement} *)
 {(* harmonic oscillator part *)
  {{n1, m1}, (2 n1 + m1 + 1) ℏ ω}},
   (* r-dependent potential parts *)
   If[#1 >= 0, {{#1, m1}, #2}, {}]& @@@ MErList1[{n1, m1}], 
   If[#1 >= 0, {{#1, m1}, #2}, {}]& @@@ MErList2[{n1, m1}], 
   (* cos(3φ) potential part *)
   If[#1 >= 0, {{#1, m1 + 3}, 𝒻1 #2}, {}]& @@@ MErListP3[{n1, m1}], 
   If[#1 >= 0 && (m1 ~ 𝒽 ~ 3), {{#1, m1 - 3}, 𝒻2 #2}, {}]& @@@ 
                                              MErListM3[{n1, m1}],
   If[m1 == 1 && #1 >= 0, {{#1, 2}, ℊ #2}, {}]& @@@ 
                                              MErListP12[{n1, m1}],
   If[m1 == 2 && #1 >= 0, {{#1, 1}, ℊ #2}, {}]& @@@ 
                                              MErListM12[{n1, m1}]] /. 
                                                    {M -> 1, ℏ -> 1};

The differences between the even and the odd cases are the inclusion/exclusion of the m=0 case and different signs of the angular momentum matrix elements.

(* even case *)
nonvanishingEvenMatrixElements[{n1_, m1_}, {α_, β_, γ_}, ω_] =
 nonvanishingMatrixElements[{n1, m1}, (* special rule for m == 0 *)
             {If[m1 == 0, 1/Sqrt[2], 1/2], 
              If[m1 == 3, 1/Sqrt[2], 1/2], 1/2,
              GreaterEqual}, {α, β, γ}, ω];

(* odd case *)
nonvanishingOddMatrixElements[{n1_, m1_}, {α_, β_, γ_}, ω_] =
 nonvanishingMatrixElements[
             {n1, m1}, {1/2, 1/2, -1/2, Greater}, {α, β, γ}, ω];

Here is a shortened form of the function nonvanishingEvenMatrixElements.

nonvanishingEvenMatrixElements[{n1, m1}, {α, β, γ}, ω] //
                                            Short[#, 12]&

For explicitly given values of (Subscript[n, 1]) and (Subscript[m, 1]), the test in nonvanishingMatrixElements can completely be carried out. As a result, we can add all nonvanishing matrix element values belonging to identical {(Subscript[n, 2]),(Subscript[m, 2])} pairs. The function uniteElements does this. The two function allNonvanishingOddMatrixElements and allNonvanishingOddMatrixElements are the final functions used to construct the Hill matrices.

uniteElements[l_] := (* sum right-hand side of rules *)
If[Length[#] === 1, Rule @@ First[#], 
   #[[1, 1]] -> (Plus @@ (Last /@ #))]& /@ 
     Split[Sort[DeleteCases[l, {}]], #1[[1]] === #2[[1]]&]

allNonvanishingEvenMatrixElements[{n1_Integer, m1_Integer}, 
                                  {α_, β_, γ_}, ω_] := 
uniteElements @ nonvanishingEvenMatrixElements[{n1, m1}, {α, β, γ}, ω]

allNonvanishingOddMatrixElements[{n1_Integer, m1_Integer}, 
                                 {α_, β_, γ_}, ω_] := 
uniteElements @ nonvanishingOddMatrixElements[{n1, m1}, {α, β, γ}, ω]

Here is a quick check of the just-calculated nonvanishing matrix elements. We compare them with the values of the matrix elements calculated by straightforward integration for explicit values of (Subscript[n, 1]) and (Subscript[m, 1]). To check that we did not miss any nonvanishing matrix elements, we calculate explicitly all matrix elements in the extended convex hull of the nonvanishing {n,m} points.

(* generalized Hénon-Heiles Hamiltonian *)
ℋOp[r_, φ_] = (-ℏ^2/(2 M) (1/r D[r D[#, r], r] + 1/r^2 D[#, φ, φ]) + 
               (α r^4 + β r^2 + γ r^3 Cos[3 φ]) #)&;

checkMatrixElements[{n1_Integer, m1_Integer}, evenOdd: (Even | Odd)] :=
Module[{mF, ψ, m0, mEsS, mEsE},
(* even or odd? *)
Which[evenOdd === Even, 
       mF = allNonvanishingEvenMatrixElements; ψ = ψEven; m0 = 0,
       evenOdd === Odd,  
       mF = allNonvanishingOddMatrixElements; ψ = ψOdd; m0 = 1];
 (* symbolically calculated nonvanishing matrix elements *)
 mEsS = Factor //@ Together //@ mF[{n1, m1}, {α, β, γ}, ω];
 (* explicitly calculated nonvanishing matrix elements *)
 mEsE = Block[{ℏ = 1, M = 1}, Factor //@ Together //@ 
  (Function[{n2, m2}, {n2, m2} -> 
    Integrate[ψ[n1, m1, r, φ] (ℋOp[r, φ] @ ψ[n2, m2, r, φ]) r,
               {φ, 0, 2Pi}, {r, 0, Infinity}, Assumptions -> ω > 0]] @@@
 (Flatten[(* all n and m values covering nonvanishing mEsS values *)
 Table[{n, m}, {n, Max[0 , #1[[1]] - 1], #1[[2]] + 1}, 
               {m, Max[m0, #2[[1]] - 1], #2[[2]] + 1}]& @@
         ({Min[#], Max[#]}& /@ Transpose[First /@ mEsS]), 1]))];     
 (* are nonvanishing elements identical? *)
 Sort[mEsS] === Sort[DeleteCases[mEsE, _ -> 0]]]

checkMatrixElements @@@ 
            {{{0, 3}, Even}, {{1, 1}, Even}, {{2, 2}, Odd}}

After having evaluated the function numberEvenBasisFunctions (or numberOddBasisFunctions respectively), the variable dim has a value and the function nmNumbers has downvalues. The function HillMatrixElements generates a list of all nonvanishing Hill matrix elements for the currently (through nmNumbers) active quantum numbers (Subscript[n, 1]) and (Subscript[m, 1]).

HillMatrixElements[{α_, β_, γ_}, ω_] := 
With[{(* even or odd basis? *)
      anme = If[nmNumbers[1] === {0, 0}, 
                allNonvanishingEvenMatrixElements,
                allNonvanishingOddMatrixElements]},
(* all nonvanishing matrix elements *)
DeleteCases[Flatten[
Table[({k, efNumber[#1]} -> #2)& @@@ anme[nmNumbers[k], {α, β, γ}, ω],
                       {k, dim}]], {_, _efNumber} -> _]];

At this point we also change the origin of the potential minimum. We will set the potential minimum to have the value zero. We do this to make sure that all eigenvalues are strictly positive, so that the function Eigenvalues with a negative integer second argument applied to the resulting sparse array will always yield the lowest eigenvalues.

(* change diagonal matrix elements so that the 
   potential minimum has value zero *)
gaugePotentialMinimum[sa_, {α_, β_, γ_}] :=
Module[{Vmin},
       (* global minimum of the potential *)
       Vmin = Minimize[{α (x^2 + y^2)^2 + β (x^2 + y^2) + 
                        γ (x^3 - x y^2)}, {x, y}][[1]] // 
                                     N[#, Precision[sa]]&;
       (* global gauge transformation to zero potential minimum *)
       sa + SparseArray[Table[{i, i} -> -Vmin, {i, Length[sa]}]]]

SparseHillMatrix[{α_, β_, γ_}, ω_] := 
      gaugePotentialMinimum[#, {α, β, γ}]& @
           SparseArray[HillMatrixElements[{α, β, γ}, ω]]

To visualize the sparse Hill matrix, we implement a function sparseArrayGraphics that displays the nonvanishing matrix values. Small values are shown in red, and large values are shown in blue.

sparseArrayGraphics[sa_, opts___] :=
Module[{(* absolutely scaled matrix elements *)
        ars = (#1 -> ArcTan[Abs[#2]]/(Pi/2))& @@@ 
                         Most[ArrayRules[sa]], min, max},
       (* scale matrix elements relative *)
       {min, max} = {Min[#], Max[#]}& @ (Last /@ ars);
       Graphics[{RGBColor[min/#2, 0, #2/max], 
                 Rectangle[#1 - 1/2, #1 + 1/2]}& @@@ ars, 
       Frame -> True, PlotRange -> All, AspectRatio -> Automatic]]

The next input just reproduces the 2D harmonic oscillator eigenvalues (α=γ=0).

numberEvenBasisFunctions[10];
SA = With[{ω = 1.}, SparseHillMatrix[{0, ω^2/2, 0.}, ω]];
SA // Eigenvalues // Reverse

The next graphic shows the nonvanishing matrix elements for the genuine anharmonic case α=γ=1.

numberEvenBasisFunctions[20];
SA = With[{ω = 1}, SparseHillMatrix[{1, ω^2/2, 1}, ω]];
Show[sparseArrayGraphics[SA]]

By construction, the resulting matrix is symmetric.

SA - Transpose[SA] // Normal // Flatten // Union

We have a quick qualitative look at the eigenvectors at this point. We diagonalize the just-visualized matrix with high precision.

evecs = Eigenvectors[N[SA, 60]];

The following are the angular momentum quantum numbers m of the basis states having a nonvanishing contribution to the resulting eigenstate. We see that in addition to the already above used symmetry, we could further split the states into two subgroups (corresponding to their parity with respect to the rays in the directions {cos(2 π/3), ±sin(2 π/3)}). One subgroup contains all states with m=3k, k∈ℕ, the other the remaining states [✶]. This would allow to use still smaller matrix sizes to obtain the same-quality solution. Doing this is straightforward and will not do it here.

(First /@ Cases[#, {_, 1}])&  /@ 
MapIndexed[{nmNumbers[#2[[2]]][[2]], If[Abs[#1] < 10^-30, 1, 0]}&, 
           Take[#, 24]& /@ Take[evecs, -12], {2}]

The next graphic shows the dependence of the ten lowest eigenvalues on ω. In this concrete example, the eigenvalues are nearly independent of ω over a relatively broad range of ω-values 1/2≲ω≲7/2.

(* prepare matrix *)
numberEvenBasisFunctions[30];
SAω[ω_] = N @ SparseHillMatrix[{1, -2, -3}, ω];
SAωN[ω_] = Normal[SAω[ω]];
(* show eigenvalue dependence on ω *)
Show[Graphics[Line /@ Transpose[(* use various ω-values *)
  Table[{ω, #}& /@ Take[Eigenvalues[SAωN[ω]], -10], 
        {ω, 0.1, 10, 0.1}]]], 
     Frame -> True, PlotRange -> {0, 35}]

We repeat the last calculations and investigate the magnitudes of the eigenvector components. Because the components are not smooth functions of the index, we do not display the components directly. Instead we fit a linear function to the logarithm of selected components (the selected components are the largest components starting with the highest states). This graphics that for ω≈3 we have fastest decay of the eigenfunction components for the lowest states.

Module[{evecs}, 
Show[Graphics[(* color each state differently *)
MapIndexed[{Hue[0.8 (#2[[1]] - 1)/10], PointSize[0.006], Point /@ #}&, 
Transpose[Table[evecs = Abs[Eigenvectors[SAωN[ω]]];
(* fit linear function to logarithm of eigenvector components *)
Table[{ω, Coefficient[Fit[
      (* select maximal components; start from the end *)
      Most[Log[Reverse[FoldList[Max, 0, Reverse[evecs[[-j]]]]]]],
                          {1, x}, x], x]}, {j, 10}], 
      {ω, 0.1, 10, 0.1}]]]], Frame -> True, PlotRange -> All]]

Next, we calculate the Hill matrix for a symbolic value of γ and show the dependence of the lowest eigenvalues as a function of γ. The spectrum of γ is identical to the spectrum for -γ because the sign change of γ in γ cos(3φ)(r^3) effectively just flips that potential around the y-axis. Some even and odd states are degenerate [✶], [✶].

Module[{εMax = 24, δγ = 1/36, SAγ},
Show[Graphics[
(* calculate lowest eigenvalues for various γ-values *)
Function[{eo, col}, eo[εMax];
 Table[(* form matrix and calculate lowest eigenvalues *)
       SAγ = Normal[SparseHillMatrix[{1, 0, γ}, 1]];
       (* even states in red; odd states in blue *)
       {col, PointSize[0.005], Point[{γ, #}]}& /@ 
               Take[Eigenvalues[N @ SAγ], -10], 
       {γ, -3, 3, δγ}]] @@@ 
  (* even and odd states *)
  {{numberEvenBasisFunctions, RGBColor[1, 0, 0]},
   {numberOddBasisFunctions,  RGBColor[0, 0, 1]}},
     PlotRange -> All, Frame -> True]]]

To calculate explicit position representations of the eigenfunctions, we need the numerical values of the Laguerre polynomials. To calculate them quickly (meaning using machine arithmetic), we need a numerically stable recursion relation. To avoid the generation of large values for increasing values of angular quantum numbers, we do not calculate the numerical values of (Subscript[L, n]^λ)(z) directly, but rather of the normalized version (Subscript[χ, n]^λ)(z)=n! /(n+λ)!(Subscript[L, n]^λ)(z). The (Subscript[χ, n]^λ)(z) obey the following recursion relation which is numerically stable when run downwards with respect to λ.

(Subscript[χ, n]^λ)(z)=(z+λ+1) (Subscript[χ, n]^(λ+1))(z)-z (n+λ+2) (Subscript[χ, n]^(λ+2))(z)

Here is a quick check of the quality of this recursion. To avoid large polynomial values for larger r, we also incorporate the exponential term exp(-z) from the 2D harmonic oscillator wave function.

Module[{Lz = 25, δz = 1/2, n = 150, Λ = 150,
        χ, zList, LaguerreLExpList},
 (* scaled LaguerreL functions *)
 χ[n_, λ_, z_] := n!/(n + λ)! LaguerreL[n, λ, z];
 (* z-values *)
 zList = N @ Table[z, {z, 0, Lz, δz}];
 (* starting values of the recursion relation *)
 Do[LaguerreLExpList[n, λ] = N[χ[n, λ, N[zList, 100]] Exp[-zList]], 
    {λ, Λ - 1, Λ}];
 (* carry out recursion downwards *)
 Do[LaguerreLExpList[n, λ] = 
     (1 + zList + λ) LaguerreLExpList[n, 1 + λ] - 
     zList (2 + λ + n) LaguerreLExpList[n, 2 + λ], {λ, Λ - 2, 0, -1}];
 (* display logarithm of relative error as a function of λ *)
 ListPlot[Table[{λ, Log[10, #]}& @ Abs[Max[
      Cases[LaguerreLExpList[n, λ]/
            (χ[n, λ, N[zList, 200]] Exp[-zList]) - 1, _?NumberQ]]],
      {λ, 0, Λ - 2}], PlotRange -> All, Frame -> True, Axes -> False]]

After having evaluated numberEvenBasisFunctions or numberOddBasisFunctions, the function nmNumbers has downvalues. For the {n,m}-values contained in the domain of the function nmNumbers, we will calculate numerical values for discretizations radially and azimuthally. We carry out the radial discretization in [0,rMax] and the azimuthal discretization in [0,π] (because we will later visualize the squares of the eigenfunctions and all eigenfunctions have definite parity with respect to the x-axis, we do not need the [π,2π] domain).

cacheEigenFunctionLists[ω_, rMax_, {ppr_, ppφ_}] :=
Block[{χ, n, Λ, LaguerreLExpList, δr = rMax/ppr, L = 1/Sqrt[ω],
       Λming, Λg, tpd = Developer`ToPackedArray},
 Clear[RList, ΦList];
 (* extremal n, m values *)
 nAndMinmMaxmList = {#1[[1, 1]], Min[Last /@ #], Max[Last /@ #]}& /@ 
       Split[Sort[nmNumbers /@ Range[dim]], #1[[1]] == #2[[1]]&];
 Do[usednmPair[nmNumbers[k]] = True, {k, dim}];
 (* radial eigenfunctions *)
 (* list of scaled, squared radii *)
 zList = N @ Table[(r/L)^2, {r, 0, rMax, δr}];
 χ[n_, λ_, z_] := n!/(n + λ)! LaguerreL[n, λ, z];
 Do[{n, Λmin, Λ} = nAndMinmMaxmList[[j]]; 
    (* calculate normalized Laguerre polynomials *)
    Do[LaguerreLExpList[n, λ] = χ[n, λ, zList] Exp[-zList/2], 
       {λ, Λ - 1, Λ}];
    Do[LaguerreLExpList[n, λ] = 
       (1 + zList + λ) LaguerreLExpList[n, 1 + λ] - 
       zList (2 + λ + n) LaguerreLExpList[n, 2 + λ], 
     {λ, Λ - 2, Λmin, -1}];
   (* cache the radial wavefunction values *)  
   Do[If[usednmPair[{n, λ}], 
         (* list of radial wavefunction values *)
         RList[n, λ] = tpd[Sqrt[2]/L 1/Sqrt[n!/(n + λ)!]*
                           If[λ =!= 0, zList^(λ/2),
                              Table[1., {r, 0, rMax, δr}]]*
                               LaguerreLExpList[n, λ]]],
      {λ, Λmin, Λ}], {j, Length[nAndMinmMaxmList]}];
 (* azimuthal eigenfunctions in [0, Pi] *)
 φList = N @ Table[φ, {φ, 0, Pi, Pi/ppφ}]; 
 (* all occurring m quantum numbers *)
 {Λming, Λg} = {Min[#], Max[#]}& @ Rest[Transpose[nAndMinmMaxmList]];
 φEF = If[Λming == 0, ΦEven, ΦOdd];
 Do[ΦList[m] = tpd[N @ φEF[m, φList]], {m, Λming, Λg}]]

The function cacheEigenFunctionLists uses machine precision and will work well with (Subscript[n, max]), (Subscript[m, max]) a few hundred. While this will be large enough for the visualizations to be presented at the later, for very high states, one might have to use high-precision arithmetic to calculate the radial eigenfunctions (the Hill eigenvectors are good enough with machine arithmetic).

The following graphic shows a comparison between the directly calculated radial eigenfunctions R[8, 8, r] (thick gray line) and the discretized eigenfunctions (thin red line) obtained through the function cacheEigenFunctionLists.

Show @
Block[{n = 24, m = 24, ℏ = 1, M = 1, ω = 2, 
       $DisplayFunction = Identity, ppr = 100, rMax = 10},
numberEvenBasisFunctions[100];
cacheEigenFunctionLists[ω, rMax, {ppr, 1}];
{(* exact radial eigenfunctions *)
 Plot[Evaluate[R[n, m, r]], {r, 0, rMax}, PlotPoints -> 200,
      PlotStyle -> {GrayLevel[0.5], Thickness[0.02]}],
 (* recursively-calculated radial eigenfunctions  *)
 ListPlot[MapIndexed[{(#2[[1]] - 1)/ppr rMax, #1}&, RList[n, m]], 
          PlotRange -> All, PlotJoined -> True, 
          PlotStyle -> {Hue[0]}]}]

We visualize the squares of the eigenfunctions using 3D plots and contour plots. Because the discretized eigenfunctions are defined on a tensor product grid in polar coordinates, we implement the two functions polarListPlot3D and polarListContourPlot that display such type discretized functions over a circular domain. The argument of both function is the matrix gef of function values in polar coordinates in the upper half-plane.

polarListPlot3D[gef_, rMax_:1, color___] :=
Module[{ppr, ppφ, r, φ, points, polysU, polysL},
 {ppr, ppφ} = Dimensions[gef] - 1;
 (* Cartesian coordinates of points *)
 points = MapIndexed[({r, φ} = {rMax (#2[[1]] - 1)/ppr, 
                                Pi (#2[[2]] - 1)/ppφ};
                      {r Cos[φ], r Sin[φ], #1})&, gef, {2}] // N;
 (* polygons in upper half-plane *)
 polysU = Table[Polygon[{points[[i, j]], points[[i + 1, j]],
                         points[[i + 1, j + 1]], points[[i, j + 1]]}], 
                {i, ppr}, {j, ppφ}];
 (* polygons in lower half-plane *)
 polysL = Map[(# {1, -1, 1})&, polysU, {-2}];              
 (* resulting 3D graphics *)
 Show @ Graphics3D[{EdgeForm[], color, polysU, polysL}, 
      PlotRange -> All, Boxed -> False, BoxRatios -> {1, 1, 0.4}]]

To see the structure in the squares of the higher-order wave functions better, we use a nonlinear scaling for the coloring of the contour regions. Actually, we implement two color functions. One is based on a nonlinear function applied directly to the function values and the second on a linear function applied on the number of function values. The first one shows the overall structure of the eigenfunctions (having physical relevance), while the second reveals fine details (showing numerical details, largely resulting from the summation) in the regions where the function values are small.

polarListContourPlot[gef_, resolveFineStructure_: False, rMax_:1] :=
Module[{ppr, ppφ, λ, 𝒸𝒻, cts = 48},
 {ppr, ppφ} = Dimensions[gef];
 If[resolveFineStructure,
    (* homogeneously spaced contours *)
    cls = Union[#[[Round[ppr ppφ/cts/2]]]& /@ 
                Partition[Sort[Flatten[gef]], Round[ppr ppφ/cts]]];
    λ = Length[cls];
    (* use linear gradient of graylevels with respect to contours *)
    𝒸𝒻 = Function @@ {Which @@
      Flatten[Append[MapIndexed[{#1, GrayLevel[1 - (#2[[1]] - 1)/λ]}&, 
                     Function[v, # < v] /@ cls], {True, GrayLevel[0]}]]};
    colorOpts = Sequence[ColorFunctionScaling -> False,
                         ColorFunction -> 𝒸𝒻, Contours -> cls],
    (* nonlinear color function scaling *)
    𝒸𝒻[x_] :=  GrayLevel[1 - If[x < 1/2, 0 + Sqrt[1/4 - (x - 1/2)^2], 
                                         1 - Sqrt[1/4 - (x - 1/2)^2]]];    
    colorOpts = Sequence[ColorFunctionScaling -> True,
                         ColorFunction -> 𝒸𝒻, Contours -> cts]];                  
 (* contour plot in the upper half-plane *)
 lcp = ListContourPlot[gef, colorOpts, 
            DisplayFunction -> Identity, ContourLines -> False,
            PlotRange -> All, MeshRange -> {{0, Pi}, {0, rMax}}, 
            ContourStyle -> {{GrayLevel[0], Thickness[0.002]}}];
 (* make a graphics and map polygons to Cartesian coordinates *)
 gr = Graphics[lcp];
 grR = gr /. (pl:(Polygon | Line))[points_] :>   
              pl[addPoints[points, 10^-2 Min[rMax, 2Pi]]];
 (* upper half-plane polygons *)
 grRCU = grR /. (pl:(Polygon | Line))[points_] :>   
                 pl[{#2 Cos[#1], #2 Sin[#1]}& @@@ points];  
 (* lower half-plane polygons *)
 grRCL = grRCU /. (pl:(Polygon | Line))[points_] :>   
                   pl[(# {1, -1})& /@ points];                
 (* resulting contour graphic *)                
 Show[{grRCU, grRCL},
      Frame -> False, DisplayFunction -> $DisplayFunction]]

To generate a contour plot in polar coordinates, we map a contour plot made in "Cartesian" φ,r-coordinates to Cartesian x,y-graphics coordinates. Because the polygons used to represent a contour plot have partially long edges, we have to subdivide these edges to obtain a smooth polygon boundary after the mapping to Cartesian graphics coordinates. The function addPoints inserts points into the list of points points, so that the largest resulting line segment is smaller than δε.

(* add intermediate points into list points so that the maximal
   distance between two consecutive points is δε *)
addPoints[points_, δε_] := 
 Module[{n, l}, Join @@ 
       (Function[s, (* segment s short enough? *)
               If[(l = Sqrt[#. #]&[Subtract @@ s]) < δε, s, 
         n = Floor[l/δε] + 1; (* form segments *)
         Table[# + i/n (#2 - #1), {i, 0, n - 1}]& @@ s]] /@ 
              (* form segments between points *)
              Partition[Append[points, First[points]], 2, 1])]

To construct the position representation of the eigenfunctions, we use the function constructEigenFunction. Its argument is an eigenvector from the diagonalized Hill matrix. The function constructEigenFunction assumes that the functions numberEvenBasisFunctions and cacheEigenFunctionLists have already been evaluated, so that the current basis functions are globally visible. We form the tensor product of the azimuthal and the radial eigenfunctions for only those states, contributing significantly to the sum (here we use the value (10^(-4)) for the relative contribution, which is sufficient for graphics purposes).

constructEigenFunction[evec_] :=
Module[{maxBasisValues, relWeightList, εR, ef, n, m,
        (* small enough for graphics purposes *) ε = 10^-4},
       (* relative size of products of expansion coefficients 
          times [radial part of the] eigenvector magnitude *)
       maxBasisValues = Table[Max[Abs[RList @@ nmNumbers[j]]], 
                              {j, Length[evec]}];
       relWeightList = maxBasisValues Abs[evec];
       εR = ε Max[relWeightList];                     
       (* assume RList is a global variable *)
       ef = Table[0., {Length[RList[0, 1]]}, {Length[ΦList[1]]}];
       (* add all eigenfunctions that contribute significantly *)
       Do[If[relWeightList[[j]] > εR,
             {n, m} = nmNumbers[j]; 
             (* faster method for: 
                ef = ef + evec[[j]] Outer[Times, RList[n, m], ΦList[m]]; *)
             LinearAlgebra`BLAS`GER[Evaluate[evec[[j]]], 
                                       RList[n, m], ΦList[m], ef]],
          {j, Length[evec]}];
       (* return summed eigenfunction *) ef]

We start with a calculation of the states for the parameter values α=1, β=-1/2, and γ=-3. We use a relatively small basis of 650 states (up to energy 50) and diagonalize the full (dense) matrix). Here are the lowest eigenvalues.

(* number all basis function up to energy 50 (basis size 650) *)
numberEvenBasisFunctions[50]; Print["dim = ", dim]; 
(* form sparse Hill matrix *)
SA = With[{ω = 1}, SparseHillMatrix[N @ {1, -1/2, -3}, N @ ω]]; 
(* calculate eigenvalues and eigenvectors *)
esystem = Eigensystem[N[Normal[SA]]]; 
(* sort by increasing eigenvalues *)
aux = Sort[MapIndexed[{#1, #2[[1]]} & , esystem[[1]]]]; 
evecs = esystem[[2, Last /@ aux]];
First /@ Take[aux, 6]

A quick look at the eigenvectors shows that this basis is a bit too small for a reliable visualization (we will use larger bases in a moment). But for a qualitative correct graphics we have enough information.

Show[GraphicsArray[
Table[ListPlot[Log[10, Abs[evecs[[j]]]], 
               PlotRange -> {0, -6}, AxesOrigin -> {0, 0},
               DisplayFunction -> Identity], {j, 3}]]]

Now, we calculate the discretized radial eigenfunctions and display the squares of the eigenfunctions as 3D plots. The qualitative shape of the eigenfunctions is as expected: in the ground state we see the full symmetry of the potential. The next higher states still have the reflection symmetry with respect to the x-axis. The second even state has only a slightly higher energy than the ground state (for three independent wells, the splitting will be exponentially small).

(* calculate position representation of eigenfunctions *)
cacheEigenFunctionLists[1, 6, {60, 120}]

Show[GraphicsArray[
 Block[{$DisplayFunction = Identity}, 
  Table[polarListPlot3D[constructEigenFunction[evecs[[j]]]^2, 6,
                        SurfaceColor[Hue[0.12], Hue[0], 2.5]], 
        {j, 3}]]]]

Here is a higher state shown.

polarListPlot3D[constructEigenFunction[evecs[[24]]]^2, 6,
                        SurfaceColor[Hue[0.78], Hue[0.12], 2.26]]

Here are contour plots of some of the higher states.

Show[GraphicsArray[
 Block[{$DisplayFunction = Identity}, 
  Table[polarListContourPlot[constructEigenFunction[evecs[[j]]]^2, False], 
        {j, 10, 12}]]]]

Using True for the second argument of polarListContourPlot yields plots whose fine structure reflects the details of the numerical evaluation of the eigenfunctions. Changing the basis size of the azimuthal and radial discretization would show differently-looking plots for the setting True.

(DownValues[In, Sort -> True][[-2]] /. False -> True)[[2]]

Now, we visualize some of higher states for some selected potentials. Due to their considerably more complicated structure, the contour plot generated by polarListContourPlot is frequently easier to grasp than the corresponding 3D plot from polarListPlot3D. Given a parity evenOdd, set of potential parameters β and γ, the maximal energy of the 2D harmonic oscillator basis states ε, and its frequency ω, the function eigenFunctionContourPlotArray calculates and displays ℴ states around the energy shift above the potential bottom. The option showEigenvectorComponents shows the base 10 logarithm of the absolute values of the eigenvector component. This allows to judge the correctness of the contour plots.

(* estimate spatial extension of a state with energy ε 
   in a potential with parameters {α, β, γ} *)
rClassical[ε_, {α_, β_, γ_}] := Max[Function[pm1, 
Select[ρ /. {ToRules[NRoots[ε == α ρ^4 + β ρ^2 + pm1 γ ρ^3, ρ]]},
       (Im[#] == 0 && # > 0)&]] /@ {+1, -1}]

eigenFunctionContourPlotArray[evenOdd: (Even | Odd), 
                              {β_, γ_}, {εMax_, ω_}, {shift_, ℴ_},
                              {ppr_, ppφ_}, opts___] :=
Module[{SA, evecs, ℛ, gef, λ = 3}, 
Print[{β, γ}];
If[evenOdd === Even, numberEvenBasisFunctions, 
                     numberOddBasisFunctions][εMax]; 
Print["dimFinal = ", dim]; 
(* use high precision to guarantee that matrix is symmetric *)
SA = N[SparseHillMatrix[{1, β, γ}, SetPrecision[ω, 30]]]; Print[SA];
(* calculate eigenvalues *)
evecs = Reverse @ 
Eigenvectors[SA, ℴ, Method -> {"Arnoldi", Tolerance -> 10^-8,
             BasisSize -> Min[dim, Abs[20 ℴ]], MaxIterations -> 10^4,
             Shift -> shift}]; Print["evecs done"];
(* approximate spatial extension of the wavefunction *)            
ℛ = 1.1 rClassical[N[shift], {1, β, γ}] + 1/4; Print["ℛ = ", ℛ];
(* calculate discretized 2D HO eigenfunctions *)  
cacheEigenFunctionLists[ω, ℛ, {ppr, ppφ}];
(* partition a list into length λ; append potential rest *)  
partition[l_] := If[Mod[Length[l], λ] === 0, Partition[l, λ],
         Append[Partition[l, λ], Take[l, -Mod[Length[l], λ]]]];
(* potentially show eigenvectors *)  
If[(# /. {opts} /. # -> False)&[showEigenvectorComponents],
   Show[GraphicsArray[#]]& /@ 
   partition[ListPlot[Log[10, Abs[#]], PlotRange -> {-6, 0}, 
                      DisplayFunction -> Identity, 
                      AxesOrigin -> {0, 0}]& /@ evecs]];
(* show eigenfunctions squared *)     
Show[GraphicsArray[#]]& /@ partition[
Table[gef = constructEigenFunction[evecs[[j]]];
      Block[{$DisplayFunction = Identity}, 
            polarListContourPlot[Abs[gef]^2]], {j, ℴ}]]]

Now we have all functions implement to lean back and enjoy a gallery of Hénon–Heiles potential eigenfunctions. While the function eigenFunctionContourPlotArray displays list plots of the Hill matrix eigenvectors, we do not show them explicitly. The reader can readily rerun the code to check that all eigenvectors decay rapidly enough to allow for a reliable visualization. We will always display six energetically consecutive states. In average, every third state has the full threefold rotational symmetry.

We start with some relatively simple eigenfunctions using 6480 basis functions. The reflection symmetry on the real axis and the relicts of the threefold rotational symmetry are clearly visible. We also show the size of the eigenvectors of the Hill matrix. The eigenvectors decay quickly. The decay of the Hill matrix eigenfunctions depends on the chosen ω. As a rule of thumb, we use in the following a value of ω, such that (Subscript[r, c])≈k ω where (Subscript[r, c]) is the maximal classical extension of a state and k is a small integer.

eigenFunctionContourPlotArray[Even, {205/42, -13/3}, {160, 3/2}, {57, 6},
               {90, 120}, showEigenvectorComponents -> False]

Here are some slightly more complicated states. We use 8190 basis functions. Neighbor states can have quite different-looking probability distributions.

eigenFunctionContourPlotArray[Even, {-49/47, 149/86}, {180, 3/2}, {106, 6},
               {90, 120}, showEigenvectorComponents -> False]

And the next set of states shows only a minor influence of the three wells on the probability distributions.

eigenFunctionContourPlotArray[Even, {487/100, 191/31}, {220, 3/2}, {101, 6},
                  {120, 160},  showEigenvectorComponents -> False]

We continue with two sets of higher states having more structures.

eigenFunctionContourPlotArray[Even, {70/17, -249/55}, {200, 3/2}, {95, 6},
                          {90, 120}, showEigenvectorComponents -> False]

For the next states, we use more plot points to obtain a better resolved graphics of their fine structure.

eigenFunctionContourPlotArray[Even, {259/44, 117/47}, {180, 2}, {180, 6},
                    {120, 160}, showEigenvectorComponents -> False]

To visualize still higher states reliably, we use a larger basis set containing 14520 functions.

eigenFunctionContourPlotArray[Even, {247/88, 163/34}, {240, 2}, {210, 6},
                        {120, 160}, showEigenvectorComponents -> False]

We now move on to the odd states. The odd states look qualitatively similar to the even states. Here are again some relatively simple states.

eigenFunctionContourPlotArray[Odd, {-481/85, -17/8}, {160, 3/2}, {95, 6},
                   {90, 120}, showEigenvectorComponents -> False]

Here are three sets of slightly more complicates states.

eigenFunctionContourPlotArray[Odd, {-5, -19/6}, {180, 2}, {145, 6},
                {120, 160}, showEigenvectorComponents -> False]

eigenFunctionContourPlotArray[Odd, {286/83, 8/3}, {180, 2}, {155, 6},
                      {120, 160}, showEigenvectorComponents -> False]

eigenFunctionContourPlotArray[Odd, {479/80, 423/97}, {180, 2}, {133, 6},
                   {120, 160}, showEigenvectorComponents -> False]

We continue with some more complicated states. We again use a larger basis size.

eigenFunctionContourPlotArray[Odd, {-8/11, -36/11}, {180, 5/2}, {171, 6},
                      {120, 160}, showEigenvectorComponents -> False]

We end with some still higher states of the potential from the last example.

eigenFunctionContourPlotArray[Odd, {-8/11, -36/11}, {200, 2}, {220, 6},
                      {150, 200}, showEigenvectorComponents -> False]

Symbolics Volume, Chapter 3

Find an examples of a Gauss hypergeometric function (Subscript[, 2])(Subscript[F, 1])(a,b;c;z) with rational arguments a, b, c, z that has a rational value which Mathematica does not find directly, or by using FunctionExpand or FullSimplify.

abcMaxDenominator = 6;
abcs = Union[Flatten[Table[i/j, {j, abcMaxDenominator}, {i, 0, j}]]];

(* use symmetry in a and b *)
abs = Flatten[Table[{abcs[[i]], abcs[[j]]}, {i, Length[abcs]}, 
                                            {j, i - 1}], 1];
                                            
Length[abc = Flatten[Function[ab, Append[ab, #]& /@ abcs] /@ abs, 1]]

hyps[z_] = Select[Hypergeometric2F1[##, z]& @@@ abc, 
                  MemberQ[#, Hypergeometric2F1, {0, Infinity}, Heads -> True]&] /.
                  Hypergeometric2F1 -> hypergeometric2F1;
                  
Length[hyps[z]]

The function rationalQ find a numerical approximation for ζ and checks if this number is a nice fraction.

rationalQ[ζ_] := 
   (Head[Rationalize[Hypergeometric2F1 @@ N[ζ, 20]]] === Rational) &&
   (* repeat with more digits *)
   (Head[Rationalize[Hypergeometric2F1 @@ N[ζ, 50]]] === Rational)

Now, we use values for z which are proper fractions with a given denominator in hyps[z] and select the ones that are fractions. We increase the denominator value until we find a result. After a few minutes, we find the example (Subscript[, 2])(Subscript[F, 1])(2/3,1/3;5/6;27/32)=8/5.

denominatorNFractions[n_] := Select[Range[n - 1]/n, Denominator[#] == n&]

n = 1;
While[rat2F1s = Flatten[Select[hyps[#], rationalQ]& /@ 
                            denominatorNFractions[n]];
      rat2F1s === {}, n++];    
rat2F1s  /.  hypergeometric2F1 -> Hypergeometric2F1

Rationalize[N[%, 1000]]

Discrete equivalents of the continuous Hermite polynomials times weight function ((((π^(1/2))(2^n)n!))^(-1/2))exp(-(ξ^2)/2)(Subscript[H, n])(ξ) are given by [✶], [✶], [✶], [✶]

(Subscript[f, m]^j)(q):=(((-1))^(j+m)) (2^(-j)) (Sqrt[(({{2 j}, {j+m}})) (({{2 j}, {j+q}}))]) (Subscript[K, j+m])(j+q;(1/2),2 j)

where (Subscript[K, n])(x;p,ν) are the symmetric Kravchuk polynomials (Subscript[K, n])(x;p,ν)(Subscript[=,  2])(Subscript[F, 1])(-n,-x;-ν;1/p), j is a positive integer, q and m are positive integers fulfilling -j≤q,m≤j.

Visualize the resulting discrete functions. As j approaches infinity, the Hermite polynomials times weight function are recovered in the following way:

(lim_(j->∞))(j^(1/4))(Subscript[f, n-j]^j)((Sqrt[j])q)=(1/(Sqrt[(Sqrt[π]) (2^n) n!]))exp(-((ξ^2)/2))(Subscript[H, n])(ξ)

For a fixed j, calculate how the left- and the right- hand sides of the last equation differ as a function of n.

KravtchukK[n_, x_, p_, ν_] = Hypergeometric2F1[-n, -x, -ν, 1/p];
(* let Hypergeometric2F1 autoevaluate in the degenerate case *)
KravtchukK[n_, ξ_, p_, ξ_] = Hypergeometric2F1[-n, -ξ, -ξ, 1/p];

f[m_, j_, q_] := (-1)^(j + m) 2^-j Sqrt[Binomial[2j, j + m] Binomial[2j, j + q]]*
                 KravtchukK[j + m, j + q, 1/2, 2j]
                 
discreteHOWF[j_][n_, q_] := {j^(-1/2) q, j^(1/4) f[n - j, j, q]}
continuousHOWF[n_, ξ_] := {ξ, Exp[-ξ^2/2] HermiteH[n, ξ]/Sqrt[Sqrt[Pi] 2^n n!]}

The next graphic shows all discrete wave functions for j=128 at once.

With[{j = 128}, 
     Show[Graphics[{PointSize[0.002],
     Table[{Hue[0.8 n/j], Point[N[discreteHOWF[j][n, q], 200]]}, 
           {n, 0, j}, {q, -j, j}]},  PlotRange -> All]]]

The following graphic shows the lowest discrete wave functions for j=128.

With[{j = 128, nMax = 12},
Show[Graphics[Table[{Hue[0.8 n/nMax], PointSize[0.006],
                Point /@ #, Line[#]}&[
                 Table[discreteHOWF[j][n, q], {q, -j, j}]],
               {n, 0, nMax}]], PlotRange -> All, AspectRatio -> 1/4]]

The next three graphic show the discrete wave functions as points and the continuous ones as curves. For n≪j, the discrete wave functions are an excellent approximation to the continuous one.

With[{j = 128, n = 6},
Show[GraphicsArray[Function[n, 
Graphics[{{Hue[0], PointSize[0.008], Point /@ #},
               {GrayLevel[0], Thickness[0.0001],
                Line[{#, continuousHOWF[n, #][[2]]}& @@@ #]}}&[
                Table[discreteHOWF[j][n, q], {q, -j, j}]],
                PlotRange -> All]] /@ {6, 20, 40}]]]

The sum of the squares of the differences (between the discrete and the continuous wave functions) at the discrete points shows the features of the last graphic more quantitatively. Interestingly, the sum of squares oscillates around a limiting value.

δ[j_, n_, prec_] := (* sum square of differences *)
Sum[(#2 - continuousHOWF[n, #1][[2]])^2& @@
     discreteHOWF[N[j, prec]][N[n, prec], N[q, prec]], {q, -j, j}]

δData = Table[{n, δ[128, n, 120]}, {n, 128}];
ListPlot[Log[10, δData], PlotRange -> All]

For a (Fock-space-)truncated harmonic oscillator, see [✶].

The average length (OverBar[(Subscript[x, d]^(<))])=(min_(1≤j≤d))|(Subscript[x, j])| of the absolute value of the smallest component of a point {(Subscript[x, 1]),(Subscript[x, 2]),…,(Subscript[x, d])} on a dD unit sphere is [✶]

(OverBar[(Subscript[x, d]^(<))])=((Γ(d/2) )/(Γ((d+1)/2)))(∫_0^∞)(((1-erf(y)))^d)dy.

For each 1≤d≤10, calculate (10^6) random points and the resulting average of the absolute value of the smallest component.

A random point (with respect to the area) on a dD unit sphere can be calculated in the following recursive way [✶]. Given a (random) point {(Subscript[x, 1]),(Subscript[x, 2]),…,(Subscript[x, d-1])} on a (d-1)D unit sphere, the point {r (Subscript[x, 1]),r (Subscript[x, 2]),…,r (Subscript[x, d-1]),±(Sqrt[1-(r^2)])} is a random point on a dD unit sphere. Here ± is chosen with equal probability to generate a point on the upper/lower hemisphere of the dD unit sphere. Here r=(Subscript[f, d])(𝕣) where 𝕣 is a uniformly in [0,1] distributed variable and the inverse function (Subscript[f, d]^(-1))(𝕣) is defined through

(Subscript[f, d]^(-1))(ξ)=(((∫_0^ξ)(((ρ^(d-2))(1-(ρ^2)))^(-1/2))dρ)/((∫_0^1)(((ρ^(d-2))(1-(ρ^2)))^(-1/2))dρ)).

Starting with {±1} (± with equal probability), this procedure generates randomly distributed points on a dD unit sphere.

(* avoid messages due to singularity at ρ == 1 *)
Off[NDSolve::ndsz]; Off[InterpolatingFunction::dmval];

Module[{pp = 200, Ε = 10^100, fInv, fInvSol, ρ}, 
Do[(* solve for f_d *)
   fInvSol = NDSolve[{fInv'[ρ] == Which[ρ == 0, 0, ρ == 1, Ε, 
                                        True, ρ^(d - 2)/Sqrt[1 - ρ^2]], 
                      fInv[0] == 0}, 
                  fInv, {ρ, 0, 1}, PrecisionGoal -> 16,
                  AccuracyGoal -> 16, WorkingPrecision -> 30,
                  MaxSteps -> 10^4][[1, 1, 2]];
   FInv1 = fInvSol[1];
   (* interpolate inverted data *)
   f[d] = Interpolation[Table[{If[ρ == 1, 1, fInvSol[ρ]/FInv1], ρ} // N, 
                              {ρ, 0, 1, 1/pp}]],
   {d, 2, 21}]]

Here are the (Subscript[f, d])(ξ) for 2≤d≤21.

Plot[Evaluate[Table[f[d][ρ], {d, 2, 21}]], {ρ, 0, 1}, 
     PlotRange -> All, PlotStyle -> Table[Hue[n/26], {n, 2, 21}]]

Given a vector x on the (d-1)D unit sphere, the function liftStep generates a vector on the dD unit sphere.

liftStep[x_List] := 
With[{r = f[Length[x] + 1][Random[]]}, 
     Join[r x, {(2. Random[Integer] - 1) Re[Sqrt[1 - r^2]]}]]

Nesting the function liftStep yields the function random𝒩SpherePointList. For a given positive integer d, it returns a list of random points on a 1D sphere, 2D sphere, …, dD sphere.

random𝒩SpherePointList[d_] := 
       NestList[liftStep, {2. Random[Integer] - 1.}, d - 1]

The ensemble average of such points is uniformly distributed with respect to the surface area measure of the spheres. The following graphics show 1000 points on a circle and a classical sphere.

With[{pointList = Table[random𝒩SpherePointList[3], {1000}]}, 
Show[GraphicsArray[
     {Graphics[Point[#[[2]]]& /@ pointList,
               AspectRatio -> Automatic,
               PlotRange -> 1.66 {{-1, 1}, {-1, 1}}],
      Graphics3D[Point[#[[3]]]& /@ pointList,
                 PlotRange -> 1.1 {{-1, 1}, {-1, 1}, {-1, 1}}]}]]]

The function randomxMinList returns a list of the minimal length of the components of a random point on a 1D sphere, 2D sphere, …, dD sphere.

randomxMinList[d_] := Min[Abs[#]]& /@ random𝒩SpherePointList[d]

Modelling now (10^6) random points on spheres up to dimension 10 can be carried out in a few minutes.

dMax = 10; o = 10^6; 
SeedRandom[1];
(averages = Sum[randomxMinList[dMax], {o}]/o);  // Timing

The resulting averages agree excellently with the theoretical predictions.

(* theoretical average value *)
xMinTh[d_] := Gamma[d/2]/Gamma[(d + 1)/2]*
              NIntegrate[(1 - Erf[y])^d, {y, 0, Infinity},
                         PrecisionGoal -> 12]

(* list of {dimension, error in percent} *)
MapIndexed[{#2[[1]], #1}&, 
           Round[10000 (Table[xMinTh[d], {d, dMax}]/
                              averages - 1)]/100. "%"]

For a computational more efficient way to produce random points on high-dimensional spheres, see [✶].

Derive an ordinary differential equation for the Jacobi elliptic function sn(z|m) with respect to m.

{D[JacobiSN[z, m], m], D[JacobiSN[z, m], m, m]} // TraditionalForm

Most functions appearing in the derivatives are Jacobi functions themselves and we could use the algebraic identities between them to eliminate them in favor of sn(z|m). Most troublesome are the two elliptic integrals E(am(z|m)|m) and F(am(z|m)|m). The last one is of the form inverseFunction(function(z)) and ignoring branch cuts, we assume for differential-algebraic purposes it is equal to z. This leaves us with E(am(z|m)|m), which we eliminate from the first two derivatives.

For shorter formulas, we start by introducing some obvious abbreviations for the functions and derivatives involved.

eqs1 = Table[Numerator[Together[
         d[k] - TrigExpand[D[JacobiSN[z, m], {m, k}]]]], {k, 2}] //. 
     (* introduce some abbreviations *)    
     {JacobiSN[z, m] -> sn, JacobiCN[z, m] -> cn, JacobiDN[z, m] -> dn, 
      JacobiCD[z, m] -> cd, JacobiDC[z, m] -> dc, JacobiNS[z, m] -> ns, 
      JacobiSD[z, m] -> sd, JacobiNC[z, m] -> nc, JacobiDS[z, m] -> ds,
      JacobiND[z, m] -> nd, JacobiSC[z, m] -> sc, JacobiCS[z, m] -> cs,
       EllipticE[JacobiAmplitude[z, m], m] -> EA,
       EllipticF[JacobiAmplitude[z, m], m] -> z} /.
     (* use only sn, cn, and dn *)   
     {cd -> cn/dn, dc -> dn/cn, ns -> 1/sn, sd -> sn/dn, nc -> 1/cn,  
      ds -> dn/sn, nd -> 1/dn,  sc -> sn/cn, cs -> cn/sn}

We eliminate EA=E(am(z|m)|m) and obtain the following expression.

eqs2 = Factor[Numerator[Together[eqs1[[2]] /. Solve[eqs1[[1]] == 0, EA][[1]]]]]

Ignoring the irrelevant factors m and m-1, we arrive at the following expression containing the a square root. By squaring, we eliminate this square root.

(eqs3 = Factor[((eqs2[[-1]] + #)^2 - #^2)&[
               2 cn^2 dn^3 Sqrt[1 - m sn^2] d[1]]]) // Short[#, 4]&

The remaining expression contains the three Jacobi functions sn(z|m), cn(z|m), and dn(z|m) polynomially. We use the two fundamental quadratic relations between the three functions to eliminate cn(z|m), and dn(z|m).

Variables[eqs3]

(eqs4 = Expand[eqs3 /. {cn -> Sqrt[1 - sn^2], 
                        dn -> Sqrt[1 - m sn^2]}]) // Short[#, 4]&

Squaring one more time to eliminate the square roots yields a product of two polynomials in the Jacobi function sn(z|m) and its derivatives.

(eqs5 = Factor[Expand[((eqs4 - #)^2 - #^2)&[Plus @@
               Cases[eqs4, __ Power[_, 1/2]]]]]) // Short[#, 4]&

A quick numerical check shows that the first factor contains the differential equation we were looking for.

eqs6 = (List @@ eqs5) /. {sn -> w[m], d[j_] :> Derivative[j][w][m]};

eqs6 /. w -> (JacobiSN[z, #]&) /. {z -> 1/Pi, m -> 1/E} // N[#, 100]&

Here is the resulting differential equation.

Collect[eqs6[[1]], {w''[m], w'[m]}, Factor] // TraditionalForm

Because the differential equation in quadratic in the second derivative, we could differentiate it with respect to m and obtain a differential equation linear in the highest derivative. Such a differential equation allows for an easy numerical solution (no choice of the branch of a root has to be made). The function sn(z|m) is a meromorphic function of m for any z [✶].

Consider the sums (Subscript[c, k])=(∑_(j=0)^k)(((-1))^j) (({{k}, {j}}))/ζ(2 j+2) [✶]. Visualize the dependence of (Subscript[c, k]) on k for 0≤k≤(10^4). Assuming |(Subscript[c, k])|∼(k^α), what is an approximate value for α?

c[k_] := Sum[(-1)^j Binomial[k, j]/Zeta[2j + 2], {j, 0, k}]

While for small k , this straightforward definition works, for larger k, it becomes exponentially slower. We observe that the results are of the order -(10^(-smallInteger)).

$MaxExtraPrecision = 10^5;
dataT = {#, Timing[N[c[#], 20]]}& /@ {10, 50, 100, 200, 500, 1000, 2000}

So we have to implement an alternative way to get a numerical value for (Subscript[c, k]) with k≈(10^4). Let us look at the size of the largest integers occurring in the exact calculations. The largest binomial coefficients has about 3000 digits for k=(10^4), but already for k=2000, the denominator of the zeta function has more than 5100 digits. This suggests using high-precision floating point numbers instead of exact arithmetic in the following.

{Binomial[10000, 5000], Denominator[Zeta[2000]]} // N

Next, we observe that ζ(2n) approaches 1 exponentially fast for large n. By observing that (∑_(j=0)^k)(((-1))^j) (({{k}, {j}}))=0, we subtract this sum to obtain summands of the form largeBinomial×smallZeta, which gives much smaller values than the original small. The following graphic shows sizes of the k+1 summands for k=500 and k=1000. The size of the summands vary over many hundred orders of magnitude to give a small final result. Approximately the first k/2 terms contribute significantly to the final result.

Show[Graphics[
{Hue[#1], Table[Point[{j, Log[10, Abs[N[(-1)^j Binomial[#2, j]*
                (1/Zeta[2j + 2] - 1), 20]]]}], {j, 0, #2}]}& @@@
 {{0, 500}, {0.8, 1000}}], PlotRange -> All, Axes -> True]

Now, let us implement two further computational optimizations. For a given k, we have to generate all binomial coefficients. While this could be, of course, done with k+1 calls to Binomial, a recursive calculation of the binomial coefficients is hundreds of times faster for larger k.

(* list of all k + 1 binomial coefficients Binomial[k, j], j, 0, 1, …, k *)
binomialList[k_] := FoldList[Times, 1, (k - Range[0, k - 1])/(1 + Range[0, k - 1])]

{Table[Binomial[10000, k], {k, 0, 10000}]; // Timing,
 binomialList[10000]; // Timing}

The second computational optimization refers to the zeta function values. Because the zeta function term in the definition of the (Subscript[c, k]) is independent of k, we can once and for all calculate a list of zeta function values and reuse parts of it for a given k. So, we calculate the following list of zeta function values zetaList. We also include the factor (((-1))^j) and calculate the function values to a precision depending on the size of the largest binomial coefficient with which they will be later multiplied. The following calculation is needed one time and will take a few minutes.

BL = binomialList[10001] // N;

(zetaList = Table[(-1)^j (1/Zeta[N[2j + 2, (* use adaptive precision *)
                         Max[Ceiling[Log[10, BL[[j + 1]]] + 300], 7/10 j]]] - 1), 
                  {j, 10000, 0, -1}] // Reverse;) // Timing

So, we end with the following optimized definition for the (Subscript[c, k]).

cF[k_] := binomialList[k].Take[zetaList, k + 1]

Here is a quick check showing that c[k] and cF[k] give identical results.

(cF[#]/c[#] - 1)& /@ {10, 100, 1000}

cF is much faster c and we can calculate (Subscript[c, 10000]) in a few seconds.

{cF[1000] // Timing // N, cF[10000] // Timing // N}

Next, we calculate a larger set of values of the (Subscript[c, k]) and visualize the logarithm of their absolute value.

tab = Table[C6 = Timing[{k, cF[k]}]; C6[[2]], {k, 10000, 0, -100}];

ListPlot[Log @ Drop[Abs[tab], -1], PlotRange -> All,
         AxesLabel -> {Log[k], Log[Subscript[c, k]]}]

Modulo some small oscillations visible for larger k, we see a dependence of the form (Subscript[c, k])∼(k^α). Fitting the data points to such a curve yields α≈-2.

Fit[Select[Log @ Abs[tab], #[[1]] > 5&], {1, x}, x] // N

Here are the resulting more pronounced oscillations of (Subscript[c, k])/(k^(-2)).

ListPlot[{#1, #2 #1^2}& @@@ Abs[tab], PlotRange -> All]

Interestingly, the condition |(Subscript[c, k])|≪(k^(-3/4+ε)) is equivalent to the Riemann hypothesis [✶].

Find a high-order series approximation for the solution of (∑_(k=1)^n)1/k=m for n=n(m) for large m.

Normal[Series[FunctionExpand[HarmonicNumber[n]], 
       {n, Infinity, 0}]] // Solve[# == m, n]&

A first order solution will contain the product log function.

Normal[Series[FunctionExpand[HarmonicNumber[n]], 
       {n, Infinity, 1}]] // Solve[# == m, n]&

To obtain a high order series solution, we look for a Laurent series in ε=exp(m-γ). The series must have the form n∝ε-1/2+(Subscript[c, 1])/ε+(Subscript[c, 2])/(ε^2)+…. It is straightforward to calculate the first 100 (Subscript[c, k]) recursively.

Module[{k = 0, nS = ε - 1/2, δnS, εnS, c, sol, o = 100},
 Do[k++; 
    (* add new series term *)
    δnS = Normal[Series[EulerGamma + 1/n + PolyGamma[0, n], 
                {n, Infinity, 2}]] /.  n -> nS + c[k]/ε^k;
    (* calculate series *)
    εnS = Series[δnS, {ε, Infinity, k + 1}] - (EulerGamma - Log[1/ε]);
    (* cancel series term *)
    coeff = Coefficient[Normal[εnS], ε, -(k + 1)];
    sol = Solve[coeff == 0, c[k]];
    nS = nS + c[k]/ε^k /. sol[[1]], {o}];
    (* resulting series *)
    n𝒮[ε_] = nS];

Here are some of the terms of the resulting series.

n𝒮[ε] // Take[#, -16]&

The left graphic shows the size of the coefficients of the series in ε. The right graphic shows the values of the series for m=1.

maxExp = Max[-Last /@ Cases[n𝒮[ε], ε^_, Infinity]];
n𝒮List[ε_] = MapIndexed[#1 ε^(2 - #2[[1]])&, 
                Reverse[CoefficientList[ε^maxExp #& /@ n𝒮[ε], ε]]];

Off[Graphics::gptn];
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      (* show base 10 logarithm *)
      {ListPlot[Log[10, Abs[n𝒮List[ε] /. ε -> 1 // N]]],
       ListPlot[Log[10, Abs[n𝒮List[ε] /. (ε -> Exp[m - EulerGamma] /. 
                                                 m -> N[1, 20])]]]}]]]

The difference (Subscript[H, n(m)])-m shows the quality of the series. Due to the argument exp(m-γ), the quality increases exponentially with m.

δm[m_] := HarmonicNumber[Plus @@ n𝒮List[Exp[m - EulerGamma]]] - m

$MaxExtraPrecision = 100;
ListPlot[Table[{m, Log[10, Abs[δm[m] // N[#, 20]&]]}, {m, 36}]]

The equations of motion for a flat spinning disk sliding on a plane surface including friction can be written, after an appropriate scaling of variables, in the following form [✶], [✶]:

(Overscript[𝓍, ..])(τ)={({{((4 )/(3 π ε(τ)))((((ε(τ))^2)+1) E(((ε(τ))^2))+((ε^2)-1) K(((ε(τ))^2))), if |ε(τ)|≤1}, {((4 sgn(ε(τ)))/(3 π))  ((((ε(τ))^2)+1) E(((ε(τ))^(-2)))-(((ε(τ))^2)-1) K(((ε(τ))^(-2)))), if |ε(τ)|≥1}})

(Overscript[φ, ..])(τ)={({{(4/(9 π)) ((4-2 ((ε(τ))^2)) E(((ε(τ))^2))+(((ε(τ))^2)-1) K(((ε(τ))^2))), if |ε(τ)|≤1}, {((4 sgn(ε(τ)))/(9π ε(τ))) ((4 ((ε(τ))^2)-2 ((ε(τ))^4)) E(((ε(τ))^(-2)))+(2 ((ε(τ))^4)-5 ((ε(τ))^2)+3) K(((ε(τ))^(-2)))), if |ε(τ)|≥1}})

Here 𝓍(τ) is the position of the disk along its direction of motion, and φ(τ) is the angle of the disk with respect to its center. The friction induces a complicated coupling between the translational and the rotational movement characterized by the quantity ε(τ)=(OverDot[𝓍])(τ)/(OverDot[φ])(τ). E(z) and K(z) are the complete elliptic integrals. For a fixed initial velocity 𝓋(0)=(OverDot[x])(0) and various initial angular velocities ω(0)=(OverDot[φ])(0), solve the equations of motion numerically. Does a disk that initially rotates move faster than one that does not rotate initially?

ℱ[ε_] = 
Which[ε == 1, 8/(3 Pi), (* no rotation *) ε === ComplexInfinity, 1, 
Abs[ε] < 1,  
4/3 ((ε^2 + 1) EllipticE[ε^2] + (ε^2 - 1) EllipticK[ε^2])/(Pi ε),
Abs[ε] > 1,
4/3 Sign[ε] ((ε^2 + 1) EllipticE[1/ε^2] - (ε^2 - 1) EllipticK[1/ε^2])/(Pi)];

𝒯[ε_] = 
Which[ε == 1, 8/(9 Pi), (* no rotation *) ε === ComplexInfinity, 0, 
Abs[ε] < 1, 
4/9 ((4 - 2 ε^2) EllipticE[ε^2] + (ε^2 - 1) EllipticK[ε^2])/Pi,
Abs[ε] > 1,
4/9 Sign[ε] ((4 ε^2 - 2 ε^4) EllipticE[1/ε^2] + 
     (2ε^4 - 5ε^2 + 3) EllipticK[1/ε^2])/(Pi ε)];

Here are the force and the torque as a function of ε. For increasing angular velocity, the force is decreasing and the torque is increasing.

Show[GraphicsArray[
Plot[#[ε], {ε, 0, 4}, DisplayFunction -> Identity,
     Frame -> True, Axes -> False, PlotRange -> All]& /@ {ℱ, 𝒯}]];

Solving the equations of motions and visualizing the results is straightforward. We use 𝓋(0)=2 and integrate the equations as long as (OverDot[x])(τ) is positive. The left graphic shows the positions and the angles (as dashed lines) for four initial angular velocities. The right graphic shows the positions and the velocity and the angular velocity (as dashed lines) for the same four initial angular velocities. The graphics show clearly that a spinning disk moves further. They also show that the translational motion and the rotational motion stop at the same moment, meaning the disk cannot end its translational motion first and just spin or end spinning before ending its translational motion [✶].

Module[{𝓋0 = 2, ndsol, Τ = 4}, 
Show[GraphicsArray[Show /@ Transpose[ Function[{ω0, color},
(* solve differential equations *)
ndsol = NDSolve[{𝓍'[τ] == 𝓋[τ], φ'[τ] == ω[τ], 
                 𝓋'[τ] == -ℱ[𝓋[τ]/ω[τ]], ω'[τ] == -2 𝒯[𝓋[τ]/ω[τ]],
                 𝓍[0] == 0, 𝓋[0] == 𝓋0, φ[0] == 0, ω[0] == ω0},
                {𝓍, 𝓋, φ, ω}, {τ, 0, Τ}, StoppingTest -> 𝓋[τ] < 0];
Τ1 = ndsol[[1, 1, 2, 1, 1, 2]];
(Plot[Evaluate[{#1[τ], #2[τ]} /. ndsol[[1]]], {τ, 0, Τ1},
     PlotStyle -> {{color, Thickness[0.002]},
                   {color, Thickness[0.002], Dashing[{0.02, 0.02}]}},
     DisplayFunction -> Identity, AxesLabel -> {τ, {#1, #2}}]& @@@ 
     (* show 𝓍, 𝓋, and φ, ω *) {{𝓍, φ}, {𝓋, ω}})] @@@
  (* various initial velocities *)
  {{0.010, Hue[0.00]}, {0.500, Hue[0.12]}, 
   {1.000, Hue[0.22]}, {3.000, Hue[0.78]}}]]]]

The elliptic theta functions (Subscript[ϑ, a])(z,q) obey many identities. For explicit values of z, typical examples are:

(Subscript[ϑ, 3])((π/4),q)-(Subscript[ϑ, 4])(0,(q^4))=0

2 (Subscript[ϑ, 1])'(0,(q^4))+(Subscript[ϑ, 3])'((π/4),q)=0

(Subscript[ϑ, 1])(-(π/2),q) (Subscript[ϑ, 1])(-(π/4),q)+2 (Subscript[ϑ, 1])(-(π/4),(q^2)) (Subscript[ϑ, 3])((π/4),(q^2))=0

2 (Subscript[ϑ, 3])(-(π/2),(q^2)) (Subscript[ϑ, 3])'(-(π/4),q)-(Sqrt[2]) (Subscript[ϑ, 1])(-(π/2),q) (((Subscript[ϑ, 1])(-(π/4),q))^3)=0

(Sqrt[2]) (Subscript[ϑ, 1])(-(π/2),q) (Subscript[ϑ, 1])(-(π/4),q) (Subscript[ϑ, 3])(-(π/4),q)-2 (Subscript[ϑ, 1])'(0,(q^2))=0

(Sqrt[2]) ((((Subscript[ϑ, 1])(-(π/2),q))^2)+2 (((Subscript[ϑ, 1])(-(π/4),q))^2)) (Subscript[ϑ, 1])(-(π/4),(q^2))-2 (Subscript[ϑ, 1])(-(π/2),(q^4)) ((((Subscript[ϑ, 3])((π/8),q)+(Subscript[ϑ, 4])((π/8),q)))^2)=0

(Subscript[ϑ, 1])'(0,q) (((Subscript[ϑ, 1])((π/3),(q^2)))^2)+(Subscript[ϑ, 1])(-(π/2),q) (((Subscript[ϑ, 1])((π/3),q))^2) (((Subscript[ϑ, 1])((π/6),q))^2)=0

(((Subscript[ϑ, 1])(-(π/3),(q^2)))^2) (((Subscript[ϑ, 1])(-(π/3),q))^4)-9 (((Subscript[ϑ, 1])'(-(π/6),(q^4)))^2)+9 (((Subscript[ϑ, 3])'(-(π/3),(q^4)))^2)=0

(((Subscript[ϑ, 1])(-(π/3),q))^2) (((Subscript[ϑ, 1])(-(π/2),q))^6)+8 (((Subscript[ϑ, 1])(-(π/3),q))^2) (((Subscript[ϑ, 1])(-(π/6),q))^6)+8 (((Subscript[ϑ, 1])(-(π/3),q))^6) (((Subscript[ϑ, 1])(-(π/6),q))^2)-144 (((Subscript[ϑ, 1])(-(π/3),(q^2)))^2) (((Subscript[ϑ, 1]^′)(-(π/3),(q^2)))^2)=0.

20 (((Subscript[ϑ, 1])(-(π/3),q))^4) (((Subscript[ϑ, 1])'(0,(q^2)))^2)-3 (Subscript[ϑ, 1])'(-(π/3),q) (((Subscript[ϑ, 1])(-(π/2),q))^7)-72 (((Subscript[ϑ, 1])'(-(π/3),(q^2)))^2) (((Subscript[ϑ, 1])(-(π/2),q))^4)+12 (((Subscript[ϑ, 1])(-(π/6),q))^4) (((Subscript[ϑ, 1])'(0,(q^2)))^2)=0.

(((Subscript[ϑ, 1])(-(π/3),q))^8)-4 (((Subscript[ϑ, 1])(-(π/6),q))^2) (((Subscript[ϑ, 1])(-(π/3),q))^6)+3 (((Subscript[ϑ, 1])(-(π/6),q))^8)-3 (((Subscript[ϑ, 1])(-(π/2),q))^6) (((Subscript[ϑ, 1])(-(π/6),q))^2)+72 (((Subscript[ϑ, 1])(-(π/6),(q^2)))^2) (((Subscript[ϑ, 1]^′)(-(π/6),(q^2)))^2)=0.

Write a program that, based on the series expansion of the theta functions in q, searches for (and finds) such identities.

θ = EllipticTheta;
Table[Series[θ[j, z, q], {q, 0, 20}], {j, 4}]

For brevity of notation, we will use ϑ for the theta functions. The two functions toTypeset and fromTypeset convert from θ (used for inputting the theta functions) to ϑ (used for formatting the resulting identities).

toTypeset[expr_] := expr //. {θ[a_, z_, q_] :> Subscript[ϑ, a][z, q], 
                              EllipticThetaPrime[a_, z_, q_] :> 
                                                 Derivative[1][Subscript[ϑ, a]][z, q]};
                                                 
fromTypeset[expr_] := expr //. {Subscript[ϑ, a_][z_, q_] :> θ[a, z, q], 
                                Derivative[d_][Subscript[ϑ, a_]][z_, q_] :> 
                                               Derivative[0, 1, 0][θ][a, z, q]};

Generalizing the identities given in the exercise, we will look for identities of the form

(∏_(j=1)^o)(Subscript[c, j])((∏_(k=1)^(Subscript[n, j]))(q^(Subscript[α, j,k]))(((Subscript[ϑ, (Subscript[a, j,k])]^(((Subscript[d, j,k]))))((Subscript[z, j,k]),(q^(Subscript[β, j,k]))))^(Subscript[γ, j,k])))=0

with rational (Subscript[c, k]), (Subscript[z, k,j]) fractions of π, and positive integers (Subscript[α, k,j]), (Subscript[β, k,j]) , (Subscript[γ, k,j]), the order of the derivatives is (Subscript[d, j,k])∈{0,1}, and (Subscript[a, j,k])∈{1,2,3,4}. We restrict the search to identities containing the theta functions and their first derivatives with respect to z. Derivatives with respect to q can be expressed through derivatives with respect to z by using the differential equation 4 q ∂(Subscript[ϑ, a])(z,q)/∂q=-(∂^2)(Subscript[ϑ, a])(z,q)/∂(z^2). And higher derivatives with respect to z can be reduced to the theta functions and their first derivatives (and the single z-independent term (Subscript[ϑ, 4]^″)(0,q)) [✶].

To find such identities programmatically, we form series in q with integer coefficients from the theta functions and their derivatives and then try to form linear combinations of products of such series with unknown coefficients (Subscript[c, j]). Taking the coefficients of the powers of q results in a linear system in the coefficients. Taking enough such linear equations, we will obtain overdetermined systems, and we will search for nontrivial null spaces. The null spaces will then give the desired identities.

Because we want series in q with integer coefficients, but for z=p/q× π we might obtain overall radical factors for the series, we define a function extractCommonRadicalFactor that extracts common radical factors from a series. (We could, of course, in principle use any exact coefficients. But (modular) integer arithmetic is much faster than calculations with arbitrary algebraic numbers.)

extractCommonRadicalFactor[f_, q_] :=
Module[{ser = Series[f, {q, 0, 40}], fac, rad},
       fac = Factor[PowerExpand[Normal[ser] /. q -> 𝓆^4]];
       rad = fac /. (r:Power[_?NumericQ, _Rational]) rest__ :> {r};
       f/Which[Head[rad] =!= List || rad === {}, 1,  True, rad[[1]]]]

We will keep our series in the form {ϑSymbolic,explicitSeriesInq}. For a given expression containing theta functions, the command makeSeriesPair forms such a pair.

makeSeriesPair[f_] := {toTypeset[#], Series[#, {q, 0, 30}]}& @ 
                                     extractCommonRadicalFactor[f, q]

Now we must decide which fractions of π to take for the z-values. The function makeSimpleSeriesTerms form the theta pairs {(Subscript[ϑ, a]^((d)))(z,q),…}, a=1,2,3,4, d=0,1 for a given z.

makeSimpleSeriesTerms[piFractions_] := 
 DeleteCases[#, {_, _?(Normal[#] === 0&)}]& @ 
     Flatten[Table[makeSeriesPair[Derivative[0, d, 0][θ][a, #, q]], 
                   {a, 4}, {d, 0, 1}]& /@ piFractions, 2];

For z=π/8, we cannot extract a simple radical. We form linear combinations of two theta functions instead.

T1 = Join[makeSimpleSeriesTerms[{0, Pi/2, -Pi/2, Pi/4, -Pi/4}],
          makeSeriesPair /@ 
        Join[{θ[3, Pi/8, q] + θ[4, Pi/8, q], θ[3, Pi/8, q] - θ[4, Pi/8, q]},
             {θ[3, Pi/8, q] + θ[4, Pi/8, q], θ[3, Pi/8, q] - θ[4, Pi/8, q]} /.
                                                θ -> Derivative[0, 1, 0][θ]]];
T1 // TableForm // TraditionalForm

We will not only consider (Subscript[ϑ, a]^((d)))(z,q), but the more general term (((Subscript[ϑ, a]^((d)))(z,(q^β)))^γ). So, for the current choices of z, we obtain 96 theta series.

makeBaseTerms[T1_] :=  Flatten[Table[Join[First /@ T1, {} (* First /@ T2 *)] /.
                                            q -> q^(2^e), {e, 0, 2}]];
                                            
ϑBaseTerms = makeBaseTerms[T1];
Length[ϑBaseTerms]

We now calculate the series of the functions ϑBaseTerms to order O((q^250)).

o = 250;

makeϑBaseTermsSeries[ϑBaseTerms_] := DeleteCases[
 {toTypeset[#], ExpandAll @ Series[fromTypeset[#], 
                                   {q, 0, o}]}& /@ ϑBaseTerms,
                               {_, _?((Normal[#] === 0)&)}];

ϑBaseTermsSeries = makeϑBaseTermsSeries[ϑBaseTerms];

Removing all the series that are simple multiples of each other leads to 33 different series. The function identifyIntegerMultiples identities series that are multiples of each other.

(* pull out a common integer from a series *)
pullOutIntegerFactor[{f_, ser_}] := 
Module[{g = Abs[FactorSquareFree[Normal[ser]] /. _Plus :> 1 /. q -> 1]}, 
       If[g == 0, {f, g}, {f/g, ser/g}]]
       
(* make pairs of plus/minus the series *)
sortedPlusMinusPair[{ϑ_, ser_}] := 
Module[{p = {ser, -ser}, pS = Sort[{ser, -ser}]},
       If[p === pS, {pS, {ϑ, -ϑ}}, {pS, {-ϑ, ϑ}}]]

identifyIntegerMultiples[listOfSeries_] := 
Module[{listOfSeries1, listOfSeriesPairs, equivalenceSeries}, 
 (* pull out common integers *)
 listOfSeries1 = pullOutIntegerFactor /@ listOfSeries;
 (* form ±1×series *)
 listOfSeriesPairs = sortedPlusMinusPair /@ listOfSeries1;
 (* identify equivalent series *)
 equivalenceSeries = Split[Sort[listOfSeriesPairs], #1[[1]] === #2[[1]]&];
 (* return equivalence classes in form {ϑ, series} *)
 Apply[{#2[[1]], #1[[1]]}&, equivalenceSeries, {2}]]

equivalentSeriesList = identifyIntegerMultiples[ϑBaseTermsSeries];
ϑBaseTermsFinal = First /@ equivalentSeriesList;
Length[ϑBaseTermsFinal]

Here are the form of the resulting 33 series shown.

Reverse[First /@ ϑBaseTermsFinal] // TraditionalForm

And here are the tuples of theta functions, representing identical series. (For the further calculations, we use only one representative version of these series. By substituting the equivalent forms, we could generate more identities.)

(* pull out an overall factor from the identities if possible *)
overallFactor[l_] := Factor[Plus @@ l] /. _Plus?(Not[NumericQ[#]]&) :> 1

(sIds = Equal @@@ ((#/overallFactor[#])& /@ 
   Map[First, Select[equivalentSeriesList, (Length[#] > 1)&], {2}])) //
                                                        TraditionalForm

A quick numerical high-precision check confirms the last result.

Off[N::meprec];
Union[N[Normal[fromTypeset[sIds]] /. q -> 1/2, 22]]
On[N::meprec];

Some of the series in ϑBaseTermsFinal are powers series in (q^(1/4)) and (q^(1/2)) rather than in q. By multiplying them with each other, we obtain power series in q. The function makeϑBaseProductsPre forms all possible such products.

makeϑBaseProductsPre[ϑBaseTermsFinal_] := 
Module[{fBases2, fBases4, intBases, λ2, λ4},
 (* series in half-integer and in quarter-integer powers of q *)                                    
 {fBases2, fBases4} = 
  Function[q, Cases[ϑBaseTermsFinal, _?(MemberQ[Normal[#[[2]]], 
                    Power[_, Rational[_, q]], Infinity]&)]] /@ {2, 4};                                    
                                     
 (* series in integer powers of q *)
 intBases = Complement[ϑBaseTermsFinal, Join[fBases2, fBases4]];
 (* form all eries in integer powers of q by multiplication *)
 {λ2, λ4} = Length /@ {fBases2, fBases4};
 Join[intBases, 
      (* 1/2 + 1/2 = 1 *)
      Union @ Flatten[Table[((fBases2[[i]]^#1) (fBases2[[j]]^#2))& @@@ 
                                  {{1, 1}}, {i, λ2}, {j, λ2}], 2],
      (* 1/2 + (1/4 + 1/4) = (1/4 + 1/4) + 1/2 = 1 *)
      Union @ Flatten[Table[((fBases2[[i]]^#1) (fBases4[[j]]^#2))& @@@ {{1, 2}},
                            {i, λ2}, {j, λ4}], 2],  
      (* (1/4 + 1/4) + (1/4 + 1/4) 
         = (1/4) + (1/4 + 1/4 + 1/4) = (1/4 + 1/4 + 1/4) + (1/4) = 1 *)
      Union @ Flatten[Table[((fBases4[[i]]^#1) (fBases4[[j]]^#2))& @@@ 
                             {{2, 2}, {1, 3}, {3, 1}},  {i, λ4}, {j, λ4}], 2]]];

By eliminating again doubles, and series that are just negtives of each other from the 73 series, we are left with 72 different series.

ϑBaseProductsPre = makeϑBaseProductsPre[ϑBaseTermsFinal];
ϑBaseProductsPre // Length

equivalentProductSeriesList = identifyIntegerMultiples[ϑBaseProductsPre];
ϑBaseProducts = First /@ equivalentProductSeriesList;
Λ = Length[ϑBaseProducts]

Here are the two products that are equivalent.

Equal @@@ ((#/overallFactor[#])& /@ Take[Map[First, 
   Select[equivalentProductSeriesList, Length[#] > 1&], {2}], All]) // 
                                                       TraditionalForm

And these are the 72 products that we will use as building blocks in forming linear combinations of products and powers to find identities.

(* truncate a series in such a way to display n nonvanishing terms *)
makeNTermSeries[HoldPattern[sd:SeriesData[x_, x0_, cs_, min_, max_, den_]], 
                n_Integer?Positive] := 
Module[{pos = Position[cs, _?(# !=0&), {1}, n], λ}, 
       λ = Max[pos];
       If[Length[pos] < n, sd,
          SeriesData[x, x0, Take[cs, λ], min, min + λ, den]]]

{#1, makeNTermSeries[#2, 4]}& @@@ ϑBaseProducts // TableForm // 
                                                TraditionalForm

Now, we have the theta monomials to use on the ansatz for the linear combinations to form the identities we are looking for. We use all basic monomials with equal probability and raise them to randomly chosen small powers. (Because sometimes the same monomial will be chosen multiple times, this does not limit the maximal power in which a theta function can occur.)

𝕣 := Random[Integer, {1, Λ}];
e𝕣 :=  Random[Integer, {0, 2}];
o𝕣 :=  Random[Integer, {0, 6}];

The function findIdentityCandidates carries out the above-described procedure to find potential nontrivial identities. The argument n indicates the number of theta monomials to be used in the initial ansatz. To speed up the null space calculation, we do not carry it out over rational numbers or integers (which would potentially lead to huge integers and so would be slow), but rather form only a modular null space.

findIdentityCandidates[n_] := 
Module[{prime = Prime[10^6], ansatzFunctions, λ, cList, qPoly, qSeries,
        coeffs, ℓ, eqs, ns, potentialIdentities}, 
(* carry out identity search until a candidate is found *)
While[
 (* form products of powers of theta functions *)
 ansatzFunctions = DeleteCases[#, 1]& @ 
         Union[Table[(* q^e *) Product[ϑS[𝕣]^e𝕣, {o𝕣}], {n}]];
 (* number of different theta monomials *)
 λ = Length[ansatzFunctions];
 (* form linear combination with unknown coefficients *)
 cList = Table[c[k], {k, λ}];
 (* form resulting series *)
 qPoly = cList.ansatzFunctions /. ϑS[k_] :> ϑBaseProducts[[k, 2]];
 qSeries = qPoly + O[q]^o; 
 (* extract linear equations in the c's from q-powers *)
 coeffs = DeleteCases[qSeries[[3]], 0, {1}];
 ℓ = Length[coeffs];
 (* form coefficient matrix with more rows than columns *)
 eqs = Function[sum, Coefficient[sum, #]& /@ cList] /@ 
                                 Take[coeffs, Min[3 λ, ℓ]];
 (* find modular null space *)
 ns = NullSpace[eqs, Modulus -> prime];
 (* lift modular null space *)
 res = (Mod[#, prime, -Floor[prime/2]].ansatzFunctions)& /@ ns;  
 (* the potential identities; ignore multiplicative factors *)
 potentialIdentities = Cases[Factor[res /. ϑS[k_] :> ϑBaseProducts[[k, 1]]], 
                             _Plus, Infinity];
 potentialIdentities === {}];
 (* return found identities *) potentialIdentities]

Because of the use of modular arithmetic in the last function, there is no guarantee that the result holds for all moduli, we add an additional high-precision numeric test to check found identities. The function findIdentity finds a numerically verified identity.

finalqTestQ[id_] := 
Module[{tf},
       Off[N::meprec]; 
       tf = N[fromTypeset[id] /. q -> 1/2, 1000] == 0;
       Off[N::meprec]; 
       tf]

findIdentity[n_] := 
Module[{ids}, 
       While[(ids = Select[findIdentityCandidates[n], finalqTestQ]) == {}];
       ids]

We are now in a position to carry out the identity search. To avoid that we get multiple copies of the same identity, we define a function findIdentities that tries to find o identities. It eliminates all multiple found identities.

findIdentities[o_, n_] :=
Module[{bag = {}, newIds, newIds1, newIds2},
 While[Length[bag] < o,
       newIds = findIdentity[n];
       (* were the newly found identities already encountered *)
       newIds1 = Union[Cases[Factor[newIds], _Plus, Infinity]];
       newIds2 = Select[newIds1, FreeQ[bag, #]&]; 
       (* update identity collection *)
       bag = Join[bag, newIds2]];
 (* return found identities *) bag]

And here are 25 identities involving some of the above-constructed 33 theta terms.

SeedRandom[2];
findIdentities[25, 300]

By changing the values of z as fractions of π to another value uniformly, we can extract the identities that are valid for any z. (To find such identities, we could have started with series expansions in q and z and form systems of equations in powers of q and z.)

Select[fromTypeset[%], (N[# /. Pi -> E /. q -> 1/2, 22] == 
                        N[# /. Pi -> 1/Pi /. q -> 1/2, 22] == 0)&]

We can now easily carry out a search for theta identities with different values of z. Here is another list of theta function series.

T1 = makeSimpleSeriesTerms[{0, Pi/2, -Pi/2, Pi/3, -Pi/3, Pi/6, -Pi/6}];

This time, we have 36 theta monomials.

ϑBaseTerms = makeBaseTerms[T1];
ϑBaseTermsSeries = makeϑBaseTermsSeries[ϑBaseTerms];
equivalentSeriesList = identifyIntegerMultiples[ϑBaseTermsSeries];
ϑBaseTermsFinal = First /@ equivalentSeriesList;
Length[ϑBaseTermsFinal]

And for the linear combinations, we can draw from 132 theta monomials and no equivalent series among the ϑBaseProductsPre.

ϑBaseProductsPre = makeϑBaseProductsPre[ϑBaseTermsFinal];
equivalentProductSeriesList = identifyIntegerMultiples[ϑBaseProductsPre];
ϑBaseProducts = First /@ equivalentProductSeriesList;
Λ = Length[ϑBaseProducts]

And here are again 20 identities among them.

SeedRandom[2];
findIdentities[20, 360]

The interested reader could now continue with further theta series. Here are a few further possibilities for the series to be used in ϑBaseTerms.

makeSeriesPair /@ Join[
   { θ[1, Pi/12, q] + θ[2, Pi/12, q], θ[1, Pi/12, q] - θ[2, Pi/12, q],
     θ[3, Pi/12, q] + θ[4, Pi/12, q], θ[3, Pi/12, q] - θ[4, Pi/12, q],
     θ[2, 4 Pi/5, q] - θ[2, 2 Pi/5, q],
    -θ[2,  Pi/5, q] + θ[2, 2 Pi/5, q] - θ[2, 3 Pi/5, q] + θ[2, 4 Pi/5, q],
     θ[3, 3 Pi/5, q] + θ[3, 4 Pi/5, q],
    -θ[3, 3 Pi/10, q] - θ[3, 7 Pi/10, q] + θ[3, 9 Pi/10, q] + 3 θ[4, Pi/5, q],
    -θ[3,   Pi/10, q] - θ[3, 3 Pi/10, q] - θ[3, 7 Pi/10, q] + 3 θ[4, Pi/5, q]},
   { θp[1, Pi/12, q] + θp[2, Pi/12, q], θp[1, Pi/12, q] - θp[2, Pi/12, q],
     θp[3, Pi/12, q] + θp[4, Pi/12, q], θp[3, Pi/12, q] - θp[4, Pi/12, q]} /.
                                                  θp -> Derivative[0, 1, 0][θ]]

These are some of the series that result from the use of theta functions at values that are multiples of π/5 and π/10.

-(Subscript[ϑ, 2])((π/5),(q^4))+(Subscript[ϑ, 2])(((2 π)/5),(q^4))-(Subscript[ϑ, 2])(((3 π)/5),(q^4))+(Subscript[ϑ, 2])(((4 π)/5),(q^4))+2 (-(Subscript[ϑ, 3])(((3 π)/5),q)+(Subscript[ϑ, 3])(((3 π)/5),(q^4))-(Subscript[ϑ, 3])(((4 π)/5),q)+(Subscript[ϑ, 3])(((4 π)/5),(q^4)))=0

(Subscript[ϑ, 2])((π/5),(q^4))-(Subscript[ϑ, 2])(((2 π)/5),(q^4))+(Subscript[ϑ, 2])(((3 π)/5),(q^4))-(Subscript[ϑ, 2])(((4 π)/5),(q^4))+2 ((Subscript[ϑ, 3])(((3 π)/5),(q^4))+(Subscript[ϑ, 3])(((4 π)/5),(q^4))+(Subscript[ϑ, 3])(((3 π)/10),q)+(Subscript[ϑ, 3])(((7 π)/10),q)-(Subscript[ϑ, 3])(((9 π)/10),q)-3 (Subscript[ϑ, 4])((π/5),q))=0

-(Subscript[ϑ, 3])(((3 π)/5),q)+2 (Subscript[ϑ, 3])(((3 π)/5),(q^4))-(Subscript[ϑ, 3])(((4 π)/5),q)+2 (Subscript[ϑ, 3])(((4 π)/5),(q^4))+(Subscript[ϑ, 3])(((3 π)/10),q)+(Subscript[ϑ, 3])(((7 π)/10),q)-(Subscript[ϑ, 3])(((9 π)/10),q)-3 (Subscript[ϑ, 4])((π/5),q)=0

-(Subscript[ϑ, 2])((π/5),(q^4))+(Subscript[ϑ, 2])(((2 π)/5),(q^4))-(Subscript[ϑ, 2])(((3 π)/5),(q^4))+(Subscript[ϑ, 2])(((4 π)/5),(q^4))-(Subscript[ϑ, 3])(((3 π)/5),q)-(Subscript[ϑ, 3])(((4 π)/5),q)-(Subscript[ϑ, 3])(((3 π)/10),q)-(Subscript[ϑ, 3])(((7 π)/10),q)+(Subscript[ϑ, 3])(((9 π)/10),q)+3 (Subscript[ϑ, 4])((π/5),q)=0

((((Subscript[ϑ, 3])(((3 π)/5),q)+(Subscript[ϑ, 3])(((4 π)/5),q)))^2)-((((Subscript[ϑ, 3])(((3 π)/10),q)+(Subscript[ϑ, 3])(((7 π)/10),q)-(Subscript[ϑ, 3])(((9 π)/10),q)-3 (Subscript[ϑ, 4])((π/5),q)))^2)+2 ((Subscript[ϑ, 2])((π/5),(q^4))-(Subscript[ϑ, 2])(((2 π)/5),(q^4))+(Subscript[ϑ, 2])(((3 π)/5),(q^4))-(Subscript[ϑ, 2])(((4 π)/5),(q^4))) ((Subscript[ϑ, 3])(((3 π)/5),(q^4))+(Subscript[ϑ, 3])(((4 π)/5),(q^4)))=0

2 (((((Subscript[ϑ, 3])(((3 π)/5),q)+(Subscript[ϑ, 3])(((4 π)/5),q)))^2)-2 ((((Subscript[ϑ, 3])(((3 π)/5),(q^4))+(Subscript[ϑ, 3])(((4 π)/5),(q^4))))^2)+((((Subscript[ϑ, 3])(((3 π)/10),q)+(Subscript[ϑ, 3])(((7 π)/10),q)-(Subscript[ϑ, 3])(((9 π)/10),q)-3 (Subscript[ϑ, 4])((π/5),q)))^2))-((((Subscript[ϑ, 2])((π/5),(q^4))-(Subscript[ϑ, 2])(((2 π)/5),(q^4))+(Subscript[ϑ, 2])(((3 π)/5),(q^4))-(Subscript[ϑ, 2])(((4 π)/5),(q^4))))^2)=0

To search for identities with other multiples of π/d, we need linear combinations of (Subscript[ϑ, a])(p π/d,q) such that the series expansion of these linear combinations has integer coefficients. The following function findϑLinearCombinations tries to find o linear combinations of thsi form for multiples of π/den.

findϑLinearCombinations[o_, den_] := 
Module[{(* general series expansions at q == 0 *)
        ser = Normal[Table[Series[EllipticTheta[j, z, q], 
                                  {q, 0, 25}], {j, 4}]],
        sum12, sumS12, sum34, sumS34, vars, 𝕣𝕔, 𝕣𝕔𝕤, 𝕤, 
        n𝕤, n𝕤r, bag = {}},
 (* symbolic linear combinations of the two pairs with equal q-powers *)
 {sumS12, sumS34} = 
   (Sum[c[α, j] Subscript[ϑ, #1][j Pi/(2 den), q], {j, 0, 2 den - 1}] + 
    Sum[c[β, j] Subscript[ϑ, #2][j Pi/(2 den), q], {j, 0, 2 den - 1}])& @@@
                                                           {{1, 2}, {3, 4}};
 (* explicit linear combinations of the two pairs with equal q-powers *)
 {sum12, sum34} = {sumS12, sumS34} /. 
                Subscript[ϑ, j_] :> Function @@ {{z, q}, Evaluate[ser[[j]]]};      
 (* the undetermined coefficients *)
 vars = Cases[sumS12, _c, Infinity];
 (* values for the 4 den undetermined coefficients 
    c[α, j] and c[β, j], j = 0, 1, …, 2 den - 1 *)
 𝕣𝕔 := Rule @@@ Transpose[{vars, Table[Random[Integer, {-1, 1}], 
                                       {Length[vars]}]}];
 While[Length[bag] < o, (* try linear combination *) 𝕣𝕔𝕤 = 𝕣𝕔;       
       (* check if try combination results in q-series 
       with integer coefficients *)     
       (* series in ϑ_1 and ϑ_2 *)                     
       𝕤 = sum12 //. 𝕣𝕔𝕤; n𝕤 = N[𝕤, 22]; n𝕤r = n𝕤 /. x_Real :> Round[x];
       If[(n𝕤 - n𝕤r /. q -> 1) == 0, AppendTo[bag, {sumS12 /. 𝕣𝕔𝕤, n𝕤r}]];
       (* series in ϑ_3 and ϑ_4 *) 
       𝕤 = sum34 //. 𝕣𝕔𝕤; n𝕤 = N[𝕤, 22]; n𝕤r = n𝕤 //. x_Real :> Round[x];
       If[(n𝕤 - n𝕤r  /. q -> 1) == 0, AppendTo[bag, {sumS34 /. 𝕣𝕔𝕤, n𝕤r}]]];
 (* return found linear combinations *) bag]

Here are some linear combinations of (Subscript[ϑ, a])(p π/7,q) that have integer q-series coefficients.

SeedRandom[123];
findϑLinearCombinations[6, 7]