Symbolic Computations

1.0 Remarks

The commands discussed in this chapter form the most important part of Mathematica’s mathematical capabilities. This accounts for the relatively large size of this chapter as well as for the relatively large number of exercises. Mathematica can only be considered a complete system for doing various parts of mathematics and its applications on a computer if we include all of its graphical, pattern recognition, programming, numerical, and symbolic capabilities. On the other hand, capabilities such as factorization of polynomials, differentiation, integration, solution of equations and differential equations, computation of sums, products, and limit values can hardly be duplicated by other conventional programming systems that can handle graphics and numerical computations. So the commands for the operations Factor, D, Integrate, FourierTransform, Solve, Eliminate, Resultant, GroebnerBasis, DSolve, Limit, and Series are in some sense the most important functions in Mathematica and the content of this chapter. As already discussed in the beginning (in Chapter 2 of the Programming volume [1559✶] of the GuideBooks), every object in Mathematica is an expression. This uniformity of the underlying data structures allows symbolic expressions to be integrated uniformly into the whole Mathematica system and to work naturally together with the graphical, pattern recognition, programming, and numerical functions of Mathematica.
A general remark about using the symbolic capabilities of Mathematica is in order. The functions discussed in this chapter are designed primarily for use with exact arguments and should, if possible, only be called with symbolic arguments, and not with numeric or mixed symbolic/numeric arguments. Although in most cases Mathematica returns a sensible answer for numeric or mixed symbolic/numeric inputs, often in the case of numeric arguments the computation becomes considerably more complicated or even ill-defined.

1.1 Introduction

Before starting to discuss polynomials, the most important symbolic data structure, we will briefly discuss the meaning of a variable and assumptions and “types”. Mathematica is basically an untyped language. In nearly every function, a variable is interpreted and handled as a generic complex number of finite magnitude [1143✶]. Indefinite integrals ∫f(z)dz return a result that is correct almost everywhere in the complex z-plane (maybe with the exception of some zero-dimensional set with respect to the Lebesgue measure)—so from time to time the result of Integrate contains terms of the form ((z^3)^(1/3)) and related forms, solutions to polynomial equations contain almost always complex numbers, and so on.
Some exceptions to the rule are that every variable is generically assumed to be complex are some logical functions. LogicalExpand[a && Not[a]] returns False and not an error message saying that Not[aSymbolRepresentingAComplexNumber] is not defined, comparisons, such as x < 1, do not automatically issue a warning message that a complex number is compared to 1, etc.
In symbolic summation, certain assumptions about the integer-valuedness of lower and upper limits are made, such as Sum[k, {k, 1, n}], which returns 1/2 n (1 + n) instead of If[Im[n] == 0 && n >= 0, 1/2 Floor[n](1 + Floor[n]), Sum[k, {k, 1, n}]] which would correspond to the result returned by Sum for an explicit (real) n.
Many matrix operations, such as Cross[𝕒, 𝕓] and Det[𝕒] stay unevaluated for symbols 𝕒 and 𝕓. Obviously, here 𝕒 and 𝕓 are not assumed to be complex numbers. There are some more exceptions, and we will encounter them in the following discussions.
Generically, the assumption that every variable is a complex one of finite size is very sensible. The complex numbers are an algebraically closed field and enable the inversion of polynomials and more complicated functions. Without using complex numbers, it would be, for instance, impossible to express the three real roots of 5 (x^3)-9 (x^2)+x+1=0 in radicals without using (Sqrt[-1]) explicitly. (See below for a more detailed discussion of this case.)

But in some instances one wants to make certain assumptions about the type of a variable, for example when one wants to express that the parameter γ in (∫_(-∞)^∞)(e^(i γ (x^2)))dx is real so that the integral exists. A few Mathematica functions, notably Simplify and Integrate, have currently the notion of a variable “type”. We will discuss assumptions in Integrate in detail in Subsection 1.6.2. The function Simplify we discussed already in Section 3.5 of the Programming volume [1559✶] of the GuideBooks, but not in its full generality. Because we will make use of it more frequently later, and because internally Simplify uses functions from all sections of this chapter we will discuss all of its options now.

We start with the last arguments of Simplify, its options.

(* no spelling warnings, set fonts for tick labels, ... *)
Get[ToFileName[ReplacePart["FileName" /. 
 NotebookInformation[EvaluationNotebook[]], "Initialization.m", 2]]];

Options[Simplify]

Let us give some examples. The meaning of Automatic in the ComplexityFunction option setting is basically to minimize the LeafCount. Some exceptions are made for numbers. Expressions of the form (((Subscript[integer, 1])^(Subscript[integer, 2]))^(1/(Subscript[integer, 2]))) autosimplify to (Subscript[integer, 1]). Such an operation might take awhile, but they will be carried out automatically.

(12345^45678)^(1/45678)

The next expression, although being mathematically an integer, does not automatically evaluate to an integer.

Exp[Log[12] + 3 (Sqrt[2] + 1)^2 Log[6] -  6 Sqrt[2] Log[6]]

Simplify will simplify it to an explicit integer.

Simplify[%]

Here are 13 expressions of this type.

ℊ[k_Integer] := Exp[Log[12] + k (Sqrt[2] + 1)^2 Log[6] -
                    2 k Sqrt[2] Log[6]]
                    
ℊTab = Table[ℊ[k], {k, 13}]

Simplify’s default measure for simplicity will not convert all of them into integers. Large integers are considered more complicated than certain symbolic expressions.

Simplify[ℊTab]

Using LeafCount as the ComplexityFunction yields now 13 integers.

Simplify[ℊTab, ComplexityFunction -> LeafCount]

Here is an expression.

expr = (x - 8)^4 - (y + 4)^8

Simplify will not convert it to the simple original expression expr.

Simplify[Expand[expr]]

Simplify is not always able to find the expression that is “simplest”. There is no (and there cannot be a) guarantee that Simplify will find the simplest possible expression. Even for the case of (multivariate) polynomials it will not always find the simplest form.

{LeafCount[expr], LeafCount[Simplify[Expand[expr]]]}

There are no restrictions on the setting of the ComplexityFunction option. The following example uses a function that favors large expressions. As a side effect, the function blowItUp monitors all expressions generated in the simplification process. We collect all expressions generated in the list bag.

blowItUp[expr_, n_] := 
  If[(counter = counter + 1) < n, 
     AppendTo[bag, expr]; 1/LeafCount[expr], Abort[]]

Now we get a fairly large result.

counter = 0; bag = {}; 
Simplify[Sin[x] - Cos[x] + (x - 1)^3/(x + 1)^3, 
         ComplexityFunction -> (blowItUp[#, 10000]&)]

LeafCount[%]

Here is a plot of the size of all expressions produced in the “simplification”.

ListPlot[LeafCount /@ bag, PlotRange -> All, AxesOrigin -> {0, 0}]

Simplify always tries to minimize the value returned by the setting of the ComplexityFunction. This means that the functions Tan and Cot will not be present in the following result.

Simplify[Tan[x] - Cot[x], ComplexityFunction -> 
             (Count[#, _Tan | _Cot, Infinity]&)]

Using all trigonometric functions as a measure, we do obtain the expression rewritten in exponentials. The reason is that the function ExpToTrig (to be discussed below) is not automatically used.

Simplify[Tan[x] - Cot[x], ComplexityFunction -> 
   (Count[#, _Tan | _Cot | _Sin | _Cos | _Csc | _Sec, Infinity]&)]

When we explicitly include TrigToExp in the list of transformations to be applied, we get a result that does not contain any trig functions.

Simplify[Tan[x] - Cot[x], ComplexityFunction -> 
   (Count[#, _Tan | _Cot | _Sin | _Cos | _Csc | _Sec, Infinity]&),
         TransformationFunctions -> {TrigToExp}]

For all α, (Subscript[θ, j])≠(Subscript[θ, k]), the following identity holds [264✶], [154✶]:

((sin(n α))/(sin(α)))==(∑_(j=1)^n)(∏_(Underscript[k=1, k≠j])^n)((sin(α+(Subscript[θ, j])-(Subscript[θ, k])))/(sin((Subscript[θ, j])-(Subscript[θ, k])))).

sinIdentity[n_, {φ_, θ_, α_}] := Sin[n α]/Sin[α] - 
    Sum[Product[If[k == j, 1, Sin[θ[j] - θ[k] + α]/Sin[θ[j] - θ[k]]],
                {k, n}], {j, n}]

Here is an example for n=3.

sinIdentity[3, {φ, θ, α}]

Simplify can verify the identity.

Simplify[%]

The running time of Simplify depends (often dramatically) on the size of the expression to be simplified.

Table[Timing[Simplify[sinIdentity[n, {φ, θ, α}]]], {n, 2, 6}]

When the option setting Trig is set to False, the identities can no longer be verified.

Table[Timing[Simplify[sinIdentity[n, {φ, θ, α}],
                      Trig -> False]], {n, 2, 3}]

But we can instead use our own transformation functions for the simplification of trigonometric expressions—the functions TrigExpand and TrigFactor from Chapter 3 of the Programming volume [1559✶] of the GuideBooks.

Table[Timing[
Simplify[sinIdentity[n, {φ, θ, α}], Trig -> False,
                     TransformationFunctions -> {TrigExpand}]],
      {n, 2, 6}]

Simplify will apply many transformation rules to an expression, but cannot guarantee finding the “simplest possible” expression. In the following input we simplify (with respect to the LeafCount measure of complexity) the expanded form of ((sin(x))^n)sin(n x). While, on average, Simplify is be able to reduce the leaf count by a factor of 2, generically it does not reach the leaf count of 9 of ((sin(x))^n)sin(n x). Because zero testing is frequently considerably easier, in the following example Simplify always succeeds in showing that the difference between the expanded and the nonexpanded version is zero.

Module[{𝓈, 𝓉, x, y, o = 12}, 
Table[(* a larger trigonometric expression *)
      𝓉 = Sin[x]^n Sin[n x]; 𝓈 =  TrigExpand[𝓉];
      (* measure sizes *){LeafCount[𝓈], 
       LeafCount[Simplify[𝓈, ComplexityFunction -> LeafCount]], 
       LeafCount[𝓉], (* difference is 0 *) Simplify[𝓈 - 𝓉]}, {n, o}]]

Now, let us discuss the possible assumptions for Simplify. The assumptions can be given in the form of equalities, inequalities, and type specification. (Sqrt[(x^2)]) does not simplify to x because it is not true in the whole complex x-plane.

Simplify[Sqrt[x^2]]

Using an additional assumption, we can simplify this expression.

Simplify[Sqrt[x^2], x > 3]

Now, what are the “type” specifications available in Mathematica? The possible domains are listed below.

To use types, we need one more function: Element.

For simple, decidable cases, Element[expr, type] will evaluate to True or False.

Element[12, Integers]

Element[Pi, Reals]

Element[Pi + I E, Complexes]

Element[GoldenRatio, Algebraics]

Element[Pi, Rationals]

Element[Pi, Algebraics]

Here are two more complicated examples [564✶].

Element[Cos[Pi/111111] + Sin[Pi/22222], Algebraics]

Element[Cos[2], Algebraics]

Still more complicated cases remain unevaluated.

Element[Sin[Pi/24]^Log[2], Algebraics]

Element[EulerGamma, Algebraics]

Element deals exclusively with mathematical domains. It does not deal with explicitly given “sets”. (In the next example the function MemberQ would be more appropriate.)

Element[1, {1, 2}]

Using assumptions, we can now simplify expressions by giving additional type information. Here are some examples.

Simplify[Sqrt[z^2], Element[z, Complexes] && Re[z] > 3]

Simplify[Sin[p Pi] + Cos[2 p Pi], Element[p, Primes]]

Simplify[a && (a || b) && b, Element[{a, b}, Booleans]]

The first argument of element can either be a single expression or a list of expressions, or it can have the head Alternatives.

Simplify[Not[a] && Not[b || a], Element[a | b, Booleans]]

Type information can be supplemented with other assumptions.

0^exp

Simplify[%, Element[exp, Reals] && exp > 2]

Here are some more complicated examples using Simplify.

Simplify[(4 (-1 + x^2))/((-1 + x) Sqrt[(1 + x)^2]*
         (2 + 3 x) + Sqrt[(-1 + x)^2] (-2 + x + 3 x^2)), x > 2]

Simplify[(4 (-1 + x^2))/((-1 + x) Sqrt[(1 + x)^2]*
         (2 + 3 x) + Sqrt[(-1 + x)^2] (-2 + x + 3 x^2)), 0 < x < 1]

Simplify[(Sin[(3 n + 1) Pi] - Cos[(2 n + 1) Pi])*
         Sqrt[x^2] > 0, Element[n, Integers] && x > Pi]

Simplify[(-1)^(2 p) + Cos[2 Pi p], Element[p, Primes] && p > 3]

Simplify[Log[Exp[x]] - Sqrt[x^2] - (x^4)^(1/4), x < -Pi]

In case inequalities appear in the assumptions, Simplify assumes all variables that appear algebraically in these inequalities as real-valued. So the assumptions in the following input are contradictory and as a result True is returned.

Simplify[ω^4 > 1, Element[ω, Complexes] && ω^4 < -1]

Specifying the properties of the real and the imaginary parts separately, yields the expected answer False.

(* use ω^4 == Im[ω]^4 - 6 Im[ω]^2 Re[ω]^2 + Re[ω]^4 + 
              I (-4 Im[ω]^3 Re[ω] + 4 Im[ω] Re[ω]^3) *)
Simplify[Im[ω]^4 - 6 Im[ω]^2 Re[ω]^2 + Re[ω]^4 > 1, 
        Element[{Re[ω], Im[ω]}, Reals] && 
        Im[ω]^4 - 6 Im[ω]^2 Re[ω]^2 + Re[ω]^4 < -1 && 
        -Im[ω]^3 Re[ω] + Im[ω] Re[ω]^3  == 0]

The second argument in Simplify can be used to give additional information about variables and symbols. This additional information often results in the possibility that more specialized transformation rules can be applied. But these more specialized transformation rules are applied only after more generically valid ones are already applied. So Simplify cannot (straightforwardly) be used to detect exceptions and special cases. So the next expression incorrectly simplifies to 0 (for generic x the numerator has been simplified to zero, resulting in 0 for the whole expression).

Simplify[((x + 1)^2 - x^2 - 2x - 1)/x, x == 0]

Here is an even simpler example that gives incorrectly 0.

Simplify[x Csc[x], x == 0]

And the following input returns False, although it is semantically meaningless for numbers.

Simplify[cNumber && Not[cNumber], Element[cNumber, Complexes]]

Here is another example of this kind. We use the sinIdentity[3, {φ, θ, α}] from above and give the conditions for degeneracy as assumptions. Nevertheless Simplify returns the generically correct result 0.

Simplify[sinIdentity[3, {φ, θ, α}], 
         θ[1] == θ[2] && θ[1] == θ[3] && θ[2] == θ[3]]

Simplify will be a “strong” enough function for the applications treated in this chapter. In some cases (especially for nested radicals [842✶], [1015✶], expressions involving Root-objects, and special functions), Simplify will not achieve the “desired” form. In such cases, one can use the function FullSimplify. (We will discuss FullSimplify in great detail in Chapter 3 when applying it to a variety of expressions containing special functions.) Here is such a case.

{Simplify[Sqrt[5 + 2 Sqrt[6]]], FullSimplify[Sqrt[5 + 2 Sqrt[6]]]}

This was a short introduction into a directed use of Simplify using options and assumption specifications.

1.2 Operations on Polynomials

1.2.1 Structural Manipulations on Polynomials

The two most important commands for manipulating polynomials, Expand and Factor, were already introduced in Chapter 3 of the Programming volume [1559✶] of the GuideBooks. Note that Factor also works for polynomials in several variables.

Expand[(1 - x)^3 (3 + y - 2x)^2 (z^2 + 8y)]

Factor[%]

The following condition is often ignored.

Thus, for instance, the following example does not work.

Expand[(1.0 - x)^3 (3.0 + y - 2.0 x)^2 (z^2 + 8.0 y)] // Factor

The following simpler example works, but we highly discourage the use of inexact numbers inside Factor.

x^2 - 5 x + 6. // Factor

Results such as the following are much better produced using NRoots or NSolve to achieve a factorization explicitly via solving for the roots.

x^3 - x^2 - 5 x + 5.23 // Factor

Using the command Rationalize introduced in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks, we can convert approximate numbers to nearby rational numbers. (But be aware that for inputs with approximative numbers with many digits, the functions myFactor might exhibit a long running time.)

myFactor[x_, opts___] :=
N[Factor[MapAll[Rationalize[#, 0]&, x], opts],
  (* output precision = input precision *) Precision[x]]

myFactor[%%%%]

For nonexact integer exponents, Expand and Factor fail.

Expand[(1.0 - x)^3. (3.0 + y - 2.0 x)^2. (z^2 + 8.0 y)^2.]

But note that the application of N to a polynomial does not give numericalized exponents.

N[Expand[(1.0 - x)^3 (3.0 + y - 2.0 x)^2 (z^2 + 8.0 y)^2]]

Mathematica factorizes over the integers (“not over the rationals”, and not over the algebraic numbers). This is not a big restriction for rational numbers. The following polynomial over the exact rationals is factorized in such a way that the resulting polynomials have integer coefficients and is written out with a common denominator.

Expand[(1/4 - x)^3 (3/2 + y - 2x)^2 (z^2 + 8/5y)^2] // Factor

An interesting theoretical question is the following. Given a polynomial p=(∑_(k=0)^d)(Subscript[c, k])(x^k) of degree d with integer coefficients (Subscript[c, k]) in the range -f≤(Subscript[c, k])≤f, what is the average number of factors of p [1271✶], [137✶], [1416✶], [475✶]? Here is a simulation for small d and f.

factorNumber[maxDegree_, maxCoefficient_] :=
Module[{x}, (* count factors *)
       If[Head[#] === Plus, 1, Length[#]]&[
        (* factored random polynomial *) Factor[
       Sum[Random[Integer, {-1, 1} maxCoefficient] x^i,
           {i, 0, maxDegree}]]]]

Module[{n = 400, dMax = 12, fMax = 20, data}, 
       (* use n random polynomials *)
       data = Table[Plus @@ Table[factorNumber[d, f], {n}], 
                    {d, 2, dMax}, {f, 1, fMax}]/n;
       ListPlot3D[Log[10, data - 1], 
                  MeshRange -> {{2, dMax}, {1, fMax}}, PlotRange -> All]]

Because no algebraic numbers are computed in the factorization of a univariate polynomial with integer (rational) coefficients, we have the following behavior.

{Factor[x^2 - a^2], Factor[x^2 - 2^2], Factor[x^2 - Sqrt[2]^2]}

To factor polynomials over algebraic number fields, the option Extension can be used.

With the default setting, None polynomials will not be factored over algebraic numbers.

Factor[x^2 - 11]

With the setting Automatic, polynomials will be factored over the field generated by the algebraic numbers explicitly present in the polynomial. This means for the following example that it will be factored over ℚ((Sqrt[2])).

Factor[x^2 + 2 Sqrt[2] x + 2, Extension -> Automatic]

By giving a list of algebraic numbers, one can explicitly specify the extension field. Here, a quartic polynomial is factored. Adjoining (11^(1/4)) allows factoring (x^4)-11 into two linear factors with real roots and one quadratic factor with two complex roots.

Factor[x^4 - 11, Extension -> (11)^(1/4)]

Adding (Sqrt[-1]) to the extensions allows for a complete factorization of (x^4)-11 into linear factors.

Factor[x^4 - 11, Extension -> {(11)^(1/4), I}]

Finding an extension such that a polynomial will factor is largely equivalent to solving polynomial=0. Here is an unsuccessful trial to factor 3(x^3)+7(x^2)-9.

Factor[x^4 - 3x^3 + 7 x^2 - 9]

Here, we use an extension such that the polynomial factors into one linear and one quadratic factor.

Factor[3 x^3 + 7 x^2 - 9, 
       Extension -> {(1501/2 - (27 Sqrt[2445])/2)^(1/3)}]

Be aware that factoring of polynomials is a rather complex process (see the general references given in the preface), which takes some time. Here, the timings for the expansion of (C + 1)^i are compared with the timings for the factorization of the expanded object. (Be aware of the different degrees for Expand and Factor.)

Show[GraphicsArray[
ListPlot[(* reasonable units for a 2-GHz computer *)
         {#[[1]], 1000 #[[2, 1, 1]]}& /@ #[[1]],
         Frame -> True, PlotLabel -> #[[2]],
         FrameLabel -> {"degree", "milliSeconds"},
         DisplayFunction -> Identity]& /@
 (* Expand and Factor data *)        
{{Table[{i, Developer`ClearCache[];
        Timing[Expand[(C + 1)^i];]}, {i, 0, 6000, 50}], "Expand"},
 {Table[{i, Developer`ClearCache[];
        Timing[Factor[#]]&[Expand[(C + 1)^i]]}, {i, 300}], "Factor"}}]]

Let us take a graphical look at the result of expanding a power of a sum. Let the sum total 0 in the form 0=(∑_(j=0)^(n-1))exp(2π i j/n). Then the powers of this sum are also 0, and, by interpreting the partial sums of the expanded power as points in the complex plane, we get a closed path.

expandPicture[{n_, pow_}, opts___] :=
Show[Graphics[{Thickness[0.002], Line[{Re[#], Im[#]}& /@
      (* form the partial sums *)
      FoldList[Plus, 0, N[(List @@
       (* first make list, and then replace to avoid reordering *)
       (* now comes the expansion *)
       Expand[Sum[C[i], {i, 0, n - 1}]^pow]) /. C[i_] -> Exp[i I 2Pi/n]]]]}],
     opts, AspectRatio -> Automatic, Frame -> True,
     PlotRange -> All, FrameTicks -> None];

Map[Show[GraphicsArray[
       expandPicture[#, DisplayFunction -> Identity]& /@ #]]&,
      (* the parameters for the pictures *)
     {Table[{3, i}, {i, 3, 21, 3}],  Table[{4, i}, {i, 2, 20, 4}],
      Table[{5, i}, {i, 3, 15, 3}],  Table[{6, i}, {i, 3, 12, 2}],
      Table[{8, i}, {i, 2, 8, 2}]}, {1}]

Here is a more complicated version of such a graphic. We use n=10 and raise it to power 10.

Show[expandPicture[{10, 10}, DisplayFunction -> Identity] /.  
      Line[l_] :> With[{n = Length[l]}, 
           MapIndexed[{Hue[#2[[1]]/n], Line[#1]}&, Partition[l, 2, 1]]],
           DisplayFunction -> $DisplayFunction]

Before discussing another algorithmically nontrivial operation for manipulating polynomials—namely, Decompose—we consider a method to rearrange an expression, if possible, into canonical polynomial form. PolynomialQ[polynomial, var] (we know this command from Chapter 5 of the Programming volume [1559✶] of the GuideBooks) tests whether polynomial is a polynomial in var. Be aware that PolynomialQ is a purely structural operation. While the expression ((cos^2)(1)+(sin^2)(1)-1) (x^x)+2 (x^2)-1 is mathematically a polynomial, structurally it is not. As a function ending with Q, PolynomialQ has to return True of False and cannot stay unevaluated. But it is always possible to construct terms of the form hiddenZero nonPolynomialPart so that it is algorithmically undecidable hiddenZero is zero (Richardson theorem [1334✶], [1336✶], [1337✶], [400✶]). This means to guarantee that PolynomialQ is not doomed to give wrong results sometimes, it must be a purely structural function.

PolynomialQ[(Sin[1]^2 + Cos[1]^2 - 1) x^x + 2 x^2 - 1, x]

PolynomialQ[polynomial] tests if polynomial can be considered as a polynomial in at least one variable. Using Collect, we can now write an expression as an explicit polynomial in given variables.

Here we again use our previous polynomial.

polyInxInyInz = (1 - x)^3 (3 + y - 2x)^2 (z^2 + 8y)^2;

Here is this expression as a polynomial in x.

Collect[polyInxInyInz, x]

The result of Collect depends on the form of its input. Collect will not expand or factor the resulting coefficients by default.

Collect[Expand[polyInxInyInz], x]

Using the optional third argument of Collect, we can bring the coefficients to a canonical form.

Collect[Expand[polyInxInyInz], x, Factor]

Note that the individual terms are not strictly ordered; in particular, not all terms (∝(x^0)) appear one after the other. This is a consequence of the Flat and Orderless attributes of Plus and the canonical order. 
Here is the same expression as a polynomial in y.

Collect[polyInxInyInz, y]

Here it is again as a polynomial in z.

Collect[polyInxInyInz, z]

Using as the second argument in Collect the list {x, y} results in a polynomial in x, whose coefficients are polynomials in y, whose coefficients are polynomials in z.

Collect[polyInxInyInz, {x, y}]

Here we apply the function C to each of the coefficients in z.

Collect[polyInxInyInz, {x, y}, C]

The second argument in Collect need not be an atomic expression, and thus the following expression will be written as a polynomial over co[x].

Collect[Expand[(co[x] + 4 si[z] + 5 co[x]^3)^4], co[x]]

Collect only reorders. It does not carry out any “content-dependent manipulations”. It only looks at the syntactical structure of expressions. (This means that in the following example, Cos[x]^2 is not rewritten as 1 - Sin[x]^2.)

Collect[Sin[x]^2 + (Cos[x]^2 + Sin[x]^2)^3 + 3 Sin[x]^3 + 7,
        Sin[x]]

Given an expression in several variables, we can use Variables to identify in which variables the expression is a polynomial.

For the above polyInxInyInz, we get the expected result.

Variables[polyInxInyInz]

The following expression is a polynomial in x and y, but not in z.

Variables[x^2 + 7 y + 5 z + Log[z]]

The “variables” do not necessarily have to be atomic objects with head Symbol.

Variables[Cos[x]^3 + Sin[y]^2 + Cos[x] Sin[y]]

The following expression is only a polynomial (of the trivial form "poly"(x)=x) “in itself”.

Variables[Cos[x^2 + 7 y + 5 z + Sqrt[z]]]

Variables does not pay attention to internal algebraic structures.

Variables[f[Sqrt[z]] + f[z^(1/3)]^2 + Log[z^2]]

Variables uses a very “general” definition for a polynomial; it also considers Laurent and Puiseux polynomials, this means the terms can have the form (var^negativeIntegerOrRational).

Variables /@ {Sqrt[z] + 1, z^(1/3) + 1, z^-4 + 1, 
              z^(1/3) + z^(-2/3) + 3, z^Pi + 1}

Be aware that Variables’s interpretation of a polynomial does not agree with the one of PolynomialQ.

PolynomialQ[#, z]& /@ {Sqrt[z] + 1, z^(1/3) + 1, z^-4 + 1, z^Pi + 1}

The degree of a polynomial (i.e., the largest exponent) can be obtained using Exponent.

Here is a polynomial of twelfth degree in x.

Exponent[(3 + 4 x + 5 x^4)^3, x]

Be aware that Exponent is in most situations a purely structural operation. For expanded polynomials Exponent does not determine the “mathematical” degree of a polynomial, but rather finds the exponent of the highest power of var present in an expression.

α0 = (Pi + 1)^2 - (Pi^2 + 2Pi + 1);
Exponent[α0 x^2 + x + 1, x]

Exponent[(Sin[α]^2 + Cos[α]^2 - 1) x^2 + x + 1, x]

If the polynomial is not expanded, Exponent will partially carry out nonstructural operations.

Exponent[(x + 1)^2 - x^2 - x - 1, x]

Exponent[(α0 x + 1)^2 - α0 x^2 - x - 1, x]

Exponent[(α0 x + 1)^2 - (α0 x)^2 - x - 1, x]

For large polynomials with many terms, usually not all powers of the various variables occur (in fact, usually only a very small fraction of all possibilities is present). To find the powers that are involved, we use Coefficient.

For typical cases, the result is obvious.

Coefficient[12 x^3 + 23 x^2 + 45 x + 56, x]

In other cases, it may not be so obvious. In the following Coefficient uses a very liberal interpretation of a polynomial power.

Coefficient[x^Pi, x, Pi]

Using a list in the second argument of Coefficient results in a list of the corresponding coefficients.

Coefficient[polyInxInyInz, {x, y, z}]

For polynomials in several variables (or for getting all coefficients in a univariate polynomial at once), we have the corresponding command CoefficientList.

Thus, CoefficientList finds a list of all coefficients appearing in the polynomial. Here is a list of the coefficients for a polynomial in one variable.

CoefficientList[Sum[i x^i, {i, 0, 12}], {x}]

For several variables, we get a list whose dimension is the number of variables. For the following polynomial in x and y, we get a 4×4 matrix.

polyxy = 𝕒 + 𝕓 x + 𝕔 y + 𝕕 x^2 + 𝕖 x y + 𝕗 y^2 +
         𝕘 x^3 + 𝕙 x^2 y + 𝕚 x y^2 + 𝕛 y^3

CoefficientList[polyxy, {x, y}]

We can implement the above definition to get the following program. (In this code, we first look for all structures with powers of the form x^i y^j, and then separate out the x and y.)

Table[
 Which[i == 0 && j == 0, (* the constant term *)
       Cases[polyxy, _?(FreeQ[#, x] && FreeQ[#, y]&)],
       True, (* the coefficient of x^i y^j *)
       Cases[polyxy, _?(FreeQ[#, x] && FreeQ[#, y]&) x^i y^j |
                        x^i y^j]/(x^i y^j)],
       (* the exponents *)
       {i, 0, Exponent[polyxy, x]}, {j, 0, Exponent[polyxy, y]}] //.
                   {{} -> 0, {coeff_} -> coeff} //.
               (* all zero lists become empty lists *) {(0)..} -> {}

Be aware that the result of CoefficientList[poly, varList] is always a rectangular array. For sparse polynomials of high degree, one will typically encounter many 0’s in the result. Here is a typical example.

CoefficientList[x^8 + y^6 - 7x - y, {x, y}]

Given the result of CoefficientList, it is straightforward to reconstruct the original polynomial. We just map the corresponding power product of the variables to the position of the coefficient and sum all terms. Here, this is done for the polynomial polyInxInyInz used above.

𝒸ℓ = CoefficientList[polyInxInyInz, {x, y, z}]

Implementing a function fromCoefficientList that converts from a nested list of coefficients to a polynomials is straightforward.

fromCoefficientList[cl_, vars_] := Plus @@ 
  Flatten[MapIndexed[#1 Times @@ (vars^(#2 - 1))&, cl, {3}]]

Expand[fromCoefficientList[𝒸ℓ, {x, y, z}] - polyInxInyInz]

For sparse multivariate high-degree polynomials, CoefficientList is a very inefficient way to access the coefficients. To get the coefficients of such polynomials efficiently, we recommend the internal function Internal`DistributedTermsList. Internal`DistributedTermsList[multivariatePolynomial, listOfVariables, options] returns a list of the form {{{(Subscript[listOfExponentsInVariables, 1]), (Subscript[coefficient, 1])}, …, {(Subscript[listOfExponentsInVariables, n]), (Subscript[coefficient, n])}}, listOfVariables} where n is the number of terms in the polynomial multivariatePolynomial collected with respect to the variables listOfVariables. Here is a simple example.

Internal`DistributedTermsList[x^12 + 2 y^22 - 3 αβγ x^10 y^20, {x, y}]

To recover the original polynomial, we can use the function Internal`FromDistributedTermsList.

Internal`FromDistributedTermsList[%]

Be aware that, in distinction to CoefficientList, the function Internal`DistributedTermsList returns also the original list of variables. The function Internal`DistributedTermsList has many Gröbner basis-like options (to be discussed in the next subsection).

Options[Internal`DistributedTermsList]

We will not discuss all of these options here. Their behavior is similar to the ones of other polynomial functions with the same options. The MonomialOrder order option, for instance, determines the order of the {(Subscript[listOfExponentsInVariables, k]), (Subscript[coefficient, k])}-sublists. In the next subsection we will discuss most of these options.

Internal`DistributedTermsList[
         x^12 + 2 y^22 - 3 αβγ x^10 y^20, {x, y},
         MonomialOrder -> DegreeReverseLexicographic]

In addition to the command Factor discussed earlier, another important function exists that can be used to simplify a polynomial. Whereas Collect, Exponent, Coefficient and CoefficientList perform mainly structural operations, the following command carries out nontrivial calculations.

To illustrate, we first create a “decomposable” polynomial.

Expand[Expand[(2x + 3)^2] /. {x -> (3x^2 + 5)^3}]

Now, we take it apart using Decompose.

dcp = Decompose[%, x]

Here is a check.

(Composition @@ (* nest the polys *)
   (Function[x, #]& (* make Function from polys *)/@
        Drop[dcp, -1]))[Last[dcp]] // Expand

The last example shows that the result of Decompose is not unique.

1.2.2 Polynomials in Equations

In this subsection, we will discuss various algebraic operations for sets of polynomials equated to zero. The most important functions of this kind are Resultant and GroebnerBasis. We will not discuss the intimately related subject of solving systems of polynomials (we will deal with this subject together with solving nonpolynomial equations when discussing the function Solve in the next section).
We start with discussing two other functions for direct manipulation of pairs of polynomials. They are important functions for algorithmic work on polynomials.

We give just one simple example PolynomialQuotient. For the following example, the answer is obvious.

Factor[PolynomialQuotient[
  Expand[(3 + 5 x^3 + 8 x^7)^6 (4 x^3 + 8 x^6)], (4 x^3 + 8 x^6), x]]

Some additional commands are useful for manipulating pairs of polynomials. These include PolynomialGCD, PolynomialLCM, and PolynomialMod. Because these are of lesser importance in scientific and technical applications (they are more important in number theory and pure algebra), we do not discuss them here.

The next, more advanced command to be discussed in this subsection is the resultant. Given two polynomials (Subscript[p, 1])(z) and (Subscript[p, 2])(z) (which might via their coefficients (Subscript[a, i]) and (Subscript[b, i]) also depend on further, not explicitly shown variables)

(Subscript[p, 1])(z)=(∑_(i=0)^n)(Subscript[a, i])(z^i)=(∏_(i=0)^n)(z-(Subscript[α, i]))        (Subscript[p, 2])(z)=(∑_(i=0)^m)(Subscript[b, i])(z^i)=(∏_(i=0)^m)(z-(Subscript[β, i]))

the resultant r((Subscript[a, 1]),… (Subscript[a, n]);(Subscript[b, 1]),…,(Subscript[b, m])) of (Subscript[p, 1])(z) and (Subscript[p, 2])(z) is given by

r=(Subscript[a, n]^m)(∏_(i=0)^n)(Subscript[p, 2])((Subscript[α, i]))=(((-1))^("mn"))(Subscript[b, m]^n)(∏_(i=0)^m)(Subscript[p, 1])((Subscript[β, i]))=(Subscript[a, n]^m)(Subscript[b, m]^n)(∏_(i=0)^n)(∏_(j=0)^n)((Subscript[α, i])-(Subscript[β, j])).

The resultant of two polynomials is an integral polynomial of their coefficients.
For nice reviews concerning properties and representations of the resultant, see, for instance, [637✶], [311✶], [1507✶], [1067✶], [399✶], [1644✶], [157✶], [258✶], [345✶], and [1645✶].
The Mathematica form for the resultant is Resultant.

One important application of the resultant is the elimination of one variable from a system of two polynomial equations. As an example, let the two polynomials (Subscript[p, 1])(z)=0 and (Subscript[p, 2])(z)=0 both depend (in a polynomial manner) on the variable a.

poly1[z_, a_] = Product[z - i a, {i, 1, 7, 2}] + 2

poly2[z_, a_] = Product[z - i a, {i, 0, 6, 2}] + 3

Then we can eliminate the variable z to get only one polynomial equation (which is, of course, much easier to solve) in the variable a.

Resultant[poly1[z, a], poly2[z, a], z]

We, of course, could have also eliminated the variable a via Resultant[poly1[z, a], poly2[z, a], a].
This is the numerical solution of the above polynomial in a.

aZeros = Chop[Last /@ (List @@ NRoots[% == 0, a])]

Because of the above formulas, these solutions are also solutions of (Subscript[p, 1])(z)=0 and (Subscript[p, 2])(z)=0 (or the highest coefficients (Subscript[a, n]) or (Subscript[b, n]) vanish for these roots). Plugging each root for a into the two polynomials and finding the root with respect to z that is the same for both polynomials will give all possible solutions. This is a first possibility to solve pairs of polynomial equations.

Sort @ Table[{a -> aZeros[[i]], z -> Flatten[
Outer[If[(* which are the same? *)
         Chop[#1 - #2] === 0, Chop[#1], {}]&,
          (* the zeros of poly1 with respect to z *)
         Last /@ List @@ NRoots[poly1[z, aZeros[[i]]] == 0, z],
          (* the zeros of poly2 with respect to z *)
         Last /@ List @@ NRoots[poly2[z, aZeros[[i]]] == 0, z]]][[1]]}, 
            {i, Length[aZeros]}]

A check in the original polynomials shows this.

Chop[{poly1[z, a], poly2[z, a]} /. %]

A comparison with the corresponding result of NSolve also confirms this.

Chop[NSolve[{poly1[z, a] == 0, poly2[z, a] == 0}, {z, a}]]

An interesting representation of the resultant of two polynomials, due to Sylvester [29✶], is given by the determinant of the following square matrix.

MatrixALaSylvester[poly1_, poly2_, var_] :=
Function[{coeffs1, coeffs2},
With[{l1 = Length[coeffs1], l2 = Length[coeffs2]},
Join[Table[Join[Table[0, {j}], coeffs1,
                Table[0, {l2 - 2 - j}]], {j, 0, l2 - 2}],
     Table[Join[Table[0, {j}], coeffs2,
                Table[0, {l1 - 2 - j}]], {j, 0, l1 - 2}]]]][
   (* the coefficients of the two polynomials *)             
   Reverse[CoefficientList[poly1, var]],
   Reverse[CoefficientList[poly2, var]]]

Here, this representation is checked for the resultant of two degree 3 polynomials.

MatrixALaSylvester[a0 + a1 x + a2 x^2 + a3 x^3,
                   b0 + b1 x + b2 x^2 + b3 x^3, x] // TableForm

Det[%]

The last determinant agrees with the result from Resultant.

Resultant[a0 + a1 x + a2 x^2 + a3 x^3,  
          b0 + b1 x + b2 x^2 + b3 x^3, x] === %

(For similar determinant-based representations of eliminating n variables from n+1 polynomial equations, see [390✶]).
As an application of the use of the Resultant function, let us derive a nonlinear third-order differential equation for the function EllipticNomeQ.

?EllipticNomeQ

This function q(m) is an important function within the theory of elliptic functions (see Chapter 3) and theta functions. It can be expressed through complete elliptic integrals in the following manner:

q(m)=exp(-π (( K(1-m))/(K(m)))),

where K(m) is the complete elliptic integral of the first kind (see Chapter 3).
We observe that the derivatives of the elliptic integrals of first and second kind can be expressed rationally through K(m) and E(m). The elliptic integrals K(m) and E(m) are in Mathematica defined as EllipticK[m] and EllipticE[m].

{D[EllipticK[m], m], D[EllipticE[m], m]}

We can differentiate q(m) repeatedly and eliminate all occurrences of K(m), K(1-m), E(m), and E(1-m) to obtain a polynomial in the first four derivatives of q(m) and m. Taking into account the so-called Legendre relation (see Chapter 1 of the Programming volume [1559✶] of the GuideBooks)

E(m) K(1-m)+E(1-m) K(m)-K(1-m) K(m)=π/2

allows us to derive a differential equation of order three [148✶]. We will derive this differential equation now.

legendreRelation =
  EllipticK[1 - m] EllipticE[m] + EllipticE[1 - m] EllipticK[m] - 
  EllipticK[m] EllipticK[1 - m] - Pi/2;

This is the set of equations obtained by differentiating q(m) three times. For shorter, more readable output, we use abbreviations for the three functions EllipticNomeQ, EllipticK, and EllipticE.

eqs = Table[Factor[Numerator[Together[
            D[q[m] - EllipticNomeQ[m], {m, i}]]]], {i, 3}] /.
             {EllipticNomeQ -> q, EllipticK -> 𝒦, EllipticE -> ℰ}

To eliminate the four functions K(m), K(1-m), E(m), and E(1-m), we start with the Legendre relation. It is linear in each of the four functions. So we solve, say, for E(m) and substitute the result in eqs.

sol1 = Solve[legendreRelation == 0, EllipticE[m]] /.
             {EllipticNomeQ -> q, EllipticK -> 𝒦, EllipticE -> ℰ}

eqs1 = Factor[Numerator[Together[eqs /. sol1[[1]]]]]

The second of the resulting equations is linear in E(1-m) and K(1-m).

Exponent[#, {𝒦[m], ℰ[1 - m], 𝒦[1 - m]}]& /@ eqs1

Solving the second equation for E(1-m) and substituting the result in the first and third equations gives the following two polynomials.

sol2 = Solve[eqs1[[2]] == 0, ℰ[1 - m]] /.
             {EllipticNomeQ -> q, EllipticK -> 𝒦, EllipticE -> ℰ}

eqs2 = Factor[Numerator[Together[Delete[eqs1, 2] /. sol2[[1]]]]]

Now, the first of the resulting equations just contains K(m) and the second equation contains a nontrivial factor containing only K(m).

eqs3 = {eqs2[[1]], eqs2[[2, -1]]}

Because both polynomials contain only even powers of K(m) and we want to eliminate K(m) anyway, we can reduce the degree with respect to K(m) by introducing a new variable 𝒦2[m].

eqs4 = eqs3 /. 𝒦[m]^n_ -> 𝒦2[m]^(n/2)

To eliminate 𝒦2[m], we finally use the function Resultant.

res = Factor[Resultant[##, 𝒦2[m]]& @@ eqs4]

The last term of res is the nontrivial one that is the differential equation we were looking for. (When carrying out repeated substitutions and resultant formations it happens frequently that the result will contain the “wanted” term, as well as other ones.)

(Simplify[res[[-1]]]) // TraditionalForm

ellipticNomeQODE = %;

Using the function Together (to be discussed in the next section), we succeed also symbolically in proving that the function EllipticNomeQ[m] is indeed a solution of the derived differential equation.

Together[ellipticNomeQODE /. q -> EllipticNomeQ]

Now we come to probably the most important command of this chapter. GroebnerBasis has major applications to Solve, NSolve, etc.

We do not give a precise definition of a Gröbner basis here; see the excellent treatments in [236✶], [375✶], [15✶], [983✶], [602✶], [234✶], [376✶], [27✶], [233✶], [780✶], [1149✶], [120✶], [893✶], [690✶], [1037✶], and [510✶], and for a short introduction, see [705✶], [1184✶], [1024✶], and [746✶]. However, roughly speaking, a Gröbner basis for a set of polynomials is a set of “simpler” polynomials with the same common zeros as the original polynomial.

Gröbner bases [1326✶], [181✶] play an important role in various applications, such as robotics [1490✶], [1376✶], [715✶], [978✶], [61✶], [976✶], [880✶], [375✶], and [270✶]; automatic geometric theorem proving [623✶], [1680✶], [1630✶], [323✶], [1681✶], [1629✶], [894✶], [891✶], [1555✶], [622✶], [324✶], [1466✶], [795✶], [326✶], [1656✶], and [994✶]; generating implicit representations of parametric curves and surfaces [1429✶], [1206✶], [872✶] and [1428✶]; in signal processing [1113✶]; and many more fields such as coding theory, Petri nets [294✶], computational group theory [466✶] and integer programming [362✶]. 
Because of its importance we will give a longer than usual list of examples in the following.
Here is a simple example for the following starting polynomials.

eqs = {x^2 + 3 x + 4 y, 2 y^2 + 4 x + 5 y + 9}

These are the numerical solutions of eqs.

NSolve[{eqs[[1]] == 0, eqs[[2]] == 0}, {x, y}]

The polynomials computed by GroebnerBasis are not always shorter, but they have the same zeros, and in sequence, each of them depends on just one more variable than its predecessor in the list of polynomials (pseudotriangular form). (This form of a Gröbner basis, called a lexicographic Gröbner basis, is the default form generated by Mathematica. Other bases can be calculated too, see the option MonomialOrder below.)

GroebnerBasis[eqs, {x, y}]

NSolve[{%[[1]] == 0, %[[2]] == 0}, {x, y}]

We give another example, this time with a plot. Given the three polynomial expressions (x^2)+(y^2)-1, (x^2)+(z^2)-1, and (y^2)+(z^2)-1, their Gröbner basis is the following.

GroebnerBasis[{x^2 + y^2 - 1, x^2 + z^2 - 1, y^2 + z^2 - 1}, {x, y, z}]

The three polynomials produced by GroebnerBasis have the same zeros and are clearly simpler (in this example, also shorter). In this case, the set of zeros of the three polynomials can easily be plotted: They are the intersections of three cylinders surrounding the coordinate axes at {±(2^(-1/2)),±(2^(-1/2)),±(2^(-1/2))}. In the following graphic, we display the three cylinders and mark the intersection points with little cubes.

(* cylinders parallel to the coordinate system axis *)
{cylinderX, cylinderY, cylinderZ} =
Cases[ParametricPlot3D[#, {φ, 0, 2Pi}, {t, -2, 2},
                       DisplayFunction -> Identity], _Polygon, Infinity]& /@
    {{t, Cos[φ], Sin[φ]}, {Cos[φ], t, Sin[φ]}, {Cos[φ], Sin[φ], t}};

(* display all three cylinders *)
Show[Graphics3D[{
     {EdgeForm[], Thickness[0.002],
     {SurfaceColor[RGBColor[1, 0, 0]], cylinderX},
     {SurfaceColor[RGBColor[0, 1, 0]], cylinderY},
     {SurfaceColor[RGBColor[0, 0, 1]], cylinderZ}} /.
Polygon[l_] :> (* making holes in cylinder polygons *)
Module[{mp = Plus @@ l/Length[l]},
        ℓ = (mp + 0.8(# - mp))& /@ l;
       {MapThread[Polygon[Join[#1, Reverse[#2]]]&, 
         Partition[Append[#, First[#]], 2, 1]& /@ {l, ℓ}]}],
       (* the intersection points as cubes *)
       {SurfaceColor[GrayLevel[0]], 
        Cuboid[# - 0.1 {1, 1, 1}, # + 0.1 {1, 1, 1}]& /@ 
        (* intersection points of the three cylinders *)
                ({x, y, z} /. NSolve[{x^2 + y^2 - 1 == 0,
                                      x^2 + z^2 - 1 == 0,
                                      y^2 + z^2 - 1 == 0},
                                     {x, y, z}])}}],
      DisplayFunction -> $DisplayFunction, PlotRange -> All]

The Gröbner basis of an inconsistent polynomial system (this means the solution set is empty) is {1}.

GroebnerBasis[{x, x + 1, x - 1}, {x}]

GroebnerBasis has the following options.

Options[GroebnerBasis]

(For symmetric configurations of more cylinders, see [56✶].)
We will discuss most of these options; for more details, see [1039✶].

The coefficient domain influences the form of a Gröbner basis.

GroebnerBasis[{x^2 - a y, y x - x^3 + a^3}, {x, y}, 
              CoefficientDomain -> RationalFunctions] // Expand

GroebnerBasis[{x^2 - a y, y x - x^3 + a^3}, {x, y},
              CoefficientDomain -> Rationals] // Expand

In the last example the variable a could be considered as a parameter. The option ParameterVariables allows to explicitly specify such parameters.

Here we repeat the last example and specify a as a parameter.

GroebnerBasis[{x^2 - a y, y x - x^3 + a^3}, {x, y},
              CoefficientDomain -> Rationals,
              ParameterVariables -> {a}] // Expand

Again, both Gröbner bases have the same zeros with respect to x and y.

Solve[# == 0& /@ %, {x, y}]

Solve[# == 0& /@ %%%, {x, y}]

Although in most cases a lexicographic basis will be the most useful one, it is at the same time in most cases the most difficult to compute. Here is a system of three equations in three variables.

eqs = {2 x^4 y + y^3 x^3 - x z^2 + 1, 
       x^2 + y^2 z^3 - 1, 
       x^2 y - 7 y^3 z^2 + y^2 z^3};

Calculating a lexicographic Gröbner basis takes less than 5 s on a 2 GHz computer.

(gb = GroebnerBasis[eqs, {x, y, z}]); // Timing

gb contains three quite complicated polynomials. The first is a univariate polynomial of degree 44 and the largest integer that occurs has 251 digits.

Exponent[#, {x, y, z}] & /@ gb

{Length /@ gb, {#, N[#]}& @ Max[Abs[Cases[gb, _Integer, Infinity]]]}

Because of the large amount of calculations containing polynomials with large integer coefficients required in intermediate steps, calculating an exact Gröbner bases is an expensive process. Calculating a Gröbner basis with approximative numbers instead of with exact numbers is often much faster.

(gbN = GroebnerBasis[N[eqs, 300], {x, y, z}, 
                     CoefficientDomain -> InexactNumbers]); // Timing

We can avoid the explicit numericalization and let Mathematica do the work. The InexactNumbers option setting can have an argument that specifies the precision to be used.

gbN == GroebnerBasis[eqs, {x, y, z}, 
                     CoefficientDomain -> InexactNumbers[300]]

gbN has the same shape as gb.

Exponent[#, {x, y, z}] & /@ gbN

Actually, gbN is a very good numerical approximation of gb.

gb[[1]]/Coefficient[gb[[1]], z, 44] -
gbN[[1]]/Coefficient[gbN[[1]], z, 44] // 
             CoefficientList[#, z]& // Abs // Min

In calculating a Gröbner basis with the option setting CoefficientDomain -> InexactNumbers, it is important that the input equations have approximative numbers of high enough precision. Using only 200 digits instead of 300 results in a failure to calculate a Gröbner basis. (This is not unexpected; the largest numbers in the exact Gröbner basis had about 250 digits.)

(gbN = GroebnerBasis[N[eqs, 200], {x, y, z}, 
                     CoefficientDomain -> InexactNumbers]); // Timing

When the coefficient domain of a Gröbner basis calculation is Rationals, often very large integers appear in the result and even larger integers are generated in intermediate stages of the calculation. Frequently the arithmetic of these large integers dominates the whole calculation time. Often, for instance when one is interested only in the shape of a Gröbner basis or when one attempts to show that a Gröbner basis is empty it is sufficient to work over a smaller field than the integers. The option Modulus deals with this situation.

We again calculate the lexicographic basis for the set of polynomials eqs. But this time we treat all coefficients modulo 541. Calculating the Gröbner basis is now about 25 times faster and yields a Gröbner basis of the same shape as above.

(gb = GroebnerBasis[eqs, {x, y, z}, Modulus -> Prime[100]]); // Timing

Exponent[#, {x, y, z}] & /@ gb

Until now, we calculated only lexicographic Gröbner bases. The option influencing the kind of Gröbner basis calculated is MonomialOrder.

We do not go into the details of term orderings here (see the above-mentioned references). A rough guide is the following: For solving polynomial systems (this means bringing them into [pseudo]triangular form), ones use the setting MonomialOrder -> Lexicographic. In the following example, the resulting basis contains one polynomial in z. It is easy to solve this univariate polynomial and substitute the solutions in the second polynomial to obtain a new univariate polynomial in y, which can be easily solved for, ….

GroebnerBasis[{x + y + z, x - 2 y + z^3, x^2 - 2y^3 + z}, {x, y, z}]

Reverting the order of the variables gives now one univariate polynomial in x.

GroebnerBasis[{x + y + z, x - 2 y + z^3, x^2 - 2 y^3 + z}, {z, y, x}]

Calculating a Gröbner basis is typically a very time-consuming process for larger polynomial systems. In most cases, the calculation using the term order MonomialOrder -> DegreeReverseLexicographic is the fastest. Here is a typical example.

Timing[(gbLex = 
        GroebnerBasis[{x^4 + y + z, x - 2 y^3 + 5 z^3, 
                       x^2 - 7 y^3 + z^4}, {z, y, x}, 
                      MonomialOrder -> Lexicographic]);]

Timing[(gbDegRevLex = 
        GroebnerBasis[{x^4 + y + z, x - 2 y^3 + 5 z^3, 
                       x^2 - 7 y^3 + z^4}, {z, y, x}, 
                      MonomialOrder -> DegreeReverseLexicographic]);]

Both Gröbner bases have four elements.

Map[Length, {gbLex, gbDegRevLex}]

But the one calculated with the option setting DegreeReverseLexicographic has many fewer terms and a much lower degree.

Map[Length, {gbLex, gbDegRevLex}, {2}]

(Exponent[#, {x, y, z}]& /@ #)& /@ {gbLex, gbDegRevLex}

The monomial ordering DegreeReverseLexicographic often results in the smallest runtime for GroebnerBasis. The DegreeReverseLexicographic is not directly useful for equation solving (in some exercises we will use it as starting systems for a Gröbner walk). But it is very useful for detecting an inconsistent system of equations. The next input shows that there are no 1 to 12-dimensional representations of the canonical commutation relations (OverHat[p])(OverHat[q])-(OverHat[q])(OverHat[p])=id [728✶], [1513✶], [614✶], [652✶]. Be aware that despite the fact that the last of the following Gröbner basis calculations contains 288 variables, the calculation is carried out quickly.

Module[{𝓅, 𝓆}, 
 Table[With[{p = Array[𝓅, {d, d}], q = Array[𝓆, {d, d}]},
    GroebnerBasis[Flatten[(* CCR *) p.q - q.p - IdentityMatrix[d]], 
              MonomialOrder -> DegreeReverseLexicographic]],
             {d, 1, 12}]] // Timing

Using an additional variable 𝕥, we can deal with the situation (OverHat[p])(OverHat[q])-(OverHat[q])(OverHat[p])=𝒸 id. The equation 1 - 𝒸 𝕥 does not allow 𝒸 to take the value 0.

Module[{𝓅, 𝓆, 𝒸, 𝕥}, 
 Table[With[{p = Array[𝓅, {d, d}], q = Array[𝓆, {d, d}]},
    GroebnerBasis[Flatten[{(* CCR *) p.q - q.p - 𝒸 IdentityMatrix[d],
                           (* 𝒸 != 0 *) 1 - 𝒸 𝕥}], 
              MonomialOrder -> DegreeReverseLexicographic]],
             {d, 1, 12}]] // Timing

As the last result suggests, there are no finite-dimensional representations of the canonical commutation relations [1407✶], [215✶], [1618✶], [476✶], [1267✶], [484✶], [1321✶], [419✶], [1512✶], [1302✶]. For another application of the term order DegreeReverseLexicographic, see below.

Finally, for eliminating variables, the term order MonomialOrder -> EliminationOrder is often the most appropriate one. Here, the parametrically defined surface {x,y,z}={s (t^2), (s^2)-(t^2),(s^3)-t} transformed into an implicit polynomial of the form p(x,y,z)=0.

GroebnerBasis[{x - s t^2 + s, y - s^2 + t^2, z - s^3 + t}, 
              {z, y, x}, {s, t}, MonomialOrder -> EliminationOrder]

Here is a more complicated implicization problem. This is the parametrization of a surface [64✶], [65✶], [1547✶].

𝓅[θ_, τ_] := 1/(1 + τ^2 - τ (Sin[2θ] - Cos[2θ]))*
     {(1 + 2τ) Cos[θ]/Sqrt[3], (1 - 2τ) Sin[θ]/Sqrt[3], 1};

The parameters belong to the domains θ∈[0,2π], τ∈(-∞,∞).

Show[GraphicsArray[{#, (* show fixed z-range layer *)
Append[#, PlotRange -> {All, All, {0, 1}}]}]]& @
Graphics3D[{EdgeForm[], SurfaceColor[Hue[0.25], Hue[0.12], 2.8],
 Cases[ParametricPlot3D[Evaluate[
 𝓅[θ, τ] /. (* change parametrization *) τ -> Tan[𝓉]],
   {θ, 0, 2Pi}, {𝓉, -Pi/2, Pi/2}, PlotPoints -> 80,
 DisplayFunction -> Identity], _Polygon, Infinity] /.
 (* make diamonds *) Polygon[l_] :> Polygon[Plus @@@ Partition[
     Append[l, First[l]], 2, 1]/2]}, Boxed -> False]

To generate an implicit form of this surface, we transform the rational expression to a polynomial one, express cos(2θ) and sin(2θ) in cos(θ) and sin(θ) and supplement with the equation ((sin(θ))^2)+((cos(θ))^2)-1 [718✶].

GroebnerBasis[Append[TrigExpand[
     Numerator[Together[{x, y, z} - 𝓅[θ, τ]]]], Cos[θ]^2 + Sin[θ]^2 - 1], 
              {x, y, z}, {τ, Cos[θ], Sin[θ]},
              MonomialOrder -> EliminationOrder]

Substituting the original parametrization shows the correctness of the last polynomial.

(% /. Thread[{x, y, z} -> 𝓅[θ, τ]]) // Simplify

Often one wants to solve a system of polynomials under the conditions that other polynomials do not vanish. Adding equations of the form 1-Z q((Subscript[x, 1]),…,(Subscript[x, n])) to the first set of polynomials ensures that  q((Subscript[x, 1]),…,(Subscript[x, n])) will not vanish. Then one can use GroebnerBasis[equations, {…}, {Z}, MonomialOrder -> EliminationOrder] to eliminate the variable Z. The solutions of the resulting polynomials will then make  q((Subscript[x, 1]),…,(Subscript[x, n])) nonvanishing generically (on lower dimensional solution sets  q((Subscript[x, 1]),…,(Subscript[x, n])) might vanish).

Next, we will use GroebnerBasis for a little geometry problem: Under which conditions are four points of an ellipse lying on a circle [140✶]? We use a rational parametrization for the ellipse. After writing all expressions over a common denominator the rational functions will give polynomials and we can apply GroebnerBasis. {X, Y} is the midpoint of the circle, and r is its radius. So we have the following set of equations. (s[i] stands for tan((Subscript[t, i])/2). The use of this parametrization is often of advantage compared with the use of cos((Subscript[t, i])) and sin((Subscript[t, i])) together with the equation (cos^2)((Subscript[t, i]))+(sin^2)((Subscript[t, i]))-1 because it reduces the number of variables.)

Table[Function[{x, y}, (x - X)^2 + (y - Y)^2 - r^2] @@ 
    ({a Cos[t], b Sin[t]} /. {Cos[t] -> (1 - s[i]^2)/(1 + s[i]^2), 
                              Sin[t] -> 2 s[i]/(1 + s[i]^2)}), {i, 4}]

To get a condition on the s[i], we form polynomials (by clearing denominators) and eliminate the midpoint and radius variables of the circle.

GroebnerBasis[Numerator[Together[%]],
              {s[1], s[2], s[3], s[4], a, b}, {X, Y, r},
              MonomialOrder -> EliminationOrder] // Factor

The last result shows the degenerate case that four points lie on a circle in case the ellipse degenerates to a circle or two of the four points coincide (the six factors s[i] - s[j]). The last factor, symmetric in the s[i], is the nontrivial condition we were looking for.

Table[{(a Cos[t[i]] - X)^2 + (b Sin[t[i]] - Y)^2 - r^2,
       Cos[t[i]]^2 + Sin[t[i]]^2 - 1}, {i, 4}]

Here is another application of the GroebnerBasis command. Let us calculate all square roots of the following matrix:

A=(({{1, 2, 3}, {4, 5, 6}, {7, 8, 9}})).

This is the matrix A to be “square rooted”.

A = {{1, 2, 3}, {4, 5, 6}, {7, 8, 9}};

Let B be a square root of the matrix A.

B = Array[b, {3, 3}]

We set up all nine equations to be fulfilled by the elements of the matrix B.B and use GroebnerBasis to bring the equations to pseudotriangular form.

gb = GroebnerBasis[Flatten[A - B.B], Flatten[B]]

Solving the equations yields the following four solutions.

sols = Solve[# == 0& /@ gb, Flatten[B]] // Union;

Length[sols]

The solutions are relatively complicated. Here, we display the first one.

sols[[1]] // InputForm

Here is a quick check for the solutions.

A - B.B /. sols // Simplify

(While a matrix typically has many square roots, only one is often the “right” one [853✶]; for nice closed forms, see [1292✶].) 
As a more complicated example of the use of the function GroebnerBasis, we will deal with an application from quantum mechanics, and we will calculate some exact radial wave functions (Subscript[R, l])(r) for the three-dimensional (3D) potential V(r)=(c^2)(r^(-6))+(a^2) (r^2)+b (r^(-4)) in the radial Schrödinger equation

-(Subscript[R, l]^″)(r)+(V(r)+((l (l+1))/(r^2))) (Subscript[R, l])(r)=(Subscript[ε, l]) (Subscript[R, l])(r),

where l is a nonnegative integer [1729✶], [1619✶], [1729✶]. In [449✶], [451✶], [993✶], [905✶], and [1100✶] the following ansatz was proposed for the radial wave function:

(Subscript[R, l])(r)=(r^κ) (β (r^2)+α+((γ )/(r^2))) exp(-(1/2) (a (r^2)+((c )/(r^2)))).

α, β, γ, and κ are functions of a, b, c, and l. (For a more general ansatz, see [310✶], [1420✶], [454✶], and [1258✶].)
For brevity, we restrict ourselves in the following investigations to the search of nontrivial (Subscript[R, l])(r), meaning α≠0, β≠0, and γ≠0.
Here is the potential V(r) and the ansatz for the wave function (Subscript[R, l])(r).

Clear[a, b, c, r, V, R, α, β, γ, κ, ε, "eqs*", "gb*"]; 
V[r_] = a^2 r^2 + b r^-4 + c^2 r^-6;
R[l_][r_] = r^κ (α + β r^2 + γ r^-2) Exp[-(a r^2 + c r^-2)/2];

Substituting the ansatz in the radial Schrödinger equation yields the following expression.

SEquation = Factor[D[R[l][r], r, r] + (ε - V[r] - l(l + 1)/r^2) R[l][r]]

For the last expression to be zero and the radial wave functions (Subscript[R, l])(r) to be physically sensible, the sum in the last expression must vanish identically. This means the individual coefficients of r in the last sum must vanish identically. We equate all powers of r to zero and obtain the following system of nonlinear equations for α, β, γ, κ, and ε, a, b, and c are considered to be parameters, as is l.

eqs = Factor[CoefficientList[SEquation[[-1]], r]]

Because we are only interested in generic solutions (none of the α, β, γ vanishing), we eliminate the obvious degenerate solution γ=0, β=0.

eqs1 = MapAt[#/β&, MapAt[#/γ&, eqs, {1}], {-1}]

We start by calculating a full Gröbner basis.

gb1 = Factor[GroebnerBasis[eqs1, {α, β, γ, κ, ε},
                           ParameterVariables -> {a, b, c, l}]];

The resulting equations contain the variables α, β, γ, κ, ε, a, b, c, l in the following degrees.

Exponent[#, {α, β, γ, κ, ε, a, b, c, l}]& /@ gb1

As it turns out, gb1 still describes many degenerate solutions with γ=0.

Cases[gb1, γ _Plus, {1}] // Length

We can force generic solutions by adding an equation of the form α β γ z - 1=0, where z is an auxiliary variable to the equations eqs1 (for α β γ z =1 to hold, the variables α, β, and γ cannot vanish). We calculate the corresponding Gröbner basis. Because the auxiliary variable z is not needed later, we eliminate it.

gb2 = Factor[GroebnerBasis[Append[eqs1, α β γ z - 1], 
                           {α, β, γ, κ, ε, a, b, c, l}, {z}]];

Now, the equations have a more interesting form. The first equation is an equation in the parameters only. The second equation is a linear equation in the energy ε.

Exponent[#, {α, β, γ, κ, ε, a, b, c, l}]& /@ gb2

The next output is the condition on the parameters a, b, and c (and l) that is needed for nondegenerate solutions. It is a nontrivial condition not easily obtained by using only paper and pencil.

gb2[[1]]

The generic solution of the system of equations under consideration is the following form.

eqSol = Solve[# == 0& /@ gb2, {ε, κ, α, β, γ}]

In addition to the last result, the conditions on a, b, and c as expressed in gb[[1]] must be kept in mind. It is interesting to note that γ appears linearly on the right-hand side in the solutions for α and β. Let us establish a direct relation between the energy ε and the parameters a, b, and c (and l) by eliminating the variables α, β, γ, and κ from gb2.

gbε = Factor[GroebnerBasis[gb2, {ε}, {α, β, γ, κ}]];

Exponent[gbε, ε]

The last Gröbner basis has eight elements. If we eliminate one additional parameter, say, a, we obtain one equation in ε, b, and c.

Factor[GroebnerBasis[gbε, {ε}, {a}]]

In a similar way, we can eliminate the parameter b or c.

Factor[GroebnerBasis[gbε, {ε}, {b}]]

Factor[GroebnerBasis[gbε, {ε}, {c}]]

We could now proceed in a similar way for κ.

gbκ = Factor[GroebnerBasis[gb2, {κ}, {α, β, γ, ε}]];

Exponent[gbκ, κ]

Factor[GroebnerBasis[gbκ, {κ}, {a}]]

Factor[GroebnerBasis[gbκ, {κ}, {b}]]

Factor[GroebnerBasis[gbκ, {κ}, {c}]]

To make sure that the obtained solutions are physically sensible, we must require the above polynomial gb2[[1]] to have solutions for positive a, b, and c. Such solutions exist indeed, as shown by the following graphic for l=1. Additionally, the corresponding (r^κ) should not be too singular. This is the case for the above solutions. The right graphic shows this.

Needs["Graphics`ContourPlot3D`"]

cp3D = ContourPlot3D[Evaluate[gb2[[1]] /. l -> 1], 
                     {a, 0, 5}, {b, 0, 5}, {c, 0, 5},
                     DisplayFunction -> Identity,
	                 PlotPoints -> 22, MaxRecursion -> 0, Axes -> True];

Show[GraphicsArray[
{cp3D, ListPlot[Sort[Apply[(#2 + #3)/(2 #3)&,
      DeleteCases[Level[Cases[cp3D, _Polygon, Infinity], {-2}],
                  {_, _, _?(# == 0.&)}], {1}]],
                  DisplayFunction -> Identity]}]]

Here is an explicit quick check of the solutions for a=b=1, l=2. We calculate the possible values of c from gb2[[1]] and substitute all solutions in the original equation. We see that within the precision used, the result is 0.

With[{𝓇 = Sequence[a -> 1, b -> 1, l -> 2]},
With[{cs = Select[{ToRules[NRoots[(gb2[[1]] /. {𝓇}) == 0, c, 60]]},
     Im[c /. #] == 0&]}, SEquation[[-1]] /. (Flatten[Join[eqSol[[1]] /. 
                      {𝓇} /. #, {#, 𝓇}]]& /@ cs)]]

For the corresponding two-dimensional problem, see [450✶], [452✶], and [453✶]; for the one-dimensional problem, see [97✶], [408✶], and [1258✶]; and for the n-dimensional problem, see [1180✶], [455✶], and [672✶]; for the use of Gröbner bases to find exact states in larger dimensions, see [642✶].

Let us use the option setting MonomialOrder -> EliminationOrder for another small, but interesting example: What is the largest area a hexagon of unit diameter can have [687✶], [941✶]? Interestingly, the largest area is not the one of a regular hexagon. It can be shown that the hexagon we are looking for must have mirror symmetry and be of the following form. The black line indicates the unit diameters. Without loss of generality we can use the following parametrization of the hexagon.

Clear["x*", "y*"];
p1 = {0, 0}; p2 = { x2, y2}; p3 = { x3, y3};
p4 = {0, 1}; p5 = {-x3, y3}; p6 = {-x2, y2};

Block[{x2 = 0.5, y2 = 0.402, x3 = 0.343, y3 = 0.939},
      Show[Graphics[{{Hue[0], Thickness[0.01], 
                    (* outline *) Line[{p1, p2, p3, p4, p5, p6, p1}]},
                    {GrayLevel[0], Thickness[0.002],
                     (* diagonals *)
                     Line[{p1, p3}], Line[{p1, p5}],
                     Line[{p2, p5}], Line[{p3, p6}],
                     Line[{p1, p4}], Line[{p2, p5}]}}],
           PlotRange -> All, Frame -> True, AspectRatio -> Automatic]]

The above hexagon has four degrees of freedom, the coordinates of the points p2 and p3. It follows from elementary geometry that the area of the hexagon is given by (Subscript[x, 3])-(Subscript[x, 3])(Subscript[y, 2])+(Subscript[x, 2])(Subscript[y, 3]). We take the unit diameter conditions into account using Lagrange multipliers (Subscript[λ, 1]), (Subscript[λ, 2]), and (Subscript[λ, 3]).

area = x3 - x3 y2 + x2 y3;
L = area + λ1 (#.#&[p1 - p3] - 1) + λ2 (#.#&[p2 - p5] - 1) +
           λ3 (#.#&[p2 - p6] - 1);

To get the polynomial of the largest area area, we eliminate the coordinates and the Lagrange multipliers.

GroebnerBasis[
 {𝒶𝓇ℯ𝒶 - area, D[L, x2], D[L, y2], D[L, x3], D[L, y3],
               D[L, λ1], D[L, λ2], D[L, λ3]}, 
 {𝒶𝓇ℯ𝒶}, {x2, y2, x3, y3, λ1, λ2, λ3},
 MonomialOrder -> EliminationOrder] // Factor

The first root larger than the area of a regular hexagon is the one we are looking for. It is nearly 4% larger than the area of a regular hexagon.

Select[NSolve[%[[1]] == 0, 𝒶𝓇ℯ𝒶], Im[(𝒶𝓇ℯ𝒶 /. #)] == 0 && 
       (* larger than regular hexagon *) 
       3 Sqrt[3]/8 < (𝒶𝓇ℯ𝒶 /. #)&][[1]]

For the largest octagon, see [87✶].
The calculation of a lexicographic Gröbner basis is sometimes a very challenging undertaking and a direct call to GroebnerBasis[eqs, vars, MonomialOrder -> Lexicographic] might not finish in a reasonable amount of time. As mentioned, the calculation of a degree reverse lexicographic basis is often easier. But a degree reverse lexicographic basis is not directly usable for solving equations. Sometimes the function Internal`GroebnerWalk from the Internal` context can be very helpful here. For a parameter-free Gröbner basis this function will convert one monomial order to another. For most cases, we will be interested in a transformation from a degree-reverse lexicographic basis to a lexicographic basis. The default option settings of this function reflect these orders. (We only show the relevant options here.)

Cases[Options[Internal`GroebnerWalk],
      HoldPattern[_?(StringMatchQ[ToString[#], "*MonomialOrder*"]&) -> _]]

As an example of the use of Internal`GroebnerWalk let us consider the following system of equations.

eqs = {16 + λ[1, 2]^4 + (λ[1, 3]^2 - λ[2, 3]^2)^2 - 
            2 λ[1, 2]^2 (λ[1, 3]^2 + λ[2, 3]^2), 
       16 + λ[1, 2]^4 + (λ[1, 4]^2 - λ[2, 4]^2)^2 - 
            2 λ[1, 2]^2 (λ[1, 4]^2 + λ[2, 4]^2), 
       16 + λ[1, 2]^4 + (λ[1, 5]^2 - λ[2, 5]^2)^2 - 
            2 λ[1, 2]^2 (λ[1, 5]^2 + λ[2, 5]^2), 
       16 + λ[1, 3]^4 + (λ[1, 4]^2 - λ[3, 4]^2)^2 - 
            2 λ[1, 3]^2 (λ[1, 4]^2 + λ[3, 4]^2), 
       16 + λ[1, 3]^4 + (λ[1, 5]^2 - λ[3, 5]^2)^2 - 
            2 λ[1, 3]^2 (λ[1, 5]^2 + λ[3, 5]^2), 
       16 + λ[1, 4]^4 + (λ[1, 5]^2 - λ[4, 5]^2)^2 - 
            2 λ[1, 4]^2 (λ[1, 5]^2 + λ[4, 5]^2), 
       16 + λ[2, 3]^4 + (λ[2, 4]^2 - λ[3, 4]^2)^2 - 
            2 λ[2, 3]^2 (λ[2, 4]^2 + λ[3, 4]^2), 
       16 + λ[2, 3]^4 + (λ[2, 5]^2 - λ[3, 5]^2)^2 - 
            2 λ[2, 3]^2 (λ[2, 5]^2 + λ[3, 5]^2), 
       16 + λ[2, 4]^4 + (λ[2, 5]^2 - λ[4, 5]^2)^2 - 
            2 λ[2, 4]^2 (λ[2, 5]^2 + λ[4, 5]^2), 
       16 + λ[3, 4]^4 + (λ[3, 5]^2 - λ[4, 5]^2)^2 - 
            2 λ[3, 4]^2 (λ[3, 5]^2 + λ[4, 5]^2)};

These ten equations of total degree four each, look very symmetric (they exhibit some permutation symmetries) and are not easy to solve. (The λ[i, k] are the edge lengths of a 4D pentatope with unit 2D areas of the 2D faces.) The system has ten variables. This suggests a zero-dimensional solution.

(λs = Cases[eqs, _λ, Infinity] // Union) // Length

While GroebnerBasis[eqs, λs, MonomialOrder -> Lexicographic] will not finish within several hours, the calculation of a degree reverse lexicographic basis and its conversion to a lexicographic basis can be done in a couple of minutes.

(gb = GroebnerBasis[eqs, λs, 
         MonomialOrder -> DegreeReverseLexicographic];) // Timing

(gbLex = Internal`GroebnerWalk[gb, λs];) // Timing

In the lexicographic basis we have one equation in only one variable.

Select[gbLex, Length[Union[Cases[#, _λ, Infinity]]] == 1&]

Solving this triquartic equation gives 12 possible values for λ[4, 5], and, because of the symmetry of the system, for all λ’s.

roots = λ[4, 5] /. Solve[gbLex[[1]] == 0, λ[4, 5]]

To solve the whole system eqs we “just” try all (12^10) possible combinations for the (Subscript[λ, i,j]) and the roots and extract all correct tuples. Doing this in an recursive way eliminates most of these potential (10^12) solutions. The function nextEquation extracts from a set of equations eqs and for a given set of λ’s the equation with the fewest new λ’s.

nextEquation[λs_, eqs_] := 
 eqs[[Position[#, Min[#], {1}, 1][[1, 1]]]]&[
       Length[(* all remaining λs *)   
            Complement[#, λs]]& /@ (* all occurring λs *)
                (Union[Cases[#, _λ, Infinity]]& /@ eqs)]

We start with the first equation and find 112 possible solutions from the 1728 tried combinations. 𝒮[k] is a list of the solutions, after taking into account k equations.

(* the equation under consideration *)
eqsActive = Expand[eqs[[1]]];
(* the remaining equations *)
remainingEqs = DeleteCases[Expand[eqs], eqsActive];
(* the λs already used *)
usedλs = {};
(* the current λs to be solved for *)
λsActive = Union[Cases[eqsActive, _λ, Infinity]];
usedλs = Flatten[{usedλs, λsActive}];
(* the 12^3 possible values for the first three λs *)
start = Apply[Rule, Transpose[{λsActive, #}], {1}]& /@ 
               Flatten[Outer[List, Sequence @@ 
            Table[roots, {Length[λsActive]}]], Length[λsActive] - 1];
(* the λ-values fulfilling the first equation *)                              
(𝒮[1] = Select[start, (eqsActive /. #) == 0&]) // Length

Dealing now with one equation after the other gives us after 10 steps (2^16)=65536 solutions.

Do[eqsActive = nextEquation[λsActive, remainingEqs]; 
   remainingEqs = DeleteCases[remainingEqs, eqsActive];
   λsActive = Complement[Union[Cases[eqsActive, _λ, Infinity]], usedλs];
   usedλs = Flatten[{usedλs, λsActive}];  
   (* rules for new λ-values *)
   newRules = Function[l, If[λsActive === {}, {{}}, 
      Apply[Rule, Transpose[{λsActive, #}], {1}]& /@ 
          Flatten[Outer[List, Sequence @@ 
          Table[roots, {l}]], l - 1]]][Length[λsActive]];
   (* join already established values with potential new ones *)
   allRules = Flatten[Function[nR, Function[oR, 
                       Join[nR, oR]] /@ 𝒮[k - 1]] /@ newRules, 1];
   (* the λ-values fulfilling the first k equations *)   
   𝒮[k] = Select[allRules, (eqsActive /. #) == 0&], 
   {k, 2, 10}]

Length[𝒮[10]]

26 solutions have all edge length positive.

(posSol = Select[𝒮[10], (And @@ (Positive /@ λs /. #))&]) // Length

A function that makes heavy use of Groebnerbasis is PolynomialReduce. To “simplify” a set of polynomials under the condition that another set of polynomial equations holds, one uses the function PolynomialReduce.

We implement the theorem of Vieta for an equation of fourth degree of the form (Subscript[a, 4])+(Subscript[a, 3])x+(Subscript[a, 2])(x^2)+(Subscript[a, 1])(x^3)+(x^4). Given an expression that contains the zeros (Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[x, 4]) of the polynomial, we want to replace them by the coefficients (Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3]),(Subscript[a, 4]). (For multivariate versions of Vieta relations, see [927✶] and [1465✶].)

vietaEquations =           {x1 + x2 + x3 + x4 == -a1,
x1 x2 + x2 x3 + x1 x3 + x1 x4 + x2 x4 + x3 x4 == +a2,
    x1 x2 x3 + x1 x2 x4 + x1 x3 x4 + x2 x3 x4 == -a3,
                                  x1 x2 x3 x4 == +a4};

In applications, we often want to get rid of the xi-variables. We calculate a Gröbner basis using the term ordering DegreeReverseLexicographic (which, as mentioned, is often the fastest term ordering).

gb = GroebnerBasis[Apply[Subtract, vietaEquations, {1}],
                           {x1, x2, x3, x4, a1, a2, a3, a4, x},
              MonomialOrder -> DegreeReverseLexicographic];

Using this Gröbner basis gb, we can reduce various polynomials quickly (this means to eliminate the xi).

pR = PolynomialReduce[(x - x1)(x - x2)(x - x3)(x - x4), gb,
                      {x1, x2, x3, x4},
                      MonomialOrder -> DegreeReverseLexicographic]

PolynomialReduce[x1^8 + x2^8 + x3^8 + x4^8, gb, {x1, x2, x3, x4},
                 MonomialOrder -> DegreeReverseLexicographic][[-1]]

Be aware that the second element of PolynomialReduce must be a Gröbner basis. In the following input the second argument of PolynomialReduce is not a Gröbner basis and as a result the output still contains the variables (Subscript[x, i]).

PolynomialReduce[(x - x1)(x - x2)(x - x3)(x - x4), 
                 Apply[Subtract, vietaEquations, {1}], {x1, x2, x3, x4}]

Here is a small example concerning the use of PolynomialReduce in the univariate case. In [212✶], the following nice identity was given:

(α^630)-1=((((α^315)-1) ((α^210)-1) ((((α^126)-1))^2) ((α^90)-1) ((((α^3)-1))^3) ((((α^2)-1))^5) (((α-1))^3))/(((α^35)-1) ((((α^15)-1))^2) ((((α^14)-1))^2) ((((α^5)-1))^6) (α^68))).

Here α is a solution of the equation (α^10)+(α^9)-(α^7)-(α^6)-(α^5)-(α^4)-(α^3)+α+1=0. Numerically, the identity seems to hold.

poly1 = (α^630 - 1)(α^35 - 1)(α^15 - 1)^2(α^14 - 1)^2(α^5 - 1)^6α^68 -
        (α^315 - 1)(α^210 - 1)(α^126 - 1)^2(α^90 - 1)(α^3 - 1)^3*
        (α^2 - 1)^5(α - 1)^3;

poly2 = α^10 + α^9 - α^7 - α^6 - α^5 - α^4 - α^3 + α + 1;

Solve[poly2 == 0 /. α^10 :> α10, α10]

poly1 /. NSolve[poly2 == 0, α, 500]

An obvious way to prove the identity would be to repeatedly substitute -1-α+(α^3)+(α^4)+(α^5)+(α^6)+(α^7)-(α^9) for (α^10). This is a relatively time-consuming process because many steps are needed. PolynomialReduce provides a proof of the above identity in lass than a second.

PolynomialReduce[poly1, poly2][[2]] // Timing

Gröbner bases are among the most important tools to do symbolic mathematics. We will end here our short tour of Mathematica’s Gröbner basis command GroebnerBasis (we will repeatedly come back to it in the solutions of the exercises). Many more things could be said [1039✶], [1040✶]. We encourage the reader to experiment more with the Gröbner basis command. After a while, the reader will find it an indispensable tool for doing mathematics on the computer.

1.2.3 Polynomials in Inequalities

In this subsection, we will discuss various algebraic operations for sets of polynomial inequalities. The most important functions of this kind are CylindricalAlgebraicDecomposition and those functions related to quantifier elimination. While these functions can also deal with equations and inequations, their typical use is for inequalities and we discuss them in a separate subsection.

An advanced, quite useful function for dealing with polynomials is CylindricalAlgebraicDecomposition. Given a set of polynomials (Subscript[p, i])((Subscript[x, 1]), (Subscript[x, 2]),…,(Subscript[x, n])), i=1,…, m, the real vector space (ℝ^n) can be naturally subdivided in cells, such that inside each cell the polynomials (Subscript[p, i])((Subscript[x, 1]), (Subscript[x, 2]),…,(Subscript[x, n])) do not change signs (meaning they are either positive, or negative or zero). This forms a decomposition of the (ℝ^n). Each cell can then be conveniently described in the form 
(Subscript[x, 1]^((l)))<(Subscript[x, 1])<(Subscript[x, 1]^((u)))
(Subscript[x, 2]^((l)))((Subscript[x, 1]))<(Subscript[x, 2])<(Subscript[x, 2]^((u)))((Subscript[x, 1]))
…
(Subscript[x, m]^((l)))((Subscript[x, 1]), (Subscript[x, 2]),…,(Subscript[x, n]))<(Subscript[x, m])<(Subscript[x, m]^((u)))((Subscript[x, 1]), (Subscript[x, 2]),…,(Subscript[x, n])) 
(where all of the < could be replaced by ≤ or ==). Such a kind of description is called a cylindrical decomposition [1150✶], [115✶], [872✶], [282✶], [850✶].
The (Subscript[x, i]^((l)))((Subscript[x, 1]), (Subscript[x, 2]),…,(Subscript[x, i-1])) are algebraic functions of the variables (Subscript[x, 1]), (Subscript[x, 2]),…,(Subscript[x, i-1]). This means they are either radicals or Root-objects. Root[polynomialInFormOfAPureFunction, rootNumber] is a (one among the n possible ones; where n is the degree of the univariate polynomial) inverse of the function polynomialInFormOfAPureFunction(z). Root-objects are generalizations of radicals to polynomials that cannot be uniquely inverted. We will discuss them in more detail in Section 1.5, but we will encounter them repeatedly in some of the outputs in this subsection. The only operation we will carry out on them in this subsection is numericalization.

In most practical situations, one does not need all cells with all possible (3^n) sign combinations, but rather one is interested in a cylindrical decomposition for a certain combination of signs only. In Mathematica, one can obtain a cylindrical decomposition by using the function CylindricalAlgebraicDecomposition.

Because the function CylindricalAlgebraicDecomposition comes from the Experimental` context, we put this context on our context path.

AppendTo[$ContextPath, "Experimental`"]

The functions (Subscript[x, i]^((l)))(…) and (Subscript[x, i]^((u)))(…) are algebraic functions (meaning they contain radicals or Root-objects) of their arguments. Although Root-objects are typically not continuous functions of their arguments for all real values of the arguments, they are continuous functions within each region. (Inside each region returned by CylindricalAlgebraicDecomposition the sign of the polynomials is constant. But neighboring regions can have the same sign characteristic. For some purposes it might be advantageous to join such regions.)

Here is a very simple example: The inside of a circle. A cylindrical description of this area is as follows. The following output has the head And.

CylindricalAlgebraicDecomposition[x^2 + y^2 < 1, {x, y}]

The outside of a circle has a slightly more complicated description. Now the head of the output is Or and the second argument of this Or has the head And (and the second argument of this And has again the head Or).

CylindricalAlgebraicDecomposition[x^2 + y^2 > 1, {x, y}]

Here is the circle itself. The left and right “endpoints” appear separately.

CylindricalAlgebraicDecomposition[x^2 + y^2 == 1, {x, y}]

Reversing the variable ordering gives the top and bottom “endpoints” separately.

CylindricalAlgebraicDecomposition[x^2 + y^2 == 1, {y, x}]

Here is the outside of the circle, including the circle itself.

CylindricalAlgebraicDecomposition[x^2 + y^2 >= 1, {x, y}]

The next result describes the lower half of two intersecting circles. A moment of reflection explains the result.

CylindricalAlgebraicDecomposition[
      (x - 1/2)^2 + y^2 < 1 && (x + 1/2)^2 + y^2 < 1 && y < 0, {x, y}]

Here is a visualization of the last result and the circles involved.

ContourPlot[Evaluate[If[%, 0, 1]], {x, -3/2, 3/2}, {y, -1, 1/2},
            PlotPoints -> 240, AspectRatio -> Automatic,
            Epilog -> {Hue[0], Line[{{-3/2, 0}, {3/2, 0}}],
                       Circle[{-1/2, 0}, 1], Circle[{ 1/2, 0}, 1]}]

Now, let us look at a slightly more complicated example. We start with a torus in parametric form.

torus[φ1_, φ2_, r1_, r2_] := {r1 Cos[φ1] + r2 Cos[φ1] Cos[φ2],
                              r1 Sin[φ1] + r2 Sin[φ1] Cos[φ2],
                                           r2         Sin[φ2]};

We squeeze the torus by making the larger radius a function of the angle φ1. Using the GroebnerBasis function, we calculate an implicit representation of this squeezed torus.

squeezedTorus[{x_, y_, z_}, r_, a_] = 
GroebnerBasis[
Join[{x, y, z} - torus[φ1, φ2, r, a + Cos[φ1]],
	 {Cos[φ1]^2 + Sin[φ1]^2 - 1, Cos[φ2]^2 + Sin[φ2]^2 - 1}],       
	 {x, y, z}, {Cos[φ1], Sin[φ1], Cos[φ2], Sin[φ2]},
	 MonomialOrder -> EliminationOrder][[1]]

Here the cross section of this torus in the x,y-plane is shown.

ContourPlot[Evaluate[squeezedTorus[{x, y, 0}, 3, 7/10]],
            {x, -5, 5}, {y, -5, 5},
	        PlotPoints -> 300, Contours -> {0}]

A cylindrical algebraical decomposition of this cross section can easily be calculated. The results looks quite complicated.

squeezedTorus2DCAD = CylindricalAlgebraicDecomposition[
           squeezedTorus[{x, y, 0}, 3, 7/10] < 0, {x, y}]

To better see the structure of the result, we replace the Root-objects by the shorter notation r[i].

Module[{i = 0}, InputForm[squeezedTorus2DCAD /. _Root :> r[i++]]]

Let us use the cylindrical algebraical decomposition to reproduce the contour plot of the cross section. We are interested only in the 2D regions; so we only keep the finite x-intervals (meaning we omit single points). Then, we replace the Less by LessEqual. Last, we generate all cells by expanding the Ors in the second argument of the Ands.

squeezedTorus2DInequalities = 
	Flatten[Cases[squeezedTorus2DCAD /. LessEqual -> Less,
	  Inequality[_, Less, x, Less, _] && _] /.
		 i1_Inequality && (i2_Inequality || i3_Inequality) :>
                                         {i1 && i2, i1 && i3}];

We generate polygons by traversing the boundaries of the cells of squeezedTorus2DInequalities.

makePolygon2D[Inequality[xl_, Less, x, Less, xu_] && 
              Inequality[yl_, Less, y, Less, yu_], pp_] :=
With[{ε = 1.`22*^-6},
Polygon[Join[Table[{x, yl}, {x, xl + ε, xu - ε, (xu - xl - 2ε)/pp}],
Block[{x = xu}, 
     Table[{x, y}, {y, yl + ε, yu - ε, (yu - yl - 2ε)/pp}]],
     Table[{x, yu}, {x, xu - ε, xl + ε, (xl - xu + 2ε)/pp}],
Block[{x = xl}, 
     Table[{x, y}, {y, yu - ε, yl + ε, (yl - yu + 2ε)/pp}]]]]]

Coloring each of the resulting polygons in a different color, we finally arrive at the following picture.

Show[Graphics[{Hue[Random[]], makePolygon2D[#, 22]}& /@ 
                      squeezedTorus2DInequalities],
     AspectRatio -> Automatic, Frame -> True]

Next, we will use the function CylindricalAlgebraicDecomposition to calculate some exact iterations of the Arnold cat map [180✶] (see Section 2.4 of the Numerics volume [1561✶]). Given semialgebraic sets parts from within the unit square, the function catMapStep applies one step of the cat map and returns the resulting semialgebraic set. We realize the mod 1 operation by splitting the affine deformed semialgebraic set with respect to the six unit squares that are mapped back to (0,1)×(0,1).

catMapStep[parts_] :=
Module[{r = 0, (* local counter *) 𝓇},
 (* stretch the given set made from the parts *)
 stretchedParts = parts /. {x -> 2 x - y, y -> -x + y};
 (* the six unit squares covered that cover any stretched parts *)
 squares = Outer[And, {0 < x < 1, 1 < x < 2},
                      {0 < y < 1, 1 < y < 2, 2 < y < 3}] // Flatten;
 (* the shifts corresponding to the six unit squares *)
 shifts = Outer[List, {0, 1}, {0, 1, 2}] // Flatten[#, 1]&;                     
 (* reduce all stretched parts with respect to the six squares *)
 Flatten[Table[
 Table[gcad = CylindricalAlgebraicDecomposition[     
                 stretchedParts[[i, 2]] && squares[[j]], {x, y}] /.
                 (* keep 2D components *) LessEqual -> Less;
       part = Cases[{gcad}, _And, Infinity];
       If[part =!= {}, 𝓇 = r++;
          C[𝓇, Or @@ (modOne[# /. (* use Less instead Inequality *)
                 Inequality[a_, Less, b_, Less, c_] :> Less[a, b, c], 
                               shifts[[j]]]& /@ part)], {}], {j, 6}],
       {i, Length[stretchedParts]}] /. (* keep all parts separated *)
           C[𝓇_, or_Or] :> (C[𝓇, #]& /@ (List @@ or))]]

(* shift semialgebraic set to unit square (0, 1)×(0,1) *)
modOne[(xMin_ < x < xMax_) && (yMin_ < y < yMax_), {ξ_, η_}] :=
       And @@ {(xMin - ξ) < x < (xMax - ξ),
       (yMin - η /. x -> x + ξ) < y < (yMax - η /. x -> x + ξ)}

The function catMapGraphic visualizes the semialgebraic sets resulting from applying the Arnold cat map. We color the parts from according to the shift needed to carry out the mod 1 operation at each step.

catMapGraphic[parts_, pp_] :=
Module[{μ = Max[Max[First /@ parts], 1], gr},
 Off[Table::itflrw]; Off[$MaxExtraPrecision::meprec]; Off[N::meprec]; 
 (* make colored polygons *)
 gr = Graphics[{regionToBorderedPolygon[#2, Hue[0.8 #1/μ], pp]}& @@@ 
               parts, PlotRange -> All, Frame -> True, 
               FrameTicks -> None, AspectRatio -> Automatic];
 On[Table::itflrw]; On[$MaxExtraPrecision::meprec]; On[N::meprec]; gr]

regionToBorderedPolygon[(xMin_ < x < xMax_) && 
                        (yMin_ < y < yMax_), col_, pp_] :=
Module[{iter = {x, xMin, xMax, (xMax - xMin)/pp}, lower, upper}, 
       {lower, upper} = {Table @@ {{x, yMin}, iter},
                         Table @@ {{x, yMax}, iter}} // N[#, 30]&;
       {(*colored polygon *)
        {col, Polygon[Join[lower, Reverse[upper]]]},
        (* thin black edge *)
        {GrayLevel[0], Thickness[0.002],
         Line[Join[lower, Reverse[upper], Take[lower, 1]]]}}]

We visualize the first few steps of repeatedly applying the cat map to the unit square (0,1)×(0,1) and a disk of radius 1/2 in this unit square.

Function[initSAS,
     Show[GraphicsArray[catMapGraphic[#, 60]& /@ 
                             NestList[catMapStep, initSAS, 3]]]] /@
     {(* the unit square (0, 1)×(0, 1) *) 
      {C[0, 0 < x < 1 && 0 < y < 1]},
      (* radius 1/2 disk in the unit square (0, 1)×(0, 1) *) 
      {C[0, 0 < x < 1 && 1/2 - Sqrt[x - x^2] < y < 1/2 + Sqrt[x - x^2]]}}

For the unit square itself, we apply the cat map five times. This results in 2636 polygons.

catSquare = Nest[catMapStep, {C[0, 0 < x < 1 && 0 < y < 1]}, 5];
Length[catSquare]

As expected, the area of these 2636 polygons adds up to 1.

area[(xMin_ < x < xMax_) && (yMin_ < y < yMax_)] :=
Module[{p1 = {xMin, yMin /. x -> xMin}, p2 = {xMax, yMin /. x -> xMax}, 
        p3 = {xMax, yMax /. x -> xMax}, p4 = {xMin, yMax /. x -> xMin}},
       area[{p1, p2, p3}] + area[{p3, p4, p1}]]
       
area[{{x1_, y1_}, {x2_, y2_}, {x3_, y3_}}] :=
     Abs[x2 y1 - x3 y1 - x1 y2 + x3 y2 + x1 y3 - x2 y3]/2

allCatSquareAreas = area[#[[2]]]& /@ catSquare;
Plus @@ allCatSquareAreas

The following graphic shows the resulting polygons randomly colored (left). Along the main diagonal of the unit square many small polygons exist. The right graphic shows the distribution of the (logarithm of the) sizes of the 2636 polygons.

Show[GraphicsArray[
 {catMapGraphic[catSquare, 2] /. 
                  {p_Polygon :> {Hue[Random[]], p}, l_Line :> {}},
  ListPlot[N @ Log @ Sort[allCatSquareAreas], PlotRange -> All,
           DisplayFunction -> Identity, Frame -> True, Axes -> False]}]]

For 3D cat maps, see [302✶].

Let us now treat a more complicated equality. Here is a Lissajous curve.

ParametricPlot[{Cos[3ϑ], Sin[5ϑ]}, {ϑ, 0, 2Pi}, 
               AspectRatio -> Automatic, Frame -> True, Axes -> False]

We calculate an implicit representation of this Lissajous curve using again the GroebnerBasis function.

lissajouCurve = GroebnerBasis[
Join[TrigExpand[{x, y}  - {Cos[6ϑ], Sin[10ϑ]}],
	 {Cos[ϑ]^2 + Sin[ϑ]^2 - 1}], {x, y}, {Cos[ϑ], Sin[ϑ]},
	 MonomialOrder -> EliminationOrder][[1]]

Here is a sketch of the cylindrical algebraic decomposition of the Lissajous curve.

lissajouCAD = CylindricalAlgebraicDecomposition[
                                       lissajouCurve == 0, {x, y}];

Module[{i = 0}, InputForm[lissajouCAD /. _Root :> r[i++]]]

Next, we separate the single points from the curve segments.

lissajouInequalities = 
Flatten[Cases[lissajouCAD /. LessEqual -> Less,
	  Inequality[_, Less, x, Less, _] && _] /.
		 i1_Inequality && or_Or :> ((i1 && #)& /@ (List @@ or))];

lissajouPoints = Point[{x, y}] /. 
 (ToRules /@ Flatten[Cases[lissajouCAD, x == _ && _] /.
    x == x0_ && or_Or :> 
    ((x == x0 && (# /. x -> x0))& /@ (List @@ or))]);

The cylindrical algebraic decomposition of the Lissajous curve consists of 60 line segments and 38 points.

Length /@ {lissajouInequalities, lissajouPoints}

The next graphic shows the line segments as well as the single points. The single points are the left-most and right-most points (where the curve has a vertical tangent), the top-most and bottom-most points (where the curve has a horizontal tangent), and the crossing points of the curve.

makeLine2D[Inequality[xl_, Less, x, Less, xu_] && y == yx_, pp_] :=
With[{ε = N[10^-8, 22]},
     Line[Table[{x, yx}, {x, xl + ε, xu - ε, (xu - xl - 2ε)/pp}]]]

Show[Graphics[{
    {Thickness[0.002],
     {Hue[Random[]], makeLine2D[#, 22]}& /@ lissajouInequalities},
    {PointSize[0.02], GrayLevel[0], N @ lissajouPoints}}],                         
    AspectRatio -> Automatic, Frame -> True]

Mathematica can calculate the cylindrical algebraic decomposition in any number of variables and (in)equalities. Here is the cylindrical algebraic decomposition of a sphere.

CylindricalAlgebraicDecomposition[x^2 + y^2 + z^2 == 1, {x, y, z}]

As a more challenging example, let us deal with our squeezed torus from above. Its cylindrical algebraical decomposition is quite complicated.

squeezedTorus3DCAD = CylindricalAlgebraicDecomposition[    
		              squeezedTorus[{x, y, z}, 3, 7/10] < 0, {x, y, z}];
Short[squeezedTorus3DCAD, 14]

To better see the structure, we again use short-hand notations for the roots.

Module[{i = 0}, InputForm[squeezedTorus3DCAD /. _Root :> r[i++]]]

Let us use squeezedTorus3DCAD to make a picture of the parts of (ℝ^3) for which squeezedTorus[{x, y, z}, 3, 7/10] < 0. Similar to the 2D case, we select the inequalities in squeezedTorus3DCAD and expand remaining Ors.

squeezedTorus3DInequalities = 
Flatten[Cases[squeezedTorus3DCAD /. LessEqual -> Less,
	             Inequality[_, Less, x, Less, _] && _] /.
	i1_Inequality && (a2_And ||  a3_And) :> {i1 && a2, i1 && a3}];

The function makePolygons3D generates polygons of the top and bottom boundaries for a given cell.

makePolygons3D[Inequality[xl_, Less, x, Less, xu_] && 
               Inequality[yl_, Less, y, Less, yu_] &&
               Inequality[zl_, Less, z, Less, zu_], pp_] :=
Block[{x, y},
Module[{ε = 10.^-12},
(* avoid endpoints for numericalization *) δx = (xu - xl - 2ε)/pp;
(* calculate points *)
pointsl = Table[x = xl + ε + ix δx; δy = (yu - yl - 2ε)/pp;
      Table[y = yl + ε + iy δy; {x, y, Re[zl]},
            {iy, 0, pp}], {ix, 0, pp}];
pointsu = Table[x = xl + ε + ix δx; δy = (yu - yl - 2ε)/pp;
      Table[y = yl + ε + iy δy; {x, y, Re[zu]},
            {iy, 0, pp}], {ix, 0, pp}];
(* form polygons *)
{Table[Polygon[{pointsl[[i, j]], pointsl[[i + 1, j]], 
                pointsl[[i + 1, j + 1]], pointsl[[i, j + 1]]}], 
       {i, pp}, {j, pp}],
  Table[Polygon[{pointsu[[i, j]], pointsu[[i + 1, j]], 
                 pointsu[[i + 1, j + 1]], pointsu[[i, j + 1]]}], 
       {i, pp}, {j, pp}]}]]

Here, the pieces of the boundary of the 3D pieces of the cylindrical algebraical decomposition are randomly colored.

Show[Graphics3D[{EdgeForm[], {SurfaceColor[Hue[Random[]]], 
     makePolygons3D[#, 24]}& /@ squeezedTorus3DInequalities}]]

In many applications of cylindrical algebraic decompositions (for instance for changing variables or the variable order in multidimensional integrals [1377✶]), one does not need the cells that are of lower dimensionality. This means only strong inequalities using Less and Greater are allowed. Fortunately, such a decomposition is also faster to calculate. The Mathematica command dealing especially with this case is GenericCylindricalAlgebraicDecomposition.

Here is the difference between CylindricalAlgebraicDecomposition and GenericCylindricalAlgebraicDecomposition for a simple example—a circle and an ellipse—demonstrated.

CylindricalAlgebraicDecomposition[
            (x^2 + y^2 - 1)(x^2/4 + y^2 - 1) <= 0, {x, y, z}]

GenericCylindricalAlgebraicDecomposition[
            (x^2 + y^2 - 1)(x^2/4 + y^2 - 1) <= 0, {x, y, z}]

The following output describes the regions in the x,y-plane where the product

𝓅(x,y)= (∏_(i=-2)^2)(x-i)(∏_(j=-2)^2)(y-j)

is negative. Observe that the use of LessEqual does not cause the corresponding lines to be returned.

𝓅 = Product[x - i, {i, -2, 2}] Product[y - j, {j, -2, 2}];
GenericCylindricalAlgebraicDecomposition[𝓅 <= 0, 
                                 {x, y}][[1]] // LogicalExpand

We will make use of GenericCylindricalAlgebraicDecomposition for a nontrivial problem in Subsection 1.9.1.
For details about the cylindrical algebraic decomposition method and its use, see [282✶], [235✶], [989✶], [51✶], [1089✶], [1104✶], [78✶], [79✶], [219✶], [77✶], [1150✶], [1026✶], and [855✶]. It should be mentioned that the algorithm used to find a cylindrical algebraic decomposition is in the worst case double-exponential in the number of variables. So whenever possible, the user should reduce the problem under consideration to one with fewer variables.

A subject intimately related to cylindrical algebraic decomposition is quantifier elimination. Given an expression e of the form

e=(Subscript[∃, qVars1])(Subscript[∀, qVars2])L((Subscript[p, 1])(qVars1, qVars2, vars),…, (Subscript[p, n])(qVars1, qVars2, vars))

where L is a logical expression (which can contain expressions with the head And, Or, Implies, Not) built from polynomial equations and inequations (Subscript[p, i]) (which can contain expressions with the head Equal, Unequal, Greater, Less, GreaterEqual, LessEqual, Inequality), it is in principle possible to eliminate the quantified variables and rewrite e in the form of a logical expression of polynomial equations and inequations (Subscript[p, i]) in the unquantified variables vars only [1529✶], [282✶]. The variables qVars1, qVars2 are quantified (and can be in principle eliminated) and the variables vars are free. All variables involved, qVars1, qVars2, and vars, will be assumed to be real.

The Mathematica form of the quantifiers ∃ and ∀ is as follows.

Here are two very simple examples of expressions formed with the quantifiers Exists and ForAll. The first one qE1 states the existence of a real number x, x>5, such that (x^3)=200.

qE1 = Exists[x, Element[x, Reals] && x > 5, x^3 == 200]

The second statement qE2 represents the fact that for all integers n, the number 2n is also an integer.

qE2 = ForAll[n, Element[n, Integers], Element[2 n, Integers]]

Both of the last inputs were not evaluated to True by Mathematica. To “evaluate” expressions containing quantifiers—this means to eliminate the quantifiers—one needs one more function (which also comes from the context Experimenbtal`).

The main function discussed in the previous subsection, GroebnerBasis, deals with polynomial equations, and the indeterminates are generically considered to be complex variables. The main function of this subsection, CylindricalAlgebraicDecomposition and Resolve, deal generically with inequations of real variables.
Resolve will always carry out its calculation for polynomial equations and inequations in real variables (this means it will never, like Integrate in case it cannot find a closed form of the integral, return unevaluated when properly called), but the actual running time for some examples might be large. Contrary to many other Mathematica functions, Resolve does not make any genericity assumptions about variables. Integrate[x^n, x] returns the result ((x^(n+1))/(n+1)), which for n=–1 is ill-defined. x and n in this example are both assumed to be generic complex variables. Resolve will produce results where all “exceptions” are explicitly listed. This property of Resolve allows its use for proving a variety of theorems from arithmetic and geometry.

Applying Resolve to the above expression qE1 yields True.

Resolve[qE1]

Applying Resolve to the above expression qE2 does not yield True. As specified in the definition of Resolve, only quantified variables that are specified as real numbers are eliminated. For quantified real variables, algorithms exist to carry out the elimination, but for integer-quantified variables, it might be algorithmically impossible to do this.

Resolve[qE2]

To resolve simple (unquantified) formulae involving integers, we can, of course, use Simplify. Here is a mathematically equivalent statement of qE2. Simplify can determine that it is true.

Simplify[(* the statement about 2n *) Element[2 n, Integers], 
         (* the condition about  n *) Element[n, Integers]]

Now, let us consider some examples of the use of quantifier elimination. We will give a larger than usual amount of examples of these important tool for solving a variety of problems coming from different fields of applications. The first group of examples will be a set of theorem from elementary arithmetic and geometry [204✶], [1152✶], [241✶]. We start with the following theorem about the relation between the arithmetic mean and the geometric mean: (x+y)/2≥(Sqrt[x y]) [242✶]. The statement does not hold for generic real x and y.

ForAll[{x, y}, (x + y)/2 >= Sqrt[x y]] // Resolve

But it does, however, hold for positive x and y.

ForAll[{x, y}, x > 0 && y > 0, (x + y)/2 >= Sqrt[x y]] // Resolve

Here is a similar statement about three variables: (x+y+z)/3≥((x y z)^(1/3)).

Resolve[ForAll[{x, y, z}, x > 0 && y > 0  && z > 0,
               (x + y + z)/3 >= (x y z)^(1/3)]]

This verifies the Cauchy inequality: ((a^2)+(b^2)) ((c^2)+(d^2))≥(((a c+b d))^2).

Resolve[ForAll[{a, b, c, d}, Element[{a, b, c, d}, Reals],
               
(a^2 + b^2)(c^2 + d^2) >= (a c + b d)^2]]

And the following input verifies the three-variable version of the Cauchy inequality:

((Subscript[a, 1]^2)+(Subscript[a, 2]^2)+(Subscript[a, 3]^2))((Subscript[b, 1]^2)+(Subscript[b, 2]^2)+(Subscript[b, 3]^2))≥((((Subscript[a, 1])(Subscript[b, 1])+(Subscript[a, 2])(Subscript[b, 2])+(Subscript[a, 3])(Subscript[b, 3])))^2).

Resolve[ForAll[{a1, a2, a3, b1, b2, b3},
		       Element[{a1, a2, a3, b1, b2, b3}, Reals],
               (a1^2 + a2^2 + a3^2)(b1^2 + b2^2 + b3^2) >= 
               (a1 b1 + a2 b2 + a3 b3)^2]]

An inequality from the year 2000 International Mathematics Olympiad (http://olympiads.win.tue.nl/imo/imo2000/imo2000-problems.pdf) can be proven by within a fraction of a second.

Timing @ Resolve[ 
ForAll[{a, b, c}, Element[{a, b, c}, Reals] && 
                  a > 0 && b > 0 && c > 0 && a b c == 1,
       (a - 1 + 1/b) (b - 1 + 1/c) (c - 1 + 1/a) <= 1]]

The following inequality from a year 2002 issue of the Mathematics Magazine [857✶] can also be proved in less than a second.

Timing @ Resolve[
	 Exists[{a, b, c},
		    Element[{a, b, c}, Reals] && 
		    0 < a < 1 && 0 < b < 1 && 0 < c < 1 &&
		    a b + a c + b c == 1,
           a/(1 - a^2) + b/(1 - b^2) + c/(1 - c^2) == 3 Sqrt[3]/2]]

Many inequalities concerning triangles exist. Using Resolve, it is straightforward to prove a large number of them. Here are some examples. In the following examples a, b, and c are the length of the sides of a triangle, s denotes its circumference, A its area, r is the radius of the inscribed circle, and R is the radius of the circumscribed circle.

s = a + b + c;

The conditions on the variables a, b, and c to be interpretable as the edge length of a triangle are as follows. (Note that we do not have to explicitly add Element[{a, b, c}, Reals]. Whenever a variable appears in an inequality inside Exists or ForAll, it is automatically assumed to be a real number.)

triangleConditions = a > 0 && b > 0 && c > 0 && 
                     a + b > c && a + c > b && b + c > a;

Here is an example from [1225✶].

Resolve[ForAll[{a, b, c}, triangleConditions,
        
8 a b c <= (a + b)(b + c)(c + a)]]

And here is an example from [346✶], [440✶].

s = a + b + c;

Timing[Resolve @ 
ForAll[{a, b, c}, triangleConditions,
       
a b c < a^2(s - a) + b^2 (s - b) + c^2 (s - c)]]

The running time of quantifier elimination problems depends dramatically on the number of variables to be dealt with (in the worse case, the dependence is double exponential in the number of variables). In the last case, the s in the last input evaluated to a + b + c. If we instead add the equivalent equality to the conditions, proving the statement takes much longer. On a 2 GHz computer, the corresponding calculation would take about 30 minutes.

Clear[s];

TimeConstrained[Resolve @ 
ForAll[{a, b, c}, triangleConditions && Element[s, Reals] &&
                  s == a + b + c,
       
a b c < a^2(s - a) + b^2 (s - b) + c^2 (s - c)], 100]

A better solution is to quantify s itself.

Resolve @
ForAll[{a, b, c}, triangleConditions, Exists[s, Element[s, Reals] &&
                  s == a + b + c,
     a b c < a^2(s - a) + b^2 (s - b) + c^2 (s - c)]] // Timing

We take the above remark into account and evaluate s, A, and R in the following calculation outside of the ForAll instead of supplying them as equalities.

s = (a + b + c)/2; 
A = (* Heron’s formula *) Sqrt[s (s - a) (s - b) (s - c)]; 
R = a b c/(4 A); 
Timing[Resolve[ForAll[{a, b, c}, triangleConditions, 
         4 R^2 >= ((b^2 + c^2)/Sqrt[2 b^2 + 2 c^2 - a^2])^2]]]

Here is a last, recently published inequality concerning triangles [160✶].

r = 2 A/(a + b + c);

Resolve[ForAll[{a, b, c}, triangleConditions, 2 s^2 >= 27 R r]]

Using an algebraic representation for the maximum functions, we can also prove the inequality max(a,b,c)<(a+b+c)/2.

max[x1_, x2_] := 1/2(x1 + x2 + Sqrt[(x1 - x2)^2])

max[max[a, b], c] < 1/2(a + b + c)

Resolve[ForAll[{a, b, c}, triangleConditions, %]]

In the following example, the main statements are equations. Heron’s formula is derived. We also get nondegeneracy conditions on the edge length such that Heron’s formula holds.

Exists[{p2x, p3x, p3y}, 
	   Element[{p2x, p3x, p3y, area, l12, l23, l13}, Reals] && 
	           p2x >= 0 && p3x >= 0 && p3y >= 0 && 
	           l23 >= 0 && l13 >= 0,
	   area == p2x p3y/2 && l12 == p2x && 
	   l23^2 == (p2x - p3x)^2 + p3y^2 &&
	   l13^2 == p3x^2 + p3y^2] // Resolve

The expression from which to eliminate quantifiers does not have to contain inequations at all. Resolve will also eliminate quantifiers from logical expressions formed purely by equations. Here is an example.

Exists[c, Element[c, Reals],
	   ForAll[{a, b}, Element[{a, b, c, d}, Reals],
	   Implies[(a == d && b == c) || 
	           (a == c && b == 1), a^6 == b c d]]] // Resolve

Taking into account the above remark to express all formulas to be treated by Resolve, we can also prove many triangle-theorems containing angles. Using the cosine theorem, we express the values of the three cosines as rational functions in the side length.

cosα = -(a^2 - b^2 - c^2)/(2 b c);
cosβ = -(b^2 - a^2 - c^2)/(2 a c);
cosγ = -(c^2 - a^2 - b^2)/(2 a b);

Here are three theorems about angles in triangles proved:

0<cos(α)+cos(β)+cos(γ)≤(3/2)
 0<cos(α)+(Sqrt[2])(cos(β)+cos(γ))≤2
 cos(α)cos(β)cos(γ)≤(1/8).

ForAll[{a, b, c}, triangleConditions,
       0 < cosα + cosβ + cosγ <= 3/2] // Resolve

ForAll[{a, b, c}, triangleConditions,
       cosα + Sqrt[2](cosβ + cosγ) <= 2] // Resolve

ForAll[{a, b, c}, triangleConditions,
       cosα cosβ cosγ <= 1/8] // Resolve

But Resolve does not only allow us to prove theorems, it can also be used to derive new ones. Here, we derive lower and upper bounds for cos(α)+2cos(β)+3cos(γ), where as always, α, β, and γ are the angles in a triangle. The new theorem is:

0≤cos(α)+2cos(β)+3cos(γ)≤4.

ForAll[{a, b, c}, triangleConditions && Element[{λ}, Reals],
       cosα + 2 cosβ + 3 cosγ <= λ] // Resolve

ForAll[{a, b, c}, triangleConditions && Element[{λ}, Reals],
        λ <= cosα + 2 cosβ + 3 cosγ] // Resolve

Besides proving polynomial inequalities, quantifier elimination has a couple of other important applications. One of them is making certain statements about the location of zeros of polynomials. We start with a simple one: We prove that every cubic polynomial has at least one real zero.

ForAll[{a, b}, Element[{a, b, c}, Reals], 
       Exists[x, Element[x, Reals], 
                a + b x + c x^2 + x^3 == 0]] // Resolve

But not every quartic has real roots. (We normalize the leading coefficient to 1.)

ForAll[{a, b, c}, Element[{a, b, c, d}, Reals], 
        Exists[x, Element[x, Reals], 
             a + b x + c x^2 + d x^3 + x^4 == 0]] // Resolve

The coefficient of the cubic term was 1 in the last input. If we let the coefficient of the cubic term be the variable d, we get as the condition for the statement to be correct the nondegeneracy condition of the cubic polynomial.

ForAll[{a, b}, Element[{a, b, c, d}, Reals], 
        Exists[x, Element[x, Reals], 
                a + b x + c x^2 + d x^3 == 0]] // Resolve

Here are the conditions for the coefficients a and b of a quadratic a + b x + (x^2), such that this quadratic has at least one real root.

Exists[{x}, Element[{x, a, b}, Reals],
          a + b x + x^2 == 0] // Resolve

To have two different roots, we get a strict inequality.

Exists[{x1, x2}, Element[{x1, x2, a, b}, Reals],
          x1 x2 == a && (-x1 - x2) == b &&
          (* different roots *) x1 != x2 && 
          a + b x1 + x1^2 == 0 && a + b x2 + x2^2 == 0] // Resolve

Using the last result, we can show that for any nondegenerate quadratic (x^2)+b x+a with real a and b and real roots, the following holds: a+b+1≤9/4max(a,b,1) [1169✶].

Resolve[ForAll[{a, b}, Element[{a, b, λ}, Reals] &&
               a <= b^2/4, a + b + 1 <= λ Max[a, b, 1]]]

Here are the more complicated conditions for the coefficients a, b, and c of the cubic a+b x + c (x^2)+(x^3) to have three different roots are calculated.

Exists[{x1, x2, x3}, Element[{a, b, c, x1, x2, x3}, Reals],
 (* roots are different *) 
 x1 != x2 != x3 && 
 (* x1, x2, x3 _are_ roots *)
 a + b x1 + c x1^2 + x1^3 == 0 && 
 a + b x2 + c x2^2 + x2^3 == 0 &&
 a + b x3 + c x3^2 + x3^3 == 0] // Resolve

Here is a still more complicated example: For which a, b does the sextic (a^4)+(a^2)b x-a (x^6) have at least one real root?

Exists[{x}, Element[{x, a, b}, Reals],  
       a^4 + a^2 b x - a x^6 == 0] // Resolve

Here is a numerical experiment. We randomly select 5000 pairs for a and b and make a point in the a,b-plane whenever the polynomial has at least one real root. The two lines are the curves described by the last result.

Show[Graphics[{{PointSize[0.01], Hue[0],
Block[{a, b},
Table[(* random values for a and b *)
      a = Random[Real, {-3, 3}]; b = Random[Real, {-5, 5}];
      (* check if at least one real root is present *)
      If[Cases[x /. 
        {ToRules[NRoots[a^4 + a^2 b x - a x^6 == 0, x]]}, _Real] =!= {},
         Point[{a, b}], {}], {5000}]]},
 (* the lines *)
 {Thickness[0.002], GrayLevel[0], Table[(* two roots *)
         Line[Table[{a, Root[46656 a^9 + 3125 #^6&, j]}, 
                    {a, -((5 5^(2/9))/6^(2/3)), 0, 0.01}]], {j, 2}]}}],
     Frame -> True, PlotRange -> All]

Under which conditions on the real coefficients (Subscript[a, k]) can a cubic polynomial be expressed as the sum of three simple cubes (((x-(Subscript[α, k])))^3) with real (Subscript[α, k])?

(x^3)+(Subscript[a, 2])(x^2)+(Subscript[a, 1])x+(Subscript[a, 0])=(((x-(Subscript[α, 1])))^3)+(((x-(Subscript[α, 2])))^3)+(((x-(Subscript[α, 3])))^3)=0

Resolve[Exists[{α[1], α[2], α[3]}, 
       Element[{α[1], α[2], α[3], a[2], a[1], a[0]}, Reals],
       ForAll[x, Element[x, Reals],
              (* from comparing coefficients of x0, x1, x2 *)
              a[0] + α[1]^3/3 + α[2]^3/3 + α[3]^3/3 == 0 &&
              a[1] - α[1]^2 - α[2]^2 - α[3]^2 == 0 && 
              a[2] + α[1] + α[2] + α[3] == 0]]]

(For more concerning the connection between the number of roots and the coefficients, see [1693✶].) 
A further very important application of quantifier elimination is the following: Given a polynomial, say, a+b z + c (z^2)+(z^3), under which conditions on the coefficients have all roots negative imaginary parts (or positive imaginary parts or are all inside or outside the unit circle or …) [621✶], [109✶]. This question has important application in control theory [1175✶], for the construction of stable finite difference schemes [1046✶], [789✶], [788✶], and more [872✶]. Because quantifier elimination techniques work only for real numbers, we write the condition for the complex roots z of a+b z + c (z^2)+(z^3)=0 as two equations for the real and the imaginary parts.

cubic = Expand[a + b z + c z^2 + z^3 /. z -> x + I y]

{im = Plus @@ (Cases[cubic, _Complex _]/I),
 re = Expand[cubic - I im]}

ForAll[{x, y}, Element[{ x, y, a, b, c}, Reals],
	   Implies[re == 0 && im == 0, x < 0]] // Resolve

Quantifier elimination can be used to solve many satisfiability questions. For example, given the two polynomials

(x^2)+2 y x-3=0
 (y^2)-f x y-5=0,

does an f exist, such that -24/10 < x < -23/10?

Exists[{x, y}, Element[{x, y, f}, Reals], 
       x^2 + 2 x y - 3 == 0 && y^2 -f x y - 5 == 0 &&
	  -24/10 < x < -23/10] // Resolve

N[%]

Here is a graphical check for the last result.

Show[Graphics[{
{Hue[0], (* bounding rectangle for x and f *)
 Polygon[{{1005559/242282, -23/10}, {1005559/242282, -24/10},
          {7471/2208, -24/10}, {7471/2208, -23/10}}]},
{GrayLevel[0], PointSize[0.01],
 Table[Point[{f, #}]& /@ (x /.
 (* solve system numerically for given f *)
 NSolve[{x^2 + 2 x y - 3 == 0, y^2 - f x y - 5 == 0},
        {x, y}]), {f, 3.3, 4.2, 0.05}]}}],
     PlotRange -> {-2.2, -2.5}, Frame -> True]

Let us now give two examples from quantum mechanics. The first example derives all nontrivial Bell and Clauser–Horne inequalities for an entangled two-particle system [1275✶], [1274✶], [88✶], [287✶], [829✶], [250✶], [19✶], [1404✶], [1654✶], [1655✶], [787✶], [695✶], [348✶], [229✶]. (For a Mathematica package to derive such inequalities, see [569✶].)

(* possible measurement outcomes *)
elementaryEvents = {{ℰ[A1], ℰ[A2]}, {ℰ[B1], ℰ[B2]}};
doubleEvents = Flatten[Outer[Join, Sequence @@ elementaryEvents]];
allEvents = Flatten[{elementaryEvents, doubleEvents}]

(* vertices of the correlation polytope *)
allPoints = Level[Table[Times @@@ allEvents,
                  Evaluate[Sequence @@ ({#[[1]], 0, 1}& /@ 
                     Cases[allEvents, ℰ[_]])]], {-2}];

(* express events as linear combinations of extremal points *)
eventEquations = And @@ Thread[(𝒫 @@@ allEvents) ==
          Sum[λ[k] allPoints[[k]], {k, Length[allPoints]}]]

λs = Table[λ[k], {k, Length[allPoints]}];
𝒫s = 𝒫 @@@ allEvents;
(* do the work *)
res = (Exists @@ {λs, Element[λs, Reals] && Element[𝒫s, Reals] &&
       (Sequence @@  (# > 0& /@ λs)) &&
       0 < (Plus @@ λs) < 1, eventEquations}) // Resolve;

(* select nontrivial inequalities *)
Cases[(Select[Flatten[res /. {Or -> List, And -> List}],
        Count[#, 𝒫[_, _], Infinity] == 4&] /. Less -> LessEqual) // Union,
      _?(MemberQ[Subtract @@ #, _Integer]&)]

Here is a more complicated example from quantum physics. The following proves that the four Bell-like inequalities in the second argument of the ForAll imply the existence of joint probability distributions for the three-particle Greenberger–Horne–Zeilinger state [407✶], [1125✶], [124✶], [88✶], [1050✶], [1715✶], [1514✶], [286✶].

ForAll[{p[A], p[B], p[C], p[D], p[ABC]}, 
   (* hidden variable probabilities for the state 
      |ψ> = (|1;↑>|2;↑>|3;↑> - |1;↓>|2;↓>|3;↓>)/Sqrt[2])
      and the observables
      A == σ[1; x]⊗σ[2; y]⊗σ[3; y],
      B == σ[1; y]⊗σ[2; x]⊗σ[3; y],
      C == σ[1; y]⊗σ[2; y]⊗σ[3; x],
      D == A⊗B⊗C *)
   0 <= p[A] <= 1 && 0 <= p[B] <= 1 && 
   0 <= p[C] <= 1 && 0 <= p[D] <= 1 && 
   (* expectation values expressed through probabilities 
      𝔼[α] == p[α] - p[!α] == -1 + 2 p[α];
      Bell-like inequalities *)
   -2 <=  2 p[A] + 2 p[B] + 2 p[C] - 2 p[D] - 2 <= 2 && 
   -2 <= -2 p[A] + 2 p[B] + 2 p[C] - 2 p[D] <= 2 && 
   -2 <=  2 p[A] - 2 p[B] + 2 p[C] - 2 p[D] <= 2 && 
   -2 <=  2 p[A] + 2 p[B] - 2 p[C] - 2 p[D] <= 2, 
  Exists[(* joint probability distributions *)
   {P[A, B, C], P[!A, B, C], P[A, !B, C], P[A, B, !C], 
    P[!A, !B, C], P[!A, B, !C], P[A, !B, !C]},
    (* conditions on joint probability distributions *)
    0 <= P[A, B, C]   <= 1 && 0 <= P[!A, B, C]  <= 1 && 
    0 <= P[A, !B, C]  <= 1 && 0 <= P[A, B, !C]  <= 1 && 
    0 <= P[!A, !B, C] <= 1 && 0 <= P[!A, B, !C] <= 1 && 
    0 <= P[A, !B, !C] <= 1, 
   (* locality assumptions *)
   p[A] == P[A, B, C] + P[A, B, !C] + P[A, !B, C] + P[A, !B, !C] && 
   p[B] == P[A, B, C] + P[A, B, !C] + P[!A, B, C] + P[!A, B, !C] && 
   p[C] == P[A, B, C] + P[A, !B, C] + P[!A, B, C] + P[!A, !B, C]]] // 
                                                              Resolve

Quantifier elimination is also used in computer graphics. We start with a simple example. Given a rationally parametrized circle of radius 𝓇, what is a description of all points in maximal distance ε from the circle [1291✶]?

distanceSquared = #.#&[{x, y} - 𝓇ρ {2t, t^2 - 1}/(t^2 + 1)]

Exists[t, Element[{t, x, y, 𝓇ρ, εSquared}, Reals] && 𝓇ρ > 0,
       distanceSquared < εSquared] // Resolve

Here is a visualization of the resulting geometric figure—a ring.

With[{εSquared = 0.1, 𝓇 = 1},
ContourPlot[𝓇^2 + x^2 + y^2 - 2 Sqrt[𝓇^2 x^2 + 𝓇^2 y^2],
            {x, -2, 2}, {y, -2, 2},
            PlotPoints -> 30, Contours -> {Sqrt[εSquared]}]]

Next we determine the conditions so that a disk and the inside of a parabola intersect.

Exists[{x, y}, Element[{x, y, ξ, η}, Reals],
        1 - x - 2 y^2 > 0 && 
        (x - ξ)^2 + (y - η)^2 < 1/64] // Resolve

Here are two examples of this situation.

Show[GraphicsArray[
ContourPlot[1 - x - 2 y^2, {x, -2, 2}, {y, -2, 2},
            Contours -> {0}, ContourLines -> False,
            DisplayFunction -> Identity,
            PlotPoints -> 50, Epilog -> {Hue[0], (* the disk *)
               Disk[{%[[1, 2, 2]] /. η -> N[#], #}, 1/Sqrt[64]]}]& /@
               {-1, 1/2}]]

Here is another example. This time we start with a genuine 2D figure—a square. By taking again all points within a given distance from any square point, we smooth out the corners of the square.

Exists[{x, y}, Element[{x, y, ξ, η}, Reals],
       (* the square *) -1 <= x <= 1 && -1 <= y <= 1 && 
       (x - ξ)^2 + (y - η)^2 < 1/4] // Resolve

The following picture shows the resulting square with the smoothed corners as well circles of radius 1/2 along the boundary points of the original square.

With[{pp = 12, qq = 8},
Show[Graphics[
{{Hue[0], (* the smoothed square *)
  Polygon[Join[Table[{η, -1 - Sqrt[-3 - 8 η - 4 η^2]/2}, 
                {η, -3/2, -1, 1/2/pp}],
          Reverse[Table[{η, 1 + Sqrt[-3 - 8 η - 4 η^2]/2}, 
                {η, -3/2, -1, 1/2/pp}]]]],
  Polygon[Join[Table[{η, -3/2}, {η, -1, 1, 1/pp}],
          Reverse[Table[{η, 3/2}, {η, -1, 1, 1/pp}]]]],
  Polygon[Join[Table[{η, -1 - Sqrt[-3 + 8 η - 4 η^2]/2}, 
                {η, 1, 3/2, 1/2/pp}],
          Reverse[Table[{η, 1 + Sqrt[-3 + 8 η - 4 η^2]/2}, 
                {η, 1, 3/2, 1/2/pp}]]]]} // N,
{GrayLevel[1/2], Thickness[0.002],
 (* circles of radius 1/2 along the 
    boundary of the original square *)
 Circle[#, 1/2]& /@ Join[
  Table[{ x, -1}, {x, -1, 1, 2/qq}], Table[{ x,  1}, {x, -1, 1, 2/qq}],
  Table[{-1,  y}, {y, -1, 1, 2/qq}], Table[{ 1,  y}, {y, -1, 1, 2/qq}]]},                
{GrayLevel[0], (* the original square *) Rectangle[{-1, -1}, {1, 1}]}}],
     Frame -> True, PlotRange -> All, AspectRatio -> Automatic]]

Another application of quantifier elimination are Minkowski sums and products [554✶], [555✶], [556✶], [557✶], [558✶]. Let us find all points {ξ,η}, such that 𝓅(ξ+i η) is a point in the unit circle for a given polynomial 𝓅. toConditions expresses the real and imaginary part of 𝓅(X+i Y) as a function of X and Y.

toConditions[p_, z_, {{x_, y_}, {X_, Y_}}] := 
And @@ Thread[{x, y} == ComplexExpand[{Re[#], Im[#]}&[
                                    p /. z -> X + I Y]]]

We will use the polynomial 𝓅(z)=(z^8)+(z^7)+(z^6)+(z^5)+(z^4)+(z^3)+(z^2)+z+1.

𝓅 =.;
𝓅[z_] := Sum[z^k, {k, 0, 8}];

The following is an implicit description of the points ξ+i η such that |𝓅(ξ+i η)|≤1.

Exists[{x, y}, Element[{x, y, ξ, η}, Reals],
       x^2 + y^2 <= 1 &&
       toConditions[𝓅[z], z, {{x, y}, {ξ, η}}]] // Resolve

Here is this region visualized. The right picture displays the boundaries of the left region(s) under the mapping z->𝓅(z) yields the unit circle.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity, cp},
{cp = ContourPlot[(* extract bivariate polynomial *)
                  Evaluate[Cases[%, _Plus, Infinity, 1][[1]]], 
                  {ξ, -3/2, 3/2}, {η, -3/2, 3/2}, 
                  Contours -> {0}, PlotPoints -> 200],
 Show[Graphics[cp] /. (pl:(Polygon | Line))[l_] :>
                 (* map lines and polygons *)
                  pl[{Re[#], Im[#]}& /@ (𝓅[{1, I}.#]& /@ l)],
          PlotRange -> {{-3/2, 3/2}, {-3/2, 3/2}}]}]]]

Another area of application of quantifier elimination is the detection of collisions between (moving) bodies [1650✶]. The following input calculates the possible centers along the vertical axis of an ellipse moving in a circle.

Clear[x, y, mx, r];
ForAll[{x, y}, Element[{x, y, r, mx}, Reals] && r > 0,
	   Implies[x^2/2^2 + y^2 - 1 < 0,
               (x - mx)^2 + (y - 0)^2 < r^2]] // Resolve

Here is a more complicated example. A unit square is moving in the x,y-plane along the path parametrized by {t, (t^2)}. At the same time a disk is moving along a straight path parametrized by {t,2t +(Subscript[y, 0])}. Is there any time t where the square and the disk will collide? Here are the paths of the centers of the square and the disk.

squarePath[t_] = {t, t^2};
diskPath[t_, y0_] = {t, 2 t + y0};

For (Subscript[y, 0])=-3, the square and the disk will never collide, meaning there is no time t that the square and the circle overlap.

collision[y0_] := Resolve[
Exists[{t, x, y}, Element[{t, x, y}, Reals],
	   -1 < x - squarePath[t][[1]] < 1 && 
       -1 < y - squarePath[t][[2]] < 1 &&
       (#.#&[{x, y} - diskPath[t, y0]]) < 1]]

collision[-3]

A picture confirms this answer (time goes vertically).

motionPicture[y0_, opts___] :=
Show[Graphics3D[{
    (* the moving square *)
    {SurfaceColor[Hue[0], Hue[0], 2.3], 
     Table[Polygon[Table[Append[squarePath[t], t] +
                   {Cos[φ], Sin[φ], 0}, {φ, Pi/4, 7 Pi/4, Pi/2}]],
                         {t, -3, 3, 6/30}]},
    (* the moving disk *)
    {SurfaceColor[Hue[0.12], Hue[0.12], 2.3], 
     Table[Polygon[Table[Append[diskPath[t, y0], t] +
             {Cos[φ], Sin[φ], 0}, {φ, Pi/4, 9 Pi/4, Pi/12}]],
                        {t, -3, 3, 6/30}]}}] // N, opts]

motionPicture[-3, ViewPoint -> {4, 2, 1}]

For (Subscript[y, 0])=3, the square and the disk will collide.

collision[3]

A picture shows two time intervals of collision.

motionPicture[3, ViewPoint -> {0, 2, 1}]

By not eliminating the variable t, we obtain the time intervals of collision.

Exists[{x, y}, Element[{t, x, y}, Reals],
	   -1 < x - squarePath[t][[1]] < 1 && 
       -1 < y - squarePath[t][[2]] < 1 &&
       (#.#&[{x, y} - diskPath[t, 3]]) < 1] // Resolve

Using a symbolic (Subscript[y, 0]), we obtain conditions on (Subscript[y, 0]) such that a collision occurs.

Exists[{x, y}, Element[{t, x, y, y0}, Reals],
	   -1 < x - squarePath[t][[1]] < 1 && 
       -1 < y - squarePath[t][[2]] < 1 &&
       (#.#&[{x, y} - diskPath[t, y0]]) < 1] // Resolve

For y0>-3, a collision will never happen.

Exists[{t, x, y}, Element[{t, x, y, y0}, Reals],
	   -1 < x - squarePath[t][[1]] < 1 && 
       -1 < y - squarePath[t][[2]] < 1 &&
       (#.#&[{x, y} - diskPath[t, y0]]) < 1] // Resolve

For problems in which all quantified variables appear linearly, the execution speed of Resolve will be much larger and it is possible to deal with examples involving more variables. The next example [738✶] deals with the conditions on the sum of the rows, the columns, the diagonal, and the antidiagonal of a matrix. We assume all matrix entries to have possible values from the interval {-1,1}.

dim = 3;
mat = Table[a[i, j], {i, dim}, {j, dim}];

This is the set of conditions.

Clear[a, A, B];
eqs = And @@ Join[
MapIndexed[((Plus @@ #1) == A[#2[[1]]])&, mat, {1}],
MapIndexed[((Plus @@ #1) == B[#2[[1]]])&, Transpose[mat], {1}],
{Tr[mat] == C[1], Tr[Reverse /@ mat] == C[2]},           
Map[-1 < # < 1&, Flatten[mat]]]

(res = Exists[Evaluate[Flatten[mat]],
	          Element[Join[Flatten[mat], 
			               Table[A[k], {k, dim}], 
			               Table[B[k], {k, dim}],
	                       Table[C[k], {k, 2}]], Reals],
              eqs] // Resolve);

The result is quite large; it consists of 36 individual parts.

Length[DeleteCases[res, _Element]]

Here is the first of the resulting conditions on the A[i], B[i], and C[i].

DeleteCases[res, _Element][[1]]

Many more problems can be solved using quantifier elimination; see [445✶], [226✶], [444✶], [446✶], [1505✶], [1506✶], [1175✶], [47✶], [726✶], [727✶], and [133✶], [135✶] for many nice examples. For details about quantifier elimination in Mathematica, see [1502✶]. We will end with a last example showing a straightforward (although esoteric) way to calculate the limit of the rational function (2 (x^3)-4 x+6)/(7 (x^3)-5 x+9) as x tends to +∞ via the following definition of the limit λ [60✶]:

(Subscript[∀, ε,ε>0])((Subscript[∃, X,X>0])((Subscript[∀, x,x>X∧λ∈ℝ])λ-ε<((2 (x^3)-4 x+6)/(7 (x^3)-5 x+9))<λ+ε)).

ForAll[ε, ε > 0, 
       Exists[X, X > 0, 
         ForAll[x, x > X && Element[ℓ𝒾𝓂𝒾𝓉, Reals],
         ℓ𝒾𝓂𝒾𝓉 -  ε < (2x^3 - 4x + 6)/(7x^3 - 5x + 9) < ℓ𝒾𝓂𝒾𝓉 + ε]]] // 
                                                                Resolve

1.3 Operations on Rational Functions

The commands Numerator and Denominator introduced at the beginning (Subsection 2.4.1 of the Programming volume [1559✶] of the GuideBooks) work for rational numbers and for rational functions, that is, for fractions of polynomials. Here is an example.

ratio = (3 + 6 x + 6 x^2)/(5 y + 6 y^3)

Numerator[ratio]

Denominator[ratio]

The parts of a product that belong to the numerator and the parts that belong to the denominator are determined by the sign of the associated exponents after transformations of the form 1/k^(-l) -> k^l.

expr = a b^2 c^-2 d^(4/3) e^-(5/6) 1/f^(-12/13) g^h i^-j 1/k^-l Exp[-E^2]

{Numerator[expr], Denominator[expr]}

Here is a nested fraction.

nestedFraction = (a/(b + 1) + 2)/(c/(d + 3) + 4)

For nested fractions the functions Numerator and Denominator take into account only the “outermost” structure.

{Numerator[#], Denominator[#]}&[nestedFraction]

For fractions, the command Expand, which multiplies out polynomials, is divided into four parts to facilitate working on the numerators and denominators.

We now look at the effect of these four commands on the sum of two ratios of polynomials.

ratio = (1 + 7 y^3)/(2 + 8 x^3)^2 + (1 + 6 x)^3/(1 - 4 y)^2

Except for the lexicographic reordering of the two partial sums, Mathematica did not do anything to this input automatically. 
Now, all numerators are multiplied out, and all resulting parts are individually divided.

Expand[ratio]

ExpandNumerator also multiplies out, but does not divide the terms individually.

ExpandNumerator[ratio]

With ExpandDenominator, the numerator remains unchanged, and only the denominator is multiplied out.

ExpandDenominator[ratio]

Finally, we multiply everything out. ExpandAll typically produces the largest expressions. Now, the numerator is multiplied out and each of its terms is written over the expanded form of the denominator.

ExpandAll[ratio]

In the following example, the same happens. Be aware that no common factors are cancelled.

ExpandAll[(1 - x^4)/(1 + x^2)^2]

In nested fractions, ExpandAll works again only the “outermost” structure.

ExpandAll[nestedFraction]

Mapping ExpandAll to all parts allows us to expand all parts.

FixedPoint[MapAll[ExpandAll, #]&, nestedFraction]

Be aware that there is a difference between Expand //@ expr and ExpandAll[expr]. ExpandAll does not automatically recursively expanded in the inner levels of expressions with Hold-like attributes.

{Expand //@ #, ExpandAll[#]}&[(α + β)^2 + Hold[(α + β)^2]]

Here is a small application of ExpandAll. Forming a matrix out of the first d rows of the Pascal triangle by right justifying them and filling in zeros into the empty spaces yields a matrix whose eigenvalues are modulo sign powers of the golden ratio. The next input is a one-liner that for a given positive d, returns the eigenvalues in the form ±(ϕ^k) [1254✶]. We first approximate k numerically and then confirm the value of k using exact numerics.

pascalMatrixEigenvalues[d_Integer?Positive] :=
Function[ev, Sign[ev] GoldenRatio^If[
             (* faster than cancelling *) ExpandAll[
                   Abs[ev]/((Sqrt[5] + 1)/2)^#] == 1, #]&[
                          Round[N[Log[GoldenRatio, Abs[ev]], 
                                   $MachinePrecision + 1]]]] /@
    Eigenvalues[Table[Binomial[n, k], {n, 0, d - 1}, {k, d - 1, 0, -1}]]

Here is an example.

pascalMatrixEigenvalues[16] // TraditionalForm

Because ExpandAll can greatly expand (the size of) an expression, sometimes we want to multiply out only certain parts of a rational expression. This can be accomplished with ExpandAll using its second argument.

In the following example, only those terms (in either the numerator or the denominator) that contain z are multiplied out.

ExpandAll[(1 + x^3)^3/(2 + z)^4 + (3 + z)^2/(r + 5)^2, z]

There is still another important command for manipulating rational functions.

Apart leads to the simplest possible denominators, exactly those that are needed for the textbook integration of rational expressions. Here are three examples. The denominators are irreducible polynomials that are potentially raised to a power.

Apart[(1 + 5 x + 6 x^2)/(1 - x^8)]

Apart[1/((x - 1)^12(x - 100))]

Apart[1/(1 - x) 1/(1 - x^2) 1/(1 - x^3)]

In the following example the roots of the denominator polynomials are symbolic coefficients.

Apart[(x - a1)(x - a2)(x - a3)/((x - b1)(x - b2)(x - b3)(x - b4)), x]

So far, we have only expanded rational functions. We now look at making them (in most cases) smaller. For this the relevant commands are Together, Cancel, and Factor.

Here are some examples with the rational function ratio defined earlier.

ratio

Over one denominator, we get the following result.

Together[ratio]

Along with replacement rules, Together is a very important command for effective simplification of expressions. We now look at an example of a Cauchy determinant [982✶]. Consider an n×n matrix with elements 1/((Subscript[a, i])+(Subscript[b, j])).

det((1/((Subscript[a, i])+(Subscript[b, j]))))=(((∏_((i,j=1)/(i<j))^n)((Subscript[a, i])-(Subscript[a, j]))((Subscript[b, i])-(Subscript[b, j])))/((∏_(i,j=1)^n)((Subscript[a, i])+(Subscript[b, j]))))

CauchyDetIdentity[dim_] :=
 Det[Outer[1/(#1 + #2)&, Array[a, dim], Array[b, dim]]] -
 Product[(a[i] - a[j])(b[i] - b[j]), {j, dim}, {i, j + 1, dim}]/
 Product[(a[i] + b[j]), {j, dim}, {i, dim}]

Timing[Together[CauchyDetIdentity[4]]]

Here is another example of the power of Together. In [825✶], the following identity was given:

(∑_(k=0)^n)(1/(k+α))(({{n}, {k}})) (((∂^k)((f(x))^(-k-α)))/(∂(x^k))) (((∂^(n-k))((f(x))^(k+α)))/(∂(x^(n-k))))=0, n∈(SuperPlus[ℕ]),α∈ℂ.

We will check this identity explicitly for n≤12. We measure the time Together needs as well as the leaf count of the expression.

differentiationIdentity[n_] :=
Sum[1/(α + k) Binomial[n, k] D[f[x]^(-α - k), {x, k}]*
                             D[f[x]^(+α + k), {x, n - k}], {k, 0, n}]

Module[{sum},
Table[sum = differentiationIdentity[n];
      {n, LeafCount[sum], Timing[Together[sum]]}, {n, 12}]]

Here is another stress test for Together: Consider the recursive definition (two term Gale–Robinson sequence [716✶], [615✶], [587✶], [40✶]) (Subscript[y, k])=(α (Subscript[y, k+p-n])(Subscript[y, k-p])+β (Subscript[y, k+q-n])(Subscript[y, k-q]))/(Subscript[y, k-n]) with p≥1, q≥p, n≥2q. While the definition suggests that (Subscript[y, k]) is a rational function of the n-1 initial values (Subscript[y, j])=(Subscript[Y, j]), j=1,…,n-1, the (Subscript[y, k]) turn out to be Laurent polynomials in the (Subscript[Y, j]). The next input implements a function to set up definitions for (Subscript[y, k]) for given integers p, q, and n. To write the (Subscript[y, k]) as a Laurent polynomial, we use Together to cancel common factors.

makeTwoTermGaleRobinsonDefinitions[{p_, q_, n_}, {η_, α_, β_, Y_}] := 
((* recursive definition *)
 η[k_] := η[k] = Expand[Together[(α η[k + p - n] η[k - p] + 
                                  β η[k + q - n] η[k - q])/η[k - n]]];
 (* initial conditions *)
 η[k_?((0 <= # <= n - 1)&)] := η[k] = Y[k]) /;
    (* conditions *)
    (And @@ Positive[{p, q, n}]) && (And @@ (IntegerQ /@ {p, q, n})) &&
     q > p && n >= 2q

Here are the first seven (Subscript[y, k]) for p=1, q=2, and n=5.

makeTwoTermGaleRobinsonDefinitions[{1, 2, 5}, {y, α, β, Y}]

Table[y[k], {k, 7}] // Together

Because higher (Subscript[y, k]) grow dramatically in size, we define a function LaurentPolynomialQ that checks if its argument is a Laurent polynomial (meaning no sums appear in denominators).

LaurentPolynomialQ[expr_] := FreeQ[Head /@ Denominator[
   If[Head[#] === Plus, List @@ #, {#}]&[Expand[expr]]], Plus]

The next input quickly checks whether the first 18 of the (Subscript[y, k]) are Laurent polynomials ((Subscript[y, 18]) has more than 1000 terms).

Table[{Length[y[k]], LaurentPolynomialQ[y[k]]}, {k, 18}]

Here is a hidden zero (the expression zero[𝓈] is 0 for almost all complex 𝓈) [279✶], [945✶], [134✶]. This time the expression is not a clean rational function, but it contains rational powers.

zero[𝓈_] = With[{x = 𝓈^(1/(𝓈 - 1)), y = 𝓈^(𝓈/(𝓈 - 1))}, x^y - y^x]

For certain rational 𝓈, the expression zero[𝓈] does not autoevaluate to 0.

zero[2/5]

Applying Together yields 0.

Together[%]

Together is a very useful function for simplification. It is often faster and sometimes even more powerful than Simplify..

Now let us deal with the function Cancel. Common factors in numerators and denominators of rational functions are not removed, except when they appear already explicitly as factors.

Expand[(x^2 - 1) (x^2 + 1)]/((x^2 - 1)(x^2 + 1))

However, using Cancel, we can force the cancellation.

Cancel[%]

Common factors are not canceled without the explicit use of Cancel if they do not appear explicitly factored already. The two expressions above actually represent different functions. The original is not even defined at x=±1.

%% /. x -> 1

Because this is a removable singularity, we are usually not too concerned about it. However, there is a theoretical difference between the functions ((x^4)-1)/(((x^2)-1)((x^2)+1)) and 1; the first is from a computational point of view not defined at x=1. But within Mathematica’s philosophy to carry out all operations that are correct for generic values of indeterminates, it is correct to cancel common factors. But because of efficiency reasons, this is not done automatically.

Factor @ Cancel[(x^24 - y^24)/(x + y)]

Finally, we give an example of the use of Factor with a rational function. Here, we get a single fraction with a factorized denominator and a factorized numerator. Terms that can be canceled from the numerator and denominator are removed.

Factor[(1 - x^4)^2/(1 + x^8)^3 - (1 + x^8)^3/(1 - x^4)^2]

In the following example, the factor 1+(x^2), common to numerator and denominator, is cancelled.

Cancel[(1 - x^4)/(1 + x^2)^2]

Cancel will not cancel common algebraic factors without being told.

Expand[(x - Sqrt[2])(x - Sqrt[6])(x - Sqrt[12])]/(x - Sqrt[2]) // Cancel

Similar to Factor, Cancel has the option Extension.

Options[Cancel]

Using the Extension option (the possible settings are the same as in Factor), we can cancel the common factor.

Expand[(x - Sqrt[2])(x - Sqrt[6])(x - Sqrt[12])]/(x - Sqrt[2]) // 
	   Cancel[#, Extension -> Automatic]&

Let us give a simple graphics\[Hyphen]generating application of Together. We will visualize the interior of the well known modular domain ℱ𝒟={z\[VerticalSeparator]-1/2<Re(z)<1/2∧\[LeftBracketingBar]z\[RightBracketingBar]>1} under repeated applications of the maps z->z±1 and z->-1/z (for the underlying mathematics, see for instance [550\[SixPointedStar]], [663\[SixPointedStar]], and [228\[SixPointedStar]]). Starting with the identity map z->z, we will recursively generate all maps resulting from applying the translation and inversion operation. The first occurrences of the maps will be collected in lists 𝓂𝒶𝓅𝓈[k]. Together is used to canonicalize the resulting rational functions of the form (a+b z)/(c + d z).

o = 12; 
𝓂𝒶𝓅𝓈[0] = {z}; 
doneQ[z] = True;
Do[𝓂𝒶𝓅𝓈[k] = Complement[#, (* select new maps *)Select[#, doneQ]]&[
             Union[(* canonicalize *) Together[(* form next maps *)
              Join[(# + 1)& /@ #, (# - 1)& /@ #, (-1/#)& /@ #]]]&[
                                                     𝓂𝒶𝓅𝓈[k - 1]]];
   (doneQ[#] = True)& /@ 𝓂𝒶𝓅𝓈[k], {k, o}]

The following list shows the number of newly occurring maps after k steps.

Table[{k, Length[𝓂𝒶𝓅𝓈[k]]}, {k, 0, o}]

Here are a few of the maps from the last calculated step.

{Take[𝓂𝒶𝓅𝓈[o], 5], Take[𝓂𝒶𝓅𝓈[o], -5]}

We approximate the region ℱ𝒟 as a polygon through the list ℱ𝒟PolygonPoints (instead of letting the region extend vertically to ∞ we use a large upper vertex).

ℱ𝒟PolygonPoints = 
With[{pp = 20, ε = 10^-12}, Polygon[Join @@ 
{(* left vertical boundary *)
 Reverse @ Table[1/2 + I Tan[ArcTan[(1 - t) Sqrt[3]/2] + t Pi/2], 
                 {t, 0, 1 - ε, (1 - ε)/pp}],
 (* circular part of the boundary *)
           Table[Exp[I Pi/3 (1 + t)], {t, 0, 1, 1/pp}],
 (* right vertical boundary *)          
           Table[-1/2 + I Tan[ArcTan[(1 - t) Sqrt[3]/2] + t Pi/2], 
                 {t, 0, 1 - ε, (1 - ε)/pp}]} // N]];

Using now the maps from 𝓂𝒶𝓅𝓈[k] to map the fundamental domain and coloring successive levels black and white, we obtain the following graphic. (We restrict the visible plot range to the neighborhood of the origin.) The graphic nicely shows how the images of the fundamental domain tessellate the upper half-plane.

mapℱ𝒟PolygonPoints[f_] :=
With[{𝒻 = Function @@ {z, f}}, Map[{Re[#], Im[#]}&, 
     Map[𝒻, ℱ𝒟PolygonPoints, {2}], {2}]]

ℱ𝒟𝒢 = Show[Graphics[{
 Table[{GrayLevel[Mod[k, 2]], mapℱ𝒟PolygonPoints[#]& /@ 𝓂𝒶𝓅𝓈[k]}, 
       {k, 0, o}]}], PlotRange -> {{-1, 1}, {0, 1}}, Frame -> True, 
                     AspectRatio -> Automatic, FrameTicks -> False]

Applying a logarithmic transformation shows better the images of ℱ𝒟 near the real axis (this time we use a random coloring). We also show a version resulting from mapping from the strip -1/2<Re(z)<1/2 to the unit disk and from the x-unit interval to the circle.

(* remove far outside points *)
ℱ𝒟𝒢ℛ[ξ_] := ℱ𝒟𝒢ℛ[ξ] = ℱ𝒟𝒢 /. Polygon[l_] :> Polygon[l /. 
  {x_, y_} :> {Which[x < -ξ, -ξ, -ξ <= x <= ξ, x, x > ξ, ξ], y}];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
  {(* vertically stretched version *)
   Show[ℱ𝒟𝒢ℛ[1] /. Polygon[l_] :> {Hue[Random[]], 
     (* stretch vertically *) Polygon[{#1, Log[#2]}& @@@ l]}, 
        PlotRange -> {All, {1, -5}}, AspectRatio -> 1/3],
   (* strip to unit disk *) Off[General::unfl];
   Show[ℱ𝒟𝒢ℛ[1/2] /. Polygon[l_] :> {(* map to unit circle *) 
     Polygon[Exp[-2Pi #2]{Cos[2Pi #1], Sin[2Pi #1]}& @@@ l]}, 
        PlotRange -> All, AspectRatio -> 1],
   (* unit interval to unit disk *) On[General::unfl];
   Show[ℱ𝒟𝒢ℛ[1] /. Polygon[l_] :> Polygon[l /. (* map radially *)
     {x_, y_} :> {x, Which[y < -1, -1, -1 <= y <= 1, y, y > 1, 1]}] /. 
     Polygon[l_] :> {Polygon[-Log[#2] {Cos[Pi #1], Sin[Pi #1]}& @@@ l]}, 
     PlotRange -> 4 {{-1, 1}, {-1, 1}}]}]]]

1.4 Operations on Trigonometric Expressions

Trigonometric functions are treated by TrigFactor and TrigExpand as discussed in Chapter 3 of the Programming volume [1559✶] of the GuideBooks. Thus, for example, TrigFactor[trigExpression] writes powers of the trigonometric functions in trigExpression as sums of trigonometric functions with sum arguments, and TrigExpand[trigExpression] writes trigonometric functions in trigExpression with sum arguments as sums of powers of trigonometric functions with simple variables. 
Here is an example of multiplying out an expression.

TrigExpand[Sin[2 x + 3 y]]

We can factor to get back to our original expression.

TrigFactor[%]

The arguments of the trigonometric functions must have heads Plus or Times or Power (with an integer second argument) to allow for an expansion.

TrigExpand[Sin[(x + y)^2]]

Trigonometric expressions will not be automatically simplified. This example remains unchanged.

Sin[x]^2 + Cos[x]^2

We must force the simplification with Simplify.

Simplify[%]

In this case, TrigFactor and TrigExpand would have led to the same result.

{TrigExpand[#], TrigFactor[#]}& @ (Sin[x]^2 + Cos[x]^2)

In Chapter 2 of the Programming volume [1559✶] of the GuideBooks, we have already seen that trigFunction[inverseTrigFunction[var]] will be simplified.

Cos[ArcSin[z]]

However, frequently we have to deal with complicated expressions with a similar structure, such as this example.

Cos[5 ArcSin[z]]

TrigExpand[%]

TrigExpand can be used to generate the well-known addition formulas for trigonometric functions.

TrigExpand[Sin[x + y]]

TrigExpand[Tan[x + y]]

It would be nice to have the addition theorem for tan(x+y) containing only the functions tan(x), tan(y), and tan(x+y) and not sin and cos. Using the above-discussed function GroebnerBasis it is straightforward to implement a little routine that generates an addition formula of this form.

makeAdditionTheorem[f_] := 
Module[{trigFunction, vars, repRules, definitions, 
        addFormula, toKeep, toEliminate, gb, revRepRules},
 (* the trigonometric function under consideration *)
 trigFunction = Head[f];
  (* the variables *)
 vars = Cases[f, _Symbol, {-1}];
 (* introduce dummies to avoid autoevaluation *)
 repRules = {Sin -> sin, Cos -> cos, Tan -> tan,
             Cot -> cot, Sec -> sec, Csc -> csc};
 (* give dummies the same properties as the 
    corresponding trigonometric functions;
    write identities in polynomial form *)
 definitions = Flatten[Numerator[Together[
   {sin[#]^2 + cos[#]^2 - 1, 
    tan[#] - sin[#]/cos[#], cot[#] - cos[#]/sin[#], 
    sec[#] - 1/cos[#], csc[#] - 1/sin[#]}]]& /@ vars];
 (* the addition formula *)
 addFormula = Numerator[Together[
    (f /. repRules) - (TrigExpand[f] /. repRules)]]; 
 (* the dummy trigonometric functions to keep *)
 toKeep = Flatten[{trigFunction /@ vars, f} /. repRules];
 (* the dummy trigonometric functions to eliminate *)
 toEliminate = 
 Complement[Flatten[{sin[#], cos[#], tan[#], 
                     cot[#], sec[#], csc[#]}& /@ vars], toKeep];   
 (* do the elimination *)
 gb = GroebnerBasis[Join[{addFormula}, definitions],
                    toKeep, toEliminate,
                    MonomialOrder -> EliminationOrder];
 (* simplify result *)
 res = Simplify[First[gb]];
 (* replace dummies by original trigonometric functions *)
 revRepRules = Reverse /@ repRules;
 (* return held result to avoid autoevaluation *)
 HoldForm @@ {res /. revRepRules}]

Here are the addition formulas for the six trigonometric functions that contain only the function itself.

makeAdditionTheorem[#[x + y]]& /@ 
           {Sin, Cos, Tan, Cot, Sec, Csc}

A third way to write trigonometric expressions is the use of arguments that are sums.

Both TrigExpand and TrigFactor do nothing with the following expression.

{TrigExpand[Sin[x]^3 Cos[y]^4], TrigFactor[Sin[x]^3 Cos[y]^4]}

TrigReduce rewrites the expression in a sum of trigonometric functions linear in x and y.

TrigReduce[Sin[x]^3 Cos[y]^4]

Often, it is very useful to convert from a trigonometric representation to an exponential one and vice versa. The functions ExpToTrig and TrigToExp carry out this transformation.

Here are three examples. Inverse trigonometric and hyperbolic functions are rewritten as logarithms.

TrigToExp[{Sin[z], Cosh[z], ArcTan[z], ArcCsch[z]}]

ExpTroTrig transforms exponentials back, but it leaves logarithms alone.

ExpToTrig[%]

Single exponentials are converted to trigonometric or hyperbolic functions.

ExpToTrig[{Exp[x], Exp[I x]}]

TrigToExp can conveniently be used to prove the representations of π as sums of arctans. Here is a typical example.

8 ArcTan[1/5] - 2 ArcTan[1/239]

Expand[TrigToExp[8 ArcTan[1/5] - 2 ArcTan[1/239]]]

After exponentiating this formula, we get just i.

Together[Exp[I %]]

Taking the logarithm and making sure by numerical evaluations that the two expressions corresponded to the same branch of the logarithm, this shows that 8 (tan^(-1))((1/5))-2 (tan^(-1))((1/239))=(π/2).

TrigToExp also works for hyperbolic and inverse hyperbolic functions. Here, we use it to simplify sinh(2 (tanh^(-1))(ξ)) sinh(log(1/ξ)).

Sinh[2 ArcTanh[ξ]] Sinh[Log[1/ξ]] // TrigToExp

Together[%]

In dealing with trigonometric and hyperbolic functions, we frequently write the imaginary unit i explicitly, so that all variables involved are expected to be purely real valued. However, Mathematica assumes automatically that all variables appearing in an expression can assume arbitrary complex values. This situation can be dealt with using ComplexExpand.

Here is a simple example. The real and imaginary parts are given separately.

ComplexExpand[Sin[x + I a] + Cos[(y + 5I s)^2] +
              Exp[u + I o] + Re[t + o I]]

Here is another example that contains some different functions.

ComplexExpand[Log[x + I y] + 1/Tan[x + I y] + (x + I y)^(x + I y)]

The command ComplexExpand has one option.

Options[ComplexExpand]

Here, the expression (e^(i x))ln(y) is decomposed in three different ways in terms of real and imaginary parts.

ComplexExpand[Exp[I x] Log[y], TargetFunctions -> {Re, Im}]

ComplexExpand[Exp[I x] Log[y], TargetFunctions -> {Abs, Arg}]

ComplexExpand[Exp[I x] Log[y], TargetFunctions -> {Sign}]

Next we try all possible 63 combinations of target functions. We obtain four different results from ComplexExpand.

allCombinations = Join @@ Table[Flatten[Table[
   Table[{Re, Im, Abs, Arg, Conjugate, Sign}[[x[k]]], {k, n}],
      Evaluate[Sequence @@ 
       Table[{x[k], If[k === 1, 1, x[k - 1] + 1], 6}, {k, n}]]], n - 1],
              {n, 6}];

Short[allCombinations, 4]

Here are these four results. The first argument of each sublist contains the target functions that produce the second argument.

{First /@ #, #[[1, 2]]}& /@ 
Split[Sort[{#, ComplexExpand[Exp[I x] Log[y], 
                        TargetFunctions -> #]}& /@ allCombinations,
     OrderedQ[{#1[[2]], #2[[2]]}]&], #1[[2]] == #2[[2]]&]

When simplifying expressions involving a variable that takes only real values, we frequently want to reduce to x.

(x^2)^(1/2)

This can be achieved using PowerExpand (or using corresponding replacement rules).

Note that the assumption ((((a^b)))^c)=(a^("bc")) does not always hold (see the discussion in Subsection 2.2.6 of the Programming volume [1559✶] of the GuideBooks). So one must be careful when using PowerExpand. 
Now, we get the “desired” result in the above root example.

PowerExpand[(x^2)^(1/2)]

Here is a demonstration of the effect of PowerExpand for general symbolic arguments.

{(x^a)^b, PowerExpand[(x^a)^b]}

A second “simplification” carried out by PowerExpand is to rewrite a logarithm of a product as the sum of logarithms of the single factors. Be aware that for arbitrary complex numbers, this is not an identity.

{Log[a b c], PowerExpand[Log[a b c]]}

1.5 Solution of Equations

By far, the most important built-in Mathematica function for solving systems of linear and nonlinear equations is Solve. (Also important for solving are the functions Roots and Reduce; they will be discussed below; in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks, we discussed already the functions NRoots and NSolve. In addition the function GroebnerBasis is also useful for solving equations; see the remarks at the end of this section.)

Solve has already been shortly discussed in Chapter 6 Programming volume [1559✶] of the GuideBooks for linear systems. We now discuss the meaning of a “generic” solution. Let us choose a simple example: a x+b=0. This is the solution calculated by Mathematica for this simple linear equation.

Solve[a x == b, x]

However, this solution does not make sense for the special case a=0, and solutions that would make sense in this setting are not produced by Solve! 
Here, b/a is the “generic” solution of the equation ax=b. For almost all (in the sense of the corresponding Lebesgue measure for the complex planes of the variables involved), the solution x=b/a is the correct solution. Solve will always return generic solutions. On lower dimensional subsets (which have the corresponding Lebesgue measure 0), solutions might either be missing or after substitution of explicit numerical value for variables, indeterminate quantities may arise.

There is no guarantee that Solve will solve a given set of equations. However, for purely algebraic equations, there is a good chance that it will give a solution. For a polynomial system, it will virtually always find a solution, although it may take quite some time and memory.

Let us start with univariate polynomials. In general (provided no factors can be explicitly removed), we can find the zeros in closed form using radicals only for univariate polynomials up to (and including) the fourth degree (see, e.g., [1586✶]). Mathematica implements closed analytic solutions for polynomials up to the fourth degree; they can be expressed explicitly in terms of roots. Nevertheless, finding the four zeros of a general polynomial of fourth degree takes up around 41 kB.

{ByteCount[#], LeafCount[#], Depth[#]}&[
    Solve[a x^4 + b x^3 + c x^2 + d x + e == 0, x]]

Be aware of the following fact when solving cubic polynomials. In the case when a cubic polynomial has three real roots and does not factor, the answer returned by Mathematica will contain, when numericalized, a term of the form verySmallNumber I. We will come back to this fact in a moment.

Solve[x^3 + x^2 - 12 x - 6 == 0, x] // N

Using high-precision arithmetic we get zeroWithFiniteAccuracy I instead of verySmallNumber I.

Solve[x^3 + x^2 - 12 x - 6 == 0, x] // N[#, 22]&

NRoots gives in this case purely real solutions.

NRoots[x^3 + x^2 - 12 x - 6 == 0, x]

This fact also means that the Mathematica paradigm to numericalize real and imaginary parts independently is not always possible to fulfill. The three roots of the following cubic are real.

NRoots[x^3 - 12x + 5 == 0, x]

Here is the symbolic expression as returned by Solve for one of them.

Solve[x^3 - 12x + 5 == 0, x]

Adding a purely real approximate number must result in a term approximativeZero I.

root1 = 4/((-5 + I Sqrt[231])/2)^(1/3) + ((-5 + I Sqrt[231])/2)^(1/3);

N[4, 100] + root1

Similarly, addition of an approximate real or imaginary zero will result in approximate imaginary and real parts.

root1 + 0``100

root1 + 0``100 I

As Abel, Ruffini, and Galois have shown [1544✶], [1280✶], it is generically impossible to express the roots of polynomials of degree five and higher in radicals (for the degree five and six exceptions see, [482✶] and [722✶]). In Mathematica, irreducible higher order polynomials will be solved for in Root-objects [1161✶]. We encountered Root-objects already in the last section. Now, let us deal with them in more detail.

Here is an example.

Solve[x^7 - 12x + 5 == 0, x]

Root-objects are representing complex numbers. As such, they can be calculated to any required precision.

N[%]

N[%%, 40]

Applying Re, Im, and Abs to a Root-object results in the automatic generation of a new Root-object. The following result shows that the first three roots were real.

Re[x /. %%%]

Im[x /. %%%%]

The absolute value of a complex-valued Root-object is typically the roots of a polynomial of degree 6×degreeOfTheOriginalPolynomial.

Abs[Last[x /. %%%%%]]

Root-objects can numericalize roots to any precision. The polynomial (x^n)+c((∑_(k=0)^(n-1))(x^k))=0 has for integer c one root this is near to an integer [474✶]. The following Root-object encodes this special root.

𝓃ℯ𝒶𝓇ℓ𝓎ℐ𝓃𝓉ℯℊℯ𝓇ℛℴℴ𝓉[n_?(# > 1&), c_?(# > 3&)] := 
  Root[Function[Evaluate[#^n + c Sum[#^k, {k, 0, n - 1}]]], 1]

For n=c=60, the resulting polynomial agrees with the nearest integer to more than 100 decimal digits.

Round[-Log[10, (Abs[# - Round[#]])&[N[𝓃ℯ𝒶𝓇ℓ𝓎ℐ𝓃𝓉ℯℊℯ𝓇ℛℴℴ𝓉[60, 60], 120]]]]

The numericalization of Root-objects can be done fast. The following shows that a root of an irreducible quintic can be found to several hundred thousand digits in a few seconds.

Table[{100 2^k, Timing[N[Root[(#^5 + 4 # - 7)&, 1], 
                         100 2^k]][[1, 1]]}, {k, 4, 12}]

(* a quick check of the last root approximation *)
With[{x = N[Root[(#^5 + 4 # - 7)&, 1], 100 2^12]}, x^5 + 4x - 7]

In Chapter 6 of the Programming volume [1559✶] of the GuideBooks we mentioned that the function Eigenvalues and Eigensystem often return Root-objects for larger symbolic matrices. Let us give one example for such a situation. Here is a symbolic 7×7 matrix with two indeterminates x and δ [1367✶].

(ℋ[x_, δ_] = With[{d = 3},
 Table[If[i == j, Which[i < 0, x + i/d, i == 0, x, 
                        i > 0, -x + i/d], δ],
       {i, -d, d}, {j, -d, d}]]) // TableForm[#, TableSpacing -> 1]&

The eigenvalues of ℋ[x, δ] are the roots of a septic polynomial.

evs[x_, δ_] = Eigenvalues[ℋ[x, δ]];
First[evs[x, δ]]

Short[Expand[81 (Det[ℋ[x, δ] - # IdentityMatrix[7]])], 6]

While the matrix is diagonal for δ=0, the corresponding Root-objects do not autosimplify in the presence of the symbolic parameter x.

Eigenvalues[ℋ[x, 0]]

FreeQ[evs[x, 0], _Root, Infinity]

evs[x, 0] /. Root[f_, k_] :> root[Factor[f[[1]]], k]

Here are some visualizations of the eigenvalues of ℋ[x, δ] as a function of x for various δ. For small δ, one nicely sees the “avoided crossing ”-behavior of the eigenvalues [745✶], [910✶], [1576✶], [1249✶], [1367✶], [1368✶], [1369✶], [424✶].

Show[GraphicsArray[
      Plot[Evaluate[evs[x, #]], {x, 0, 0.9}, 
           PlotRange -> All, Frame -> True,
           DisplayFunction -> Identity]& /@ {0, 0.01, 0.1, 1}]]

One remark is in order at this point. When using the functions Eigenvalues, Eigenvectors, or Eigensystem with matrices containing symbolic entries, Mathematica has repeatedly to test if expressions are zero. These tests might fail in case hidden algebraic dependencies exist between various symbolic parameters. So, it is frequently helpful to preprocess the initial matrix by introducing symbols for linear independent radicals, by introducing polynomial variables for exponentials and by rewriting trigonometric expressions in exponential form. In addition, a carefully constructed function for the ZeroTest option might be useful.

It happens in calculations that one ends up with an expression containing more than one Root-object and/or radical. A very useful command for manipulating such expressions is RootReduce.

Here the sum of two Root-objects is reduced to one.

sumOfTwoRoots = Root[5 - 12 #1 + #1^7 &, 1] + Root[5 - 12 #1 + #1^7 &, 2];
RootReduce[sumOfTwoRoots]

The numerical value of the last result is equal to the numerical value of the sum of the two individual roots.

{N[sumOfTwoRoots], N[%]}

RootReduce can often be used to prove tricky identities such as the following.

Tan[Pi/24] - (Sqrt[6] + Sqrt[2] - Sqrt[3] - 2)

First, we rewrite the Tan in exponential form.

TrigToExp[%]

Now, we rewrite the exponentials Exp[I rationalNumber] in algebraic form (-1)^rationalNumber.

Together[%]

This expression is now in a form suitable for RootReduce.

RootReduce[%]

RootReduce allows us to transform (nested) radicals into a canonical form.

Nest[Sqrt[# + 1]&, 0, 6]

RootReduce[%]

In the next input we use RootReduce to show that some of the polynomial roots, if the irreducible (noncyclotomic) polynomial (z^6)-2 (z^4)-6 (z^3)-2 (z^2)+1, have the interesting property that the product of two of them is again a root [472✶].

Module[{(* the roots of the sextic *)
        roots = z /. Solve[z^6 - 2z^4 - 6z^3 - 2z^2 + 1 == 0, z]},
Cases[Table[If[# === {}, {}, {i, j, #[[1, 1]]}]&[
       (* is a products identical to a root? *)
       Position[roots, RootReduce[roots[[i]] roots[[j]]], {1}]],
            {i, 6}, {j, i, 6}], {_, _, _}, {2}]]

For some Root-objects, it is possible to express them in radicals. The function ToRadicals is relevant here.

The above Root-object of degree 32 rewritten as a nested square root.

ToRadicals[%]

Sometimes it might be possible to express a Root-object in radicals, but Mathematica might not find it. Transforming a Root-object into radicals requires in general complicated Galois-group calculations [732✶], [731✶].

Root-objects can also contain parameters. In this case, they represent algebraic functions, complex-valued, piecewise continuous functions of the parameters [1471✶], [986✶], [1161✶], [1306✶]. As such a function, they fit together with all other Mathematica functions. This means one can differentiate them.

root = Root[α - 12 #1 + #1^7&, 1];
D[root, α]

One can expand them into a series (see Subsection 1.6.4 below).

Series[root, {α, 2, 2}] // N

One can plot them.

Plot3D[Evaluate[Re[root] /. α -> αr + I αi], 
       {αr, -12, 12}, {αi, -12, 12}, PlotPoints -> 30]

RootReduce does not handle Root-objects with parameters. Root-objects with symbolic parameters will have a complicated branch cut structure with respect to these parameters. This means that Root-objects as a function of a parameter are typically not smooth functions everywhere in the complex plane of the parameter(s). We show a contour plot of a Root as a function of a complex parameter. The branch cuts are easily identifiable as clusters of contour lines.

ContourPlot[Im[Root[(αr + I αi) + 4 #1 +3 #1^7&, 1]],
            {αr, -5, 5}, {αi, -5, 5},
            PlotPoints -> 120, ColorFunction -> Hue, Contours -> 30]

The following graphic visualizes the numbering of the Root-objects. We create an irreducible polynomial (by adding a small number) to the simple product (∏_j) (x-(Subscript[x, j])). One sees that first come the real roots and then come the pairs of complex conjugate ones. At the position of the root with number k we display the integer k.

poly = 1/100 + Times @@ 
   ((x - #)& /@ Flatten[Table[x + I y, {x, -3, 3}, {y, -3, 3}]]);

sol = x /. Solve[poly == 0, x];

Take[sol, 3]

Show[Graphics[MapIndexed[Text[#2[[1]], {Re[#1], Im[#1]}]&, N[sol]]],
     Frame -> True, PlotRange -> {{-4, 4}, {-4, 4}}];

Roots of polynomials have many interesting properties; for a bibliography, see [1111✶]; for more details about Root-objects in Mathematica, see [1499✶], [1500✶], and [1501✶].

Here is a small Galois-related application of Root-objects [81✶], [96✶], [269✶], [567✶], [1366✶], [1165✶], [571✶], [1544✶], and [1251✶] . We start with the roots of an irreducible cubic equation.

cubic = x^3 - x^2 - 2 // Factor

roots = Last /@ List @@ Roots[cubic == 0, x, Cubics -> False]

Using the package NumberTheory`PrimitiveElement`, the three roots can be expressed as a polynomial of a root of a sextic.

Needs["NumberTheory`PrimitiveElement`"]

prim = PrimitiveElement[z, roots]

We generate all six possible roots of the first element of the list prim.

pRoots = (Last /@ List @@ Roots[prim[[1, 1]][x] == 0, x,
         Quartics -> False, Cubics -> False]) // RootReduce

Substituting the roots pRoots into the three elements of the second part of prim again yields all roots of the original cubic, this time in all possible orders [847✶].

RootReduce[prim[[2]] /. z -> #]& /@ pRoots

Sort[Map[#[[2]]&, %, {2}]] == Sort[Permutations[{1, 2, 3}]]

Similar to NSolve and NRoots, the function Roots calculates the roots of a univariate polynomial.

In distinction to Solve, the function Roots returns its answer in the form of Or[solutions].

Roots[x^7 - 12x + 5 == 0, x]

Roots has the following options.

Options[Roots]

Cubics is the option of most importance from the last list (Quartic is similar).

This solves a cubic equation in radicals.

radicalCubeRoots = Roots[x^3 - 3 x + 5 == 0, x, Cubics -> True]

Here, the same cubic is solved in Root-objects.

rootCubeRoots = Roots[x^3 - 3 x + 5 == 0, x, Cubics -> False]

Using RootReduce, we can establish equality between the roots.

RootReduce[radicalCubeRoots[[1, 2]] - rootCubeRoots[[1, 2]]]

Let us take another cubic.

radicalCubeRoots = Roots[x^3 - 19 x^2 + 76 x - 83 == 0, x, 
                         Cubics -> True]

rootCubeRoots = Roots[x^3 - 19 x^2 + 76 x - 83 == 0, x, Cubics -> False]

Although all three roots of this cubic are real, we see explicit Is in radicalCubeRoots as already mentioned above. The numericalization of the Root-objects avoids these spurious imaginary parts.

N[radicalCubeRoots]

N[rootCubeRoots]

Because it is impossible to use only real expressions to represent the roots in the casus irreducibilis (see [785✶], [944✶], [338✶], and [812✶]), the above occurrences of I are unavoidable from a mathematical point of view.

Roots deals with univariate polynomials over the integers. The following input contains an algebraic coefficient and is left alone by Roots.

Roots[Sqrt[2] x^5 - 2 x + 1 == 0, x]

But Solve will deal with this situation.

Solve[Sqrt[2] x^5 - 2 x + 1 == 0, x]

Root-objects without parameters can be numericalized to arbitrary precision. If they contain numeric symbolic quantities, their numericalization might require a higher setting of $MaxExtraPrecision. Here is an example.

πSol = Solve[(Pi - Rationalize[N[Pi, 100], 0]) x^5 - 2 x + 1 == 0, x]

N[πSol, 22] /. _Root :> ℛ

$MaxExtraPrecision = 100;
N[πSol, 22] /. _Root :> ℛ

After univariate polynomials, the second important set of equations that always gets solved by Solve are systems of univariate polynomials. Now, it is no longer easily predicted how many solutions we will have (see the remarks about this subject in the discussion of NSolve in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks.) Here are two examples of polynomial and algebraic equations and systems of equations that Solve can handle. Here are two examples. Often, the results returned by Solve for systems of polynomials are quite large. So we will only display one of the solutions.

sol = Solve[{x + y + z == 1,
             x^2 + y^2 + z^2 == 4,
             x^3 + y^3 + z^3 == 9}, {x, y, z}];

Length[sol]

sol[[1]]

sol = Solve[{x^3 + y^5 + x y == 3, 
             x^3 + y^5 + x^2 y^2 == 5}, {x, y}];

Length[sol]

sol[[1]]

Here is an example of a system of polynomial equations that can be solved by Solve but produces a fairly large output (of size about 4 MB). (For a “hand” solution, see [1494✶], [1215✶], [1345✶], and [1459✶]; this is the set of equations describing the circles of Apollonius shown in Chapter 1 of the Programming volume [1559✶] of the GuideBooks.) The geometric interpretation of this system of equations as circles inside a triangle is obvious.

(* three circles touching a fourth one *)
Solve[{(x - x1)^2 + (y - y1)^2 == (r1 + r)^2,
       (x - x2)^2 + (y - y2)^2 == (r2 + r)^2,
       (x - x3)^2 + (y - y3)^2 == (r3 + r)^2}, {r, x, y}] // Short[#, 12]&

Note the form of the solutions produced by Solve for solutions with respect to more than one variable.

Solve[{x^2 == 4, y^2 == 9}, {x, y}]

This is similar to the results of NDSolve that have already been discussed.

Solve does not always produce large expressions as in the example above. Here are two examples of polynomial equations whose inverses also have a polynomial structure.

Solve[{X == x - 2(x z + y^2) y - (x z + y^2)^2 z,
       Y == y + (x z + y^2) z,
       Z == z}, {x, y, z}]

Solve[{X == x - (z x + y w) w, Y == y + (z x + y w) z,
       Z == z, W == w}, {x, y, z, w}]

This behavior is the exception, not the rule. For more on this situation, see [534✶], [1451✶], and [670✶].

Let us deal with a slightly more complicated example. Given the polynomial

(x-(Subscript[x, 1]))(x-(Subscript[x, 2]))⋯(x-(Subscript[x, n]))=(∑_(i=0)^n)(Subscript[c, i])(x^i),

we have the following Vieta-relations: (Subscript[c, n])=1, (Subscript[c, n-1])=-(Subscript[x, 1])-(Subscript[x, 2])-⋯-(Subscript[x, n]), …, (Subscript[c, 0])=(Subscript[x, 1])(Subscript[x, 2])⋯ (Subscript[x, n]). Setting now (Subscript[c, n-1])=(Subscript[c, n-2])=⋯=(Subscript[c, 1])=0 and (Subscript[c, 0])=1, the resulting polynomial is (x^n)-1=0. The solutions of (x^n)-1=0 are clearly also solutions for (Subscript[c, n-1])=(Subscript[c, n-2])=⋯=(Subscript[c, 1])=0, (Subscript[c, 0])=1. But given the system 0=-(Subscript[x, 1])-(Subscript[x, 2])-⋯-(Subscript[x, n]), …, 1=(Subscript[x, 1])(Subscript[x, 2])⋯ (Subscript[x, n]), we will solve it for the (Subscript[x, i]). The function cyclicEquations produces the equation (Subscript[c, n-1])=(Subscript[c, n-2])=⋯=(Subscript[c, 1])=0, (Subscript[c, 0])=1 for a given n.

cyclicEquations[n_] :=
MapIndexed[If[#2 === {1}, #1 == 1, #1 == 0]&, 
           Drop[CoefficientList[Product[x - x[i], {i, n}], x], -1]]

The resulting equations for n=3.

cyclicEquations[3]

For n=2, we have two solutions.

Solve[cyclicEquations[2], Array[x, 2]] // Union

cyclicEquations[2] /. %

For n=3, we have six solutions. We turn off the $MaxExtraPrecision::meprec message because it would be issued in the solution verification process.

Off[$MaxExtraPrecision::meprec]
csol3 = Solve[cyclicEquations[3], Array[x, 3]] // Union

Using RootReduce, we can rewrite the solutions in a slightly nicer form.

RootReduce[csol3]

As expected, the six solutions are just permutations of one fundamental solution.

Sort[{x[1], x[2], x[3]} /. %] ===
Sort[Permutations[{x[1], x[2], x[3]} /. %[[1]]]]

Here is a quick numerical check for the solution.

N[Apply[Subtract, cyclicEquations[3], {1}] /. csol3, 22] // 
                                                 Abs // Max

For n=4, we have 4!=24 solutions.

csol4 = Solve[cyclicEquations[4], Array[x, 4]] // Union;

Length[csol4]

Now, the solutions look a bit complicated.

csol4[[1, 1]] // Simplify

Instead of explicitly solving the equations, it is often useful to look at the structure of the solution. Inspecting a lexicographic Gröbner basis often gives useful information. We see a quartic equation in x[4], a cubic in x[3], a quadratic in x[2], and a linear one in x[1].

GroebnerBasis[Apply[Subtract, cyclicEquations[4], {1}], Array[x, 4]]

Here is the structure of the Gröbner basis for n=8. It is easy to see that solving this triangular system would result in 8!=40320 solutions, all permutations of a single solution [1682✶].

Exponent[#, Array[x, 8]]& /@ 
GroebnerBasis[Apply[Subtract, cyclicEquations[8], {1}], Array[x, 8]]

The third class of equations Solve deals with systems of algebraic equations. By introducing auxiliary variables, it is always possible to rewrite such equations as systems of polynomials (the case we just discussed). Here is an example.

sol = Solve[{x^2 + x^(1/2) == a^(1/3) x,
             a x + Sqrt[a x] == 2}, {a, x}];

Length[sol]

sol[[1]]

A quick numerical check for the solutions is carried out by the following input.

N[{x^2 + x^(1/2) - a^(1/3) x, a x + Sqrt[a x] - 2} /. sol, 22]

So far, we have discussed Solve for inputs where it will always (in principle) be successful. The algorithms built into Solve allow for an exhaustive treatment of polynomial inputs or algebraic input with no parameters. But the actual running times may sometimes be quite large. If the reader has a complicated system to be solved and Solve seems not be able to find a solution in a reasonable amount of time, it is often useful to “massage” the system. There is no general rule of what kind of “massaging” might be useful (if there was one, Mathematica would do it). Typically, useful strategies are the elimination of linear variables “by hand” and appropriate “Together-ing”, the elimination of high multiplicities, precalculating a Gröbner basis using GroebnerBasis, and others. The reader will find at the end of this section some more detailed remarks.

Now, let us discuss the next set of equations: Transcendental equations. Here is one of the simplest examples.

Solve[Sin[x] == a, x]

With trigonometric functions, this message is a typical “problem” with the use of Solve.

The last example issued a message. This message is connected to one of the options of Solve. Here are the options of Solve.

Options[Solve]

The first option of Solve is InverseFunctions. It is this message and its setting True that caused the above message.

With this option set to False, the following simple equation is no longer solved.

Solve[Cos[x] == a, x, InverseFunctions -> False]

Here are three more examples. The first one is rather trivial; in the second example, inverse functions are needed three times (the variable to solve for is the difference in the three inputs); and in the third example, f is not found as an argument of a nonhead symbol.

Solve[f[f[f[x]]] == a, {#}]& /@ {a, x, f}

Mathematica can solve complicated equations and systems of equations involving trigonometric functions. Here, a slightly complicated equation in trigonometric functions is solved.

sol = Solve[Sin[2 x] + Cos[3 x] + Tan[x/5] == 0, x];

The individual solutions are expressed in Root-objects.

sol[[1]]

Here is a quick check that the solutions are correct.

Sin[2 x] + Cos[3 x] + Tan[x/5] /. N[sol, 30] // Abs // Max

In addition to trigonometric and inverse trigonometric equations, a large set of equations containing logarithms and exponentials that can be solved by the so-called ProductLog function (we will discuss this function in Chapter 3). ProductLog[z] is (one of) the solution(s) of the equation z == ProductLog[z] Exp[ProductLog[z]]. Here are two examples of such equations.

Solve[Log[x] == x^γ, x]

Solve[Exp[x]^n Exp[α Exp[x]^m] == β, x]

Although Mathematica can (modulo a potentially long runtime) solve every system of polynomial equations, systems of transcendental equations are much more difficult to treat, and “helping” Mathematica is often required. Here is a system consisting of one polynomial and one transcendental equation. Mathematica cannot currently solve this system.

Solve[{2^x + 4^y == 9, x == y}, {x, y}]

Using the second equation in the “obvious” way results in one equation that Mathematica can now solve.

Solve[2^x + 4^x == 9, x]

Another option of Solve is WorkingPrecision.

With WorkingPrecision less than Infinity, we get a numerical result. Similar to corresponding cases discussed in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks, be aware that if arbitraryPositiveInteger is less than $MachinePrecision, this will still result in using $MachinePrecision for the calculations or for the result. In such cases, we would normally use NSolve.

Solve[{x + y == 2, x + y^3 == 5}, {x, y}, WorkingPrecision -> 22]

This gives the same result.

NSolve[{x + y == 2, x + y^3 == 5}, {x, y}, WorkingPrecision -> 22]

Sort[%] == Sort[%%]

The next option that we want to discuss is VerifySolutions.

The following situation can happen for nonpolynomial equations: Solve computes one or more “solutions” that not only fail to be solutions for some particular parameter value (i.e., they are not generic solutions), but also fail for a set of parameters of finite Lebesgue measure. (This is because certain nonequivalent transformations such as exponentiation are used which generate spurious solutions in the computation.) Here is an example of an algebraic equation containing the parameter a.

Timing[(sol = Solve[x^(1/3) + x^(1/2) == a, x])];

Length[sol]

Here is one of the three solutions. It contains radicals of polynomials in a.

sol[[1]]

We look at the three solutions as a function of a by individually inserting them into the original equation. We see that the solutions depend explicitly on the value of a. Here, the behavior of the backsubstituted solution along the real axis is shown.

Clear[pp, a, x, y, i]
(* the three single solutions *)
{pp[1, a_], pp[2, a_], pp[3, a_]} = (x /. sol);

Module[{x}, 
Show[GraphicsArray[Table[
(* pictures of the three solutions used in the equation *)
Plot[x = pp[i, a] // N;
     Chop[Abs[x^(1/3) + x^(1/2) - a]], {a, -1/2, 1/2},
     DisplayFunction -> Identity, PlotPoints -> 50, 
     Axes -> False, PlotRange -> All, Frame -> True, 
     PlotStyle -> {Thickness[0.002], Hue[0]}], {i, 3}]]]]

One clearly sees that none of the solutions is correct for negative a. A view of the backsubstituted solution in the complex a-plane shows a complicated behavior of the solutions.

Module[{x}, 
Show[GraphicsArray[Table[
(* pictures of the three solutions used in the equation *)
Plot3D[x = pp[i, ar + I ai] // N;
       Chop[Abs[x^(1/3) + x^(1/2) - (ar + I ai)]], 
       {ar, -1/2, 1/2}, {ai, -1/2, 1/2}, 
       DisplayFunction -> Identity, PlotPoints -> 90,
       Mesh -> False, PlotRange -> All], {i, 3}]]]]

It is in such situations, in which we have a complicated “parameter dependence”, in which the option VerifySolutions becomes useful. With VerifySolutions -> True, a check of the correctness (as far as possible) automatically takes place. Here, the solutions are not verified.

With[{a = -3}, 
     Solve[x^(1/3) + x^(1/2) == a, x, VerifySolutions -> False]]

In the process of verifying the above three solutions, all three become rejected.

With[{a = -3}, 
     Solve[x^(1/3) + x^(1/2) == a, x, VerifySolutions -> True]]

With the default setting VerifySolutions -> Automatic, no wrong solutions are returned for our example.

With[{a = -3}, 
      Solve[x^(1/3) + x^(1/2) == a, x, VerifySolutions -> Automatic]]

Even with VerifySolutions -> True, one should be skeptical of the results for equations containing radical expressions containing parameters, because it is impossible to test with respect to all possible values of a.

Solve[x^(1/3) + x^(1/2) == a, x, VerifySolutions -> True] === sol

For the verification process, Solve will use numerical techniques. This means it can be fooled. So, for the following input of a cubic equation only one root is returned.

verySmallNumber = 
(Sqrt[2 - Sqrt[2 + Sqrt[2]]]/2 - Sin[Pi/16] + 10^-200);
Solve[verySmallNumber x^3 + x + 1 == 0, x, VerifySolutions -> True]

At the end of our discussion of Solve, let us shortly discuss two limiting cases: Sometimes a system of equations has no solution at all.

Solve[x + 1 == x + 2, {x}]

Solve[{x^2 + y^3 == 2, x^2 + y^3 == 3}, {x, y}]

Note the difference between the case in which a system of equations has no solutions ({} is returned) and the case in which the equations are fulfilled for all values of the solved variables.

Solve[x + 1 == x + 1, {x}]

We now return to the problem of “generic” solutions mentioned in the beginning. If we need to find all solutions, and all exceptions to returned generic solutions—that is, including ones associated with special choices of the parameters—we can use Reduce.

Here again is the first equation from this section, but now all solutions will be simultaneously computed.

Reduce[α x == β, x]

Polynomial equations are also solved by Reduce.

Reduce[{a x^2 + y == b, c x + d y == f}, {x, y}]

For the following equation with a rational function on the right-hand side, we get the situations of vanishing denominators treated especially. Here, there are four cases.

Reduce[(x - a)/((x^2 - 1)(x - a b)) == 0, x]

In contrast, Solve finds only the one and two generic solutions for the last two examples.

Solve[{a x^2 + y == b, c x + d y == f}, {x, y}] // Length

Solve[(x - a)/((x^2 - 1)(x - a b)) == 0, x] // Length

Reduce has the same options as Solve. Except for Mode, they are set in the same way.

(First /@ Options[Reduce]) == (First /@ Options[Solve])

Select[Options[Reduce], FreeQ[Options[Solve], #]&]

As a small application of Reduce let us prove that there are no nonsingular real-valued 3×3 matrices 𝒜 that fulfill the identity [852✶], [1687✶], [305✶]

𝒜(Subscript[⊗, ℋ])((((𝒜^T)))^(-1))=(1/3)(Subscript[(OverTilde[1]), 3]).

Here (Subscript[⊗, ℋ]) denotes Hadamard multiplication (the default elementwise multiplication of Mathematica), ((((𝒜^T)))^(-1)) is the inverse of the transpose of 𝒜, and (Subscript[(OverTilde[1]), 3]) is the 3×3 matrix with all elements 1. Here are the nine scalar equations representing the above matrix equation. We denote the elements of 𝒜 by (Subscript[𝒶, i j]).

𝒜 = Array[𝒶, {3, 3}];
𝕠𝕟𝕖Matrix[n_] := Table[1, {n}, {n}];
(* the equations *)
eqs = Factor[Numerator[Together[
      𝒜 Transpose[Inverse[𝒜]] - 𝕠𝕟𝕖Matrix[3]/3]]] // Flatten;
(* use subscripts *)
eqs /. 𝒶[ij__] :> Subscript[𝒶, ij]

Adding the nonsingularity condition to the last nine equations and solving for the elements (Subscript[𝒶, i j]) gives the following two solutions.

𝒶s = Flatten[𝒜];
sol = (Reduce[Append[# == 0& /@ eqs, 
              (* 𝒜 is nonsingular *) Det[𝒜] != 0], 𝒶s] //
        (ExpandNumerator //@ #&)) //. 𝒶[ij__] :> Subscript[𝒶, ij]

Reduce calculates all complex solutions, but here we are interested in the real ones only. The (Subscript[𝒶, i j]) were assumed real. A quick inspection of the last solution shows that to guarantee the realvaluedness of the left-hand sides of all solutions would require exactly these (Subscript[𝒶, i j]) to vanish that according to the solution cannot vanish.

Often, we do not require solutions for all variables, but only for a prescribed subset of variables. This can be accomplished with Eliminate.

Solve offers a similar possibility for the cases in which we want to solve for some variables while at the same time eliminating others. This requires a third argument for Solve. Here is an example involving elimination of a variable from the following equations.

equations = {a x^2 + y == 1, a x + y^2 == 1, a x y == 1}

The variable a is to be eliminated. The result of this operation is a logical And coupling the equations.

Eliminate[equations, a]

In turn, it can be converted into a list of equations.

List @@ %

Now, we solve these equations for x and y after eliminating a.

Solve[equations, {x, y}, a]

Thus, Solve solves the equations produced by Eliminate for the desired variables.

Solve[%%, {x, y}] == %

For comparison, we give the result of Solve without a third argument (we would have three independent equations in two variables).

Solve[equations, {x, y}]

The system of equations involves three equations in the two variables x and y, and in this case, there is generally no generic solution. 
Let us use Eliminate to derive a fourth-order algebraic differential equation with the remarkable property that any continuous function can be approximated arbitrarily closely by a solution of this differential equation [1373✶], [200✶], [522✶], [218✶] (for a universal functional equation, see [523✶]).

f[t_] = Integrate[Exp[-1/(1 - t^2)], t];

g[t_] = Exp[1/(1 - t^2)];

eqs = {y'[x] == Together[A α f'[t] g[t]],
       y''[x] == Together[A α^2 f''[t] g[t]],
       y'''[x] == Together[A α^3 f'''[t] g[t]],
       y''''[x] == Together[A α^4 f''''[t] g[t]]}

Expand[Subtract @@ Eliminate[eqs, {A, α, t}]]

As another little application to Eliminate, let us calculate (non)linear differential equations with integer coefficients that have cos(x)+sin(2x) as their solutions. We construct these differential equations by eliminating all trigonometric functions from cos(x)+sin(2x) and its derivatives.

Flatten[Table[
  Factor[#] == 0& /@ Apply[Subtract,
   If[Head[#] === And, List @@ #, {#}]&[
   Eliminate[(* eliminate trig functions *)
      Join[Table[(* table of derivatives *)
        D[w[z], {z, i}] == TrigExpand[
         (* rewrite all Sin, Cos of multiple arguments *)
          D[Cos[x] + Sin[2 x], {x, i}]], {i, 0, j}],
          (* algebraic relation between Sin[x] and Cos[x] *)
          {Sin[x]^2 + Cos[x]^2 == 1}], {Sin[x], Cos[x]}]], {1}],
                {j, 1, 4}]] // TableForm

Note, the last differential equation of order four is linear. Here, the results are checked.

Simplify[% /. w -> Function[x, Cos[x] + Sin[2 x]]] // Union

(For generalizations, see [1001✶].)
In this section, in Section 1.4 of the Numerics volume [1561✶] of the GuideBooks, and in the above subsections on polynomial equations and inequalities, we have discussed many functions related to solving equations: Solve, NSolve, Roots, NRoots, FindRoot, Eliminate, Reduce, Resultant, GroebnerBasis, and CylindricalAlgebraicDecomposition. Together with the functions SolveAlways, Experimental`Groebnerwalk, and Algebra`InequalitySolve, this gives the user a broad set of tools to handle, rewrite, and solve equations and inequations. Which of the functions should be used under which circumstances? There is no one-sentence answer to this question. It depends on:

◼ Do we deal with equations, inequations, or inequalities?
◼  Do we deal with a univariate or a multivariate problem?
◼  Do we look for a numeric or symbolic solution?
◼  Are we interested in explicit or implicit solutions?
◼  Do we expect that the solutions are isolated or form finite dimensional manifolds?
◼  Does the problem have parameters?
◼  Do in the problem polynomial, rational or transcendental functions appear?
◼  Do we want all solutions or only some?
◼  Do we look for solutions correct only for special parameter values?
◼  How large and/or complicated is the system?

We cannot give exhaustive answers to all of the above questions, but in the following we will give some rules, guidelines, recommendations, and tricks. The following discussion is restricted to methods that use functions currently built into Mathematica. Further methods, such as multiresultants, can solve polynomial system efficiently.
If we want a numeric solution of a univariate polynomial equation of “reasonable” degree with rational coefficients, we can safely use NRoots. If the coefficients contain exact numeric transcendental quantities (like E or Sqrt[5]), we can still use NRoots, but depending on the coefficients the user might want to numericalize them explicitly with a sufficiently high precision. The function NRoots will return all solutions for a univariate polynomial. Returning all solutions for large degree univariate polynomial might take a considerable amount of time. If the polynomial is simple, a preprocessing call to Factor or Decompose may be useful. And if we are only interested in some solutions (often the smallest or largest root), then a call to FindRoot (with properly set parameters, especially WorkingPrecision and AccuracyGoal) is often preferable.
If we want a symbolic solution of a univariate polynomial equation of “reasonable” degree with rational coefficients, we can use Roots. This will give all roots either as radicals or as Root-objects (depending on the degree of the polynomial and the setting of the Cubics and Quartics option). If the coefficients contain numeric transcendental quantities, we can still use Roots, but the result is more symbolic (meaning that not all operations that can, in principle, be carried out on Root-objects will work properly). (For most problems, a “reasonable” degree for numeric and symbolic univariate polynomials means less than or equal to a few hundred.)

After a univariate polynomial, the next complicated type would be a univariate rational function. NRoots will not deal with them, but NSolve will for numerical purposes. Similarly, for symbolic solutions, Solve is now the function of choice. Concerning the degree, and if all solutions are needed, the remarks from the last paragraph stay valid.

The most important type of equations (from the relevance in practical applications as well from what can be dealt algorithmically) is a set of multivariate polynomial equations. If they are free of parameters, the set has only isolated solutions, and we want all of them, NSolve is the function of choice. If the set has parameters, they either have to be instantiated or they may be eliminated by using a three-argument form of NSolve. (Now that we have discussed Gröbner bases, let us add one sentence about what NSolve is doing with such a set of equations. For the most important case of n equations in n variables, it calculates a degree reverse lexicographic basis using numericalized coefficients and then converts this basis to a lexicographic one using eigensystems of matrices [90✶]. A degree reverse lexicographic basis is often much easier to calculate than a lexicographic one. But in the calculation and in the ongoing basis conversion, many digits can be lost due to cancellations; we saw examples in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks. That is why it is important to use a sufficiently high working precision for such calculations.)
(For completeness, let us mention that to get a numerical solution we can, of course, always calculate an exact solution and apply N to it.)
Now concerning the case where we want a symbolic solution: The function Solve is the appropriate choice in most cases. Solve will try to calculate a lexicographic Gröbner basis and then solve the resulting system of polynomials. Although this approach works theoretically always, the actual running time and memory needed depend crucially on the order of variables and certain internal choices. Solve has an elaborate set of heuristics to “do the right thing” and often will give a solution in a “reasonable” time.
If Solve does not return a solution after a “reasonable” amount of time (say after one day) the user can try to solve the system “manually”. A first try would be a direct call to GroebnerBasis. (The order of the variables to be solved for might matter.) Often it is very helpful to eliminate certain parts of the solution the user is not interested in. Eliminating some variables (using GroebnerBasis with EliminationOrder, or Resultant on all pairs of equations) and then factoring the result sometimes achieves this. (But be aware that multiple uses of Resultant can give spurious solutions.). One could also try to calculate a degree reverse lexicographic basis and then convert it to a lexicographic basis using the (undocumented and still experimental in Version 4.1) function Internal`Groebnerwalk [347✶], [46✶]. For systems that are linear in some of the variables it often is a good idea to solve for these variables, and backsubstitute the solutions in the remaining equations. (Of course, care has to be taken with denominators that could vanish. Sometimes, a generalization of this approach, namely solving for the highest monomial (x^d) and replacing in other equations (x^e) (e>d) by (x^(⌊e/d⌋))(x^(e-⌊e/d⌋)) yields simpler equations.) Because the running time of GroebnerBasis is dramatically dependent on the number of variables, this method is sometimes of great advantage. As said, NSolve will calculate an approximative Gröbner basis. Such a Gröbner basis can be also calculated directly using the CoefficientField -> InexactNumbers[precision] option setting. Because under this setting the coefficients cannot become arbitrary large numbers, GroebnerBasis runs often faster. And although numeric, the resulting basis can either be used to draw conclusions about the exact number of symbolic solutions of the system or sometimes even might be made symbolical (using Rationalize). In the solutions to the exercises of this chapter, we will demonstrate the mentioned possibilities on various example problems.

Often the just-mentioned alternatives to a direct call to Solve are also useful as processing steps to obtain numeric solutions. When we only want some solutions and we “roughly know” their values, FindRoot (again with properly set options) will come in handy. By starting with sufficiently many random starting values, we will sometimes also succeed to find all solutions for a polynomial system numerically.

Sometimes even a linear system with coefficients that are symbolic parameters may be a challenge to solve. For up to typically eight equations Solve will often work fine, but for a larger system it may need a long time and/or a lot of memory. Depending on the special characteristic of the system, solving one equation after the other and substituting the solutions may be an alternative. Especially if it is possible to simplify (using say Factor or Together) the coefficients after each step considerably.

For a multivariate polynomial system that has finite dimensional solutions, NSolve will resort to Solve. Either this works or we have to resort to the above mentioned manual alternatives and then numericalize the solutions.

Multivariate systems of rational functions formally reduce to a polynomial system after writing them over common denominators. Depending on the problem, care might have to be taken to ensure that denominators do not vanish. In a direct call to Solve, this will be done automatically. When using the above-described manual approach, one either tests if the solutions are appropriate at the end or introduces in the beginning auxiliary equations of the form 1-(Subscript[ξ, 1])(Subscript[denominator, 1]), 1-(Subscript[ξ, 2])(Subscript[denominator, 2]), or 1-(Subscript[ξ,  ])((Subscript[denominator, 1]^2)+(Subscript[denominator, 2]^2)+…) and eliminates the auxiliary variables (Subscript[ξ, k]). These equations ensure that the denominators never vanish.

The most complicated equations are genuinely transcendental ones. For a few such equations, Solve will generate a solution. It will use heuristics to first find a variable substitution ((radicalOrRootOfOrdern^n)=radicalOrRootOfOrdern, like y=exp(i x) for trigonometric or y=exp(x) for hyperbolic equations) to transform the equations to a polynomial form. (Sometimes also operations on the whole equation, like exponentiating the equation when logarithmic or inverse hyperbolic functions exist, may be fruitful.) Then the described techniques will be used to solve these polynomials. Using the inverse functions, we get explicit solutions. Because the variable substitution is not an algorithmic process and not all possible inverse functions of transcendental functions are known to Solve, some manual work can lead to a success if Solve takes too long or fails.

Now, let us assume we have a polynomial system (or we have brought the problem into such a form). Solving the system is the most common operation, either with or without parameters. If we are interested in all special and degenerate solutions, Reduce is the function to be used. Most remarks from above hold. If Reduce does not succeed, we could try a manual approach. But great care has to be taken not to “lose” a branch. In the opposite case, where we are only interested in generic solutions, the function SolveAlways should be used. 
Above we used repeatedly the word “parameter”, without formally defining it. Often it is clear from the problem at hand what are the solve variables and what are the parameters. For Solve, parameters are all symbols that are not solve variables and that appear in the equations (the first argument of Solve). This means that potential coefficients such as Pi, Sqrt[2], Sin[Pi/20] are parameters for Solve. Inside GroebnerBasis, parameters are either determined automatically or can be explicitly specified in the option ParameterVariables. For radicals such as Sqrt[2], the identity Sqrt[2]^2 == 2 will automatically be used, but for transcendental constants such as Sin[Pi/20], it is often advantageous to add the identity Sin[Pi/20]^2 + Cos[Pi/20]^2 == 1 explicitly. Inside GroebnerBasis parameters could, of course, also be listed in the variable list; typically they would be listed last. Finally when parameters are present, the option setting CoefficientDomain -> RationalFunctions is sometimes useful.

Another frequently desired operation is the elimination of variables. Either a call to Eliminate or a call to GroebnerBasis with the option setting MonomialOrder -> EliminationOrder is advised here. Often this will succeed directly, but again, manual manipulations might dramatically accelerate this.

Solving systems that contain inequations (such as Solve[{x^2 ==1, x != 1}, x]) reduces basically to the above cases. Either one finds first all solutions and then eliminates the unwanted ones or one introduces auxiliary equations of the form 1-ξshouldNotVanish.

Finally, sets of polynomial inequalities are either solved directly by using the Algebra`InequalitySolve package or by manually massaging the equations and then carrying out a call to the underlying CylindricalAlgebraicDecomposition.

To summarize: If the problem under consideration is not very complicated, a direct call to Solve, NSolve, Reduce, or Algebra`InequalitySolve will do the job. These functions make use of strong algorithmic techniques and elaborate heuristics. If this is not the case (from a timing or memory point of view), some manipulations of the equations, the use of numerical and symbolic techniques (and sometimes also graphical techniques to find appropriate starting values for instance) will often make progress. (The most elaborate heuristics usually cannot compete with some “physical insight” into a problem of how many solutions and solutions of which kind one expects). In the exercises of this chapter many of these “solution strategies” described will be put to work on concrete examples.

1.6 Classical Analysis

1.6.1 Differentiation

The important command D for differentiation has already been discussed in Chapter 3 of the Programming volume [1559✶] of the GuideBooks. D has a more general syntax than was described there. D has one option.

Mathematica can of course compute the derivatives for all elementary functions and compositions of these functions, as well as for many special functions. This includes, for example, the Legendre functions (see Chapter 3).

D[LegendreP[n, z], {z, 2}]

Here is the computation of the second derivatives of a function with respect to two different variables.

D[Sin[x^3] y^2, {x, 2}, {y, 2}]

Variables that do not explicitly depend on the variables of differentiation are treated as constants.

D[x^2 z^z, {x, 2}]

If z in this example also depends on x, we can take this into account in two different ways. First, we can explicitly state that x is an argument by writing z[x].

ex1 = D[(x^2 z^z /. z -> z[x]), {x, 2}]

Alternatively, we can tell D that z depends on x. (This can be useful for a proper treatment of total versus partial derivatives [332✶].)

ex2 = D[x^2 z^z, {x, 2}, NonConstants -> z]

In this case, the output form is different, but we can easily convert it back to the earlier one.

ex3 = ex2 /. {z -> z[x],
              D[z, x     , NonConstants -> {z}] -> z'[x],
              D[z, {x, 2}, NonConstants -> {z}] -> z''[x]}

Expand[ex3 - ex1]

For a function of several variables, the derivative is not represented by ', but instead by using numbers in parentheses to specify how many times to differentiate with respect to the corresponding variable.

D[func[t, 𝔱, 𝕥], {t, 2}, {𝔱, 3}, {𝕥, 3}]

Mathematica is able to explicitly differentiate nearly all special functions with respect to their “argument”, but only a few special functions with respect to their “parameters”. Here is the derivative of LegendreP with respect to its first argument.

D[LegendreP[n, z], {n, 1}]

Numerically, these quantities can still be calculated.

N[% /. {z -> 2.04, n -> 0.567}]

Here is a high-precision evaluation of the last derivative.

N[%% /. {z -> 204/100, n -> 567/1000}, 22]

Here, we have to make a remark about the numerical differentiation encountered in the last examples. Whereas the last derivative was evaluated “just fine” by Mathematica, the following “simple” derivative does “not work”.

Abs'[1.]

The reason Abs'[inexactNumber] does not evaluate is the fact that the derivative of Abs does not exist. The derivative is (by definition) the limit (lim_(δ->0))(f(z+δ)-f(z))/δ for complex δ. But for Abs, the result depends on the direction of δ approaching 0. Let z=1; then we have the following result. (Here, we use the soon-to-be-discussed function Limit.)

absDeriv[zr_, zi_, φ_] =
With[{z = zr + I zi, δz = δ Exp[I φ]},
Limit[ComplexExpand[(Abs[z + δz] - Abs[z])/δz, 
              TargetFunctions -> {Re, Im}], δ -> 0]]

Here is the direction dependence for z=1 as a function of arg(z-1). The two curves show the real and the imaginary parts of absDeriv[1, 0, φ].

Plot[{Re[absDeriv[1, 0, φ]], Im[absDeriv[1, 0, φ]]}, {φ, 0, 2Pi},
     PlotRange -> All, Frame -> True,
     Axes -> False, PlotStyle -> {{Thickness[0.005]},
                      {Thickness[0.005], Dashing[{0.01, 0.01}]}}]

The numerical derivative is always taken for purely real δz. To use the numerical differentiation, we “hide” Abs in the following definition of abs.

SetAttributes[abs, NumericFunction];
abs[x_?InexactNumberQ] := Abs[x]

For purely real δz and complex z, we have the following behavior of the “derivative”. The right picture shows the result of the numerical differentiation.

Show[GraphicsArray[
 Plot3D[#, {x, -1, 1}, {y, -1, 1}, DisplayFunction -> Identity,
        PlotPoints -> 25]& /@ {absDeriv[x, y, 0], abs'[x + I y]}]]

While the last two pictures look “sensible”, checking the difference between absDeriv[x, y, 0] and abs' more carefully, we see near the origin the effects of the numerical differentiation.

Plot3D[Abs[absDeriv[x, y, 0] - abs'[x + I y]], 
       {x, -1/4, 1/4}, {y, -1/4, 1/4}, 
       PlotRange -> All, PlotPoints -> 50]

The following picture shows the points used in the numerical differentiation process near the high-precision number 1.

bag = {};
abs[x_?InexactNumberQ] := ((* collect values *) AppendTo[bag, x]; Abs[x]);
abs'[1`100];
Show[Graphics[Line[{{#, 0}, {#, Abs[#]}}]& /@ bag], 
     PlotRange -> All, Frame -> True]

From the last result we conclude that we should not trust the numerical derivatives of discontinuous functions or quickly oscillating functions. Here is the numerical derivative of a step-like function (be aware that we display f(x) and f'(x)/60).

SetAttributes[meander, NumericFunction];
meander[x_?NumberQ] := Sin[x]/Sqrt[Sin[x]^2]

Plot[{meander[x], meander'[SetPrecision[x, 100]]/60}, {x, 2, 4}, 
     PlotStyle -> {Hue[0], GrayLevel[0]}, PlotRange -> All,
     Compiled -> False]

One word of caution is in order here: If very reliable high-precision numerical values of derivatives are needed, it is safer to use the function ND from the package NumericalMath`NLimit` instead of numericalizing symbolic expressions containing unevaluated derivatives using N. N[unevaluatedDerivative] has to choose a scale for sample points. Like all other numerical function no symbolic analysis of unevaluatedDerivative is carried out, and as a result the chosen scale may result in mathematically wrong values for the derivative (this is especially the case for values of derivatives near singularities; but in principle higher order numerical differentiation is difficult [1198✶]).
We should make another remark concerning a potential pitfall when differentiating. Mathematica tacitly assumes that the differentiation with respect to different variables can be interchanged. This means that for the following well-known example, we do not get the “correct” derivatives.

strangeFunc[0, 0] = 0;
strangeFunc[x_, y_] = x y (x^2 - y^2)/(x^2 + y^2);

First, we differentiate with respect to x and evaluate at {0,y}.

D[strangeFunc[x, y], {x, 1}] /. {x -> 0}

We differentiate a second time with respect to y.

(Subscript[(∂/(∂y))(∂/(∂x))"\!\(\*StyleBox[\"\\\"strangeFunc[\\\"\", \"MR\"]\)"x"\!\(\*StyleBox[\"\\\", \\\"\", \"MR\"]\)"y"\!\(\*StyleBox[\"\\\"]\\\"\", \"MR\"]\)"|, ((x=0)/(y=0))])=-1.

D[strangeFunc[x, y], {y, 1}] /. {y -> 0}

Here, we differentiate a second time with respect to x.

(Subscript[(∂/(∂x))(∂/(∂y))"\!\(\*StyleBox[\"\\\"strangeFunc[\\\"\", \"MR\"]\)"x"\!\(\*StyleBox[\"\\\", \\\"\", \"MR\"]\)"y"\!\(\*StyleBox[\"\\\"]\\\"\", \"MR\"]\)"|, ((x=0)/(y=0))])=1

This function is not differentiable at the point {0,0}. For comparison, generically, the result is correct (this means for generic values of x and y, the order of differentiation does not matter). D uses the same kind of philosophy with respect to generic parameter values as already discussed for Solve.

D[strangeFunc[x, y], {x, 1}, {y, 1}]

D[strangeFunc[x, y], {y, 1}, {x, 1}]

%% - %

Although the derivatives cannot be exchanged, strangeFunc is differentiable at {0,0}. An easy way to find out if a function f((Subscript[x, 1]),(Subscript[x, 2]),…,(Subscript[x, n])) is differentiable at a point {(Subscript[(OverTilde[x]), 1]),(Subscript[(OverTilde[x]), 2]),…,(Subscript[(OverTilde[x]), n])} is to change from an n-dimensional Cartesian coordinate system to an n-dimensional polar coordinate system with the origin {(Subscript[(OverTilde[x]), 1]),(Subscript[(OverTilde[x]), 2]),…,(Subscript[(OverTilde[x]), n])}. If and only if f(r,(Subscript[ϑ, 1]),…,(Subscript[ϑ, n])} in the limit r->0 is independent from all (Subscript[ϑ, i]), the function f is differentiable at {(Subscript[(OverTilde[x]), 1]),(Subscript[(OverTilde[x]), 2]),…,(Subscript[(OverTilde[x]), n])} [1604✶], [1110✶]. For the function strangeFunc the limit r->0 exists and is 0.

strangeFunc[r Cos[φ], r Sin[φ]] // Simplify

But the second derivative under consideration does not have a φ-independent value in the limit r->0.

D[strangeFunc[x, y], {y, 1}, {x, 1}] /. 
                  {x -> r Cos[φ], y -> r Sin[φ]} // Simplify

For a collection of counter examples involving the interchangeability of differentiation, integration, and taking of limits, see [635✶], [1117✶], [1316✶], [926✶], [740✶], [957✶], and [1668✶]; for some vector analysis counter examples, see [999✶].

Drawing attention to nongeneric points, it is even possible to encounter difficulties with functions of just one variable. Consider the following discontinuous function.

Which[x <= 0, 0, x > 0, 1]

For some applications, the following result is not desired, although correct almost everywhere with respect to the 1D Lebesgue measure on the real axis.

D[%, x]

The Mathematica kernel does not recognize the derivative of such discontinuous functions as proportional to Dirac delta function by default (but see Section 1.8). Other case-sensitive functions are differentiated in a similar way.

D[If[true, false[unknownVariable], dontKnow[unknownVariable]],
  unknownVariable]

Be aware that D does generically not act in a distributional sense, not for the above-mentioned case of piecewise-defined functions and not for “closed-form” functions. The following two expressions are so-called differential algebraic constants.

D[{(Sqrt[x^2] - x)/(2x), (Log[x^2] - 2 Log[x])}, x] // Together

Such constants are piecewise constants, but they may have jumps in the complex plane and/or the real axis.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{Plot[(Sqrt[x^2] - x)/(2x), {x, -1, 1}, Frame -> True, Axes -> False],
 Plot3D[Im[(Log[(x + I y)^2] - 2 Log[x + I y])], 
        {x, -1, 1}, {y, -1, 1}, PlotPoints -> 30]}]]]

With respect to carrying out differentiations, one system option should be mentioned.

Select[Developer`SystemOptions[], 
       StringMatchQ[#[[1]], "*Derivative*"]&]

The meaning of this system option setting is that multiple derivatives should be evaluated as efficiently (with respect to time) as possible. Here, we calculate the sixth derivative of the expression (((x+1))^4)exp((x^4)).

f = (x + 1)^4 Exp[x^4];
D[f, {x, 6}]

Repeatedly differentiating (((x+1))^4)exp((x^4)) gives a different-looking (although of course mathematically equivalent) expression.

Nest[D[#, x]&, f, 6]

To carry out multiple derivatives by repeated differentiation, we can use the system option setting "DirectHighDerivatives" -> False.

Developer`SetSystemOptions["DirectHighDerivatives" -> False];
D[f, {x, 6}]

Expand[%%% - %]

There is no general rule regarding what is preferable, the setting "DirectHighDerivatives" -> False or "DirectHighDerivatives" -> True. In many cases, "DirectHighDerivatives" -> True will be much faster, but will produce larger results. Here is a “typical” example.

With[{f = x^3 Log[x^5 + 1] Exp[-x^2], n = 50},
{Developer`SetSystemOptions["DirectHighDerivatives" -> True];
 Timing[ByteCount[D[f, {x, n}]]],
 Developer`SetSystemOptions["DirectHighDerivatives" -> False];
 Timing[ByteCount[D[f, {x, n}]]]}]

For the following simple polynomial it is fastest to not use special algorithms.

With[{f = Sum[k x^k, {k, 1600}], n = 400},
{Developer`SetSystemOptions["DirectHighDerivatives" -> True];
 Timing[ByteCount[D[f, {x, n}]]],
 Developer`SetSystemOptions["DirectHighDerivatives" -> False];
 Timing[ByteCount[D[f, {x, n}]]]}]

We restore the default setting.

Developer`SetSystemOptions["DirectHighDerivatives" -> True]

The next input makes use of fairly high derivatives. We visualize the (normalized) coefficients (Subscript[c, k]^((n))) appearing in

((∂^n)/(∂(z^n))) ((1/(ln(z))))=(1/((z^n)(ln^(n+1))(z)))(∑_(k=0)^(n-1))(Subscript[c, k]^((n)))(ln^k)(z).

Here, we use n=1…200.

Show[Graphics3D[
Table[(* the derivative *) deriv = D[1/Log[z], {z, n}]; 
      (* the coefficients *) cl = CoefficientList[Expand[
                     (-1)^n z^n Log[z]^(n + 1)deriv], Log[z]];
      (* colored line *)
      {Hue[n/ 250], Line[MapIndexed[{#2[[1]] - 1, n, #1}&,  
          (* normalize coefficients *) cl/Max[Abs[cl]]]]}, {n, 200}]],
     BoxRatios -> {1, 3/2, 0.5}, PlotRange -> All, 
     Axes -> True, ViewPoint -> {0, 3, 1}]

In addition to explicitly given functions, Mathematica is also able to differentiate certain abstract function(al)s of functions, for example, indefinite integrals or inverse functions [66✶], [856✶], [1548✶], [1452✶].

Table[D[InverseFunction[Υ][z], {z, i}], {i, 3}]

We now turn to a topic that has not yet been discussed, the FullForm of derivatives. This came up in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks in connection with the numerical solution of differential equations.

FullForm[𝕩'[𝕥]]

FullForm[𝕩''[𝕥]]

FullForm[D[𝕙[𝕩, 𝕪], {𝕩, 1}, {𝕪, 2}]]

In this form, we have Derivative.

To use it, we write Derivative[(Subscript[i, 1]), (Subscript[i, 2]), …, (Subscript[i, n])][function][(Subscript[argument, 1]), (Subscript[argument, 2]), …, (Subscript[argument, n])], where function must be a (pure) function. If possible, the differentiation will be carried out explicitly. The result of applying Derivative to a function is again a function; applying it to a (built-in) Symbol with function properties also yields a function (head Function).

Derivative[1][Sin]

Head[%]

From a mathematical point of view, this would have given the same thing.

Derivative[1][Sin[#]&]

The following pure functions will also be differentiated.

Derivative[1][Function[x, Sin[x]]]

Derivative[1][Function[symbol, symbol^2]]

The following expression remains uncomputed because Mathematica does not know any differentiation rules for sin.

Derivative[1][sin[#]&]

The derivative function can then again be provided with variables.

Derivative[1][#^2&][argument]

The next input generates an error message because the built-in Sin command has only one argument and in the process of calculating the derivative Sin[#1, #2] is evaluated..

Derivative[1, 1][Sin]

Here are some derivatives of simple pure functions.

{Derivative[1, 1][Power], Derivative[1, 1][Times],
 Derivative[1, 2][Times]}

The next input shows a higher order derivative of the three-argument Power. (For brevity we simplify the result).

Derivative[1, 2, 3][Power][[1]] // Together

Nesting the two argument Power gives the same result.

% == (Derivative[1, 2, 3][Power[#1, Power[#2, #3]]&][[1]] // Together)

We have the following result for Plus and Times viewed as functions that can take multiple arguments.

Derivative[1, 1] /@ {Times, Plus}

Because Derivative evaluates the function with symbolic arguments, the result for “program-like” functions is sometimes not so useful.

fProgram[x_] := Module[{ξ = x}, Nest[#^2&, ξ, ν]]

{fProgram[3], fProgram'}

Note the following difference between the assumptions on the dependence of the expressions considered for D and for Derivative.

Derivative[1][fuga]

%[x]

D[fuga, x]

This is the implicitly understood grouping: The compound head Derivative[1] is applied to the (function) x and gives Derivative[1][x]. This expression is applied to the argument t.

((Derivative[1])[x])[t]

The following two trials to group the expression differently fail.

Derivative[1]([x][t])

Derivative([1][x])[t]

Derivative can of course also calculate higher derivatives.

Derivative[12][#1 Sin[#]&]

FullForm[%]

Note that to write the last result in a compact form the body of the pure function was evaluated.

{Derivative[1][Sin[abc1 = 1; #]&], Derivative[2][Sin[abc2 = 1; #]&]}

{abc1, abc2}

Note that Derivative is one of the few commands that does not carry the attribute Protected.

Attributes[Derivative]

The reason for this is that derivatives can be user defined. The following definition does not work.

bcr''[x_] ^:= bcrss[x]

bcr /: bcr''[x_] := bcrss[x]

We recognize the reason for the above failure by looking at the FullForm of the expression.

bcr''[x_] // FullForm

{(bcr''[x])[[0]], (bcr''[x])[[0, 0]], (bcr''[x])[[0, 0, 0]]}

Thus, bcr is too deeply nested in Derivative[2][bcr][Pattern[x, Blank[]]] to associate a rule with it. (Remember, for TagSet to work, it was necessary for the symbol associated with the definition to appear in level 1.)

Position[bcr''[x_], bcr]

Therefore, the rule has to be associated with Derivative, which does not carry the attribute Protected.

Clear[bcr, bcrss]

bcr''[x_] := bcrss[x]

Here is the information now associated with Derivative.

Definition[Derivative]

Note that the following definition would still work. (We do not give an explicit argument.)

bcr''[x_] =.

Definition[Derivative]

bcr'' ^:= bcrss

Again, the information is coupled with Derivative, but stored with bcr.

Definition[Derivative]

Definition[bcr]

The fact that derivatives are internally represented as Derivative[n][f][arg] allows us, in a convenient way, to replace the function f with an explicitly given function (head Function). The following function odeForPolynomial calculates the differential equation that annihilates an n-nomial (this is a sum of n different terms of the form (x^m)) [1374✶].

odeForPolynomial[y_, x_, numberOfTerms_] :=
Det @ Table[Nest[D[#, x]&, Nest[(x D[#, x])&, y[x], j], i],
            {i, 0, numberOfTerms}, {j, 0, numberOfTerms}]

Here is its explicit form for generic binomials, y(x)=a(x^p)+b(x^q).

odeForPolynomial[𝓎, 𝓍, 2]

Substituting this functions in the above expression gives zero for all p and q.

% /. 𝓎 -> Function[𝓍, 𝒶 𝓍^𝓅 + 𝒷 𝓍^𝓆] // Expand

Until now, we encountered derivatives of the form Derivative[(Subscript[i, 1]), (Subscript[i, 2]), …, (Subscript[i, n])]. When the arguments of a function have explicit list heads, the list structure is mirrored in the Derivative arguments. Some of the built-in special functions (to be discussed in Chapter 3), such as HypergeometricPFQ and MeijerG, have such arguments. Here is a simple example. The function 𝕗 has a second argument that is a nested list.

Clear[𝕗, x, a];
D[𝕗[x, {x, {x}}, a], x]

Next, we use the function derivative to implement a generalized Taylor series expansion [802✶], [743✶], [1009✶], [680✶], [1475✶], [172✶], [1121✶]. In addition to the usual derivatives at the expansion point (Subscript[z, 0]) it also contains derivative contributions at z. (The two parameters m and n are nonnegative integers and R is the remainder term.)

f(z)=f((Subscript[z, 0]))+(∑_(k=1)^o)(((m+n-k)!)/((m+n)!)) ((({{m}, {k}})) Derivative[k][𝒻]((Subscript[z, 0]))-(((-1))^k) (({{n}, {k}})) Derivative[k][𝒻](z)) (((z-(Subscript[z, 0])))^k)+(Subscript[R, o+1])[f](z,(Subscript[z, 0]))

GeneralizedTaylorSeries[𝒻_, {m_, n_}, {z0_, z_}, o_] :=
𝒻[z0] + Sum[If[m + n - k < 0, 0, (m + n - k)!/(m + n)! *
 (Binomial[m, k] Derivative[k][𝒻][z0] -
  (-1)^k Binomial[n, k] Derivative[k][𝒻][z]) (z - z0)^k], {k, o}]

We will use f(z)=exp(z), (Subscript[z, 0])=0, and o=6 in the following. For n=0, we recover the ordinary Taylor series.

GeneralizedTaylorSeries[Exp, {6, 0}, {0, z}, 6]

For m=n, we obtain a series that contains the function exp(z) itself.

GeneralizedTaylorSeries[Exp, {6, 6}, {0, z}, 6]

Equating the last expression to exp(z) yields the diagonal Padé approximation of order 6.

Module[{exp}, Together //@ 
       Solve[(% == Exp[z] /. (* rename *) Exp[z] -> exp), exp] /.
       exp -> Exp[z]]

(* load Padé package *)
Needs["Calculus`Pade`"]
Pade[Exp[x], {x, 0, 6, 6}] // Together

We calculate some more of the generalized expansion for 0≤m,n≤9.

Do[exp[{m, n}, z_] = GeneralizedTaylorSeries[Exp, {m, n}, {0, z}, 6],
   {m, 0, 9}, {n, 0, 9}]

The left graphic shows the logarithm of the absolute error at z=1 over the m,n-plane. The right graphic shows the logarithm of the absolute error of the 100 approximations as a function of real z. We color the curves according to their m,n-values. The two graphics show the error is smallest for m≈n.

(* high-precision value for the absolute error *)
δexpHP[{m_, n_}, z_?NumericQ] := 
     With[{(* make input exact *)ζ = SetPrecision[z, Infinity]},
          N[Abs[exp[{m, n}, ζ] - Exp[ζ]], 
            (* guaranteed digits *) $MachinePrecision + 1]]

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {(* at z = 1 over the n,m-plane *)
  ListPlot3D[Log[Table[δexpHP[{m, n}, 2], 
                           {m, 0, 9}, {n, 0, 9}]]],
  (* as a function of real z *)
  Show[Table[Plot[Log[δexpHP[{m, n}, z]], 
      {z, -2, 2}, PlotRange -> All, DisplayFunction -> Identity,
      PlotStyle -> RGBColor[m/9, 0, n/9]], {m, 0, 9}, {n, 0, 9}],
     Frame -> True, PlotRange -> All]}]]]

Next, we discuss total differentials of a function of several variables [1027✶]. This is accomplished in Mathematica as follows.

Here is the total differential of a function z[x, y], where y is considered as a function of x.

Clear[z, x, y];
Dt[z[x, y], x]

This behavior of Dt makes it very useful in changing variables in 1D integrals. If we have an integrand f[s] and change the integration variable from s to Sin[t], the new integrand can be obtained in the following way.

(𝕗[𝓈] /. {𝓈 -> Sin[𝓈]}) Dt[Sin[𝓈], 𝓈]

Here is an example of a total differential of order 2.

Dt[z[x, y], x, z]

Of course, higher orders can be calculated [1010✶].

Expand[Nest[Dt, f[x, y], 4]] // Short[#, 6]&

Note the following difference in the assumption of the implicit dependence in D[…] compared with Dt[…]:

({{D[y, x], gives, 0}, {D[y, x, NonConstants -> y], gives, D[y, x, NonConstants -> {y}]}, {Dt[y, x], gives, Dt[y, x]}, {Dt[y, x, Constants -> y], gives, 0}, {Derivative[j][y], gives, (y^((j)))}})

Although differentiation is generally an elementary process, the ability to do it on a computer is often a big advantage. We can illustrate this with a few concepts from differential geometry.

Often, it is useful or necessary to work with coordinates other than the commonly used Cartesian coordinate system. For example, we may have to work with non-Euclidean geometry (e.g., in general relativity theory). For such calculations, the following three quantities play a fundamental role: the metric tensor, the Christoffel symbols, and the Riemann curvature tensor.

We now discuss the basic relationships between these quantities. If we change from a coordinate system S with coordinates x to a new system S' with coordinates x' on a manifold, the local connection between the two is given by (Subscript[A, n']^n)=∂(x^n)(x)/∂(x^(n')). Under such a coordinate transformation, the metric tensor (Subscript[g, "mn"])=(Subscript["e", m])(P)(Subscript["e", n])(P) where (Subscript["e", n])(P) is the basis vector in the direction (x^n) at the point P, becomes (Subscript[g, n'm'])=(Subscript[g, "nm"])(Subscript[A, n']^n)(Subscript[A, m']^m)where it is to be summed over repeated indices (Einstein’s summation convention).

In addition to this covariant metric tensor (which is covariant because it has subscripts), its contravariant form (g^("mn")), defined by (Subscript[g, "mn"])(g^("np"))=(Subscript[δ, m]^p) (with (Subscript[δ, m]^o) the Kronecker symbol), also plays an important role. The Christoffel symbols (Subscript[Γ, "ab"]^m) can be computed from the metric tensor (which is in general x-dependent). They represent the changes in the basis vectors for infinitesimal movements:

((∂(Subscript["e", i])(P))/(∂(x^j)))=(Subscript[Γ, "ij"]^k)(Subscript["e", k])(P).

The Christoffel symbols themselves are given by

(Subscript[Γ, "ab"]^m)=(1/2)(g^("mn"))((Subscript[g, "an",b])+(Subscript[g, "bn",a])-(Subscript[g, "ab",n]))

where (Subscript[f, ,x]) is the derivative of f with respect to x. Whether a space (or a geometry) is intrinsically curved, or whether only curvilinear coordinates are involved, can be decided on the basis of the Riemann curvature tensor (Subscript[R, "qkl"]^i). This in turn can be found from the Christoffel symbols as follows:

(Subscript[R, "qkm"]^i)=(Subscript[Γ, "qk",m]^i)-(Subscript[Γ, "qm",k]^i)-(Subscript[Γ, "pk"]^i)(Subscript[Γ, "qm"]^p)+(Subscript[Γ, "pm"]^i)(Subscript[Γ, "qk"]^p).

Geodesic equations are differential equations that describe the shortest path between two points (the path taken by a physical particle). They have the form:

(((d^2)(x^m)(λ))/(d(λ^2)))+(Subscript[Γ, "ab"]^m)(((("dx")^a)(λ))/(dλ))(((("dx")^b)(λ))/(dλ))=0.

Here, λ is the parameter (e.g., time). (For more on differential geometry, see, for example, [1022✶], [1472✶], [1262✶], [322✶], [1103✶], [9✶], [1609✶], [477✶], [1044✶], [1698✶], [689✶], [616✶], and [1167✶].)

As a simple computational example, we now look at all of the above quantities for the case of 3D spherical coordinates. We begin with the metric tensor in Cartesian coordinates (we assume these are the initial coordinates). The variable u stands for upper and denotes an upper index; similarly, l denotes a lower index. (There is a more elegant way to do this than what we will do in the following program.) As is common in differential geometry, we will explicitly work with components and thus prefer to use g[n, m] rather than g[[n, m]]. (For a very elegant Mathematica implementation of upper and lower indices for tensor calculations, see [737✶].)

MetricTensorCart[l, l] = IdentityMatrix[3];
MetricTensorCart[l, l, n_, m_] := MetricTensorCart[l, l][[n, m]];

Here is the change of coordinates, where we express the old Cartesian coordinates in terms of new spherical coordinates.

oldVariable = {(* x = *)  r Cos[φ] Sin[ϑ],
               (* y = *)  r Sin[φ] Sin[ϑ],
               (* z = *)  r Cos[ϑ]};

newVariable = {r, ϑ, φ};

The passage from the coordinates (x^(n'))=(x^(n'))((x^n)) ((x^n) for Cartesian coordinates, (x^(n')) for 3 spherical coordinates) is described by the coordinate transformation matrix (the Jacobian) (Subscript[A, n']^n)=∂(x^n)(x)/∂(x^(n')).

(* the whole matrix *)
A[u, l] = Outer[D, oldVariable, newVariable];
(* the elements *)
A[u, l, n_, ns_] := A[u, l][[n, ns]]
A[u, l] // TableForm

The metric tensor (Subscript[g, n'm']) in the new spherical coordinates becomes (Subscript[g, n'm'])=(Subscript[g, n m])(Subscript[A, n']^n)(Subscript[A, m']^m). The replacement rules carry out specific simplification; they are significantly faster than Simplify.

MetricTensorSphere[l, l] =
Table[Sum[MetricTensorCart[l, l, n, m] *
            A[u, l, n, ns] A[u, l, m, ms],
          {n, 3}, {m, 3}] //. {a_. Cos[φ_]^2 + a_. Sin[φ_]^2 -> a},
      {ns, 3}, {ms, 3}];

MetricTensorSphere[l, l, ns_, ms_] := MetricTensorSphere[l, l][[ns, ms]]

Here is MetricTensorSphere evaluated.

MetricTensorSphere[l, l] // TableForm

We still need the metric tensor with superscripts. The connection is given by (Subscript[g, "mn"])(g^("np"))=(Subscript[δ, m]^p).

MetricTensorSphere[u, u] = Inverse[MetricTensorSphere[l, l]];
MetricTensorSphere[u, u, ns_, ms_] := MetricTensorSphere[u, u][[ns, ms]]

MetricTensorSphere[u, u] // TableForm

We now compute the Christoffel symbols. A bit of work is involved in finding the derivatives.

Christoffel[u, l, l] =
Table[1/2 Sum[   MetricTensorSphere[u, u, m, n]*
              (D[MetricTensorSphere[l, l, a, n], newVariable[[b]]] +
               D[MetricTensorSphere[l, l, b, n], newVariable[[a]]] -
               D[MetricTensorSphere[l, l, a, b], newVariable[[n]]]), 
               {n, 3}], {m, 3}, {a, 3}, {b, 3}];
(* the elements *)
Christoffel[u, l, l, m_, a_, b_] := Christoffel[u, l, l][[m, a, b]]

We now examine them explicitly.

Christoffel[u, l, l] // 
        TableForm[#, TableSpacing -> {4, 1, 1},
                     TableDirections -> {Row, Row, Column}]&

Next, we calculate the curvature tensor. For Euclidean space with a curvilinear coordinate system, all of these components are equal to 0.

CurvatureTensor[u, l, l, l] =
Table[D[Christoffel[u, l, l, i, q, k], newVariable[[m]]] -
      D[Christoffel[u, l, l, i, q, m], newVariable[[k]]]  -
      Sum[Christoffel[u, l, l, i, p, k] *
          Christoffel[u, l, l, p, q, m] -
          Christoffel[u, l, l, i, p, m] *
          Christoffel[u, l, l, p, q, k], {p, 3}],
      {i, 3}, {q, 3}, {k, 3}, {m, 3}] // Simplify // TableForm

To conclude, we also look at the geodesic equations. They have the following symbolic form:

(((("dx")^m)(λ))/(d(λ^2)))+(Subscript[Γ, "ab"]^m)(((("dx")^a)(λ))/(dλ))(((("dx")^b)(λ))/(dλ))=0

Because we need the explicit dependence of the variables r, φ, and ϑ on a parameter λ, we define an auxiliary function 𝓋ϡ𝓇[n] that implements this.

𝓋ϡ𝓇[n_] := 𝓋ϡ𝓇[n] = newVariable[[n]][λ]

Here is the result of applying var to 1, 2, and 3.

{𝓋ϡ𝓇[1], 𝓋ϡ𝓇[2], 𝓋ϡ𝓇[3]}

GeodesicEquations =
Table[D[𝓋ϡ𝓇[m], {λ, 2}] +
       Sum[(Christoffel[u, l, l, m, a, b] /.
       (* replace variables with variables with arguments *)
                           {r -> r[λ], φ -> φ[λ], ϑ -> ϑ[λ]})*
                     D[𝓋ϡ𝓇[a], λ]* D[𝓋ϡ𝓇[b], λ],
           {a, 3}, {b, 3}] == 0, {m, 3}]

In Euclidean space, geodesics (shortest paths) are straight lines. We quickly check this by finding a numerical solution of the geodesic equations.

GeodesicPlot[r0_, φ0_, ϑ0_, r0s_, φ0s_, ϑ0s_, ficTime_] :=
ParametricPlot3D[ (* the geodesic *)
          Evaluate[{r[λ] Cos[φ[λ]] Sin[ϑ[λ]],
                    r[λ] Sin[φ[λ]] Sin[ϑ[λ]],
                    r[λ]           Cos[ϑ[λ]]} /.
        (* solve the differential equation for the geodesic *)
       NDSolve[Flatten[{GeodesicEquations,
                (* initial conditions *)
                r[0] == r0, φ[0] == φ0, ϑ[0] == ϑ0,
                r'[0] == r0s, φ'[0] == φ0s, ϑ'[0] == ϑ0s}],
  {r, φ, ϑ}, {λ, 0, ficTime}, MaxSteps -> 5000]], {λ, 0, ficTime},
 PlotLabel -> "A geodesic", AxesLabel -> {"x", "y", "z"}]

The following plot verifies this result.

GeodesicPlot[1, 1, 1, 1/2, 1, -1, 0.2]

As a visually more interesting example than the just-calculated straight line, we now calculate some geodesics on a surface in (ℝ^3). The implicit description of the surface is the following.

holedCube = (# @ x + # @ y + # @ z[x, y])&[(-8 #^4 + 8 #^2 - 1)&]

(We used this quartic describing a “holed cube” in Chapter 3 of the Graphics volume of the GuideBooks [1560✶].) Because in the above formulas, we need to express new coordinates through old ones, we view x and y as the old ones and {x,y,z(x,y)} as the new ones (meaning, we consider x and y as the variables that parametrize the surface). To avoid ugly radicals and potential branch cut problems, we avoid solving explicitly for z(x,y), but, rather express all quantities again in x, y, and z(x,y). Differentiating the last equation repeatedly allows to obtain rational functions for the derivatives (z^((i,j)))(x,y).

zDerivativeRules = Factor[Together[#]]& //@
Solve[# == 0& /@ #[holedCube], #[z[x, y]]]&[
     (* all derivatives up to total order 2 *)
     Flatten[Table[If[0 < i + j < 3, D[#, {x, i}, {y, j}], 
                      {}], {i, 0, 2}, {j, 0, 2}]]&][[1]];
zDerivativeRules /. z[x, y] -> z // Simplify

Using these derivatives allows to express (Subscript[g, "mn"]) and (g^(mn)) as rational functions in x, y, and z(x,y) too.

𝓍𝓎𝓏 = {x, y, z[x, y]};
{𝓍𝓎𝓏x, 𝓍𝓎𝓏y} = {{1, 0, D[z[x, y], x]}, 
                {0, 1, D[z[x, y], y]}} /. zDerivativeRules;
                
gll = {{𝓍𝓎𝓏x.𝓍𝓎𝓏x, 𝓍𝓎𝓏x.𝓍𝓎𝓏y}, {𝓍𝓎𝓏x.𝓍𝓎𝓏y, 𝓍𝓎𝓏y.𝓍𝓎𝓏y}};
guu = Factor //@ Together //@ Inverse[gll];

Next, we calculate the Christoffel symbols (Subscript[Γ, "abc"]) and (Subscript[Γ, "ab"]^c). Again they are rational functions in x, y, and z.

𝓍𝓎[1] = x; 𝓍𝓎[2] = y;

Γlll[a_, b_, c_] := Γlll[a, b, c] = 
 (* rewritten form of derivatives of gll *)
 Together[(D[𝓍𝓎𝓏, 𝓍𝓎[a], 𝓍𝓎[b]].D[𝓍𝓎𝓏, 𝓍𝓎[c]]) /. 
                    zDerivativeRules] /. z[x, y] -> z;
       
Γllu[a_, b_, c_] := Γllu[a, b, c] = (* raise third index with g *)
Together[Sum[Γlll[a, b, d] guu[[c, d]], {d, 2}]] /. z[x, y] -> z

The two equations for the geodesics are of the form x''(τ)=F(x(τ),y(τ),z(τ),x'(τ),y'(τ),z'(τ)) and similar for y''(τ). To make sure the geodesics stay on the original, implicitly defined surface, and to obtain three equations for the three coordinates, we supplement the two geodesic equations with the differentiated form of the implicit equation (meaning (grad holedCube(x(τ),y(τ),z(τ))).{x'(τ),y'(τ),z'(τ)}=0 [297✶].

geodesicEquations = (# == 0)& /@ Append[
(* second-order odes for x[τ] and y[τ] *)
Table[D[𝓍𝓎[c][τ], τ, τ] +
Sum[Γllu[a, b, c] D[𝓍𝓎[a][τ], τ] D[𝓍𝓎[b][τ], τ], {a, 2}, {b, 2}],
    {c, 2}] /. Derivative[n_][xy_][τ] :> Derivative[n][xy], 
 (* differentiated form of the implicit equation of the surface *)
 D[holedCube  /. {x -> x[τ], y -> y[τ], z[x, y] -> z[τ]}, τ] /.
                 xyz_[τ] -> xyz] /. {x -> x[τ], y -> y[τ], z -> z[τ]} /.
                  Derivative[n_][xy_[τ]] :> Derivative[n][xy][τ];

For a nicer visualization, we calculate a graphic of the surface.

Needs["Graphics`ContourPlot3D`"]

holedCubeGraphic3D = Graphics3D[{EdgeForm[], 
(* map in other positions *)
Fold[Function[{p, r}, {p, Map[# r&, p, {-2}]}], 
    (* 3D contour plot of holedCube in the first octant *)
    Cases[ContourPlot3D[Evaluate[holedCube /. z[x, y] -> z],
           {x, 0, 1.1}, {y, 0, 1.1}, {z, 0, 1.1},
           PlotPoints -> {{24, 2}, {20, 2}, {12, 2}}, 
           MaxRecursion -> 1, DisplayFunction -> Identity], _Polygon, 
          {0, Infinity}] /. Polygon[l_] :> (* make diamonds *)
     Polygon[Plus @@@ Partition[Append[l, First[l]], 2, 1]/2], 
                       {{-1, 1, 1}, {1, -1, 1}, {1, 1, -1}}]}];

We visualize the geodesics as lines on the surface. To avoid visually unpleasant intersections between the discretized surface and the discretized geodesics, we define a function liftUp that lifts the geodesics slightly in direction of the local surface normal.

normal[{x_, y_, z_}] = (* gradient gives the normal *)
 D[holedCube /. z[x, y] -> z, #]& /@ {x, y, z} // Expand;

liftUp[{x_, y_, z_}, ε_] = (* move in direction of normal *)
       {x, y, z} - ε #/Sqrt[#.#]&[normal[{x, y, z}]];

In the following graphic, we calculate 64 geodesics. We choose the starting points along the upper front “beam”. The function rStart parametrizes the starting values.

rStart[φ_] := rStart[φ] = Module[{r}, r /. FindRoot[Evaluate[
  holedCube == 0 /. {x -> 0, y -> 0.7 + r Cos[φ], 
                     z[x, y] -> 0.7 + r Sin[φ]}], {r, 0, 1/3}]]

Here are the resulting geodesics. On the nearby smoothed corners of the cube, we see the to-be-expected caustics.

Module[{o = 64, T = 4, 𝓅, τ1, τ2},
Show[{(* the surface *) holedCubeGraphic3D, 
Table[
(* solve differential equations for geodesics *)
nsol = NDSolve[Join[geodesicEquations,
             (* starting values *)
             {x[0] == 0, y[0] == 0.7 + rStart[φ] Cos[φ], 
                         z[0] == 0.7 + rStart[φ] Sin[φ],
              x'[0] == 1, y'[0] == 0}],
        {x, y, z}, {τ, -T, T}, MaxSteps -> 2 10^4,
        (* use relatively low precision goals for speed *)
        PrecisionGoal -> 4, AccuracyGoal -> 6];
(* parametrized geodesics *)
𝓅[τ_] :=  (Append[liftUp[{x[τ], y[τ], z[τ]} /. nsol[[1]], 0.015],
                    {Thickness[0.003], Hue[φ/(2Pi)]}]);      
(* for larger T *) {τ1, τ2} = nsol[[1, 1, 2, 1, 1]];
(* show surface and geodesics *)
ParametricPlot3D[𝓅[τ], {τ, τ1, τ2}, Compiled -> False, 
                 PlotPoints -> Round[200 (τ2 - τ1)], 
                 DisplayFunction -> Identity],
                 {φ, 0, 2Pi (1 - 1/o), 2Pi/o}]},
     DisplayFunction -> $DisplayFunction, Boxed -> False, 
     Axes -> False, ViewPoint -> {2.2, 2.4, 1.6}]]

We end here and leave it to the reader to calculate euthygrammes [803✶]. For large-scale calculations of this kind arising in general relativity (see [327✶]), we recommend the advanced (commercially available) Mathematica package MathTensor by L. Parker and S. Christensen [1238✶] (http://smc.vnet.net/MathSolutions.html); or the package Cartan by H. Soreng (http://store.wolfram.com/view/cartan). For the algorithmic simplification of tensor expressions, see [106✶] and [1286✶].

Next, we give an application of differentiation involving graphics: the evolute of a curve, the evolute of the evolute of a curve, the evolute of the evolute of the evolute of a curve, etc. [244✶].

The evolute of a curve is the set of all centers of curvature associated with the curve. For a planar curve given in the parametric form (x(t),y(t)), the parametric representation of its evolute is:

(((x(t)-y'(t)(((x'(t))^2)+((y'(t))^2)))/(x'(t)y''(t)-y'(t)x''(t))),((y(t)+x'(t)(((x'(t))^2)+((y'(t))^2)))/(x'(t)y''(t)-y'(t)x''(t)))).

For more on evolutes and related topics, see any textbook on differential geometry, for example, [1022✶], [1262✶], [443✶], [689✶], and [551✶]. For curves that are their own evolutes, see [1684✶].

Here we implement the definition directly. We apply Together to get one fraction. The optional function simp simplifies the resulting expressions in a user-specified way.

Evolute[{x_, y_}, t_, simp_:Identity] :=
simp[{x - #2(#1^2 + #2^2)/(#1 #4 - #2 #3),
      y + #1(#1^2 + #2^2)/(#1 #4 - #2 #3)}&[
     (* compute all derivatives only once *)
          D[x, t], D[y, t], D[x, {t, 2}], D[y, {t, 2}]] //
     (* avoid blow-up in size of iterated form *)  Together]

For a circle, the set of all centers of curvature is precisely the center of the circle.

Evolute[{Cos[ϑ], Sin[ϑ]}, ϑ]

For an ellipse, we get a nontrivial parametrized curve.

Evolute[{a Cos[ϑ], b Sin[ϑ]}, ϑ]

This is a simplified form.

Evolute[{a Cos[ϑ], b Sin[ϑ]}, ϑ,
        (# /. {a_. Sin[ϑ]^2 + a_. Cos[ϑ]^2 -> a})&]

We now iterate the formation of evolutes starting with an ellipse, and we graph the resulting evolutes. We use 10 ellipses with different half-axes ratios. The right graphic shows a magnified view of the center region of the left graphic.

Show[GraphicsArray[{Show[#], 
                    Show[#, PlotRange -> {{-3, 3}, {-3, 3}}]}&[
Table[ParametricPlot[Evaluate[(* nest forming the evolute *)
NestList[Evolute[#, ϑ, (# /. {a_. Sin[ϑ]^2 + a_.Cos[ϑ]^2 -> a})&]&,
{α Cos[ϑ], 2 Sin[ϑ]}, 4]], {ϑ, 0, 2Pi}, 
               PlotStyle -> {Hue[0.78 (α - 3/2)]},
               Axes -> False, PlotRange -> All, AspectRatio -> 1,
               DisplayFunction -> Identity, PlotPoints -> 140], 
 (* values of α *) {α, 3/2, 5/2, 1/11}]]]]

A rich field for the generation of nice curves is given by starting the above process, for instance, with Lissajous figures. We could now go on to the analogous situation for surfaces. Here, for an ellipsoid, we construct a picture with the two surfaces formed by going the amount of the principal radii of the curvature in the direction of the normal to the surface [1053✶].

With[{(* ellipsoid half axis *)a = 1, b = 3/4, c = 5/4,
      (* avoid 0/0 in calculations *) ε = 10^-12},
Module[{φ, ϑ, x, y, z, e, f, g, l, m, n, λ, ν, μ, k, h,
        cross, normal1, normal, ellipsoid, makeAll},
(* parametrization of the ellipsoid *)
{x, y, z} = {a Cos[φ] Sin[ϑ], b Sin[φ] Sin[ϑ], c Cos[ϑ]};
(* E, F, G from differential geometry of surfaces *)
e = D[x, φ]^2 + D[y, φ]^2 + D[z, φ]^2;
g = D[x, ϑ]^2 + D[y, ϑ]^2 + D[z, ϑ]^2;
f = D[x, φ] D[x, ϑ] + D[y, φ] D[y, ϑ] + D[z, φ] D[z, ϑ];
(* L, M, N from differential geometry of surfaces *)
{l, n, m} =  Det[{{D[x, ##], D[y, ##], D[z, ##]},
                  D[#, φ]& /@ {x, y, z}, D[#, ϑ]& /@ {x, y, z}}]& @@@
                              {{φ, φ}, {ϑ, ϑ}, {φ, ϑ}};
{λ, ν, μ} = {l, m, n}/Sqrt[e g - f^2];         
(* Gaussian curvature and mean curvature *)
k = (λ ν - μ^2)/(e g - f^2);
h = (g λ - 2 f μ + e ν)/(2 (e g - f^2));
(* normal on the ellipsoid *)
normal1 = Cross[{D[x, φ], D[y, φ], D[z, φ]},
                {D[x, ϑ], D[y, ϑ], D[z, ϑ]}];
normal = normal1/Sqrt[normal1.normal1];
(* construct all pieces from the piece of one octant *)
makeAll[polys_] := Function[v, Map[v #&, polys, {-2}]] /@ 
 {{ 1,  1,  1}, { 1,  1, -1}, { 1, -1,  1}, {-1,  1,  1},
  {-1, -1,  1}, { 1, -1, -1}, {-1,  1, -1}, {-1, -1, -1}};
(* 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}]}];
(* a sketch of the ellipsoid *)
ellipsoid = {Thickness[0.002],
(ParametricPlot3D[Evaluate[{x, y, z}],
   {φ, 0, 2Pi}, {ϑ, 0, Pi}, DisplayFunction -> Identity][[1]]) //.
                                            Polygon[l_] :> Line[l]};
(* surfaces of the centers of the principal curvatures *)
Show[GraphicsArray[
Graphics3D[{ellipsoid, {EdgeForm[],
makeAll @ ParametricPlot3D[#, {φ, ε, Pi/2 - ε}, {ϑ, ε, Pi/2 - ε},
                 DisplayFunction -> Identity][[1]]}}, Boxed -> False,
                 PlotRange -> All]& /@
{{x, y, z} + normal 1/(h + Sqrt[h^2 - k]),
 {x, y, z} + normal 1/(h - Sqrt[h^2 - k])}] /.
             p_Polygon :> makeHole[p, 0.7], GraphicsSpacing -> 0]]]

We give one more example illustrating the usefulness of symbolic differentiation.

Here, we are dealing with a method for the approximate solution of the ordinary differential equation (and associated eigenvalue problem):

y''(z)+(R^2)(z)y(z)=0,    (R^2)(z)≫1.

If we assume y(z) has the form

y(z)=((q(z))^(-1/2))exp(i(∫^z)q(z')("dz")'), q(z)=Q(z)g(z)

where Q(z) is “ arbitrary”, we get the following differential equation for g:

1+ε(Q(ξ))-((g(ξ))^2)+((g(ξ))^(1/2))(((d^2)((g(ξ))^(-1/2)))/(d(ξ^2)))=0
    ξ=ξ(z)=(∫^z)Q(z')("dz")',
    ε(Q)=(((R(z)-(Q^2)(z)))/((Q^2)(z)))+((Q(z))^(3/2))(((d^2)((Q(z))^(-1/2)))/(("dz")^2)).

Introducing the parameter λ (which we will later set to 1) in the differential equation,

1+(λ^2)ε(Q(ξ))-((g(ξ))^2)+(λ^2)((g(ξ))^(1/2))(((d^2)((g(ξ))^(-1/2)))/(d(ξ^2)))=0

and expanding g(z) in an infinite series in λ (with (Subscript[Y, 2n+1])=0) g(z)=(∑_(n=0)^∞)(Subscript[Y, 2n])(z)(λ^(2n)), we are led to the following recurrence formula for Y as a function of ε(ξ) and its derivatives ε'(ξ), ε''(ξ), … :

({{(Subscript[Y, 0]), =1}, {(Subscript[Y, 2n]), =(1/2)(∑_((α+β=n)/(0≤α,β,≤n-1)))(Subscript[Y, 2α])(Subscript[Y, 2β])-(1/2)(∑_((α+β+γ+δ=n)/(0≤α,β,γ,δ≤n-1)))(Subscript[Y, 2α])(Subscript[Y, 2β])(Subscript[Y, 2γ])(Subscript[Y, 2δ])}, {,     +(1/2)(∑_((α+β=n-1)/(0≤α,β≤n-1))){ε(Subscript[Y, 2α])(Subscript[Y, 2β])+(3/4)(Subscript[Y, 2α]^′)(Subscript[Y, 2β]^′)-(1/4)((Subscript[Y, 2α])(Subscript[Y, 2β]^(′′))+(Subscript[Y, 2α]^(′′))(Subscript[Y, 2β]))}}})

where (Subscript[Y, α]^′)=(Subscript[Y, α]^′)(ξ)=(Subscript["dY", α])(ξ)/dξ and ξ=ξ(z).

(Subscript[Y, 2])(ξ), (Subscript[Y, 4])(ξ), and (Subscript[Y, 6])(ξ) were found earlier by painful hand computations, but from (Subscript[Y, 8])(z) on, computer algebra becomes necessary [268✶]. For more details on such asymptotic expansions, see [604✶], [439✶], [605✶], [387✶], [917✶], [1453✶], [127✶], [1176✶], [1701✶], [1007✶], and [607✶]. For the corresponding supersymmetric problem, see [16✶], [606✶], [50✶], and [492✶].

Here, we want to find the first few nonvanishing (Subscript[Y, 2α]). We now give an unrefined implementation of the above recurrence. (It is unrefined considering the restriction α+β+γ+δ=n, and the fourfold sum can be replaced by a threefold sum.)

Υ[_Integer?OddQ] = 0;

Υ[0] = 1;

Υ[zn_Integer?EvenQ] := Υ[zn] =
Module[{n = zn/2},
(* the If is the obvious implementation,
   but it requires summing over all variables *)
1/2 Sum[If[a + b == n, 1, 0] Υ[2 a] Υ[2 b], 
        {a, 0, n - 1}, {b, 0, n - 1}] -
1/2 Sum[If[a + b + c + d == n, 1, 0] Υ[2 a] Υ[2 b] Υ[2 c] Υ[2 d],
        {a, 0, n - 1}, {b, 0, n - 1}, {c, 0, n - 1}, {d, 0, n - 1}] +
1/2 Sum[If[a + b == n - 1, 1, 0] *
        (ε[ξ] Υ[2 a] Υ[2 b] + 3/4 D[Υ[2 a], ξ] D[Υ[2 b], ξ] -
        1/4 (Υ[2 a] D[Υ[2 b], {ξ, 2}] + D[Υ[2 a], {ξ, 2}] Υ[2 b])),
        {a, 0, n - 1}, {b, 0, n - 1}] //
  (* keep the results as short as possible *) Expand // Factor]

We now look at the first few (Subscript[Y, i])(z).

Υ[2]

Υ[4]

Υ[6]

Υ[8]

The Y[i] for higher orders can also be found in a few seconds.

Timing[Υ[16]]

1.6.2 Integration

Symbolic integration of functions is one of the most important capabilities of Mathematica. In contrast to many other operations (which can also be carried out by hand by the user, albeit more slowly and probably with more errors), and in addition to standard methods such as integration by parts, substitution, etc., Mathematica makes essential use of special algorithms for the determination of indefinite integrals (see [221✶], the references cited in the appendix, Chapter 21 of [1734✶], and the very readable introductions of [1197✶], [901✶], [579✶], and [1088✶]).

Mathematica can find a great many integrals, including many that are not listed in tables. This holds primarily for integrands that are not special functions; but even for special functions, Mathematica is often able to find a closed form answer. Nevertheless, once in a while, the user will have to refer to a book such as [1298✶] for complicated integrals. For most integrals, Mathematica works with an algorithm rather than looking in a table. For indefinite integrals, these algorithms are based on the celebrated work by Risch and extensions by Trager and Bronstein [221✶]. Definite integrals are computed by using contour integration, by reduction to Meijer-G functions [1400✶], [1401✶], [256✶], [1479✶], and [519✶], or by integration via differentiation.

We have already introduced the Integrate command for symbolic integration. In view of its extraordinary importance, we repeat it here.

Let us start with a remark similar to the one made in Section 1.5. All variables in integrals are assumed to take generic complex values. So the result of the simple integral (∫^x)(x^n)d x will be 1/(n+1) (x^(n+1)).

Integrate[x^n, x]

This is the correct answer for all complex x and for nearly all complex n (the exception, which is of Lebesgue measure zero with respect to dx, being n=-1). This assumption about all unspecified variables being generic can cause indeterminate expressions when substituting numerical values into the result of an integration containing parameters.

The integrand can either be given explicitly or implicitly. Here is such an example of the latter case.

Integrate[f'[x], x]

Integrate[f'[x] f''[x], x]

Integrate[f'[x] g[x] + f[x] g'[x], x]

Integrate[Sin[f[x]] f'[x], x]

The following product cannot be symbolically integrated without the result containing unevaluated integrals (which would cause recursion).

Integrate[f'[x] g[x], x]

Be aware that in distinction to NIntegrate, the function Integrate has no HoldAll attribute. This means that the scoping behavior in nested integrals is different. Whereas NIntegrate can treat its body as a black box that delivers values at given points, the algorithms used in Integrate require an evaluation of the integrand.

Integrate carrying out an indefinite integral does not return any explicit constants of integration (implicitly the result given amounts to selecting a concrete one). So two mathematically identical integrands can result in different indefinite integrals. The following polynomial shows such a situation.

Integrate[(x + 1)^3, x]

Integrate[Expand[(x + 1)^3], x]

Expand[%% - %]

Mathematica’s ability to integrate implicitly defined functions can be seen clearly in the following example. Suppose

(Subscript[𝒢, 0])(x)=(1/2)
(Subscript[𝒢, j])(x)=(∫^x)((Subscript[𝒢, j-1]^(′′′))(x)+4𝓊(x)(Subscript[𝒢, j-1]^′)(x)+2𝓊'(x)(Subscript[𝒢, j-1])(x))"dx", j=1,2,….

These equations are of great practical importance for the construction of the Korteweg–de Vries equation hierarchy. Because the mathematical description of Lax pairs is slightly more complicated, we do not go into details here; see, however, [34✶], [648✶], [1087✶], [1297✶], [566✶], [1413✶], [1414✶], [292✶], [231✶], [1611✶], [646✶]. Note that 𝓊(x) is not explicitly defined. We now implement the above definition of the (Subscript[𝒢, j])(x).

𝒢[0] = 1/2;

𝒢[j_] := 𝒢[j] = Integrate[D[𝒢[j - 1], {x, 3}] + 4 𝓊[x] D[𝒢[j - 1], x] + 
                          2 𝓊'[x] 𝒢[j - 1], x] // Together // Numerator

We look at the first few (Subscript[𝒢, j])(x); they are “completely integrated”.

{𝒢[1], 𝒢[2], 𝒢[3]}

Here are the corresponding equations from the Korteweg–de Vries equation hierarchy. We denote the temporal derivative by (Subscript[𝓊, t]).

KdVShortForm[j_] := Subscript[𝓊, t] == Simplify[D[𝒢[j], x]] /. 
                    {𝓊[x] -> 𝓊, Derivative[i_][𝓊][x] -> Derivative[i][𝓊]}

KdVShortForm[1]

KdVShortForm[2]

KdVShortForm[3]

Higher order equations become quickly quite complicated.

KdVShortForm[6]

Iterated integrals (that cannot be done) are left alone; they are not integrated by parts.

Integrate[Integrate[𝕗[x], x], x]

In dealing with nested integrals, the variables may be renamed to avoid interference of variables with one another. (The application of Set (instead of SetDelayed) in the following definition leads to an error message concerning $RecursionLimit, as well as, an unexpected result; see also Exercise 3.)

g[x_, 0] = x;

g[x_, n_] := Integrate[g[x, n - 1], x]

{g[a, 0], g[b, 1], g[c, 2], g[z, 25]}

Here is a selection of indefinite integrals that Mathematica can compute.

Integrate[1/x^2 1/(x^2 + 4), x]

Integrate[(1 + Sin[x])/(1 - Cos[x]), x]

Integrate[Sqrt[1/x^2 1/(x^2 + 4)], x]

Integrate[Exp[-x^2] x^3, x]

Integrate[Tanh[x^2 + 3] x, x]

Integrate[Cos[x + 3]/x^3 x, x]

Integrate[Log[Log[x + 1]], x]

Integrate[ArcSin[x]^2, x]

Integrate[ArcSin[x]/x, x]

Integrate[ArcCosh[Sec[ArcSinh[x]]], x]

The following example is a complicated composition of two special functions (see Chapter 3 for Erf and ProductLog)—Mathematica is able to integrate it.

Integrate[Erf[ProductLog[c1, x]], x]

Using Simplify, it is straightforward to prove that the result was correct.

D[%, x] // Simplify

The reason for this difference is that Mathematica was setting the additive constant (that is independent of the variable of integration) differently than it is in (x - 1)^4/4 - x.

There are, however, many integrals that in principle exist, but that Mathematica cannot find. Some of them are impossible to express in terms of finite sums of functions that are built into Mathematica, and some of them are just not implemented in Version 4.0.

Integrate[Exp[1/(Log[x] + 1)], x]

Integrate[Cos[Exp[Sin[x + 1]]], x]

Sometimes indefinite integrals can be expressed in quite different forms. The next integral contains a hypergeometric function.

Integrate[1/(x^3 (a + b x)^(1/3)), x]

Sometimes Mathematica will produce answers in terms of special functions, also in cases in which it is possible to express the integral without a special function [846✶], [1592✶], [1593✶], [1076✶], [692✶], [1235✶]. (Although the result becomes typically larger.) Currently, no Method option for Integrate influences the form of the result.

D[(* closed form elementary result *)
  (-2 b^2 x^2 Sqrt[3] Log[a^(1/3) (a + b x)^(2/3) +
  a^(2/3) (a + b x)^(1/3) + a] +
  4 b^2 x^2 Sqrt[3] Log[a^(2/3) (a + b x)^(1/3) - a] +
  12 b^2 x^2 ArcTan[(2 Sqrt[3] a^(2/3) (a + b x)^(1/3) +
  a Sqrt[3])/(3a)] + (12b x - 9a) Sqrt[3] a^(1/3) (a + b x)^(2/3))/
  (18 a^2 x^2 Sqrt[3] a^(1/3)), x] - 1/(x^3 (a + b x)^(1/3)) // Simplify

Mathematica can find the indefinite integral of every rational function over the rationals (this means every function of the form polynomial1/polynomial2 in one indeterminate where both polynomials have integer or rational coefficients). Here is an example.

Integrate[(x^3 - 4 x + 8)/(x^7 - 3 x^5 + 3 x^2 - x + 9), x]

D[%, x]

The above integral contained a RootSum.While the function RootSum is closely related to the function Root, it is of relevance mostly for integration and not for solving equations.

For rational functions as the second argument, RootSum can calculate closed-form expressions.

RootSum[Function[x, x^7 - 4 x + 8], (#^2 + 1)/(# - 7)&]

If the reader has specialized applications for which Mathematica cannot do the integrals needed—but the reader can—it is easy to implement your integration table based on the pattern-matching capabilities of Mathematica. 
We now turn to definite integrals. Again, a great many integrals can be computed, frequently in terms of special functions (see Chapter 3), especially (generalized) hypergeometric functions. We now look at a few examples.

Integrate[Sin[x^2], {x, 0, 1}]

Integrate[Log[Sin[x]]^2, {x, 0, Pi}]

Integrate[Exp[-x] Log[x]^6, {x, 0, Infinity}]

Integrate[x^n (1 - x^p)^o, {x, 0, 1}]

Integrate[(Exp[-x] - Exp[-z x])/x, {x, 0, Infinity}]

Integrate[(Sin[x] - x Cos[x])^6/x^4, {x, 0, Pi}]

Integrate[(Cos[n x] - Cos[n α])/(Cos[x] - Cos[α]), {x, 0, Pi}]

Integrate[r^-3 Sin[r ρ1] Sin[r ρ2]^4, {r, 0, Infinity}]

Integrate[Log[x]/(x^2 + a^2), {x, 0, 1}]

Integrate[BesselJ[0, Sqrt[x]] BesselK[0, Sqrt[x]] Log[Sqrt[x]],
          {x, 0, Infinity}]

Integrate[Exp[-t] Log[t]^6, {t, 0, Infinity}]

Integrate[x^2 Log[x]/(x^2 + 1)^(1/2), {x, 0, 1/(2 Sqrt[2])}]

Integrate[x^(-7/2) Log[x]^5, {x, 1, Infinity}]

Integrate[Sin[x^3], {x, 0, 1}]

Integrate[Log[1 + 1/Sqrt[x]] Log[1 + x]/x^(3/2), {x, 0, Infinity}]

Integrate[Gamma[l + m]/(Gamma[l] Gamma[m])*
          x^(l - 1) (1 - x)^(m - 1) (a x + b (1 - x))^(-l - m), {x, 0, 1}]

Integrate[Sin[a x] Cos[b x]/x, {x, 0, Infinity}]

Integrate[x^s Exp[-x]/Sqrt[x + z^2], {x, 0, Infinity}]

Integrate[Csch[t]^2 - 1/t^2, {t, -Infinity, Infinity}]

Integrate[1/(x^4 + 3 x^2 + 1)^8, {x, 0, Infinity}]

The results returned by Integrate are typically not simplified. Applying RootReduce to the last expression gives a much simpler answer.

RootReduce[%]

Here is another example where applying Simplify yields a simpler answer (a Frullani-type integral [21✶], [828✶], [76✶]).

Integrate[(Sin[α x] - Sin[β x])^2/x^2, {x, 0, Infinity},
          Assumptions -> (Im[α] == 0 && Im[β] == 0)] //
                    Simplify[#, Im[α] == 0 && Im[β] == 0]&

The following two integrals contain Gamma functions. 𝓅 is the probability distribution of the third power of a normal distributed variable 𝓅(x)=(π^(-1/2))(∫_(-∞)^∞)δ(x-(ξ^3))exp(-(x^2))dξ [138✶]. Interestingly, the distribution 𝓆 has the same moments as 𝓅. Because we cannot specify that n in an integer through Assumptions, we use Simplify on the result.

𝓅[x_] := 1/(3 Sqrt[Pi]) Abs[x]^-(2/3) Exp[-Abs[x]^(2/3)]

𝓆[x_, r_] := 𝓅[x] * (* the following factor is positive for r < 1/2 *)
                (1 + r (Cos[Sqrt[3] Abs[x]^(2/3)] - 
                  Sqrt[3] Sin[Sqrt[3] Abs[x]^(2/3)]))

{moment𝓅[n_], moment𝓆[n_, r_]} = 
       Integrate[x^n {𝓅[x], 𝓆[x, r]}, {x, -Infinity, Infinity},
                 Assumptions -> Re[n] > 0]

Because of symmetry, the odd moments vanish for 𝓅 and 𝓆 and the even moments agree.

Simplify[moment𝓅[n] == moment𝓆[n, r], Element[n/2, Integers]]

As some of the above examples showed, sometimes Mathematica will produce If statements as results, where the first argument represents a set of conditions on parameters appearing in the integral such that the second argument of If is the integrated form. The last argument contains the unevaluated form of the integral (which is possible because If has the HoldRest attribute).

There are many integrands for which the indefinite integral cannot be expressed in closed form (using Mathematica’s built-in special functions), but certain definite integrals can be done. Here is an example.

With[{f = Sqrt[1 - x^2] Exp[-x]}, 
     {Integrate[f, x], Integrate[f, {x, 0, 1}]}]

In the last example it was crucial that the limits of the definite integral were 0 and 1. There are also integrals for which the indefinite integral cannot be done while the definite integral can be done for arbitrary limits. Here is such an integral.

Integrate[Re[x], x]

Integrate[Re[x], {x, 0, ζ}]

The indefinite integral could not be done because the integrand was not an analytic function. But still, along a straight line in the complex x-plane between 0 and ζ, the definite integral has a well defined value.

The following integral is a nontrivial one; it arises in the calculation of the ground-state energy of the homogeneous electron gas [1029✶].

Integrate[(1/x (1/x Log[(1 + x)/(1 - x)] - 2))^2, {x, 0, 1}]

Although Mathematica has powerful algorithms, some insight of the user in a given problem is often irreplacable and allows a much faster, more compact solution. Sometimes it is the only way to obtain a solution at all. Here is such an example. Mathematica will not likely finish the evaluation of the following definite integral in a reasonable time.

int = Apply[Integrate, 
HoldForm @@ {{Function[ξ, 1/(5 - 27/(2^(2/3) ξ)(1 - I Sqrt[3]) - 
                             ξ/(2 2^(1/3))(1 + I Sqrt[3]))^(1/8)][
         (277 + τ + Sqrt[-2003 + 554 τ + τ^2])^(1/3)],
         {τ, -277 - 162 Sqrt[3], 3}}}, {1}]

TimeConstrained[ReleaseHold[int], 100]

Numerically, of course, it is easy to get an approximation of this integral.

ReleaseHold[int /. Integrate[l__] :> NIntegrate[l, PrecisionGoal -> 12]]

If one knows that the integrand has the form 1/(Sqrt[-(p^((-1)))(y)]) where p(x) is a triquartic polynomial p(ξ)= ((((ξ^4)))^3)-15 ((((ξ^4)))^2)-6 ((((ξ^4)))^1)+3 is straightforward to carry out a change of variables y->p(y) manually, using [173✶], [939✶], [1236✶], [1478✶]

∫g((p^((-1)))(y))dy⟶∫g(y) p'(y)dy.

𝓅[x_] = (x^4)^3 - 15 (x^4)^2 - 6 (x^4)^1 + 3

If one knows, in addition, that the limits of the integral are the values of the polynomial where its derivative vanishes, the calculation of the integral becomes trivial.

𝓅[x] /. Solve[D[𝓅[x], x] == 0, x] // Simplify // Union

{x, 𝓅[x]} /. Solve[D[𝓅[x], x] == 0, x] // Simplify // Union

Here is the exact symbolic result and its numerical value.

{Simplify[#], N[#]}&[
((# /. y -> 0) - (# /. y -> (5 + 3 Sqrt[3])^(1/4)))&[
      Simplify[Integrate[1/Sqrt[y] 𝓅'[y], y]]]]

(If we would not know the polynomial 𝓅, we could calculate it the following way.)

GroebnerBasis[Numerator[Together[
  {(5 - (27 (1 - I Sqrt[3]))/(2^(2/3) 𝒳) - 
           ((1 + I Sqrt[3]) 𝒳)/ (2 2^(1/3))) - 𝕪^4,
   (277 + τ + 𝒴) - 𝒳^3, -2003 + 554 τ + τ^2 - 𝒴^2}]], 
   {τ, 𝕪}, {𝒳, 𝒴}]

While Mathematica tries hard to carry out an integral, it does not try all transformations of the integrand. So sometimes rewriting and/or simplifying the integrand helps to carry out an integral. Here is such an example (we make use of the function FunctionExpand that will be discussed in Chapter 3).

𝒻[𝓍_] := Log[Sin[𝓍]^5 Cos[𝓍]^6];
Integrate[𝒻[𝓍], {𝓍, 0, Pi/2}]

Simplify[FunctionExpand[𝒻[𝓍], 0 < 𝓍 < Pi/2], 0 < 𝓍 < Pi/2]

Integrate[%, {𝓍, 0, Pi/2}]

Here is a transcendental integral. It can be carried out using Jensen’s formula [848✶].

Module[{R = Pi},
       {Integrate[Log[Abs[Cos[R Exp[I φ]]]], {φ, 0, 2Pi}],
         {NIntegrate[Log[Abs[Cos[R Exp[I φ]]]], {φ, 0, 2Pi}],
        (* Jensen's formula; two simple zeros, no poles *)
        2Pi Log[Abs[Cos[0]] R^(2 - 0)/Abs[(-Pi/2) (Pi/2)]]} // N}]

Using a sufficiently complicated transformation of the integration variable inside a known integral allows one easily to find examples of doable, but not done, integrals. Here is an example based on the Cauchy transformation x->ξ+1/ξ [656✶].

Integrate[Cos[x] Exp[-x^2] /. x -> x - 1/x, {x, -Infinity, Infinity}]

(For another possibility to derive difficult integrals with known result, see [1419✶].) 
If one has a priori knowledge about the parameters, one can use them in Integrate via the Assumptions option, one of the three options of Integrate.

Options[Integrate]

Without specifying the properties of a in the following example, a condition on a is generated.

Integrate[Exp[a x^2], {x, -Infinity, Infinity}]

By specifying the properties of a, we do not get an If statement.

Integrate[Exp[a x^2], {x, -Infinity, Infinity}, 
          Assumptions -> {Re[a] < 0}]

For real positive a, the integral is divergent.

Integrate[Exp[a x^2], {x, -Infinity, Infinity}, 
          Assumptions -> {Re[a] > 0}]

Here is a more complicated example—a nontrivial Lévy distribution [626✶].

Integrate[Exp[-q^(4/3)] Cos[q x], {q, 0, Infinity},
          Assumptions -> Im[x] == 0]

Assumptions can be given in the form of a List or as logical operators such as And and Or.

Integrate[Exp[a x^2 + b x^4], {x, -Infinity, Infinity}, 
          Assumptions -> {Re[a] < 0, Re[b] < 0}]

Integrate[Exp[a x^2 + b x^4], {x, -Infinity, Infinity}, 
          Assumptions -> Re[a] < 0 && Re[b] < 0]

Assumptions in Integrate can currently have a form containing Re, Im, and equalities and inequalities. Specifying a parameter as integer is currently not possible. Assumptions will be used in various stages in the integration algorithm to decide convergence and cases. They will typically not be used to write the result in the shortest possible form.

Integrate[(1 + Cos[x]) Log[a + Cos[x]], {x, 0, Pi}, Assumptions -> a > 1]

{LeafCount[%], LeafCount[Simplify[%, a > 1]]}

The following half-sided Fourier transform of (exp(i (x^3)/3)-1) (x^(-3/2)) yields for positive ξ a complicated result involving generalized hypergeometric functions.

Collect[#, Union[Cases[#, _HypergeometricPFQ, Infinity]],
        Simplify]& @ 
Integrate[Exp[-I ξ x] (Exp[-I x^3/3] - 1) x^-(3/2), 
          {x, 0, Infinity}, Assumptions -> ξ > 0] // TraditionalForm

The second option of Integrate is GenerateConditions.

Sometimes one knows that a certain integral exists for certain parameters, but specifying the parameter ranges might be difficult. In this case, one uses the option setting GenerateCoditions -> False. For the last example, we do not get an If statement.

Integrate[Exp[a x^2 + b x^4], {x, -Infinity, Infinity}, 
          GenerateConditions -> False]

Be aware that the option setting GenerateConditions -> False results in two different behavior changes. One is the fact that the result will not be an If statement and no conditions are given as discussed above. The second effect is that many divergent integrals will return finite values. Here is an example of an obviously divergent integral.

Integrate[x^4 Sin[x], {x, 0, Infinity}]

Using GenerateConditions -> False gives a finite answer.

Integrate[x^4 Sin[x], {x, 0, Infinity}, GenerateConditions -> False]

Giving finite values for divergent integrals is not a mathematical flaw in Mathematica, but for some kind of calculations a very useful property. The result 24 for the last integral can easily be understood when regularizing the integral with the convergence implying factor (e^(-ε x)).

Integrate[x^4 Sin[x] Exp[-ε x], {x, 0, Infinity}, Assumptions -> ε > 0]

% /. ε -> 0

Here is another integral. Obviously, for large x, the integral (∫_0^x)(ξ^4)/(1+(e^(-ξ)))dξ diverges like (x^5)/5. Nevertheless, Mathematica returns a finite answer.

Integrate[x^4/(1 + Exp[-x]), {x, 0, Infinity}, GenerateConditions -> False]

N[%]

Although the last integral was “formally positive”, the result was negative [1145✶], [1146✶], [1084✶]. The last result can be understood in a Hadamard(–Adhemar [246✶]) sense [890✶], [163✶], [164✶], [1208✶], [521✶], [1581✶], [1582✶], [276✶] (for numerical applications, see [719✶], [1003✶], [800✶], [1527✶]), which basically means to subtract all divergencies of the form (x^positiveInteger) and logarithmic singularities (for generalizations, see [860✶]). Subtracting the divergent term, we get exactly the result from above.

NIntegrate[x^4/(1 + Exp[-x]) - x^4, {x, 0, Infinity}]

Another way to understand the result -45 ζ(5)/2 is the so-called zeta function regularization technique [517✶], [518✶] (which is in most cases equivalent to the Hadamard regularization [990✶]).

Integrate[x^s/(1 + Exp[-x]), {x, 0, Infinity}, GenerateConditions -> False]

% /. s -> 4

In some rare cases, Mathematica will give a regularized result also in case the option GenerateConditions is set to True. Here is an example.

Integrate[x^α (Sin[x]/x - Cos[x])^2, {x, 0, Infinity},
          GenerateConditions -> True, Assumptions -> -1 < α < 1]

For large x, the integral has the value (x^1) plus terms vanishing as x tends to infinity. So, the Hadamard value of this integral is 0.

Integrate[(Sin[x]/x - Cos[x])^2, x] // Expand

Mathematica is often able to detect poles (and some branch points and branch cuts) along the path of integration.

Integrate[1/x, {x, -1, 1}]

Often one wants such first-order pole singularities interpreted as Cauchy principal value integrals. The option PrincipalValue allows this (sometimes the limit (lim_(ε->0))((∫_a^b)f(x)dx+(∫_b^c)f(x)dx) of an integrand with any kind of singularity at x=b is also called principal value integral).

Now, we get the result 0.

Integrate[1/x, {x, -1, 1}, PrincipalValue -> True]

Here is a slightly more complicated example.

Integrate[1/x Sin[x], {x, -1/2, 1}, PrincipalValue -> True]

For the following integral with a third-order pole, the classical Cauchy principal value is not defined.

Integrate[1/x^3, {x, -1, 1}, PrincipalValue -> True]

Let us demonstrate the Kramers–Kronig transformation for the example function ε(ω) = 1/(ω + i β). The real and imaginary parts of ε(ω) are then given by the following expressions.

εr[ω_] =  ω/(ω^2 + β^2); 
εi[ω_] = -β/(ω^2 + β^2);

Here, the Kramers–Kronig transformation [969✶], [831✶], [1260✶], [1290✶], [630✶], [1362✶], [559✶], [854✶] is carried out.

(Integrate[#, {α, 0, Infinity}, Assumptions -> {ω > 0, β > 0}, 
           PrincipalValue -> True] // Cancel)& /@
           {-2ω/Pi εi[α]/(ω^2 - α^2), 2/Pi εr[α] α/(ω^2 - α^2)}

Integrate can also handle integrable singularities.

Integrate[1/Sqrt[x], {x, 0, 1}]

Although Mathematica can integrate a huge amount of functions, there are many definite integrals that Mathematica 4.0 cannot compute or that are impossible to express terms for by using the built-in functions.

Integrate[Sin[x^3]/(x + 5), {x, 0, 1}]

Integrate[Sin[Exp[t] + Log[t]]/(t^6 + 7t^4 + 5t + 7), {t, 0, Infinity}]

We end now our discussions of univariate integration. To analytically compute multidimensional integrals, we use the standard iterator notation in Integrate.

The following integrals will be integrated in the prescribed order. In contrast to numerical methods, no special methods are currently used in Integrate. Here are two examples for 2D integrals.

Integrate[(x + y + z)^3 Exp[-x - y - z],
          {x, 0, Infinity}, {y, 0, Infinity}]

Integrate[1/(a y + b (x - y) + c (1 - x))^3, {x, 0, 1}, {y, 0, x},
          GenerateConditions -> False]

As for differentiation of nonintegrable functions (see the example with strangeFunc discussed above), for “nonnice” functions, the result of integration may depend on the order in which the integrals are calculated [635✶].

{Integrate[(x^2 - y^2)/(x^2 + y^2)^2, {x, 0, 1}, {y, 0, 1}],
 Integrate[(x^2 - y^2)/(x^2 + y^2)^2, {y, 0, 1}, {x, 0, 1}]}

The next input defines the function dUnitSphereVolume that calculates the volume of a dD unit sphere by integrating the volume form following from the implicit equation (Subscript[x, 1]^2)+(Subscript[x, 2]^2)+…+(Subscript[x, d]^2)=1. We use the symmetry of the sphere to carry out the integral over the positive coordinate values only, and multiply the result with (2^d).

dUnitSphereVolume[d_Integer?Positive] := 
Module[{x}, If[d == 1, 2, 
            2^d Integrate[Sqrt[1 - Sum[x[k]^2, {k, d - 1}]], Sequence @@
                          (* limits of integration along the coordinate axes *)
                          Table[{x[j], 0, Sqrt[1 - Sum[x[k]^2, {k, j + 1, d - 1}]]}, 
                                {j, d - 1, 1, -1}]]]]

Here are the resulting volume values and the known exact form for the volume.

Table[{dUnitSphereVolume[d], Pi^(d/2)/(d/2)!}, {d, 5}]

Two remarks about multiple integrals are in order here:
Integrate[integrand, {(Subscript[var, 1]), (Subscript[lowerLimit, 1]), (Subscript[upperLimit, 1])},…, {(Subscript[var, n]), (Subscript[lowerLimit, n]), (Subscript[upperLimit, n])}] calculates a multiple integral, not a multidimensional one. This means that it will first carry out the integration with respect to (Subscript[var, 1]), and then with respect to (Subscript[var, 2]), …. No change of variables will be carried out. This means that some “simple” multidimensional integrals will not be integrated in closed form. Here is an example.

Integrate[Exp[-(x^2 + y^2 + z^2)]/(x^2 + y^2 + z^2), 
          {x, -Infinity, Infinity}, {y, -Infinity, Infinity}, 
          {z, -Infinity, Infinity}]

The second remark concerns singularities. The option GenerateConditions is always set to False in multiple integrals. As discussed above, this option setting results in certain regularizations of divergencies. As a result, one might get unexpected results.

As a little example shows Mathematica’s multiple integration capabilities, let us test a few special cases of Robbin’s integral identity. The identity is [1346✶], [1712✶]:

(Underscript[∫d(Subscript[x, 1])∫d(Subscript[x, 2])⋯∫d(Subscript[x, n]), 0≤(Subscript[x, 1])≤(Subscript[x, 2])≤(Subscript[…x, n-1])≤(Subscript[x, n])])|(({{(Subscript[x, 1]^((Subscript[a, 1])-1)), (Subscript[x, 1]^((Subscript[a, 2])-1)), ⋯, (Subscript[x, 1]^((Subscript[a, n])-1))}, {(Subscript[x, 2]^((Subscript[a, 1])-1)), (Subscript[x, 2]^((Subscript[a, 2])-1)), ⋯, (Subscript[x, 2]^((Subscript[a, n])-1))}, {  ⋮, ⋯, ⋱, ⋮}, {(Subscript[x, n]^((Subscript[a, 1])-1)), ⋯, ⋯, (Subscript[x, n]^((Subscript[a, n])-1))}}))|=((∏_(i=1)^n)(∏_(j=i+1)^n)((Subscript[a, j])-(Subscript[a, i])))((((∏_(i=1)^n)(Subscript[a, i])))^(-1))((((∏_(i=1)^n)(∏_(j=1)^(i-1))((Subscript[a, j])+(Subscript[a, i]))))^(-1)).

The Mathematica version of this theorem is as follows.

RobbinsIntegralIdentityTest[n_, a_Function] :=
{Integrate[Det[Table[x[i]^(a[j] - 1), {i, n}, {j, n}]], 
  Sequence @@ (Table[{x[i], x[i - 1], 1}, {i, n}] /. x[0] -> 0)],
Product[a[j] - a[i], {i, n}, {j, i + 1, n}]/
(Product[a[i], {i, n}] Product[a[j] + a[i], {i, n}, {j, i - 1}])}

The simplest possible choice for (Subscript[a, j]) is (Subscript[a, j])=j.

RobbinsIntegralIdentityTest[3, #&]

Here is a more difficult choice for the (Subscript[a, j]). The resulting integrand is no longer polynomial.

RobbinsIntegralIdentityTest[2, 1/#&]

And here is a much larger example—120 five-dimensional examples have to be carried out.

RobbinsIntegralIdentityTest[5, # + 1&]

Often, it is useful to factor the integrand, multiply it out, or remove large “constant” expressions before performing the integration.

Here is a 2D example of Hadamard-regularized integral. We have (∫_0^1)(∫_0^1)((|x-y|)^α)dy dx=2/((1+α)(2+α)) for all α.

Integrate[Sqrt[(x - y)^2]^α, {x, 0, 1}, {y, 0, 1},
          GenerateConditions -> False] // Together

One can understand this result by excluding a thin strip around the singular curve x=y. The resulting algebraic singular terms in ε are dropped within the Hadamard regularization. (Observe that for -2<α<-1 the regularized integral is negative despite the integrand being positive definite.)

Collect[#, ε, Together]& @ Simplify[
  Integrate[Sqrt[(x - y)^2]^α, {x, 0, 1 - ε}, {y, x + ε, 1},
            GenerateConditions -> False] +
  Integrate[Sqrt[(x - y)^2]^α, {x, ε, 1}, {y, 0, x - ε},
            GenerateConditions -> False], ε > 0]

In computing definite integrals, whenever possible we should exploit Mathematica’s knowledge of definite integrals (although in general this is much slower than indefinite integration), rather than first finding indefinite integrals and inserting the limit values. In fact, in many cases, the latter approach can result in an incorrect value. For example, (∫_0^(4π))1/(5+cos(x))"dx" has a strictly positive integrand, and hence, the integral must also be positive. But calculating the indefinite integral and substitution of the limits results in a zero result.

𝒸ℴ𝓈[x_] = Integrate[1/(5 + Cos[x]), x]

𝒸ℴ𝓈[4Pi] - 𝒸ℴ𝓈[0]

Using Mathematica’s definite integration capabilities, we get the correct result.

Integrate[1/(5 + Cos[x]), {x, 0, 4Pi}]

A numerical check confirms the last result.

{NIntegrate[1/(5 + Cos[x]), {x, 0, 4Pi}], N[%]}

The reason for the discrepancy in the above results is not because of any problem with the fundamental theorem of calculus, of course; it is caused by the multivalued nature of the indefinite integral arctan. (Using nonstandard conventions for the branch cuts of arctan could make the result correct [528✶]. For the arithmetic nature of such integrals, see [1591✶].)
Let us have a look at the indefinite integral. The integral is correct, as can be shown by differentiation.

Simplify[D[𝒸ℴ𝓈[x], x]]

Plot[𝒸ℴ𝓈[x], {x, 0, 4Pi}];

The indefinite integral is not a continuous function of x. The discontinuities are from the branch cuts that start and end from the simple poles of the integrand [1652✶] at (2n+1)π±iarccos(5).

Show[GraphicsArray[
Block[{$DisplayFunction = Identity, ε = 10^-10},
{(* contour plot *)
 ContourPlot[Evaluate[Re[𝒸ℴ𝓈[x + I y]]], {x, 0, 4Pi}, {y, -4, 4},
             PlotPoints -> 60, ContourShading -> False];
 (* 3D plot made piecewise *)
 Show[Table[Plot3D[Re[𝒸ℴ𝓈[x + I y]], {x, k Pi + ε, (k + 1) Pi - ε}, 
                   {y, -4, 4}, PlotPoints -> {8, 60}], {k, 0, 3}],
     AxesLabel -> {"x", "y", None}]}]]]

By adding the piecewise constant function, we can make the antiderivative a continuous function.

𝒸ℴ𝓈𝒞[x_] :=
 Which[x < 1  Pi // N, 𝒸ℴ𝓈[x],
       x == 1 Pi // N, Pi/2/Sqrt[6],
       x < 3  Pi // N, 𝒸ℴ𝓈[x] + Pi/Sqrt[6],
       x == 3 Pi // N, 3Pi/2/Sqrt[6],
       x < 5  Pi // N, 𝒸ℴ𝓈[x] + 2 Pi/Sqrt[6]]

Plot[𝒸ℴ𝓈𝒞[x], {x, 0, 4Pi}]

Now, the integral is given as the difference of the function value of the upper limit and the lower limit.

𝒸ℴ𝓈𝒞[4Pi] - 𝒸ℴ𝓈𝒞[0]

Even for everywhere smooth function the indefinite integral returned by Mathematica might be discontinuous. The following plots show the real and imaginary parts of ((e^x)-1)/x and ∫((e^x)-1)/x dx along the real axis. The imaginary part of the indefinite integral is discontinuous at x=0. But the

Module[{f, F, x},
       f[x_] = (Exp[x] - 1)/x;  F[x_] = Integrate[f[x], x];
Show[GraphicsArray[   
     (* show function and indefinite integral along real axis *)   
     Plot[{Re[#1[x]], Im[#1[x]]}, {x, -1, 1}, PlotLabel -> #2,
          PlotStyle -> {RGBColor[1, 0, 0], RGBColor[0, 0, 1]},
          DisplayFunction -> Identity, Frame -> True,
          PlotRange -> {{-1, 1}, {-3.5, 3.5}}]& @@@
     {{f, "f[x]"}, {F, "∫f[x]dx"}}]]]

But the indefinite integral was nevertheless correct.

D[Integrate[(Exp[x] - 1)/x, x], x] - (Exp[x] - 1)/x // Simplify

(For more details concerning such pitfalls, see [840✶], [838✶], and [841✶].) 
As an application of Mathematica integration capabilities, let us briefly discuss a class of parametrically describable minimal surfaces.

Minimal surfaces are surfaces z=f(x,y) that satisfy the differential equation

(1+(Subscript[f, y]^2))(Subscript[f, "xx"])+2(Subscript[f, x])(Subscript[f, y])(Subscript[f, "xy"])+(1+(Subscript[f, x]^2))(Subscript[f, "yy"])=0

or for surfaces given in parametric form {x(u,v),y(u,v),z(u,v)}, they satisfy H=0 where (for brevity we suppress the u,v-dependence of all quantities)

({{H, =((("LG"-2"FM"+"EN"))/(2("EG"-(F^2))))}, {E, =(((((∂x)/(∂u))))^2)+(((((∂y)/(∂u))))^2)+(((((∂z)/(∂u))))^2)}, {G, =(((((∂x)/(∂v))))^2)+(((((∂y)/(∂v))))^2)+(((((∂z)/(∂v))))^2)}, {F, =(((∂x)/(∂u)))(((∂x)/(∂v)))+(((∂y)/(∂u)))(((∂y)/(∂v)))+(((∂z)/(∂u)))(((∂z)/(∂v)))}, {L, =(l/(Sqrt["EG"-(F^2)])),   ({{N, =(n/(Sqrt["EG"-(F^2)]))}}),  ({{M, =(m/(Sqrt["EG"-(F^2)]))}})}, {l, =(({{(((∂^2)x)/(∂(u^2))), (((∂^2)y)/(∂(u^2))), (((∂^2)z)/(∂(u^2)))}, {((∂x)/(∂u)), ((∂y)/(∂u)), ((∂z)/(∂u))}, {((∂x)/(∂v)), ((∂y)/(∂v)), ((∂z)/(∂v))}})), ({{n, =(({{(((∂^2)x)/(∂(v^2))), (((∂^2)y)/(∂(v^2))), (((∂^2)z)/(∂(v^2)))}, {((∂x)/(∂u)), ((∂y)/(∂u)), ((∂z)/(∂u))}, {((∂x)/(∂v)), ((∂y)/(∂v)), ((∂z)/(∂v))}}))}}), ({{m, =(({{(((∂^2)x)/(∂u∂v)), (((∂^2)y)/(∂u∂v)), (((∂^2)z)/(∂u∂v))}, {((∂x)/(∂u)), ((∂y)/(∂u)), ((∂z)/(∂u))}, {((∂x)/(∂v)), ((∂y)/(∂v)), ((∂z)/(∂v))}})).}})}})

For given boundary curves, these are surfaces with minimal surface area. Here, H is the mean curvature. 
It is remarkable that an infinite variety of such surfaces can be constructed relatively easily. (The general problem of more practical interest for computing the minimal surfaces corresponding to given boundary curves is called the Plateau–Douglas problem [586✶] and is far more difficult to solve.) Let f(ξ) and g(ξ) be two holomorphic functions with no common zeros in a connected domain of the complex u+i v-plane. Then, a parametric formula for a minimal surface is given by:

x(u,v)=(Subscript[x, 0])+"Re"(∫_(Subscript[ξ, 0])^(ξ(u,v)))(1-((g(ξ'))^2))f(ξ')dξ'
y(u,v)=(Subscript[y, 0])+"Re"(∫_(Subscript[ξ, 0])^(ξ(u,v)))i(1+((g(ξ'))^2))f(ξ')dξ'
z(u,v)=(Subscript[z, 0])+"Re"(∫_(Subscript[ξ, 0])^(ξ(u,v)))2f(ξ')g(ξ')dξ'.

Here, ξ(u,v) is an arbitrary complex function of u and v (e.g., u+i v, u(e^(i v))), whereas u and v are the two parameters in the parametric formula of the surface, and Re denotes the real part. For a proof of these formulas, see [1223✶] and [778✶].

We now implement these formulas.

WeierstrassMinimalSurface[f_, g_, var_, pictVar_] :=
(* pictVar for various coordinate systems;
   for instance, x + I y or r Exp[I φ] *)
Re[(Integrate[#, var]& /@ {(1 - g^2)f, I(1 + g^2)f, 2 f g}) /.
                                               var -> pictVar]

Here is an example: the Enneper surface with f(ξ)=1 and g(ξ)=ξ.

ParametricPlot3D[Evaluate[
   WeierstrassMinimalSurface[1, ξ, ξ, r Exp[I φ]]],
                 {r, 0, 3}, {φ, 0, 2Pi},
                 PlotPoints -> {116, 80}, Boxed -> False,
                 Axes -> False, PlotRange -> All]

Next, we look at a Henneberg surface; here, f(ξ)=-i/2(1-(ξ^(-4))) and g(ξ)=ξ.

ParametricPlot3D[Evaluate[
WeierstrassMinimalSurface[-I/2 (1 - ξ^-4), ξ, ξ, r Exp[I φ]]],
                 {r, 0.72, 1}, {φ, 0, 2Pi},
                 PlotPoints -> {16, 40}, Boxed -> False,
                 Axes -> False, PlotRange -> All]

Here is a spiraling minimal surface related to the behavior of a soap film near a boundary wire [213✶].

Block[{γ = 0.02 Pi, wms},
wms = WeierstrassMinimalSurface[
        I Exp[-w + I Pi w/(2 Cot[γ/2])], Exp[w], w, r Exp[I φ]];
ParametricPlot3D[
         Evaluate[Append[wms, SurfaceColor[Hue[φ/(2 Pi)]]]],
                 {r, 0, 6}, {φ, 0, 2Pi},
                 PlotPoints -> {40, 160}, Boxed -> False,
                 Axes -> False, PlotRange -> All,
                 BoxRatios -> {1, 1, 2}]]

We could plot many other such (generally unnamed) surfaces, for example, f(ξ)=(ξ^(1/4))+(ξ^(1/3)) and g(ξ)=ξ.

wms = WeierstrassMinimalSurface[ξ^(1/4) + ξ^(1/3), ξ, ξ, r Exp[I φ]]

An initial attempt to plot this function does not produce a satisfactory result. (We use lines rather than polygons in the following graphic because the polygons touch each other often, and rendering the corresponding graphic takes a long time.)

Show[Graphics3D[
ParametricPlot3D[Evaluate[%], {r, 0.7, 0.75}, {φ, 0.001, 12Pi - 0.001},
                 PlotPoints -> {2, 600}, PlotRange -> All,
                 Axes -> False, DisplayFunction -> Identity][[1]] //.
        Polygon[l_] :> Line[Append[l, First[l]]]]]

To get the “correct” function values for multivalued functions, we have to modify the results of the indefinite integration; in this case, we take the nth root. For ease of understanding, we view only a small strip.

ParametricPlot3D[Evaluate[(* analytically continue and add color *)
                  Append[wms /. {(r Exp[I φ])^n_ -> r^n Exp[I n φ]}, 
                  SurfaceColor[Hue[φ/(12 Pi)], Hue[φ/(12 Pi)], 2]]], 
                  {r, 0.7, 0.75}, {φ, 0.01, 12Pi - 0.01},
                  PlotPoints -> {2, 600}, PlotRange -> All, Axes -> False]

Many further examples of minimal surfaces exist and are easy to (re)produce in Mathematica. By changing the integrands in the three integrals in the Weierstrass representation from integrand to exp(i ϑ)"integrand", we can (in dependence on ϑ) look at how a minimal surface evolves to its adjoint surface. 
For additional examples of minimal surfaces, see [1422✶], [1056✶], [1209✶], [783✶], [433✶], [1106✶], [585✶], [1068✶], [1533✶], [781✶], [1669✶], [436✶], [782✶], [897✶], [578✶], [703✶], [792✶], [1524✶], [1281✶], [214✶], [1270✶], [1534✶], [896✶], [1365✶], [251✶], [1181✶], and [1535✶]. 
Remark: It is not necessary to use integrals when constructing minimal surfaces. If the above g(ξ)->ξ and f(ξ)->f'''(ξ), we can write

x="Re"((1-(ξ^2))f''(ξ)+2ξf'(ξ)-2f(ξ))
y="Re"(i((1+(ξ^2))f''(ξ)-2ξf'(ξ)+2f(ξ)))
z="Re"(2ξf''(ξ)-2f'(ξ)).

As another application let us deal with infinite electrical networks. The resistance between the node {0, 0} and the node {m, n} in an infinite network is given by the following expression [581✶], [1713✶], [1714✶], [85✶], [1221✶] (each resistor has the value 1 Ohm).

R[m_, n_] := R[m, n] =
  1/(2 Pi) Integrate[(1 - ((t - I)/(t + I))^(m + n)*
                          ((t - 1)/(t + 1))^Abs[m - n])/t, 
                     {t, 0, Infinity}]

R[0, 0]

It is a well-known result that the resistance between two neighboring nodes is 1/2.

R[0, 1]

Here are some more values of the resistance.

{R[1, 1], R[2, 4]}

The following two values are equal because of symmetry.

{R[-1, -2], R[1, 2]}

To avoid unnecessary calculations, we implement the symmetry of the underlying network and calculate the integral only once for every node distance.

𝕣 /: DownValues[𝕣] = (* order of the definitions matters *)
     {HoldPattern[𝕣[m_, n_]] :> (𝕣[m, n] = R[m, n]) /; 
       NonNegative[m] && NonNegative[n] && m <= n, 
      HoldPattern[𝕣[m_, n_]] :> 𝕣[n, m] /; NonNegative[m] && NonNegative[n], 
      HoldPattern[𝕣[m_, n_]] :> 𝕣[-n, -m] /; Negative[m] && Negative[n], 
      HoldPattern[𝕣[m_, n_]] :> 𝕣[n, -m] /; Negative[m], 
      HoldPattern[𝕣[m_, n_]] :> 𝕣[-n, m] /; Negative[n]};

Here, the resistance in the neighborhood of the origin is shown.

With[{n = 5}, ListPlot3D[Table[𝕣[i, j], {i, -n, n}, {j, -n, n}], 
                         MeshRange -> {{-n, n}, {-n, n}}]];

The function R makes heavy use of definite integration. For larger values of n and m, it becomes somewhat slow.

R[m_, n_] := Integrate[(1 - ((t - I)/(t + I))^(m + n)((t - 1)/
                       (t + 1))^Abs[m - n])/t, {t, 0, Infinity}]

R[8, 12] // Timing

Indefinite integration is often much faster than definite integration. As a result, it is sometimes advantageous to first calculate the indefinite integral and then substitute the integration limits. (Sometimes this might require the calculation of limits). For this procedure to be correct one must of course know that, inside the integration interval, the indefinite integral is a continuous function without any singularities. For the integrands under consideration this is actually the case, and using the following careful substitution of the upper integration limit ∞ yields a dramatic speed-up.

RFast[m_, n_] := Function[int, 
(* upper limit at ∞ *)
(int //. {ArcTan[t] -> Pi/2,
          (I + t)^e_?Negative -> 0, (1 + t)^e_?Negative -> 0,
          ((a_ Log[1 + t] + b_ Log[1 + t^2])) :> 0 /; a/b == -2}) -
(* lower limit *) (int /. t -> 0)][        
  Integrate[Together[(1 - ((t - I)/(t + I))^(m + n)*
                          ((t - 1)/(t + 1))^Abs[m - n])/t], t]]

RFast[8, 12] // Timing

For the n-dimensional case of such resistor networks, see [380✶], [381✶], [1228✶], [845✶]; for the continuous analog, see [913✶], [924✶]; for finite lattices, see [1678✶].

Mathematica can differentiate expressions that arise from computations in which it is not able to explicitly integrate.

D[Integrate[f[x], y], y]

This also works for integrals in which the variable of differentiation enters in a complicated way in the limits of integration (differentiation of parametric integrals).

Clear[f, x, y];
D[Integrate[f[x], {x, 0, y}], y]

D[Integrate[f[x], {x, -x, x}], x]

Derivative[1, 0][Integrate[f[x], {x, #1, #2}]&][a, b]

Derivative[0, 1][Integrate[f[x], {x, #1, #2}]&][a, b]

We now look at a somewhat more complicated expression: the d’Alembert solution of the one-dimensional wave equation.

Suppose we are given the following differential equation (wave equation)

(((∂^2)u(x,t))/(∂(t^2)))-(a^2)(((∂^2)u(x,t))/(∂(x^2)))=f(x,t)

in (("ℝ")^1)×(("ℝ")^(1+)). Here, u(x,t) is the amplitude of the wave as a function of position x and time t, and a is the inverse phase velocity. The d’Alembert solution for prescribed f(x,t) is:

u(x,t)=(1/(2a))(∫_0^t)(∫_(x-a(t-τ))^(x+a(t-τ)))f(ξ,τ)dξ dτ+(1/(2a))(∫_(x-"at")^(x+"at"))(Subscript[u, 1])(ξ)"dx"+(1/2)((Subscript[u, 0])(x+"at")+(Subscript[u, 0])(x-"at")).

Here, (Subscript[u, 0])(x) is the initial position, and (Subscript[u, 1])(x) is the initial velocity function; that is, u(x,t=0)=(Subscript[u, 0])(x) and (Subscript[∂u(x,t)/∂t|, t=0])=(Subscript[u, 1])(x).

For references, see any textbook on partial differential equations, for example, [1457✶] and [956✶]. For some direct extensions, see [374✶] , [767✶], and [1674✶].

We now check this solution.

u[x_, t_] =
1/2/a Integrate[Integrate[f[ξ, τ], {ξ, x - a(t - τ), x + a(t - τ)}],
                          {τ, 0, t}] +
1/2/a Integrate[u1[ξ], {ξ, x - a t, x + a t}] +
1/2 (u0[x + a t] + u0[x - a t]);

u[x, 0]

D[u[x, t], t] /. t -> 0

(D[u[x, t], {t, 2}] - a^2 D[u[x, t], {x, 2}] // Simplify) // Timing

As a related example, let us develop a series solution of the differential equation z'(t)=f(z(t),t) for small t. We rewrite the differential equation as an integral equation z(t)=z(0)+(∫_0^t)f(z(τ),τ)dτ and calculate the series expansion of the right-hand side.

Together /@ Normal[Series[z[0] + Integrate[f[z[τ], τ], {τ, 0, t}],
                          {t, 0, 4}, Analytic -> True]] //.
 (* replace derivatives of z using the differential equations *)
    {Derivative[n_][z][0] :> (D[f[z[t], t], {t, n - 1}] /. t -> 0)}

Using f(z,t)=z, we get the series expansion of exp(t).

% /. f -> (#1&)

And using f(z,t)=2tz, we get the series expansion of exp((t^2)).

%% /. f -> (2 #1 #2&)

At this point, we mention that Mathematica can integrate a large class of functions whose antiderivatives can be expressed as elliptic integrals. Typically, such integrands contain roots of polynomials of third or fourth degree. Here are three examples.

Integrate[Sqrt[(b^2 - x^2)/(x^2 + a^2)], x]

Integrate[Sqrt[(b^2 - x^2)/(x^2 + a^2)^3], x]

Integrate[1/Sqrt[1 - x^3], x]

Note that sometimes Mathematica produces an incorrect result for a definite integral. Such cases usually involve integrands with symbolic parameters and branches. One possibility for checking the correctness of integrals is to use the package VIntegrate (Verify Integrate), available as MathSource 0205-029. Another possibility is to compare the result of Integrate with that of NIntegrate. Here is an example: (∫_(1/10-i)^(1/10+i))ln((z^2)-1)"dz".

The integrand has a branch cut between -1 and 1. Here, the results of Integrate and NIntegrate do not agree (the appearance of a message—here, Integrate::gener from Integrate should always be taken seriously).

Integrate[Log[z^2 - 1], {z, 1/10 - I, 1/10 + I}]

{N[%], NIntegrate[Sqrt[z^2 - 1], {z, 1/10 - I, 1/10 + I}]}

1.6.3 Limits

Another important task of classical analysis that can be accomplished with Mathematica is the computation of limits. The appropriate command is Limit.

Here are four simple examples to start.

Limit[Sin[x]/x, x -> 0]

Limit[Exp[-x] x^2, x -> Infinity]

Limit[((x + h)^(1/3) - x^(1/3))/h, h -> 0]

Limit[(Tan[x]/x)^(1/x^2), x -> 0]

Here are three slightly more complicated limits. Two of the form (∞^0) [836✶] and one of the form (1^∞).

Limit[(1/x)^Tan[x], x -> 0]

Limit[(2 - 2 x)^Tan[Pi x], x -> 1/2]

Limit[(((n - 1)^2 n^n)/(n^n - n))^((n - n^(2 - n))/(n - 1)^2), 
      n -> Infinity]

The next limit shows how the logarithm ln(x) arises as the limit of a power function (x^a). (For continuity it follows from this that (x^a) and ln(x) should have the same branch cut structure.)

Limit[Integrate[ξ^a, {ξ, 0, x}, Assumptions -> x > 0 && Re[a] > -1] -
      1/(1 + a), a -> -1]

For functions whose limit values depend on the direction from which we approach specificValue, we can use the option Direction.

Here is an example of finding the limit of exp(1/x) as x->0. A plot clearly shows the two different limits.

Plot[Exp[1/x], {x, -2, 2.1}, PlotRange -> {0, 5}]

Using the Direction option in Limit, we can determine both limits.

Limit[Exp[1/x], x -> 0, Direction -> #]& /@ {1, -1}

Here, we look at limits of the analogous function on the imaginary axis.

Limit[Exp[1/(I x)], x -> 0, Direction -> #]& /@ {-I, I}

Here is another limit where the direction matters.

Limit[(-1 + ε I)^λ, ε -> 0, Direction -> #]& /@ {+1, -1}

Often, it is not possible to get an explicit value because the function does not approach a limit. sin(1/x) as x approaches 0 is a typical example. In cases in which the solution is bounded in an interval, the result will often be an Interval-object (we encountered these already in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks). An example of such a situation is sin(1/x) as x->0.

Limit[Sin[1/x], x -> 0]

The second option of Limit is Analytic.

Options[Limit]

Here is what happens with different option settings of Analytic.We use a function that is not explicitly defined.

Remove[f, x];
{Limit[f[x], x -> 1], Limit[f[x], x -> 1, Analytic -> True]}

Almost all functions f(z) of a complex variable z are nondifferentiable or even not continuous. As a result, the following limit stays unevaluated.

Limit[(f[z + ε] - f[z])/ε, ε -> 0]

Assuming that f(z) is an analytic function yields, as the result, the derivative f'(z).

Limit[(f[z + ε] - f[z])/ε, ε -> 0, Analytic -> True]

Here is a slightly more complicated limit.

Limit[(f[z + ε + ε^2] + f[z - ε - ε^3/4] - 2 f[z + ε^2/3])/ε^2, 
      ε -> 0, Analytic -> True]

Also in the following limit (that gives the Schwarz derivative) the option setting Analytic -> True is needed.

6(lim_(z->ζ))((∂^2)/(∂z∂ζ))log(((w(z)-w(ζ))/(z-ζ)))=((Derivative[3][w](ζ))/(w'(ζ)))-((3 ((w''(ζ))^2))/(2 ((w'(ζ))^2)))

Limit[6 D[Log[(w[z] - w[ζ])/(z - ζ)], z, ζ], z -> ζ, 
      Analytic -> True] // Expand

The following input reduces also to the Schwarzian derivative [1230✶], [1231✶].

(lim_(w(ξ)->0))((∂^3)/(∂(ζ^3)))(1/2)(ζ-((w(ζ))/(w'(ζ))))=((Derivative[3][w](ζ))/(w'(ζ)))-((3 ((w''(ζ))^2))/(2 ((w'(ζ))^2)))

Because w[ξ] appears multiplicative in this expression the option setting Analytic -> True is not needed.

Limit[Derivative[3][Function[z, (z - w[z]/w'[z])/2]][ζ], w[ζ] -> 0] // Expand

The next input represents a discrete approximation to the nth derivative of a function f at ξ [1663✶].

derivativeApproximation[f_, n_, ξ_, ε_] :=
     Sum[(-1)^k Binomial[n, k] f[ξ + (n - 2k)/2 ε], {k, 0, n}]/ε^n

In the limit ε->∞, we get the explicit derivative for explicit integer n.

Table[Limit[derivativeApproximation[f, n, x0, ε], ε -> 0, 
            Analytic -> True], {n, 0, 6}]

The built-in command Limit cannot find all limits. In particular, essential singularities cause problems. The following limit does get evaluated.

Limit[x^x - x^(Log[x]), x -> Infinity]

But the next limits stay unevaluated [383✶].

expr = ((n + 3)^(n + 3) - (n + 2)^(n + 2))/
       ((n + 2)^(n + 2) - (n + 1)^(n + 1)) - 
       ((n + 2)^(n + 2) - (n + 1)^(n + 1))/
       ((n + 1)^(n + 1) - (n + 0)^(n + 0));
       
Limit[expr, n -> Infinity]

Limit[Binomial[n, k] (a/n)^k (1 - a/n)^(n - k), n -> Infinity]

The package Calculus`Limit` provides a sometimes useful extension of Mathematica’s ability to find limits. The built-in Limit command is not able to find the limit. We now load the package Calculus`Limit`, and look again at the binomial example.

Needs["Calculus`Limit`"]

We get the following result for n!/k!/(n-k)!(((a/n))^k)(((1-a/n))^(n-k)).

Limit[Binomial[n, k] (a/n)^k (1 - a/n)^(n - k), n -> Infinity]

And the second limit from above now evaluated to e

Limit[expr, n -> Infinity]

Having loaded the package Calculus`Limit`, Limit can now handle some infinitely nested expressions. To express them, we use Nest. Here is a nested square root.

(Sqrt[5+(Sqrt[5+(Sqrt[5+⋯])])])

Limit[Nest[Sqrt[5 + #]&, 5, n], n -> Infinity]

Let us compare the result numerically with the first iterations.

NestList[Sqrt[5 + #]&, 5., 25] - % // N

Here is a further example containing a continued fraction.

(1/(1+(1/(1+(1/(1+⋯))))))

Limit[Nest[1 + 1/#&, 1, n], n -> Infinity]

Again, a comparison with the numerical result confirms this result.

NestList[1 + 1/#&, 1., 25] - % // N

To compute limits when several variables are simultaneously tending toward given values, we have to apply Limit repeatedly. However, constructions of the form Limit[f(a,b), a -> (Subscript[a, 0]), b -> (Subscript[b, 0])] are not allowed. Here is a function, with two different limit values, that depends on the order in which Limit is applied.

Limit[Limit[(x^2 - y^2)/(x^2 + y^2), x -> 0], y -> 0]

Limit[Limit[(x^2 - y^2)/(x^2 + y^2), y -> 0], x -> 0]

The following input does not work (but be aware of the different message).

Limit[(x^2 - y^2)/(x^2 + y^2), x -> 0, y -> 0]

To conclude this section, we now present a small application of Limit concerning the computation of a 2D rotation matrix from infinitesimals [837✶]: An infinitesimal rotation by an angle (Subscript[φ, ϵ]) around the z-axis can be described (which is easily seen from the geometry) by x'=x+(Subscript[φ, ϵ])y,y'=-(Subscript[φ, ϵ])x'+y. 
Here, x and y are the coordinates of a point before the rotation, and x' and y' are the coordinates after the rotation. 
In matrix form, this is

(({{x'}, {y'}}))=(({{     1, (Subscript[φ, ϵ])}, {-(Subscript[φ, ϵ]), 1}}))(({{x}, {y}})).

Here, (Subscript[φ, ϵ]) is the infinitesimal angle of rotation. A finite rotation by an angle φ can be obtained by n-fold repetition of this small rotation, where n(Subscript[φ, ϵ])=φ. Here is the limit as n->∞.

MatrixPower[{{1, φ/n}, {-φ/n, 1}}, n]

This is what we get after some reorganization.

ComplexExpand[Map[Limit[#, n -> Infinity]&, %, {2}]]

This is the well-known 2D rotation matrix for a given angle φ of rotation.

1.6.4 Series Expansions

Mathematica can compute

({{ , ◼"Taylor series", ((Subscript[a, 0])+(Subscript[a, 1])x+(Subscript[a, 2])(x^2)+⋯)}, { , "◼ Laurent series", (⋯+(Subscript[a, -2])(x^(-2))+(Subscript[a, -1])(x^(-1))+(Subscript[a, 0])x+(Subscript[a, 1])x+(Subscript[a, 2])(x^2)+⋯)}, { , "◼ Puiseux series", "expansions around branch points where functions behave like radicals or logarithms"}})

(See [1300✶] and [953✶] for more on the not-so-widely-known Puiseux series expansions.) 
For all standard functions and combinations of functions, and for a multitude of special functions, the command is Series.

We now look at some simple examples of series expansions.

Series[Sin[x], {x, 0, 3}]

Here, we saw the remainder term O[x] to represent a term of order n. Let us look at its FullForm.

FullForm[O[x]^3]

Written out, the above series has this form.

Series[Sin[x], {x, 0, 3}] // FullForm

The object SeriesData that appears in this FullForm output has the following meaning.

The O[x]-form results in easier readability and inputting of a series. Using O[x]^n often is a convenient way to indicate a series.

FullForm[O[z, z0]]

O[z, ord] evaluated to a SeriesData-object. Unevaluated O is just a symbol.

FullForm[Hold[z + O[z, z0]]]

For explicit positive integer or rational α, the expression O[z, z0] evaluates to SeriesData[z, z0, {}, 1, 1, 1]. If O[z, z0] is present in another expression this SeriesData causes (if possible) the whole expression to be converted to a SeriesData. Here is an example.

Cos[z] + O[z, Pi/2]^4

We now look at a sample of computable series expansions. 
◼ Taylor Series [875✶]

Here is a rational function.

Series[(a x^6 + b x^4 + c x^2 + 4)/
       (g x^23 + 78 h x^12 + 456), {x, 0, 4}]

We would have obtained the same result by just adding O[x]^5 to the rational expression (which is sometimes preferable because of readability of the code).

(a x^6 + b x^4 + c x^2 + 4)/(g x^23 + 78 h x^12 + 456) + O[x]^5

Here is a Taylor series of a nested trigonometric function.

Series[Tan[Sin[x]], {x, 0, 5}]

We have trigonometric functions with an algebraic argument.

Series[Sin[Sqrt[z]]/Sqrt[z], {z, 0, 5}]

Here is a rational function of a trigonometric function expanded in a series. To rewrite the result more elegantly, we use TrigFactor.

(* rewrite the coefficients in a short form *)
TrigFactor /@ Collect[Normal[Series[
        (a Cos[x] - a^2)/(1 - 2a Cos[x] + a^2), {a, 0, 12}]], a]

Here is the series expansion of the sin iteration discussed graphically in Chapter 1 of the Graphics volume [1560✶] of the GuideBooks.

Series[Nest[Sin, x, #], {x, 0, 5}]& /@ {1, 10, 100}

For a detailed analytical treatment of this example, see [410✶].

Here is a slightly more complicated example: The following continued fraction due to Ramanujan has the fascinating property that as n->∞, it approaches three different limit points [1313✶], [54✶], [205✶].

1+(1/(-(1+q)+(1/(+(1+(q^2))+
                           ⋱ 
                                +(1/((((-1))^(k-1))(1+(q^(k-1)))+(1/((((-1))^k)(1+(q^k)+α))))))))).

Forming the explicit fraction for n=20…25 and looking at the series terms for small q clearly shows how the three limit points are approached cyclically.

Table[{n, Series[FromContinuedFraction[
  Table[(-1)^k (1 + q^k + Which[k == 0, -1, k == n, α, True, 0]), 
        {k, 1, n}]], {q, 0, 1}]}, {n, 20, 25}] // (Cancel //@ #)&

◼ Laurent Series

Now we have terms with negative powers of x. (Within Mathematica it is a series with positive powers of 1/x.)

Series[1/(x^2 + a^2), {x, Infinity, 3}]

Series[Sin[x]^-1, {x, 0, 4}]

Note the O[x] terms in the following two examples.

Series[x^-3, {x, 0, 4}]

Series[(x^2 + 3)/(x^12 - 17), {x, Infinity, 4}]

To get a nontrivial term for the last series, we must calculate more terms.

Series[(x^2 + 3)/(x^12 - 17), {x, Infinity, 12}]

The trigonometric functions csc(z) and cot(z) have Laurent expansions around z=0.

Series[Csc[z], {z, 0, 3}]

Series[Cot[z], {z, 0, 3}]

◼ Puiseux Series

(Sqrt[z]) is an independent term in a Puiseux series. The ((O[x])^(13/2)) term arises from the order of the series requested.

Series[Sqrt[x], {x, 0, 6}]

Series[x^x, {x, 0, 4}]

Series[x^(x^2), {x, 0, 3}]

The last example contained a term of the form ln(x) (x^2). Logarithmic factors appear in the third argument of the underlying SeriesData-object.

FullForm[%]

The function arcsin(z) has three branch points. Two square-root–like branch points at ±1 and a logarithmic branch point at ∞. Looking at the series expansion of ArcSin, these two different type of branch points are clearly visible.

Series[ArcSin[z], {z, 1, 3}]

Series[ArcSin[z], {z, Infinity, 3}]

Logarithms appearing in Puiseux series can be found in the third argument of the corresponding SeriesData expression.

FullForm[%]

Here are the series expansions of two special functions.

Series[BesselJ[ν, z], {z, 0, 4}]

Series[Gamma[z], {z, 1/2, 2}]

There are also some examples in which series expansions are (currently) not computable. These mostly involve essential singularities (in the function theoretic sense) at the point of expansion, or they involve derivatives that currently cannot be expressed in closed form (for an extension of Mathematica’s capabilities for calculating series, see [949✶], [950✶], and [952✶]).

Series[Exp[x], {x, Infinity, 2}]

{Series[(1 + 1/n)^n, {n, Infinity, 2}], Series[(1 + n)^(1/n), {n, 0, 2}]}

Using the above described function SeriesData such series cannot work. Where should, say, exponential terms be kept? In the following example the result does not have the head SeriesData, but rather times.

Series[Gamma[z], {z, Infinity, 1}]

FullForm[%]

Because the result was not a SeriesData-object, already simple arithmetic operations with the above expression will issue messages.

z %

The following, only slightly more complicated, series does not work.

Series[Gamma[z^γ], {z, Infinity, 1}]

In the next example the expansion is done in a symbolic way; no explicit functions for Derivative[i, 0][BesselJ] are given (which is not so easy to do).

Series[BesselJ[ν, z], {ν, 0, 3}]

A multitude of series expansions can also be found in [733✶]. 
For functions that are not given analytically, we can only differentiate the functions symbolically.

Series[𝕗[u], {u, v, 3}]

Here is a small application of forming a series expansion of not explicitly given functions. The combined Numerov–Mickens nonstandard finite difference scheme discretizes the differential equation ψ''(x)=𝒱(x)ψ(x) through the set of coupled difference equations -(Subscript[𝓊, n-1])+2(Subscript[𝒹, n])(Subscript[𝓊, n])-(Subscript[𝓊, n+1])=0 where (Subscript[u, n])=1-(h^2)𝒱((Subscript[x, n]))/12, (Subscript[𝒹, n])=cosh(h (Sqrt[𝒱((Subscript[x, n]))])) and (Subscript[x, n])=(Subscript[x, 0])+n h [304✶], [1129✶].
Expanding the difference equation around a fixed (Subscript[x, n]) in a power series in h and assuming ψ''(x)=𝒱(x)ψ(x)  shows that the first nonvanishing term is of order O((h^6)).

Module[{x, 𝓊, 𝒹, discreteEq, ser},
  (* definitions *)
  x[n_] = 𝓍 + n h;
  𝓊[n_] = (1 - h^2 𝒱[x[n]]/12) ψ[x[n]];
  𝒹[n_] = Cosh[h Sqrt[𝒱[x[n]]]];
  (* difference equation *)
  discreteEq[n_] = -𝓊[n - 1] + 2 𝒹[n] 𝓊[n] - 𝓊[n + 1];
  (* series expansion around 𝓍 *)
  ser = Series[discreteEq[1], {h, 0, 6}];
  (* use differential equation ψ''[x] = 𝒱[x] ψ[x] *)
  ser //. Derivative[n_ /; n >= 2][ψ][x_] :> D[𝒱[x] ψ[x], 
                     {x, n - 2}] // Simplify]

Series can work with exact and approximate coefficients. Series applies zero testing to the series coefficients and drops terms that are considered to be zero. Here are the first terms of a functions with the property (f^((-1)))(z)=-((f(z))^(-1)).

𝒻𝒻Inv[z_] = 1 + Table[z^k, {k, 20}]. (* series coefficient *)
{ 0.11201933586799460636,  0.04013232971298552835,  0.05017599118780908587, 
  0.02331170198490686166,  0.04169759366964792265,  0.01434818305566120933, 
  0.04341898484131755962,  0.00427268422270174173,  0.05316437195644763211, 
 -0.01227684573369744105,  0.07511431972356796605, -0.04373397070311347075, 
  0.12019355271066564345, -0.10687118497186786129,  0.21222687421724158176, 
 -0.23683787138794410136,  0.40230256474819762393, -0.50866679958475735404,
  0.80042942843989834362,  1.73706479076791285289};

Calculating f(-1/f(z)) yields z+((O(z))^20).

𝒻𝒻Inv[-1/𝒻𝒻Inv[z]] + O[z]^21

Calculating the same expression to polynomial and rational algebra we see that the coefficients of (z^j), j=2,…,19 are high-precision zeros that have been converted to exact zeros by Series.

Take[Expand[𝒻𝒻Inv[Normal[-1/𝒻𝒻Inv[z] + O[z]^21]]], 21]

(* for comparison: make coefficients exact *)
𝒻𝒻InvInf[z_] = SetPrecision[𝒻𝒻Inv[z], Infinity];
SetPrecision[Normal[𝒻𝒻InvInf[-1/𝒻𝒻InvInf[z]] + O[z]^21], 2]

Series can often be successfully used to calculate leading terms of very large, unexpanded polynomials. In the following input, we display the number of possibilities (Subscript[c, n]^((F))) to represent an integer n as a sum of Fibonacci numbers n=(∑_(j=0)^∞) (Subscript[ε, j])(Subscript[F, j]) where (Subscript[ε, j]) is 0 or 1 [278✶], [1649✶]. Using the obvious generating function for this problem, we obtain the following self-similar plot for (Subscript[c, n]^((F))). (As we see from the following example, the function CoefficientList works not only for polynomials, but also for SeriesData.)

ListPlot[Rest[CoefficientList[Series[Product[1 + z^Fibonacci[k], 
                              {k, 21}] - 1, {z, 0, 10946}], z]]]

Using in addition to the explicit exponents symbolic exponents of another variable allows to obtain the explicit form of the sums. Here are the 820 possibilities for representing the first 100 integers as sums of Fibonacci numbers are shown.

fibonacci01Partitions100 = 
MapIndexed[((* make equations *)
            Equal @@ Flatten[{#2[[1]], #1}])&,
(* separate powers of ζ *)
List @@@ Expand[Rest[CoefficientList[
     Series[Product[1 + z^Fibonacci[k] ζ^Subscript[F, k], 
                       {k, 12}] - 1, {z, 0, 100}], z]]] /. 
                        (* powers to exponents *) ζ^e_. :> e];

Short[fibonacci01Partitions100, 16] // TraditionalForm

Next we use Series to determine the limit of the reordered sequence (((-1))^k)(k^(-1)). We reorder the series in such a way, that after p positive terms q negative ones follow [1296✶], [568✶], [1406✶] (for instance, for p=3, q=2 this means (1^(-1))+(3^(-1))+(5^(-1)) -(2^(-1))-(4^(-1)) +(7^(-1))+(9^(-1))+(11^(-1)) -…). We sum the first o terms and determine the behavior around o=∞.

(* p/(p + q) o terms of the first o are positive (for large o) *)
Sum[1/j, {j, 1, p/(p + q) o, 2}] - 
(* q/(p + q) o terms of the first o are negative (for large o) *)
Sum[1/j, {j, 2, q/(p + q) o, 2}] /. Floor[x_] :> x

Simplify[% /. PolyGamma[0, x_] :> (* expand PolyGamma function *)
        (Normal[Series[PolyGamma[0, y], {y, Infinity, 1}]] /. 
                                     y -> x), p > 0 && q > 0]

If a function of several variables is to be expanded around a point in multidimensional space, we can use the standard iterator notation again. The computation proceeds in the usual order from right to left.

Series allows allows to expand with respect to two or more variables. The result is again a SeriesData object with further SeriesData in its third argument.

Series[Exp[x y], {x, 0, 2}, {y, 0, 2}] // InputForm

Note that the explicit form of multivariate series depends on the order in which the expansion is done. One has to specify orders for each variables; Mathematica does not allow for a total order with respect to all variables.

Series[Sin[x y], {x, 0, 3}, {y, Pi/2, 3}]

Series[Sin[x y], {y, Pi/2, 3}, {x, 0, 3}]

But mathematically the last two results are identical. The function normal converts a SeriesData-object to a polynomial.

normal[expr_] := expr //. 
HoldPattern[SeriesData[x_, x0_, coeffs_, e1_, e2_, den_]] :>
            coeffs.Take[Table[(x - x0)^e, {e, e1, e2, den}], Length[coeffs]]

normal[%%%] - normal[%%] // Together

Sometimes one wants a multivariate series expansion up to a given total degree. This can be conveniently done by using the univariate built-in Series command by homogenizing the expression. The following function dSeries shows this.

dSeries[f_, {vars_List, points_List, d_}] := 
Module[{τ}, (Normal[Series[f /. Thread[vars -> τ vars + points], 
             {τ, 0, d}]] /. τ -> 1) + (* for correct form of the result *) 
             O[Times @@ (vars - points)]^d]

Here is an example that shows dSeries on action. Because the argument of O has head Times, we cannot use the result directly for further manipulations.

dSeries[Sin[x] Cos[y] + Tan[z]^2 , {{x, y, z}, {X, 0, 0}, 4}]

(For recovering the original function from the higher-order series terms, see [765✶].)
One word of caution is in order when working with multivariate SeriesData objects. Because constant with respect to the expansion variable do not form SeriesData objects, some orders might become wrong. So it is recommended to ensure that each of the coefficients of the outer SeriesData object is itself a SeriesData object. Here is an example that demonstrates the difference.

{Series[1 +  y + x y, {x, 0, 4}, {y, 0, 4}] + x^2 y^3,
 Series[1 +  y + x y + x^2 y^2, {x, 0, 4}, {y, 0, 4}]}

Normal[Subtract @@ (%^3)]

Series also works in conjunction with other commands. The functions in the following example cannot be integrated explicitly; so Series operates inside the integral.

Series[Integrate[ℊ[y] 𝒻[x], {x, -1, 1}], {y, 0, 2}]

FullForm[%]

The next input calculates the series expansion of the implicitly defined inverse function of f(x)=(∫_ξ^x)f(t)dt (assuming f(ξ)≠0) [448✶].

InverseSeries[Series[Integrate[f[t], {t, ξ, x}], {x, ξ, 5}]]

To transform a SeriesData expression into an “ordinary” Mathematica expression, we can use Normal. (The function normal from above is a crude version of the built-in function Normal.)

Now, the O[n] disappears.

Series[Sin[x y], {x, 0, 3}, {y, Pi/2, 2}] // Normal

The two series above agree up to their total order.

Series[Sin[x y], {x, 0, 3}, {y, Pi/2, 2}] // Normal // Simplify

Series[Sin[x y], {y, Pi/2, 2}, {x, 0, 3}] // Normal // Simplify

For O[x^ν], the result is trivially 0.

{Normal[O[x^3]], Normal[O[x^ν]], Normal[O[x]^3], Normal[O[x]^ν]}

One reason that the operation Normal is needed can be seen from the following example. We define a function generated by a series expansion.

serFunction1[x_] = Series[x, {x, 0, 3}]

We are not able to substitute numerical values for the expansion variable in series expansion, because for SeriesData-objects, numbers cannot be substituted for the variable.

serFunction1[1]

We can, of course, proceed as follows.

serFunction2[x_] = Series[x, {x, 0, 3}] // Normal;

serFunction2[1]

In the next input, we first form a series, than convert it to a normal expression and substitute another series for all occurrences of n. (This gives an expansion due to Ramanujan of the harmonic numbers (Subscript[H, n]) in terms of m=n(n+1)/2 [1606✶].)

Simplify[Normal[1/n + EulerGamma + 
        Series[PolyGamma[0, n], {n, Infinity, 16}]] /. 
         n -> Series[(Sqrt[1 + 8 m] - 1)/2, {m, Infinity, 6}]]

We now look at the zeros in the complex plane of the series expansion of (e^z) about z=0 as a function of the order [396✶], [1625✶]. Because (e^z) has no finite zeros in the plane, the zeros in the following plot appear as smaller and smaller points moving outward for increasing orders. (Other than the variables for the polynomial, we do not need any further variables.) We implement a function seriesZerosGraphics that generates a graphic of the zeros of the series expansion of f to order o.

seriesZerosGraphics[f_, z_, {o_, n_}, opts___] :=
Show[Graphics[Reverse[(* make colored points from zeros *)
 MapIndexed[{PointSize[0.001 #2[[1]]], Hue[0.8 (#2[[1]] - 1)/n], #1}&,
 Map[Point[{Re[#], Im[#]}]&,
 (* solve the polynomials *) (z /. NSolve[# == 0, z])& /@
 (* make all polynomials by series truncation *)
 NestList[Drop[#, -1]&, (* calculate series only once *)
 Normal[Series[f, {z, 0, o}]], n], {-1}]]]],
      opts, AspectRatio -> Automatic, Frame -> True,
      PlotRange -> All, FrameLabel -> {"Re[z]", "Im[z]"}]

seriesZerosGraphics[Exp[z], z, {35, 34}]

The zeros of the scaled partial sums z->order z cluster asymptotically at the curve |z exp(1-z)|=1.

Module[{o = 60, z}, 
Show[{(* region Abs[z Exp[1 - z]] < 1 *)
      ContourPlot[Abs[(x + I y) Exp[1 - x - I y]] - 1,
                  {x, -1, 1}, {y, -3/4, 3/4}, Contours -> {0}, 
                  PlotPoints -> 200, DisplayFunction -> Identity], 
      (* zeros of the rescaled partial sums *)
      Graphics[Table[{Hue[0.8 n/o], Point[{Re[#], Im[#]}]& /@
                     N[z /. Solve[(Normal[Series[Exp[z], {z, 0, n}]] /.
                    (* rescale *) z -> n z) == 0, z]]}, {n, o}]]}, 
     AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction]]

Let us use seriesZerosGraphics to visualize the zeros of some more polynomials that arise from a series. For sin(z), the zeros of the polynomials have to accumulate near the zeros of sin(z) at k π, k∈ℤ [1589✶], [1599✶].

seriesZerosGraphics[Sin[z], z, {40, 19}]

The Taylor series expansion of (((1+z))^(1/2)) has the finite convergence radius 1. Now, the zeros accumulate at the boundary of convergence.

seriesZerosGraphics[Sqrt[1 + z], z, {35, 34}]

The zeros of the partial sums of an asymptotic series (the series of the Gamma function at infinity) are shown.

Show[Graphics[Reverse[
MapIndexed[{PointSize[0.001 #2[[1]]], Hue[(#2[[1]] - 1)/40], #1}&,
Map[Point[{Re[#], Im[#]}]&, (z /. NSolve[# == 0, z])& /@
Rest[Table[Numerator @ Together @ Expand[Cancel[Normal[
(* the series; divide out Puiseux part *)
 Series[Gamma[z], {z, Infinity, k}]]/
       (z^z Exp[-z] Sqrt[1/z] Sqrt[Pi/2])]], {k, 25}]], {-1}]]]],
    AspectRatio -> Automatic, Frame -> True,
    PlotRange -> All, FrameLabel -> {"Re[z]", "Im[z]"}]

Here are the zeros of the series of a truncated polynomial [1442✶].

seriesZerosGraphics[(1 - z)^-50, z, {40, 19}]

Here are some more pictures of this kind. The next example shows the zeros of the partial sums of the divergent series

(∫_0^∞)((e^(-t))/(t z+1))dt∝(∑_(n=0)^∞)(((-1))^n) n! (z^n).

Integrate[Normal[Series[Exp[-t]/(1 + x t), {x, 0, 9}]],
                        {t, 0, Infinity}]

seriesZerosGraphics[Sum[(-1)^n n! z^n, {n, 0, 40}], z, {30, 22}]

The last picture of this series shows the zeros of the partial sums of the series of (((1-z))^(-1)).

Show[GraphicsArray[#]]& /@ Partition[
Table[seriesZerosGraphics[D[1/(1 - z), {z, n}], z, {30, 23},
                          DisplayFunction -> Identity],
      {n, 0, 7}], 4]

For the behavior of partial sums of other divergent series, see [438✶]. For mathematical details on the behavior of partial sum approximations of power series, see [1201✶], [505✶], [1597✶], [1598✶], and [199✶].

Now let us use the Series command to build a more complicated series, a q-Taylor series [830✶], [530✶], [998✶], [874✶], [1510✶], [1307✶]. For any function f(x) analytic at (Subscript[x, 0]), the series

(Subscript[f, n])(x)=(∑_(k=0)^n)((Subscript[(x,(Subscript[x, 0]);q), n])/(Subscript[(k!), q]))(((Subscript[d, q])f(x))/((Subscript[d, q])x))

converges to f(x) as n->∞ for all |q|≠1. Here

(Subscript[(x,a;q), n])=(∏_(k=0)^(n-1))(x-a (q^k))

and (Subscript[d, q]) is the q-differential operator

(((Subscript[d, q])f(x))/((Subscript[d, q])x))=((f(x)-f(q x))/((1-q) x)).

It is straightforward to implement the last definitions.

(* q-factorial function *)
qFactorial[q_][n_] := Product[(q^k - 1)/(q - 1), {k, 1, n}];
qFactorial[q][0] = 1;

(* q-differential operator; defined recursively *)
qD[q_][f_, x_] := (f - (f /. x -> q x))/((1 - q) x);
qD[q_][f_, {x_, 0 }] := f
qD[q_][f_, {x_, 1 }] := qD[q][f, x]
qD[q_][f_, {x_, n_}] := qD[q][f, {x, n}] = 
              Together[qD[q][qD[q][f, {x, n - 1}], x]]
     
(* q product *)
qProduct[q_][n_, x_, a_] := Product[x - a q^k, {k, 0, n - 1}]  

(* q-Taylor series *)
qTaylorSeries[q_][f_, {x_, x0_, n_}] := 
Sum[Together[qProduct[q][k, x, x0]/qFactorial[q][k]*
    (* need Series here to avoid indeterminate expressions *)
    Normal[Series[qD[q][f, {x, k}], {x, x0, 0}]]], {k, 0, n}]

Here are the first two terms of the q-Taylor series expansion of an abstract function f(x) around (Subscript[x, 0]).

qTaylorSeries[q][f[x], {x, x0, 2}]

Series[%, {q, 1, 1}] // Simplify

For (Subscript[x, 0])=0, the q-Taylor series agrees with the ordinary Taylor series.

qTaylorSeries[q][Cos[x], {x, 0, 6}]

But for general q, the q-Taylor series is typically far more complicated.

qTaylorSeries[q][Cos[x], {x, 2Pi, 3}]

Similarly to the above investigations, we could visualize the behavior of the zeros of (Subscript[f, n])(x). This time we fix n and study the dependence on q. Here this is done for a simple polynomial (x^50)-1 with (Subscript[x, 0])=1, n=25 and q varying between -1 and 1.

qft[x_] = qTaylorSeries[q][x^50 - 1, {x, 1, 25}];

Show[Graphics[{PointSize[0.003],
Table[{Hue[0.8 (q0 - 1)/2], Point[{Re[#], Im[#]}]& /@ 
      Cases[NRoots[qft[x] == 0 /. q -> N[q0], x], _?NumberQ, {-1}]},
     {q0, -1, 1, 2/501}]}], 
     Frame -> True, PlotRange -> 3/2 {{-1, 1}, {-1, 1}}]

Here are three examples for the q-Taylor series of random polynomials.

Show[GraphicsArray[
(SeedRandom[#]; (* q-Taylor series *)
 qft[x_] = qTaylorSeries[q][(* random polynomial *)
             Sum[Random[Integer, 10 {-1, 1}] x^k, 
             {k, 10}], {x, 1, 9}];
(* make graphics *)
Graphics[{PointSize[0.003],
Table[{Hue[0.8 (q0 - 1)/2], Point[{Re[#], Im[#]}]& /@ 
      Cases[NRoots[qft[x] == 0 /. q -> N[Exp[I q0]], x], 
            _?NumberQ, {-1}]},
     {q0, -1, 1, 2/1001}]}, Frame -> True, PlotRange -> All,
     PlotRange -> 3/2 {{-1, 1}, {-1, 1}}, FrameTicks -> False])& /@
   (* the seeds *)  
   {51879769166741319900, 67570387056305739148}]]

Many operations that apply to “ordinary functions” can also be applied to series. These include, for example, D, Integrate, Plus, Times, Power, etc. The results are SeriesData-objects (this is similar to interval arithmetic, in which the result has the head Interval). We present a few examples. Here is the initial object.

ser = Series[Tan[Sin[x]] - Sin[Tan[x]], {x, 0, 10}]

Here is its derivative.

D[ser, x]

This is its indefinite integral with respect to x.

Integrate[ser, x]

Here is an algebraic expression formed from it.

ser + 5 ser^2 + Sqrt[ser]

If two series expansions are such that all of their terms coincide up to a certain order, their difference may still not be 0. They could be series expansions of two distinct functions that just happen to agree up to that order.

s1 = Series[Sin[x], {x, 0, 3}]

s2 = %

s1 - s2

Be careful with the following subtractions of two SeriesData-objects. The following result is also not 0.

s1 - s1

And the result of the following is not 1.

s1/s1

Because Mathematica computes the two arguments before subtracting, and at the point when the subtraction takes place, it no longer knows anything about the previous equality of the two arguments. 
If SeriesData-objects are used as arguments of functions, a new SeriesData-object that has the corresponding order is automatically formed. We have already observed this in the above example with simple functions involving ser.

Exp[ser]

AiryAi[ser]

However, for a function that is not explicitly defined, nothing happens.

f[ser]

As a little application of Series, we will check the first few instances of the following neat identity [1662✶]. Let the (formal) series be f=1+(Subscript[a, 1])x+(Subscript[a, 2])(x^2)+⋯. Then the determinant of the matrix C with entries (Subscript[c, i j])=[(x^i)](((f(x))^j))  is given by det(C)=(Subscript[a, 1]^(n(n+1)/2)).

With[{n = 7},
	Module[{f = 1 + Sum[a[i] x^i, {i, n}] + O[x]^(n + 1)},
	Table[Expand[Det[Table[If[i == 0, If[j == 0, 1, 0],
		       SeriesCoefficient[f^i, j]], {i, 0, k}, {j, 0, k}]]], 
		  {k, 0, n}]]]

A similar identity holds for f=x+(Subscript[a, 2])(x^2)+(Subscript[a, 3])(x^3)+⋯ [911✶]. Then, the determinant of the matrix C with entries (Subscript[c, i j])=[(x^(i+1))]((f^((j)))), where (f^((i)))=f((f^((i-1)))) and (f^((0)))=x is given by:

det(C)=((∏_(k=0)^n)k!)(Subscript[a, 2]^(n(n+1)/2)).

Here is a check of the last theorem for n=6.

With[{n = 6},
 Module[{f},
        f[x_] = x + Sum[a[i] x^i, {i, 2, n }];
        Table[Expand[Det[Table[SeriesCoefficient[
                                Nest[f, x + O[x]^(n + 1), i], j + 1], 
		                      {i, 0, k}, {j, 0, k}]]], {k, 0, 5}]]]

Table[Product[k!, {k, 0, n}] a[2]^(n (n + 1)/2), {n, 0, 5}]

Sometimes one does not need the whole series, but rather a single term. SeriesCoefficient extracts a specific term from a series.

SeriesCoefficient[Series[Exp[x], {x, 0, 10}], 10]

When the series does not have enough terms, Indeterminate is returned.

SeriesCoefficient[Series[Exp[x], {x, 0, 4}], 10]

Here is a little application of SeriesCoefficient. How many ways are there to have change for $1? Using the generating function approach [1016✶], [784✶], it is straightforward to write down the following answer [1556✶], [685✶].

NumberOfDifferentChanges[coins_List, money_] :=
Module[{z}, SeriesCoefficient[Series[1/(Times @@ (1 - z^coins)), 
                                     {z, 0, money}], money]]

Using standard U.S. coins, we have 293 possibilities for $1.

NumberOfDifferentChanges[{1, 5, 10, 25, 50, 100}, 100]

And we have 3954 possibilities for $1 if we would add a two-cent coin.

NumberOfDifferentChanges[{1, 2, 5, 10, 25, 50, 100}, 100]

Finding the number of ways to express $10 requires the calculation of the series up to order 1000. Nevertheless, this can be carried out quickly.

NumberOfDifferentChanges[{1, 5, 10, 25, 50, 100}, 1000] // Timing

The complexity of NumberOfDifferentChanges is O((moneyInCent^2)). This means that calculating that there are 139946140451 possibilities for $100 takes about 100 times as long as the last example.

NumberOfDifferentChanges[{1, 5, 10, 25, 50, 100}, 10000] // Timing

The function NumberOfDifferentChanges can be extended to deal with the case of representing money through number coins coins.

NumberOfDifferentChanges[coins_List, money_, number_] :=
Module[{z, ζ}, 
   SeriesCoefficient[Series[
    SeriesCoefficient[Series[1/(Times @@ (1 - ζ z^coins)), 
                 {z, 0, money}], money], {ζ, 0, number}], number]]

Here are the number os possibilities to express $1 using 1, 2, 5, 10, 20, 50 cent coins.

{#, NumberOfDifferentChanges[{1, 5, 10, 25, 50, 100}, 100, #]}& /@ 
        {1, 2, 5, 10, 20, 50, 100}

For $2, we see already a smooth dependence on the number of coins emerge.

ListPlot[
Table[{number, 
       NumberOfDifferentChanges[{1, 5, 10, 25, 50, 100}, 200, number]},
          {number, 200}], PlotRange -> All, Frame -> True,
                         Axes -> False, PlotStyle -> {PointSize[0.01]}]

For the optimal coins values, see [1441✶].

Here is another counting-related application of SeriesCoefficient. The following small program counts the number of different series-parallel networks with 1, 2, …, n edges http://www.research.att.com/projects/OEIS?Anum=A000084, [1052✶], [667✶], [44✶].

SeriesParallelNetworksList[n_] := 
Module[{S, τ}, Rest[#[[3]]]& @ 
       Fold[(#1/(1 - S^#2)^SeriesCoefficient[##])&, 
            1/(1 - (S = τ + O[τ]^(n + 1))), Range[2, n]]]

SeriesParallelNetworksList[12]

Asymptotically the number of networks is proportional (n^(-3/2))×0.28083(…^n) [570✶].

ListPlot[MapIndexed[0.41276 #2[[1]]^(-3/2) 0.28083^(-#2[[1]])/#1&,
                    SeriesParallelNetworksList[200]]]

Using series, we can perform another important operation: inversion. Thus, from a series r(x), we obtain a new series s(x) such that r(s(x))=id(x), or in Mathematica semantics, InverseSeries.

We look at an example.

ser = Series[Exp[-Exp[x]], {x, 0, 4}]

invSer = InverseSeries[ser]

ser /. x -> invSer

Normal[%]

The converse also holds.

invSer /. x -> ser

We now invert the series (∑_(i=0)^n)(Subscript[a, i])(x^i) with symbolic (Subscript[a, i]).

Together /@ Normal[InverseSeries[
(* the series of the form a0 + a1 x + a2 x^2 ... *)
           Array[Subscript[a, #] ξ^#&, 5, 0, Plus] + O[ξ]^6]]

Here is a series with the property that the coefficients of both, the direct and the inverse series are integers [1732✶].

𝒾Series[z_, o_] := 
z Exp[3 Sum[(3k)!/k!^3 Sum[1/j, {j, k + 1, 3k}] z^k, {k, o}]/
        Sum[(3k)!/k!^3 z^k, {k, 0, o}] + O[z]^o]

𝒾Series[z, 5]

InverseSeries[%]

Calculating the first 100 terms of the inverse series takes just a few seconds on a 2 GHz computer.

{Union[Head /@ #], N[Max[Abs[#]]]}&[
          InverseSeries[𝒾Series[z, 100]][[3]]] // Timing

Using InverseSeries, we can easily compute the higher terms needed for finding zeros numerically using the Chebyshev method [300✶], [1230✶], [755✶], [1177✶], [1253✶], and [1266✶]. The idea behind this method is quite simple. Make a series expansion of an equation f(x)=0 around an approximation x≈a of a root, invert this series, then use the fact that at the root, we have f(x)=0.

𝒞 = Together /@ (Normal[InverseSeries[(* symbolic series; f not specified *)
                 Series[f[x], {x, a, 5}]]] /. x -> 0)

Here, a is the approximate value of the zero. We clearly see the Newton method in the first two terms. Here is a simple example that shows how the higher order terms improve the solution. We use the function f(x)=cos((x^2))-x and a=1.

Block[{λ = List @@ 𝒞, f = Cos[#^2] - #&, a = 1.},
      f /@ Rest[FoldList[Plus, 0, List @@ λ]]]

In addition to the wanted roots, the higher order method have other zeros. Here is the example f(x)=(x^2)-𝓍 used.

Solve[a == Take[𝒞, 4] /. f -> ((#^2 - 𝓍)&), a]

Let us remark here that such higher-order root finding procedures can be calculated using Schröder’s formula [748✶], [36✶], [465✶] without using explicit series inversion.

SchröderIterationFunction[f_, z_, n_] := 
z + Sum[1/k! Nest[(1/f'[z] D[#, z])&, 1/f'[z], k - 1] (-f[z])^k, 
        {k, n - 1}]

SchröderIterationFunction[f, a, 6] - 𝒞 // Together

Let us also remark that a truncated version of the continued fraction form of the first four terms of 𝒞 yields Halley’s root finding method [843✶].

Before discussing solutions of equations involving series, here is a short remark on the expression SeriesTerm from the package DiscreteMath`RSolve`.

Needs["DiscreteMath`RSolve`"]

?SeriesTerm

This means that with SeriesTerm, we can symbolically calculate series terms. Here is one example.

SeriesTerm[(2 + 4x)/(5 + 6x), {x, 0, n}]

(For calculating series terms of arbitrary order, see [949✶], [950✶], and [952✶].)

Let us use Series to solve equations in an example from iteration theory. Let (f^((k)))(x) stand for f applied k times to x. If f(0)=0 for small x, under certain conditions the function (f^((k)))(x) can be approximated through the following function 𝔉[k, x, {a, b, c}] [701✶]. Here a, b, c are uniquely defined parameters.

𝔉[k_, x_, {a_, b_, c_}] := 
   x/(1 - a k x) + (x/(1 - a k x))^2 b Log[1 - a k x] +
   (x/(1 - a k x))^3 b^2 (Log[1 - a k x]^2 -
   Log[1 - a k x] + c k x)

Let f(x) be the relatively complicated function (1-x) tan(x) exp((x^2))/(sin(x)+1).

𝔣[x_] := (1 - x) Tan[x] Exp[x^2]/(1 + Sin[x]);

𝔣[k_, x_] := Nest[𝔣, x, k]

Fixing k allows to uniquely determine the parameters a, b, and c.

Module[{o = 6, ser1, ser2}, 
       Union @ (* one unique solution *) 
       Table[ser1 = Series[𝔣[𝓀, x], {x, 0, o}];
             ser2 = Series[𝔉[𝓀, x, {a, b, c}], {x, 0, o}];
             Solve[(# == 0)& /@ Take[
              DeleteCases[CoefficientList[ser1 - ser2, x], 0], 3],
                   {a, b, c}][[1]], {𝓀, 2, 6}]]

This yields the following approximation for (f^((k)))(x).

𝔉𝔣[k_, x_] = 𝔉[k, x, {a, b, c}] /. %[[1]]

The next graphic shows the relative difference between (f^((1000)))(x) and the calculated approximation along the real and imaginary axes. The two functions agree quite well for small x.

With[{k = 1000, ε = 10.^-6},
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
     {(* along real axis *)
      ListPlot[Table[Log[10, Abs[𝔉𝔣[k, x]/𝔣[k, x] - 1]], 
                     {x, ε, 1 - ε, (2 - ε)/200}],
               Frame -> True, Axes -> False, PlotRange -> All],
      (* along imaginary axis *)     
      ListPlot[Table[Log[10, Abs[𝔉𝔣[k, I x]/𝔣[k, I x] - 1]], 
                     {x, -1 + ε, 1 - ε, (2 - ε)/400}],
           Frame -> True, Axes -> False]}]]]]

The error is a decreasing function of k.

With[{x = N[1/3, 100], k = 10000},
ListPlot[Log[10, Abs[Rest[NestList[𝔣, x, k]]/
             Table[𝔉𝔣[j, x], {j, k}] - 1]],
     PlotRange -> All, Frame -> True, Axes -> False]]

Next, we discuss a peculiarity of Solve. When applied with series (with the head SeriesData) as arguments in the Equals of the first argument of Solve: Solve[(Subscript["series", 1]) == (Subscript["series", 2]), {(Subscript["var", 1]), (Subscript["var", 2]), …, (Subscript["var", n])}] solves the equations resulting from comparing the coefficients in (Subscript["series", 1]) and (Subscript["series", 2]) for the variables (Subscript["var", i]). This allows the solution of differential equations by assuming a power series expansion for the solution. We now look at an example involving the (nonlinear!) differential equation of a planar mathematical pendulum y''(t)=sin(y(t)).

ySeries = Sum[a[i] t^i, {i, 0, 6}] + O[t]^7

ySeriesDiff = D[ySeries, {t, 2}]

Now, we express the constants a[2] and a[3] in terms of a[0] and a[1] (which are to be determined by the initial conditions) using Solve.

Solve[ySeriesDiff == Sin[ySeries], {a[2], a[3], a[4], a[5], a[6]}]

This leads us to the following solution for y(t).

ySeries /. %

Although Series alone can deal with Laurent and Puiseux series as well as Taylor series, this may not be the case when it is used in conjunction with Solve. In the following example, we expand y[x] and y''[x] in a series about x = 0, and compare the coefficients of the (x^j). Mathematica does not currently handle this kind of series in Solve.

Solve[Series[y''[x] +  y[x] + 2 + x^2, {x, 0, 2}] == 0,
      {y''''[0], y'''[0], y''[0]}]

This leads to the following first terms of the solution.

Series[y[x], {x, 0, 2}] /. %

In the following two examples, we would have to use a Laurent and Puiseux series, respectively, for y[x].

Solve[Series[y''[x] +  y[x] + 2 + x^(-1), {x, 0, 2}] == 0,
      {y''''[0], y'''[0], y''[0]}]

Solve[Series[y''[x] +  y[x] + 2 + x^(7/4), {x, 0, 2}] == 0,
      {y''''[0], y'''[0], y''[0]}]

Solve does not carry out a comparison of coefficients, although Series works as usual.

Series[y''[x] +  y[x] + 2 + x^(-1), {x, 0, 2}]

Series[y''[x] +  y[x] + 2 + x^(7/4), {x, 0, 2}]

The computation of higher-order terms for Taylor series in several variables is also possible. Here, we express the coefficients (Subscript[c, "ijl"]) of the series

(∑_(i,j,k=0)^n)(Subscript[c, ijk])(Subscript[s, a]^i)(Subscript[s, b]^j)(Subscript[s, c]^k)=ln((∑_(i,j,k=0)^n)(Subscript[m, ijk])(Subscript[s, a]^i)(Subscript[s, b]^j)(Subscript[s, c]^k))

in terms of the (Subscript[m, "ijl"]). (This is a so-called cumulant expansion; see [1118✶], [1178✶], [1587✶], [625✶], [1098✶], [938✶], and [965✶].) Let n=2.

n = 2;

(momentSum = Sum[m[i, j, l] sa^i sb^j sc^l,
                 {i, 0, n}, {j, 0, n}, {l, 0, n}] /. m[0, 0, 0] -> 1)

logMomentSum = Series[Log[momentSum], {sa, 0, n}, {sb, 0, n}, {sc, 0, n}];

(cumulantSum = Sum[c[i, j, l] sa^i sb^j sc^l,
     {i, 0, n}, {j, 0, n}, {l, 0, 2}] + (* make Series *)
     O[sa]^(n + 1) + O[sb]^(n + 1) + O[sc]^(n + 1)) // Short[#, 3]&

Because of space limitations, we do not look at all (Subscript[k, "ijl"]), but only at (Subscript[k, 222]), and this only in short form.

Solve[logMomentSum == cumulantSum, {c[2, 2, 2]}] // Simplify // Short[#, 4]&

If we need the equations for comparison of the coefficients of equal powers themselves, we can use the command LogicalExpand, which we have already discussed in Chapter 5 of the Programming volume [1559✶] of the GuideBooks in connection with logical coupling.

Here are the resulting equations for the differential equation y''(x)=y'(x)+3y(x)+4x+5 using a series expansion of the form y(x)=(∑_(j=0)^8)(Subscript[c, j])(x^j).

LogicalExpand[(D[#, {x, 2}]  == D[#, x] + 3 # + 4 x + 5)&[
                       Sum[c[j] x^j, {j, 0, 8}] + O[x]^9]]

We could operate further on this system of equations, for example, with Solve. (We can plug in the last output directly into Solve, because Solve accepts a list of equations or a logical combination of equations.)

Solve[%, Array[c, 7, 2]] // Short[#, 6]&

Here is a quick check of the solution.

(D[#, {x, 2}]  - (D[#, x] + 3 # + 4 x + 5))&[
    (Sum[c[j] x^j, {j, 0, 8}] /. %[[1]]) + O[x]^9]

There is no special way of using series in InverseFunction. For example, if we try to find the series expansion of the inverse function for y=(x^5)+x about y=∞, the following implementation fails. (InverseFunction[Function[x, x^5 + x]] is not explicitly computed.)

Series[InverseFunction[Function[x, x^5 + x]][y], {y, Infinity, 3}]

However, with InverseSeries, we can easily find the (more correctly—one of the) desired series representation.

InverseSeries[Series[x^5 + x, {x, Infinity, 50}]]

Here is a check for the correctness of the last result.

#^5 + #&[%] // Normal

While Solve[Series[…] == 0,…] works, it is frequently more efficient to not generate too many terms of a series that have symbolic expressions because they frequently grow quickly in size. Instead solving for the highest term recursively is in many cases more efficient. Here is an example. The function ψ(z)=z+(∑_(k=0)^∞)(Subscript[β, m])(z^(-m)) defined implicitly through (Subscript[p, n])(ψ(z))=(z^(2^n))+O(z) for large z, maps the exterior of unit disk to the exterior of the Mandelbrot set [542✶]. Here (Subscript[p, n])(z)=(((Subscript[p, n-1])(z))^2)+z, (Subscript[p, 0])(z)=z. The function makeMandenbrotFunction[n] calculates the approximation (Subscript[ψ, n])(z)=z+(∑_(k=0)^((2^n)-2))(Subscript[β, m])(z^(-m)). We use approximate series coefficients to avoid building fractions with large integers for the higher-order (Subscript[β, k]).

makeMandenbrotFunction[n_Integer?Positive] := 
Module[{},
  (* classical Mandelbrot recursion *)
  p[0][z_] := z;
  p[ν_][z_] := p[ν - 1][z]^2 + z;
  (* recursion start *)
  g[z_] = 1. z; ℒ = Table[0, {2^n}]; ℒ[[1]] = 1.;
   (* loop over terms of the series until order 2^n-2 *)
  Do[ψ = Series[g[z] + β[j]/z^j, 
                {z, Infinity, j + If[$VersionNumber >= 5, 0, 1]}];
     eqs = Chop @ 
           If[$VersionNumber >= 5, Normal[p[n][ψ] - z^(2^n)],
               Series[p[n][Normal[ψ]] - z^(2^n) /. z -> 1/z, 
                            {z, 0, 0}][[3, 1]]] == 0; 
     sol = Solve[eqs, β[j]]; 
     g[z_] = g[z] + β[j]/z^j /. sol[[1]]; ℒ[[2 + j]] = sol[[1, 1, 2]],
     {j, 0, 2^n - 2}];
     (* return series as pure function and coefficient list *)
     {Function[Evaluate[g[#]]], ℒ}]

Here is a shortened version of the resulting series.

Short[(mBF = makeMandenbrotFunction[8])[[1]][z], 6] // Timing

Graphing the map of the unit circle under the (Subscript[ψ, k]) for the k≤(2^8)-2 shows how the classical Mandelbrot shape arises.

Show[Graphics[
(* color each ψ_k differently *)
MapIndexed[{Hue[0.78 #2[[1]]/Length[mBF[[2]]]], Line[#]}&, 
(* form curves efficiently *)
Map[{Re[#], Im[#]}&, Transpose[Rest[FoldList[Plus, 0, #]]& /@ 
   Table[Table[Exp[I φ]^j, {j, 1, -Length[mBF[[2]]] + 2, -1}] mBF[[2]], 
         (* use enough plotpoints *) {φ, 0., 2.Pi, 2Pi/1200}]], {2}]]]]

As an application of Series, we will deal with the discrete approximation of arbitrary linear functionals on equally spaced data points. This very elegant and useful application is from [344✶]. (We follow [344✶] mainly here.)

A functional is a mapping L:G->"ℝ" (or G->"ℂ") of a linear space G (numbers, function space, etc.) into the real or complex numbers. A functional is linear, provided that L[(Subscript[λ, 1])(Subscript[g, 1])+(Subscript[λ, 2])(Subscript[g, 2])]=(Subscript[λ, 1])L[(Subscript[g, 1])]+(Subscript[λ, 2])L[(Subscript[g, 2])] for (Subscript[λ, i])∈ℝ or (Subscript[λ, i])∈ℂ and (Subscript[g, i])∈G.

Examples of linear functionals are integrals, differential quotients at given points, etc. To work with functionals numerically, it is necessary to discretize them; that is, L(g(x)) should be approximated by an expression of the form L[g(x)]≈(∑_(i=0)^n)(Subscript[w, i])g((Subscript[x, i])), where g(x) is a function of a real variable x. Here, (Subscript[x, i])=(Subscript[x, 0])+ih are data points and (Subscript[w, i]) are weights. For n equally spaced data points with spacing h, the requirement that the approximation of the functional should reproduce exactly the moments (Subscript[m, i])=L[(x^i)] leads to the following result. If we expand W(ξ)=(ξ^(-(Subscript[x, 0])/h))(∑_(j=0)^(n-1))(Subscript[m, j])/(j!(h^j))(ln^j)ξ in a Taylor series about ξ=1 up to order n-1 with respect to the variables ξ, the factors appearing in front of the (ξ^i) are the desired weights (the proof proceeds by substitution and explicit computation) (Subscript[w, i])=[(ξ^i)](W(ξ)). (For the remainder estimation, see [293✶].)

We now give a straightforward implementation.

weights[functional_, order_Integer, {x0_, h_}] :=
Module[{X, var}, CoefficientList[Series[X^(-x0/h) *
                  Sum[functional[var^j, var] Log[X]^j/j!/h^j,
                        {j, 0, order - 1}], {X, 1, order - 1}], X]]

We assume that the functional being approximated is given in the form functional[function, variable]. We now look at a few examples. First, we consider the approximation of a first derivative of a function at x=0 using a finite number of equally spaced points (with distance 1) lying symmetrically around (Subscript[x, 0])=0.

(* or, in a more functional style: Derivative[1][Function[#2, #1]][0]& *)
der1[f_, var_] := D[f, var] /. var -> 0;

Do[Print["i = ", i, "  ", weights[der1, i, {-i/2 + 1/2, 1}]], {i, 3, 11, 2}]

Here is the analog for second derivatives.

(* or, in a more functional style: Derivative[2][Function[#2, #1]][0]& *)
der2[f_, var_] := D[f, {var, 2}] /. var -> 0;

Do[Print["i = ", i, "  ", weights[der2, i, {-i/2 + 1/2, 1}]], {i, 3, 11, 2}]

Here are the weights for even-order approximations for the first and second derivative around (Subscript[x, 0])=0 and node distance 1 [925✶], [912✶].

Table[weights[der1, k, {(-k + 1)/2, 1}], {k, 2, 8, 2}]

Table[weights[der2, k, {(-k + 1)/2, 1}], {k, 4, 8, 2}]

We can also find the weights for a functional that is not given explicitly. To improve readability, we replace the functional by the corresponding moments.

weights[f, 4, {x0, h}] //. {f[var_^exp_., var_] -> m[exp],
                            f[1, var_] -> m[0]} // Simplify

Next, we examine a few integration Newton–Cotes-type formulas. We consider only integrating from -n to n. To be able to compare with the references [10✶], we factor out the greatest common multiple of the denominators.

integral[f_, var_] := Integrate[f, {var, -k, k}] /. var -> 0;

Do[k = (i - 1)/2;
   wts = weights[integral, i, {-k, 1}];
   (* bring result in nicer form *)
   denominator = LCM @@ (Denominator /@ wts);
   numerator = GCD @@ (denominator wts);
   Print["i = ", i, "  ", numerator/denominator, wts denominator/numerator],
   {i, 3, 13, 2}]

This agrees with the mentioned reference [10✶].

1.6.5 Residues

The residue is the coefficient of the term (((z-(Subscript[z, 0])))^(-1)) in the Laurent expansion of a function about the point (Subscript[z, 0]). (For a very detailed survey of applications of residues, see [1153✶] and [1154✶].) In Mathematica, we get the residue of a function at a given point via Residue.

Such residues arise frequently in the solution of ordinary differential equations via Fourier transforms. Here are two examples.

Residue[Exp[I k x]/(k^2 - ki^2), {k, ki}]

Residue[Exp[I k x]/(k^4 - ki^4), {k, ki}]

The residue can also be computed at the point Infinity.

Residue[1/z, {z, Infinity}]

Residues do not exist at branch points.

Residue[z^(-1/2), {z, 0}]

Typically, residues are only defined for poles. Here, we give Mathematica an essential singularity.

Residue[Exp[-1/z], {z, 0}]

Carrying out the defining contour integral for the residue shows that the last result is sensible.

NIntegrate[Exp[-1/z], {z, 1, I, -1, -I, 1}]/(2Pi I) // Chop

In a similar way, the following results can be explained [1564✶].

Table[Residue[z^k Exp[-1/z], {z, 0}], {k, -3, 3}]

{Residue[Exp[Exp[1/z]], {z, 0}], Residue[Exp[Exp[Exp[1/z]]], {z, 0}]}

Residue[Exp[Exp[Exp[1/z]]], {z, 0}]

Residues can also be calculated at the poles of special functions, such as at the following pole of order 2 of the product of two Γ functions.

Residue[Gamma[z] Gamma[z + 3], {z, -5}]

Unfortunately the command Residue does not have an Assumption option in the moment. So the following input does not work.

Residue[1/Sin[x/Pi], {x, k}, Assumptions -> Element[k, Integers]]

1.6.6 Sums

We already encountered the function Sum. We used it for carrying out finite sums in a procedural way. The symbol Sum has a double meaning in Mathematica. It does the sum by evaluating one summand after the other, but it is also used to carry out symbolic summations.

?Sum

Similar like for integration, a variety of special algorithms exist to do symbolic summation [1460✶], [955✶].

Consider the following sums: (Subscript[s, j,n])=(∑_(i=i)^n)(i^j)

Do[CellPrint[Cell[BoxData[FormBox[RowBox[{(* marker *) " ∘ ",
          MakeBoxes[#, TraditionalForm]& @@ 
           {Subscript[s, j, n] == Sum[i^j, {i, n}]}}], 
                       TraditionalForm]], "Output"]], {j, 4}]

Note that a commonly given closed formula for this sum in terms of Bernoulli numbers is

(1/(j+1))(∑_(i=0)^j)(({{j+1}, {i}})) (Subscript[B, i]) (((n+1))^(j-i+1))

(for arbitrary positive integers n and j) ([328✶], [864✶], [947✶], [733✶], [710✶], [1065✶], and [975✶]). Mathematica computes the following sum as a difference of two harmonic numbers (Zeta functions).

Sum[i^j, {i, n}]

Here are a few examples of the capabilities of Sum. (We assume that the limits of summation are integers.) Here is a slight generalization of the harmonic series.

Sum[1/(i + a), {i, n}]

The result contains a Polygamma function, which we will discuss in Chapter 3. 
As another small example, we compute the first five moments of the binomial distribution.

Table[Sum[Binomial[n, k] p^k (1 - p)^(n - k) k^i, {k, 0, n}] //
                           PowerExpand // Factor, {i, 0, 5}]

For symbolic limits it is implicitly assumed that the limits are integer-valued.

Sum[Exp[I k x], {k, n}]

Similar to integration results, the results of Sum will often contain special functions and RootSums.

Sum[Binomial[n, k] k^3/(n - k), {k, n}]

Sum[Log[k^2 + 2k - 1], {k, n}]

Sum[(k^2 - 3)/(k^3 + 4), {k, n}]

Sum[(-1)^k/(α + β k), {k, n}]

Here are some more infinite sums.

Sum[1/(k^2 2^k), {k, Infinity}]

Sum[Sin[k a]/k^2, {k, Infinity}]

Sum[z^k/k!/k, {k, Infinity}]

Sum[(k - 1)^2/(k + 2)^5, {k, Infinity}]

Sum[(2n + 1)!/(2^(3n) (2n - 1) n!^2), {n, Infinity}]

As with Integrate, results of Sum are not automatically simplified. Applying Simplify and other functions often allows to get a simpler result.

Sum[2/(2k + 1) ((z - 1)/(z + 1))^(2k + 1), {k, 0, Infinity}]

% // TrigToExp // Simplify[#, z > 1]&

Here are two forms of the binomial theorem [1038✶]. The two sums contain symbolic products as arguments.

1 + Sum[Product[α - k, {k, 0, k - 1}] t^k/k!, {k, Infinity}]

1/(-𝒽)^α Sum[(-1)^k Product[α - k, {k, 0, k - 1}] (1 + 𝒽 + 𝒽 t)^k/k!, 
             {k, 0, Infinity}] // Simplify // PowerExpand

There is a small extension in the definition for sums extending over all integers: The intuitive notation {k, -Infinity, Infinity} works, and the iterator variable k starts at the “integer” -∞.

Sum[1/(1 + k^2), {k, -Infinity, Infinity}]

Multidimensional sums use iterators similar to multidimensional integrals. (For sums of noninteger dimensions, see [363✶].) Here is a simple example.

{Sum[j, {k, n}, {j, k}], Sum[Sum[j, {j, k}], {k, n}]}

Of course, there are also many sums that Mathematica cannot sum.

unevaluatedSum = Sum[n^-n, {n, Infinity}]

Applying N yields results in a call to NSum and we get a numerical approximation of the sum.

N[%]

Be aware that the automatic comparisons carried out by Equal, Less, and so on, do not work immediately for unevaluated sums and integrals.

unevaluatedSum < Pi/2

For comparisons to be carried out by numericalization, the terms involved must be numeric. But Sum does not have the NumericFunction attribute. Nevertheless, we can declare the whole sum to be a numeric expression.

NumericQ[unevaluatedSum] = True;

Now, the comparison results in True.

unevaluatedSum < Pi/2

Because of Sum’s double life, as procedural summation routine and as symbolic summation engine, it must decide what to do for finite limits. It will switch between a procedural and a symbolic approach. This explains the timings in the following example.

ListPlot[Table[{k, Timing[Sum[j, {j, 10^k}]][[1, 1]]}, {k, 12}],
         PlotJoined -> True, PlotRange -> All]

We mentioned above that there are two ways to “do” a sum—evaluating the summands one after another in a procedural way or carrying out the symbolic summation. The first possibility can be further subdivided into two possibilities. Either form the cumulative sum after the calculation of each summand or first calculate all summands and then apply Plus to the resulting list. It depends on the nature of the summands which way is more appropriate. Let us take for instance the case of summing 100000 approximative real numbers. First, we use Sum.

Sum[k + Sin[k] + Log[k]^3, 
    {k, (* approximate numbers in limits *) 1., 10.^5}] // Timing

Next, we carry out a Do loop and form cumulative sums.

(sum = 0; Do[sum = sum + k + Sin[k] + Log[k]^3, {k, 1., 10.^5}];
 sum) // Timing

The last method to calculate the sum is to first form a list of 100000 elements and then to change the list head to head Plus.

Apply[Plus, Table[k + Sin[k] + Log[k]^3, {k, 1., 10.^5}]] // Timing

The last method was clearly the fastest, the reason being the autocompilation of Table (which was discussed in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks).
It is the compilation of the whole process that makes the last method fast. Just making the calculation of the elements fast accounts for about 30% of the speed-up.

cf = Compile[k, k + Sin[k] + Log[k]^3];

Sum[cf[k], {k, 1., 10.^5}] // Timing

(sum = 0.; Do[sum = sum + cf[k], {k, 1., 10.^5}]; sum) // Timing

Doing a compiled evaluation of the whole sum is of course the fastest method.

Compile[{}, Module[{sum = 0.},
                   Do[sum = sum + k + Sin[k] + Log[k]^3, {k, 1, 10.^5}];
                  sum]][] // Timing

Both approaches, forming all cumulative sums and forming the sum at once, have sometimes advantages and disadvantages. Forming all partial sums clearly saves memory. In the last examples, forming the compiled sum cumulative was fastest.
Now, let us consider the case in which the individual summands are symbolic quantities that, after adding up, cancel partially. Here is the definition for the summands.

summand[k_] := Sum[Random[Integer, {-100, 100}] *
                   c[Random[Integer, {1, 10000}]], {j, 200}]

We carry out some timing as a function of the number of summed terms.

doTimes =  Table[{n, Timing[(sum = 0;
                           Do[sum = sum + summand[k], {k, 1, n}];
                           sum)][[1, 1]]}, {n, 1, 51, 5}]

sumTimes = Table[{n, Timing[Sum[summand[k], {k, 1, n}]][[1, 1]]}, 
                 {n, 1, 51, 5}]

applyTimes = Table[{n, Timing[Apply[Plus, 
                               Table[summand[k], {k, 1, n}]]][[1, 1]]}, 
                   {n, 1, 51, 5}]

It is clearly visible that the cumulative sum approach is the slowest and has the worst complexity. We see that Sum and Apply[Plus[Table[…], {1}] are basically identical. Here is a graphical representation of these timings.

Show[Graphics[
{Thickness[0.002], {RGBColor[1, 0, 0], Line[doTimes]},
                   {RGBColor[0, 1, 0], Line[sumTimes]}, 
                   {RGBColor[0, 0, 1], Line[applyTimes]}}],
     PlotRange -> All, Frame -> True]

We see a much more pronounced O((n^2)) contribution in the complexity of the cumulative sum version. The reason for this term is because of the sorting that takes place each time a new sum is formed.

Sum has the attribute HoldAll. As a result of this, the body of Sum is not evaluated until the summation variables are localized. Be aware of this difference to Integrate, which does not have the HoldAll attribute. Here this difference is demonstrated.

Clear[α, k, n]; α = k;
{Sum[α, {k, 1, n}], Sum[Evaluate[α], {k, 1, n}]}

Clear[α, k, n]; α = k;
{Integrate[α, {k, 1, n}], Integrate[Evaluate[α], {k, 1, n}]}

As a slightly larger example for the use of Sum for symbolic summation, let us construct one sheet of the Riemann surface of (((1+z))^(1/2)) by Weierstrass’s method.

Let the analytic function f(z) have the following Taylor expansion around z=(Subscript[z, 0]):

f((Subscript[z, 0])+δ)=(∑_(i=0)^∞)(Subscript[a, n]^((0)))(δ^n).

Now, let us look for the series expansion of f(z) around a (regular) point z=(Subscript[z, 1]) (inside the disk of convergence of the above Taylor expansion). Formally, we can expand f(z) in the same manner around z=(Subscript[z, 1]):

f((Subscript[z, 1])+δ)=(∑_(i=0)^∞)(Subscript[a, n]^((1)))(δ^n).

Using elementary arithmetic, it can be shown [435✶], [747✶], [748✶], [861✶], [104✶], [1456✶], [1496✶], [259✶] that the coefficients (Subscript[a, n]^((1))) can be expressed through the coefficients (Subscript[a, n]^((0))) in the following way:

(Subscript[a, n]^((1)))=(∑_(i=n)^∞)((i/n))(((Subscript[a, i]^((0)))((Subscript[z, 1])-(Subscript[z, 0])))^(i-n)).

We will use this formula repeatedly by encircling the branch point z=-1 of (((1+z))^(1/2)). The nth coefficient of (((1+z))^(1/2)) is given by (((-1))^i)(-3/2+i)!/i!/(-2(π^(1/2))).

Sum[(-1)^i (-3/2 + i)!/i! z^i, {i, 0, Infinity}]

The function analyticContinuation implements the above formula for calculating the new coefficients of the Taylor series from the old ones (this function makes heavy use of the symbolic part of Sum).

analyticContinuitation[startTerm_, expansionPointList_] :=
FoldList[Sum[Binomial[n, i] (#1 /. i -> n) #2^(n - i),
             {n, i, Infinity}]&, startTerm,
         Apply[-Subtract[##]&, Partition[expansionPointList, 2, 1], {1}]]

Here is the procedure of calculating new series terms iterated eight times. We denote the expansion points by eP[i] and display them in the next output as (Subscript[𝓅, i]) for brevity

(seriesTerms = analyticContinuitation[(-1)^i (-3/2 + i)!/i!, 
                                      Table[eP[j], {j, 0, 8}]]) /.
 (* for a more compact display *) {eP[i_] :> Subscript[𝓅, i], Gamma -> Γ}

We can use SymbolicSum to get closed-form expressions for all of the series of interest here.

(summedSeries =  Sum[# z^i, {i, 0, Infinity}]& /@ seriesTerms) // 
                                                          TableForm

The basic structure of all of the elements of the last list is just (Sqrt[1+z]). The large factors are correcting for branch cuts. Using PowerExpand, this becomes visible (the next result is of course no longer mathematically equivalent to the last one).

summedSeries // PowerExpand // Simplify

We see mainly the Sqrt[1 + z] expression, and the prefactors determine the phase. 
We now specialize the expansion points to lie on a circle of radius 1 around the point -1. (By using nine points on this circle, we make sure that the jth expansion point lies inside the disk of convergence of the (j-1)th series expansion.)

eP[i_] = -1 + Exp[i I 2Pi/8];

Let us piecewise define a function sqrt that is represented by the summed forms of the various series.

Do[sqrt[i - 1, z_] = Evaluate[summedSeries[[i]] /.
   {z -> z - eP[i - 1]}], {i, 1, Length[summedSeries]}]

We look at the resulting Riemann surface by showing the values of the various sqrt[i, z] inside their disks of convergence.

Do[points[i] = Table[{Re[#], Im[#], Im[N[sqrt[i, #]]]}&[
                                       N[eP[i] + r Exp[I φ]]],
                     {r, 0, 0.99, 0.99/10}, {φ, 0, N[2Pi], N[2Pi]/16}],
   {i, 0, 8}]

Show[Graphics3D[{
{Thickness[0.002], Table[(* the disks *)
{Hue[i/8 0.76], Line /@ points[i],
                Line /@ Transpose[points[i]]}, {i, 0, 8}]},
{Thickness[0.01], GrayLevel[0.3], Line[{{-1, 0, -5}, {-1, 0, 2}}]},
{Thickness[0.01], (* the continuation path *)
 Line[N[Append[#, First[#]]]& @
 Table[{Re[eP[i]], Im[eP[i]], Im[N[sqrt[i, eP[i]]]]}, {i, 1, 8}]]}}],
     PlotRange -> All, BoxRatios -> {1, 1, 1.5}, 
     ViewPoint -> {-2, -1, 1.1}, Axes -> True, 
     AxesLabel -> (StyleForm[#, TraditionalForm]& /@
                  {"x", "y", "Sqrt[1 + x + I y]"})]

Because of the two-valuedness of (((1+z))^(1/2)), the first function sqrt[0, z] (in red) and the last function sqrt[8, z] (in blue) do not coincide, and the branch cut of Sqrt[1 + z] along the negative real axis is—because of the analytic continuation—missing.

As another application of Sum, let us look at the Hölder summation method [1568✶], [963✶], [183✶], [592✶].

Given a divergent sum (divergent in the limit n->∞) (Subscript[S, 0]^((n)))=(∑_(j=1)^n)(Subscript[a, j]) one recursively forms the (partial) sums (Subscript[S, k]^((n)))=(n^(-1))(∑_(j=1)^n)(Subscript[S, k-1]^((n))) until (Subscript[S, k]^((n))) converges (if this happens).

Let us take an example, the series of -(((x+1))^(-2)) for x=1. The nth term of the series is given by (Subscript[a, j])=(((-1))^j)j(x^(j-1)).

Series[-1/(1 + x)^2, {x, 0, 8}]

The first partial sums are formed.

sum1 = Sum[(-1)^j j x^(j - 1), {j, n}]

The first partial sum does not converge for n->∞.

Table[sum1 /. x -> 1, {n, 12}]

So, let us form the second iteration.

sum2 = Sum[Evaluate[sum1 /. n -> j], {j, n}]/n // Together

This partial sum still does not converge.

Table[sum2 /. x -> 1, {n, 12}]

{sum2 /. x -> 1 /. (-1)^n -> -1, sum2 /. x -> 1 /. (-1)^n -> +1}

So, let us do one more iteration.

sum3 = Sum[Evaluate[sum2 /. n -> j], {j, n}]/n // Together

Now, we finally have a convergent sum.

Table[Expand[sum3 /. x -> 1], {n, 12}] // N

The limit is -1/4, which is exactly what one obtains by substituting x=1 into -(((x+1))^(-2)).

Table[1/4 + sum3 /. x -> 1 /. n -> N[10^k, 22], {k, 20}] // N

The following picture visualizes the big smoothing property of forming recursively partial sums. We start with largely random numbers, and after a very few steps, we have a very smooth sequence.

ListDensityPlot[NestList[MapIndexed[#1/#2[[1]]&, 
 Rest[FoldList[Plus, 0, #]]]&,
      Table[Random[Real, {-i^2, i^2}], {i, 1200}], 10],
     Mesh -> False, ColorFunction -> (Hue[0.78#]&), AspectRatio -> 1/3]

The next inputs use the Cesàro summation method [197✶] to establish the value -1/4.

partialSums = Simplify[#, x > 0]& @ 
                 Sum[(-1)^(j + 1) (j + 1) x^j,  {j, 0, k}]

(* multiply partial sums with a binomial and sum again *)
cesaroSum = 
Sum[Evaluate[partialSums Binomial[n - k + 𝓅 - 1, n - k]], 
    {k, 0, n}]/Binomial[n + 𝓅, n] /. x -> 1 // Simplify

(* limits for different values for the parameter p *)
Table[Limit[FullSimplify[cesaroSum], n -> Infinity], {𝓅, 4}]

The function Integrate gives finite results for (some) divergent integrals when using the option setting GenerateConditions -> False. Sum does not have the option GenerateConditions. But the function SymbolicSum`SymbolicSum does. The next input calculates a finite result for the divergent sum (∑_(k=1)^∞)(((-1))^k) ln(k).

SymbolicSum`SymbolicSum[(-1)^k Log[k], {k, Infinity},
                        GenerateConditions -> False] // Simplify

Taking into account that ∂ (k^ε)/∂ ε=(k^ε)ln(k), the last result can be understood in the following way (zeta regularization).

Normal[Series[D[Sum[(-1)^k k^ε, {k, Infinity}], ε], 
              {ε, 0, 0}]] // Simplify

We end this subsection by remarking that the symbolic analog of the function NProduct, namely the function Product should be mentioned here. Because its syntax and functionality is largely identical to the one of Sum, we just give three simple examples here.

{Product[Sin[z + k Pi/ν], {k, 0, ν - 1}],
 Product[1 - k^-4, {k, 2, Infinity}],
 Product[(1 - Prime[k]^-2)^4, {k, Infinity}]}

We end with an infinite sum over finite products.

Sum[n!/Product[x + k, {k, n}], {n, Infinity}]

1.7 Differential Equations

1.7.0 Remarks

In this section, we discuss another of the very useful Mathematica commands for symbolic computations: DSolve, the function for the symbolic solution of ordinary differential equations (ODEs), systems of ODEs [1495✶] and partial differential equations. The function DSolve is very powerful and will find closed form solutions to many differential equations. Here we present examples for the most popular classes of differential equations. The listing given is far from being exhaustive.

1.7.1 Ordinary Differential Equations

The syntax for solving an ordinary differential equation is straightforward.

We first look at a simple example. The result of a successfully solved differential equation is a list of lists of rules—structurally, like the result of Solve.

y1 = DSolve[y''[x] == x^2, y[x], x]

Here is a more complicated example. Similar to Integrate and Sum, DSolves results often contain special functions, Root-objects, and RootSums.

DSolve[y'[x] == y[x]^2 - x, y[x], x]

The next picture shows a visualization of the last solution curves generated by choosing real values from the interval (-4,4) for the integration constant C[1].

Show[Graphics[{Thickness[0.002],
Table[With[{c = Random[Real, {-3, 3}]},
Line /@ DeleteCases[Partition[Table[{x, 
  -(AiryAiPrime[x] + AiryBiPrime[x] c)/(AiryAi[x] + AiryBi[x] c)},
        {x, -4., 4., 1/50.}], 2, 1],
       (* delete steep vertical parts *) 
        _?(#.#&[Subtract @@ #] > 5&)]], {50}]}], Frame -> True]

The specification of the functions in the second argument of DSolve is analogous to that for NDSolve; that is, if no argument is specified for the function to be found, a pure function is returned. To improve the readability of the solution, Slot[1] is sometimes not used for the solution, but Function[independentVariable, solution] is returned instead. Here this is demonstrated using the simple differential equation y''(x)=-y(x) [1082✶], [1683✶].

y2 = DSolve[{y''[x] == -y[x], y[0] == 0}, y, x]

As with NDSolve, the difference between using func or func(var) (or lists of this form) in the second argument is in the use of the result in later replacements. The form y[x] can only replace y[x] itself. The form with a pure function can contain other arguments, or purely y (e.g., in derivatives). So, in the following the expression, y2 can be used for substituting y into every y[something] or just for y as it appears in constructions such as Derivative[i][y][arg].

{y /. y2, Integrate[(x y[z]) /. y2, z]}

y1 cannot be used in the same fashion.

{y /. y1, Integrate[(x y[z]) /. y1, z]}

Here is the difference for the third derivative.

{y'''[x] /. y1, y'''[x] /. y2}

Because of the pure function form of the solution, arbitrary derivatives can also be immediately replaced.

Here is a very simple differential equation, for which the solution in quadratures is obvious and results in a special function, the function Erfi (which we discuss in Chapter 3).

DSolve[{w'[z] == Exp[(I - 1/15) z^2], w[0] == 0}, w, z]

Often, the built-in DSolve can integrate the ODE, but the internally called Solve cannot solve the resulting equation for the dependent variables and the solution is then given in implicit form, and the output has head Solve (one could have expected a “wrapper” head like ToFunction that would, maybe after parameter specification, convert to a pure function). The differential equation (x^n)y'(x)-((y(x))^2) is an example for this situation.

DSolve[{x^n y'[x] - y[x]^2 + 1 == 0}, y[x], x]

Similar to NDSolve, DSolve also solves some boundary-value problems (but it typically does not find all possible solutions). In the following example, these are (Subscript[y, k])(x)=csin(kx),kϵ"ℤ". The k=1 solution is returned in the following example.

DSolve[{y''[x] == -y[x], y[0] == 0, y[Pi] == 0}, y[x], x]

Also, systems of coupled differential equations can be solved.

DSolve[{y'[x] == z[x] + 2 x, z'[x] == y[x] + 2 z[x]},
       {y[x], z[x]}, x] // Short[#, 6]&

All functions appearing in the second argument of DSolve must occur differentiated in the first argument. So the following does not work. No derivative of 𝔷1 exist in the list of equations.

DSolve[{𝔷2'[𝔵] == 1, 𝔷1[𝔵] == 𝔷0'[𝔵], 𝔷2[𝔵] == 𝔷0'[𝔵]}, 
       {𝔷0[𝔵], 𝔷1[𝔵], 𝔷2[𝔵]}, 𝔵]

The following, mathematically equivalent form works.

DSolve[{𝔷2'[𝔵] == 1, 𝔷1[𝔵] == 𝔷0'[𝔵], 𝔷1'[𝔵] == 𝔷2[𝔵]}, 
       {𝔷0[𝔵], 𝔷1[𝔵], 𝔷2[𝔵]}, 𝔵]

For linear ODEs with constant coefficients, the characteristic equation can, of course, also contain multiple zeros, resulting in the typical structure (x^n)(e^(a x)).

DSolve[{y'''[x] - 3y''[x] + 3y'[x] - y[x] == 0}, y, x]

Here is an example of a linear ODE with symbolic constant coefficients.

DSolve[{y'''[x] - (a + b + c) y''[x] +
        (a b + a c + b c) y'[x] - a b c y[x] == 0,
        y[0] == 1, y'[0] == 0, y''[0] == 0}, y[x], x]

In the case a==b==c, the form of the solution changes from exponential functions to products of exponential functions with powers.

DSolve[{y'''[x] - (a + b + c) y''[x] +
        (a b + a c + b c) y'[x] - a b c y[x] == 0,
        y[0] == 1, y'[0] == 0, y''[0] == 0} //. {a -> c, b -> c}, y[x], x]

This solution can also be calculated using Limit, starting with the nondegenerate case [546✶].

Expand[Limit[Limit[Together[%%[[1, 1, 2]]], a -> c], b -> c]]

Here is a linear system with the same property—the characteristic polynomial has multiple roots. (These are Newton’s equations for a free-falling body, including Coriolis’s force; for a closed-form solution, see [620✶], [923✶], [100✶], [357✶], [1192✶], and [1066✶].)

With[{r = {x[t], y[t], z[t]}, ω = {ωx, ωy, ωz}},
     Thread[D[r, t, t] == -2 Cross[ω, D[r, t]] + {0, 0, -g}]]

dsol = DSolve[%, {x[t], y[t], z[t]}, t];

The solution returned from DSolve is quite large, so we do not display it here.

{ByteCount[dsol], LeafCount[dsol]}

This is an often occurring “problem” when doing symbolic calculations. Functions such as Integrate, DSolve, Sum, … will return an answer, but either a large one or in a form “not wanted”. Functions such as TrigExpand, Simplify, and so on are intentionally not applied inside Integrate, DSolve, Sum, and so on. Their automatic application would slow down these functions unacceptably and unpredictably. But Mathematica provides all tools so the users can “massage” the result in the form they want. Let us do some simplification with the last result. As expected, the absolute value of the angular velocity vector appears frequently in the result.

{Count[dsol, +ωx^2 + ωy^2 + ωz^2, Infinity],
 Count[dsol, -ωx^2 - ωy^2 - ωz^2, Infinity]}

Replacing the absolute value of the angular velocity vector with the symbol ω shrinks the size of the solution dramatically.

ωRules = {+ωx^2 + ωy^2 + ωz^2 -> +ω^2,
          -ωx^2 - ωy^2 - ωz^2 -> -ω^2} 

dsol1 = dsol //. ωRules // PowerExpand;

{ByteCount[dsol1], LeafCount[dsol1]}

Simplifying the result, we get a manageable expression. (For brevity, we display only the x-component of the solution.)

((dsol1[[1, 1]] //. ωRules) // Simplify) //. ωRules

As expected, the result contains six integration constants—the three initial positions and the three initial velocities of the particle. The last example shows one frequently encountered issue in DSolve. Using ExpToTrig //@ % /. _Complex -> 0 we could recast the last result in a purely real form, which is more appropriate for the physical meaning of this example. Doing this results in an expression of reasonable size.

Module[{num, den, im, aux, trigs},
 (* numerator and denominator *)
 {num, den} = {Numerator[#], Denominator[#]}&[
                            Together[ExpToTrig[%[[2]]]]];
 (* delete imaginary part *)                           
 im = Factor[Plus @@ Cases[Expand[num], _Complex _]];
 (* rewrite in minimal set of trigonometric expressions *)
 aux = TrigFactor[Expand[num - (Plus @@ Cases[Expand[num], _Complex _])]];
 (* cancel factors and 
    collect with respect to trigonometric expressions *) 
 trigs = Union[Cases[aux, _Sin | _Cos, Infinity]];
 Collect[Factor[Collect[aux, trigs, Simplify] //. ωRules]/(2 ω^3),
         trigs, Simplify] * (2 ω^3/den) //. ωRules]

Here is an ODE that contains an unspecified function g(x). The solution of the differential equations are all functions f[g(x)](x), such that the pair of functions f(x), g(x) obeys the differentiation rule ((f(x)g(x)))'=f'(x)g'(x) [1070✶].

DSolve[f'[x] g'[x] == D[f[x] g[x], x], f[x], x]

Here are the similar solutions for ((f(x)/g(x)))'=f'(x)/g'(x).

DSolve[f'[x]/g'[x] == D[f[x]/g[x], x], f[x], x]

Before looking at some typical ODEs, we make a remark about the integration constants that usually appear in the integration of differential equations. The notation C[i] used in DSolve can be changed using DSolveConstants.

Options[DSolve]

In the following example, the default C is employed.

DSolve[(x^2 + 1)y''[x] - x y'[x] + y[x] == 0, y[x], x]

Here, we use the modified form of ℭ.

DSolve[y'[x] == y[x] + 1, y[x], x, 
       If[$VersionNumber >= 5, GeneratedParameters,
          DSolveConstants] :> ℭ]

The right-hand side of the DSolveConstants option can also be a pure function. For each integration constant the pure function is called with an increasing integer argument starting from 1.

DSolve[y''''[x] == y[x] + 1, y[x], x, 
       If[$VersionNumber >= 5,
          GeneratedParameters :> (Subscript[𝒸, #]&),
          DSolveConstants :> (Subscript[𝒸, #]&)]]

We now look at a few more or less difficult examples to get an idea of what Mathematica can do. (The examples are assembled randomly from [220✶], [1482✶], [1382✶], [883✶], and [1282✶]. (If Mathematica cannot find the solution to a differential equation, the reader should have a look at these books.) We begin with differential equations of first order. 
◼ Linear Inhomogeneous ODE with Constant Coefficients     ((∑_(k=0)^n)(Subscript[a, k])(y^((k)))(x)=g(x))

Here is a simple example (we have seen this type of equation already above).

DSolve[f'[x] + f[x] == 0, f[x], x]

This slightly more general example has multiple zeros of the characteristic equation and an inhomogeneous term on the right-hand side.

DSolve[y''''[x] - 4y'''[x] + 6y''[x] - 4y'[x] + y[x] == x Sin[x], 
       y[x], x] // Simplify

Because Mathematica does not introduce auxiliary variables and expresses all results explicitly in terms of the input variables, the explicit solution of the characteristic equation can lead to very large expressions (even in the solution of simple linear homogeneous and/or inhomogeneous ODEs with constant coefficients). To avoid this, Mathematica uses Root-objects whenever possible in the solution of such type differential equations.

DSolve[a[4] y''''[x] + a[3] y'''[x] + a[2] y''[x] +
       a[1] y'[x] + a[0] y[x] == x^3, y[x], x]

If we rewrote the Root-objects in radicals, the solution would be much larger.

{ByteCount[%], ByteCount[ToRadicals[%]]}

If Mathematica solves a differential equation except for quadratures, functions not explicitly given can also appear in the given differential equation.

DSolve[f''[x] + f'[x] + f[x] == g[x], f[x], x]

Note the appearance of the context-protected variable DSolve`t as the dummy integration variable. For the following linear inhomogeneous differential equation (with variable coefficients), we obtain nested unevaluated integrals.

DSolve[Log[x] y'[x] + y[x] Cos[x] + Exp[x] == 0, y[x], x]

Many differential equations are converted to the form of an unevaluated integral. In this form, the built-in Integrate cannot integrate the function explicitly. Here is a trivial higher order example of this kind.

DSolve[y''''[x] == unknownFunction[x], y[x], x]

Now let us investigate some classes of first-order of differential equations [972✶] in more detail.

◼ ODE with Separated Variables     (y'(x)=g(x)/f(y(x)))
The following example can be integrated in closed form. (The warning message again comes from Solve in generating the ProductLog function; see Chapter 3.)

DSolve[y'[x] == Exp[x]/Log[y[x]], y[x], x]

◼ Homogeneous ODE     (y'(x)=f(x,y(x)),f(tξ,tψ)=f(ξ,ψ))

Here, Mathematica finds a first integral of this homogeneous ODE. However, because it is a polynomial of fifth degree, we again obtain Root-objects in the solution.

DSolve[y'[x] == (4x + 6y[x])/(6x + 4y[x]), y[x], x]

◼ Exact ODE     (y'(x)=P(x,y(x))/Q(x,y(x))    "with"    ∂P(ξ,ψ)/∂ψ=-∂Q(ξ,ψ)/∂ξ)

The following ODE is also solvable with the DSolve function.

solExactODE = DSolve[y'[x] == (y[x] - x)/(y[x]^-2 - x), y[x], x]

Let us make a short graphical check of the solution by plotting the solution curves together with the vector field generated by the right-hand side of the differential equation.

Needs["Graphics`PlotField`"]

Module[{sols, vectorField, statusPlotplnr, solutionCurves},
(* the solution curves calculated by DSolve *)
sols = Union[Last /@ Flatten[solExactODE]];
(* the vector field, calculated at randomly chosen points *)
vectorField = ListPlotVectorField[
Table[Function[{x, y},
 {{x, y}, 1/10 {Cos[#], Sin[#]}&[ArcTan[(y - x)/(y^-2 - x)]]}
    ][Random[Real, {-2, 2}], Random[Real, {-2, 2}]], {2000}],
    DisplayFunction -> Identity];
(* turn of message of Plot triggered because of nonreal values *)
statusPlotplnr = Plot::plnr; Off[Plot::plnr];
(* solution curves for randomly chosen integration constants *)
solutionCurves = Table[
{Plot[#, {x, -2, -10^-6}, DisplayFunction -> Identity],
 Plot[#, {x, 10^-6, 2},   DisplayFunction -> Identity]}&[
        sols /. {C[1] -> Random[Real, {-12, 12}]}], {100}];
(* restore old status of Plot message *)
If[Head[statusPlotplnr] === String, On[Plot::plnr]];
(* show vector field and solution curves *)
Show[{vectorField, Graphics[{GrayLevel[1/2],
         Cases[solutionCurves, _Line, {0, Infinity}]}]},
 PlotRange -> {{-2, 2}, {-2, 2}}, Axes -> False, Frame -> True,
 DisplayFunction -> $DisplayFunction]]

◼ Bernoulli ODE     (y'(x)=f(x)y(x)+g(x)((y(x))^n))

A nontrivial solution is again found.

DSolve[x^2 (x - 1) y'[x] == y[x]^2 + x(x - 2) y[x], y[x], x]

We insert the (nontrivial) solution into the ODE to check the result.

(x^2 (x - 1) D[#, x] - (#^2 + x(x - 2) #))&[%[[1, 1, 2]]] // Simplify

◼ Jacobi ODE     ((a x + b y(x) + c)+((OverTilde[a]) x + (OverTilde[b]) y(x) + (OverTilde[c]))y'(x)+((OverHat[a]) x + (OverHat[b]) y + (OverHat[c]))(x y'(x)-y(x))=0)

The following reduced example can also be solved, even though it cannot be solved explicitly for y[x].

DSolve[(14x) + (4x + 5y[x])y'[x] + (-4)(x y'[x] - y[x]) == 0, 
       y[x], x]

Here is a quick check of the solution.

Simplify[D[%[[1, 1]], x]]

◼ Special Riccati ODE     (y'(x)+a((y(x))^2)=b(x^α))

This special Riccati ODE is also solved.

DSolve[y'[x] - y[x]^2 == x^ν, y[x], x]

◼ Lagrange ODE     (A y'(x)y(x)+B y'(x) x=C y'(x))

The following Lagrange ODE can be explicitly solved for y(x).

DSolve[y[x] == 2y'[x] x + y'[x]^2, y[x], x]

◼ Clairaut ODE (a Special Case of a Lagrange ODE)     (y(x)=y'(x)x+ψ(y'(x)))

The two solutions produced for the Clairaut ODE are correct in different parts of the complex x-plane.

DSolve[y[x] == y'[x] x + 2 Sqrt[-y'[x]], y, x]

To see that the individual solutions are not correct in the whole complex x-plane, we substitute the solutions in the original differential equation.

(y[x] - (D[y[x], x] x + 2 Sqrt[-D[y[x], x]])) /. % // Simplify

{% /. C[1] -> 2, % /. C[1] -> 2I} // N // Chop

This Clairaut ODE is solved correctly in the whole complex x-plane.

DSolve[y[x] == y'[x] x + 2 (y'[x])^2, y[x], x]

y[x] == y'[x] x + 2 (y'[x])^2 /. 
           y -> Function[x, Evaluate[%[[1, 1, 2]]]] // Simplify

◼ ODE with Shifted Argument     (y'(x)=f(y(x)+a x))

For the following ODE with shifted argument, we get an explicit, although large, result for y(x).

DSolve[y'[x] == Sin[y[x] + 3x], y[x], x] // Simplify

Closed solutions can also be found for the following two special cases of the Riccati ODE with purely symbolic coefficients f[x], g[x], and h[x].

h[x] = -g[x] - f[x];
DSolve[y'[x] == h[x] y[x]^2 + g[x] y[x] + f[x], y[x], x]

(y'[x] == h[x] y[x]^2 + g[x] y[x] + f[x] /.
         y -> Function[x, Evaluate[%[[1, 1, 2]]]]) // Simplify

For the following Riccati ODE, a closed-form solution can also be found.

Clear[h];
f[x] = 1/4 g[x]^2/h[x] - D[g[x]/h[x], x]/2;

DSolve[y'[x] == h[x] y[x]^2 + g[x] y[x] + f[x], y[x], x]

(y'[x] == (h[x] y[x]^2 + g[x] y[x] + f[x]) /.
         y -> Function[x, Evaluate[%[[1, 1, 2]]]]) // Simplify

We end here with giving examples of the classical types of first order ODEs. Mathematica can solve many more types of differential equations. Here is a nonlinear first order ODE attributed to Cayley [283✶]. The result is quite a complicated function that contains Root-objects. To better see the structure of the solution, we abbreviate the roots by 𝓇[counter, degree].

Module[{c = 0},
DSolve[Q[k]^2 - Q[k] (k + 1/k) - 3 == 3(1 - k^2) Q'[k],
       Q, k] /. Root[p_, ___] :> 
      With[{𝒸 = c++, d = Exponent[p[C], C]}, 𝓇[𝒸, d] /; True]]

Similar to integrals and sums, there exist many first (and higher)-order differential equations for which Mathematica is unable to find a solution.

DSolve[y'[x] + y[x]^2 Log[x] == 2, y[x], x]

Differential equations of second order are describing many physical processes [1690✶], but at the same time, they are much more difficult to solve. Only a few types have been given names. Many of the ones that appear more often in practice belong to the Painlevé type [359✶], [361✶], [340✶], [1526✶]: y''(x)=f(x,y(x),y'(x)).

Here, f is a rational function of y(x) and y'(x) with coefficients that are analytic functions of x. Unfortunately, at present, relatively few properties (when compared to the known properties of the named special functions of Chapter 3) of these equations are known, and fast numerical values for all parameters are also not available. For the state-of-the-art, see [700✶], [1032✶], [360✶], and [1573✶]. For some of the modern techniques and algorithms for solving differential equations in general, see [1063✶], [1216✶], [807✶], [808✶], [1486✶], [809✶], and [1733✶]. A very readable introduction can be found in [995✶] and [1433✶]. For some of the original research on this subject, see [1041✶]. Mathematica does not recognize a Painlevé-type differential equation and does not bring any differential equation into a Painlevé normal form.
We now give a few examples of relatively simple differential equations of second order. Here is a homogeneous differential equation that Mathematica solves.

DSolve[x^2 y[x] y''[x] == y[x]^2 - 2 x y[x] y'[x] + x^2 y'[x]^2, y, x]

Here is a check if the solution is correct.

x^2 y[x] y''[x] == y[x]^2 - 2 x y[x] y'[x] + x^2 y'[x]^2 /. 
                                          %[[1]] // Simplify

Here is an equation in which the independent variables do not appear explicitly. It too is solved.

DSolve[y[x] y''[x] - y'[x]^2 == y[x]^2 Log[y[x]], y[x], x]

The solution to the following interesting differential equations contains a singular point. The location of the singular point depends on the integration constants.

DSolve[{y''[x] == y'[x]^2 (2 y[x] - 1)/(y[x]^2 + 1)}, y[x], x]

This is another example for solving a nontrivial ODE of second order.

DSolve[x^5 y''[x] + 2x^4 y'[x] - 1 == 0, y[x], x]

The following two second-order ODEs can also be solved explicitly.

DSolve[y''[x] - y[x]/x^4 == 0, y[x], x]

DSolve[{(x - a)^2 (x - b)^2 y''[x] == c y[x]}, y[x], x] // Simplify

Here is a nonlinear second-order ODE that has a rational solution.

DSolve[y''[x] + 3 y[x] y'[x] + y[x]^3 == 0, y, x]

The next differential equation can be solved in quadratures for a symbolic function f(x).

DSolve[y''[x] == f[x] y'[x], y[x], x]

In addition to implicit solutions of differential equations, the modified DSolve is also able to solve some differential equations whose solutions are special functions. Here are examples whose solutions are confluent hypergeometric, Bessel, and Legendre functions. The latter solution is also expressed in terms of hypergeometric functions.

DSolve[x χ''[x] + χ'[x] + (-x/4 - m^2/(4x)) χ[x] == 0, χ[x], x]

DSolve[x^2 y''[x] + x y'[x] + (x^2 - ν^2) y[x] == 0, y[x], x]

DSolve[y''[x] == x^a y[x], y[x], x]

DSolve[(1 - x^2) y''[x] - 2 x y'[x] + ν (ν + 1) y[x] == 0, y[x], x]

A restricted class of differential equations of higher order and systems of nonlinear differential equations are solved, too. Here are three examples.

DSolve[x y''''[x] + 5y'''[x] == 24, y[x], x]

DSolve[z^8 w''''[z] == 2 w[z], w[z], z]

DSolve[w''[z] + w[z]^3 w'[z] == 
       w[z] w'[z] (w[z]^4 + 4 w'[z])^(1/2), w[z], z]

Here, the last solution is plotted for some random values of the integration constants.

Show[Table[
ParametricPlot[Evaluate[{Re[#], Im[#]}&[%[[1, 1, 2]] /.
  {_C -> Random[Complex, {-1 - I, 1 + I}], z -> r/10 Exp[I φ]}]], 
  {φ, 0, 2Pi}, PlotStyle -> {{Hue[r/20], Thickness[0.002]}}, 
   DisplayFunction -> Identity, PlotPoints -> 60,
   PlotStyle -> {Thickness[0.002]}], {r, 20}], Frame -> True, 
   Axes -> False, DisplayFunction -> $DisplayFunction]

As already demonstrated above in the Coriolis example, Mathematica can also solve systems of differential equations. Here is a more complicated system of three coupled nonlinear differential equations.

DSolve[{x'[t] == y[t]   - z[t], 
        y'[t] == x[t]^2 + y[t],
        z'[t] == x[t]^2 + z[t]}, {x, y, z}, t]

Here is a check that the solution is correct.

({x'[t] == y[t] - z[t], y'[t] == x[t]^2 + y[t], 
  z'[t] == x[t]^2 + z[t]} /. %) // Simplify

We chose random values for the constants C[1], C[2], and C[3] and display the solutions graphically.

Show[Graphics3D[
Table[{Hue[Random[]], Thickness[0.002],
  ParametricPlot3D[Evaluate[Re[{x[t], y[t], z[t]}] /. %%[[1]] /. 
     (* substitute random values for the C[i] *)
 Table[C[j] -> Random[Complex, {-3, 3} (1 + I)], {j, 3}]], {t, -3, 3}, 
     PlotPoints -> 500, DisplayFunction -> Identity][[1]]}, {100}]], 
     PlotRange -> {{-10, 10}, {-20, 20}, {-30, 30}},
     BoxRatios -> {1, 1, 1}]

Mathematica always tries to explicitly solve for y(x). As a result, we sometimes get some Solve::ifun messages from Solve in the following example.

DSolve[y''[t] == Exp[y[t]], y, t]

An implicit solution can be found for the following Abel-type differential equations. [299✶] Again, we get messages from Solve.

DSolve[y'[x] == 1/(g[y[x]] x + f[y[x]]), y[x], x]

Introducing a printing side effect in a user definition of Solve allows us to monitor which (implicit) equations are given to Solve. This is useful, for instance, in cases in which Solve succeeds in solving for y[x], but the result is too “messy” to be useful when compared with the implicit solution.

Unprotect[Solve]; 
Solve[eqs_, vars_] := Null /; 
         (Print["Calling: ", HoldForm[Solve[eqs, vars]]]; False)

The following equation gives an implicit answer. As a side effect, we get the equations given to Solve printed out.

DSolve[{y'[x] == (y[x] - x)/(y[x] + x)}, y[x], x]

The above example y''(t)==(e^(y(t))) results in two carried out Print commands: One from the equation preprocessing step and one from the solution of the implicit equation found by DSolve for y[x].

DSolve[y''[t] == Exp[y[t]], y, t];

We restore the original state of Solve.

Solve[eqs_, vars_] =.
Protect[Solve];

Here is a relatively complicated nonlinear second order differential equation. Again, Mathematica cannot solve for Υ[ξ] explicitly, but it finds an implicit solution.

DSolve[ξ D[ξ Υ'[ξ], ξ] == (ξ Υ'[ξ])^2 + α Exp[Υ[ξ]] + β, Υ[ξ], ξ]

Here is a quick check for the correctness of the two solutions found.

Module[{𝓈 = Subtract @@ First[#], 𝓇1, 𝓇2}, 
       (* express Υ'[ξ] and Υ''[ξ] from the two solutions *)
       𝓇1 = Simplify[Solve[D[𝓈, ξ] == 0, Υ'[ξ]]][[1]];
       𝓇2 = Simplify[Solve[D[𝓈, ξ, ξ] == 0, Υ''[ξ]][[1]] /. 𝓇1];
       Simplify[(* extract ode from last input *)
                DownValues[In][[$Line - 1, 2, 1]] //. 
                                               𝓇1 //. 𝓇2]]& /@ %

Now, let us deal with a slightly more complicated use of DSolve, the δ-expansion.

Many nonlinear problems (equations, differential equations, and so on) cannot be solved in closed form. The idea of the so-called δ-expansion is to parametrize the nonlinearity with a parameter δ and then make a perturbation expansion around such a value (Subscript[δ, 0]) such that the original problem becomes a linear one for δ=(Subscript[δ, 0]). The various orders of perturbation expansion in (((δ-(Subscript[δ, 0])))^n) typically require the solution of only linear problems. (For more details, see [129✶], [1585✶], [943✶], [742✶], [395✶] and references therein.)

Here, we will deal with a very simple case (from [129✶]) of the application of the δ-expansion. The nonlinear differential equation y'(x)=((y(x))^ϵ),y(0)=1 can be solved in closed form.

DSolve[{y'[x] == y[x]^ϵ, y[0] == 1}, y[x], x] // Simplify

For the parametrization y'(x)=((y(x))^(1+δ)), we get for δ=0 a linear problem. Making the ansatz y(x)=(∑_(k=0)^∞)(Subscript[y, k])(x)(δ^k) and carrying out a series expansion of y'(x)-((y(x))^(1+δ)) around δ=0 yields a system of coupled equations for the (Subscript[y, k])(x).

ord = 12;
eqs = CoefficientList[Normal[
Series[y'[x] - y[x]^(1 + δ) /. y -> Function[x, 
        Evaluate[Sum[y[i][x] δ^i, {i, 0, ord}]]], {δ, 0, ord}]], δ];

Here are the first three equations for the (Subscript[y, k])(x). Although nonlinear by itself, the kth equation is a linear differential equation in (Subscript[y, k-1])(x).

Take[eqs, 3]

It is now straightforward to implement the recursive solution of the (Subscript[y, k])(x). We take the nonhomogeneous boundary condition y(0)=1 into account for (Subscript[y, 0])(x) and then use homogeneous boundary conditions for the (Subscript[y, k])(x), k≥1. Here, we calculate the first 12 orders using DSolve.

yiList = {};
Do[AppendTo[yiList, MapAt[Factor, 
       DSolve[{(eqs[[k + 1]] /. yiList /. Log[Exp[x]] -> x) == 0, 
               y[k][0] == If[k == 0, 1, 0]}, 
               y[k][x], x][[1, 1]], 2]], {k, 0, 11}]

Here is the resulting expansion.

Sum[y[i][x] δ^i, {i, 0, 10}] /. yiList // Factor

To get an idea about the quality of the solution, we compare the various orders of the perturbation expansion with the exact result for x=1/7 and 1/5≤δ≤6. We display the logarithm of the absolute value of the difference between the exact and the series solution.

diffList[δ_, x_] = Rest[FoldList[Plus, 0, (* all orders *)
                     Table[y[i][x] δ^i, {i, 0, 10}] /. yiList]] -
                     (1 + x - (1 + δ) x)^(1/(1 - (1 + δ)));

ListPlot3D[Table[(* logarithm of the difference *)
                 N[Log[10, Abs[diffList[δ, 1/7]]], 22],
	             {δ, 1/5, 6, 1/5}], 
	       PlotRange -> All, MeshRange -> {{0, 10}, {1/5, 6}}]

1.7.2 Partial Differential Equations

Partial differential equations of first order arise, for example, in the solution of the Hamilton-Jacobi differential equations of classical theoretical mechanics. (See, for example, [666✶], [239✶], [1013✶], [730✶], [1657✶], [427✶], [1379✶], and [1241✶].) The reduced Hamilton-Jacobi differential equation for a slanted trajectory has the following form:

(1/(2m))((((((∂S(x,y))/(∂x))))^2)+(((((∂S(x,y))/(∂y))))^2))+m g y=ε

(ε is the total energy, g the gravitational acceleration).
We do not need the most general solution of this differential equation, but only a so-called complete integral (see [884✶] and [1482✶]). This can be found using Mathematica. Let us just try it.

DSolve[1/2m (D[S[x, y], x]^2 + D[S[x, y], y]^2) + m g y == ε, 
       S[x, y], {x, y}]

The message recommends loading the package Calculus`DSolveIntegrals`.

Needs["Calculus`DSolveIntegrals`"]

Now, we get a solution.

DSolve[1/2m (D[S[x, y], x]^2 + D[S[x, y], y]^2) + m g y == ε,
       S[x, y], {x, y}]

A parametric formula for the path of a point mass can be obtained as follows (we look only at the y-component).

Solve[D[%[[2, 1, 2]], ε] == t - A[2], y]

We can clearly see the expected quadratic dependence on the time t. The two constants A[2] and B[1] can be adjusted to make the solution satisfy given initial conditions. For details of this approach, see the references cited above.

And, similar to the case for ordinary differential equations, some solutions are not found at all. The Hamilton–Jacobi differential equation [255✶] for the Kepler (Coulomb) problem in spherical coordinates remains unsolved in Mathematica Version 4.

DSolve[1/(2m) (D[S[r, ϑ, φ], r]^2 + α/r 1/r^2 D[S[r, ϑ, φ], ϑ]^2 +
               1/r^2/Sin[ϑ]^2 D[S[r, ϑ, φ], φ]^2) == ε,
       S[r, ϑ, φ], {r, ϑ, φ}]

Here is another example of a partial differential equation that has a nice solution that is not found [430✶].

pde[Φ_, {α_, β_}, {x_, t_}] := 
    D[-Φ, t, t] + D[Φ, x, x] == α Exp[β Φ]

DSolve[pde[Φ[x, t], {α, β}, {x, t}], Φ[x, t], {x, t}]

(* the solution *)
Φ = 1/β Log[C[1]'[t + x] C[2]'[t - x]/
            (1 + α β/8 C[1][t + x] C[2][t - x])^2];
            
(* check solution *) pde[Φ, {α, β}, {x, t}] // Simplify

The solution of a partial differential equation often depends not only on arbitrary constants, but also on arbitrary functions. These arise in the solution as follows.

DSolve[D[u[x, y], x] == D[u[x, y], y], u[x, y], {x, y}]

As the next example, we look at the computation of first integrals of systems of nonlinear differential equations of first order. Some solutions are found explicitly, and some are returned in implicit form, wrapped in Solve or in unresolved InverseFunction.

DSolve[{u'[x] == u[x] v[x], v'[x] == u[x]/v[x]}, {u, v}, x]

Let us consider another, less-known example of a partial differential equation from classical mechanics. Given a family of orbits in 2D in the form f(x,y)=parameter and a relation between the total energy ε and parameter in the form ε=ε(parameter), the Szebehely equation is a first-order linear partial differential equation for the (unknown) potential V(x,y), giving rise to the orbits f(x,y)=parameter [223✶], [698✶], [210✶], [209✶], [364✶], [673✶], [57✶], [1217✶], [188✶]. This is the Szebehely equation:

(Subscript[f, x])(Subscript[V, x])+(Subscript[f, y])(Subscript[V, y])=2W(ε-V)
W=(((Subscript[f, x x])(Subscript[f, y]^2)-2(Subscript[f, x y])(Subscript[f, x])(Subscript[f, y])+(Subscript[f, y y])(Subscript[f, x]^2))/((Subscript[f, x]^2)+(Subscript[f, y]^2))).

Given f(x,y) and ε=ε(parameter), makeSzebehelyPDE generates the Szebehely equation.

makeSzebehelyPDE[f_, ε_, parameter_, {x_, y_}, V_] := 
Module[{sol = Solve[f == 0, parameter], e, W},
 (* express ε in x and y *)
 e = ε /. sol[[1]];
 W = (D[f, x, x] D[f, y]^2 - 2 D[f, x, y] D[f, x] D[f, y] +
      D[f, y, y] D[f, x]^2)/(D[f, x]^2  + D[f, y]^2);
(* the Szebehely pde *)      
D[V[x, y], x] D[f, x] + D[V[x, y], y] D[f, y] - 2 (e - V[x, y]) W]

Here, we solve the Szebehely equation for circular orbits and (x^2)+(y^2)=(R^2) and ε=(R^2).

makeSzebehelyPDE[x^2 + y^2 - R2, R2, R2, {x, y}, V]

Setting the arbitrary function C[1][y/x] in the solution to 0 results in the potential of a 2D harmonic oscillator.

DSolve[% == 0, V[x, y], {x, y}]

Here is a quick check for the correctness of the solution.

Simplify[%% /. V -> Function[{x, y}, Evaluate[%[[1, 1, 2]]]]]

1.8 Integral Transforms and Generalized Functions

Until now, in all sections of this chapter, we dealt with polynomials (where basically every possible operation can be done on algorithmically safe ground), rational functions, or at least analytic functions (like all of the elementary functions, all special functions of mathematical physics.) In many instances, when describing idealized situations, this set of smooth functions is not enough and a natural generalization is to deal with certain limits of such functions, or what is technically more suited, with linear, continuous functionals of (a subclass of) such functions. This leads to the world of generalized functions, also called distributions (and ultradistributions). Obviously, there are many such functionals; distributions of finite order can be represented as integrals over smooth functions. For the most common-named distributions, one typically chooses as the space of test functions the space of all functions with continuous nth derivative and compact support (such functions exists) or the space of all functions with continuous  nth derivative that vanish faster than any power at ±∞—which generates the tempered distributions. Let Ξ be such a linear functional. One typically writes the functional as ⟨Ξ,φ⟩=Ξ[φ], where φ is the test function and the scalar product notation reminds us of the Riesz–Fischer-theorem based (Subscript[L, 2])-case. In a slight abuse of notation, one often just refers then to the generalized function Ξ, but its sole existence is only inside ⟨Ξ, φ⟩ and must always be kept in mind. We remark that some, but not all, “ordinary” functions are distributions [540✶] and that at the same time some, but not all, distributions are “ordinary” functions (for a representation of all Schwartz distributions as smooth nonstandard functions, see [1229✶], [759✶]). For the many interesting mathematical properties of distributions, see, for example, [636✶], [1551✶], [1613✶], [794✶], [1612✶], [887✶], [1059✶], [155✶], [59✶], [352✶], [549✶], [600✶], [353✶], [1005✶], [1333✶], [810✶], [416✶], and [162✶]. Beyond being a convenient mathematical idealization, distributions such as the Dirac delta functions are unavoidable ingredients for a proper mathematical formulation of the solutions of partial differential equations [1317✶] and of many physical theories, such as quantum mechanics [178✶], [652✶], [177✶], [1595✶], [179✶], [417✶], [1171✶], [480✶] and engineering applications, such as the calculation of propeller noise in areoacoustics [544✶], [545✶], [547✶].

Currently, there are two distributions built-into Mathematica: DiracDelta and UnitStep.

The Heaviside distribution θ(x) is, like all generalized functions, defined for real x only (no nontrivial, nonproduct-like extensions into the complex plane are possible). It is 1 for positive x and 0 for negative x (in the world of distributions, it does not matter which finite value one chooses for x=0).

Plot[UnitStep[x], {x, -2, 2}, Frame -> True, Axes -> False,
     PlotStyle -> {Hue[0], Thickness[0.01]}]

The picture clearly shows a step of unit size and justifies the Mathematica naming of the Heaviside distribution. In Subsection 1.6.2, we did not recommend using If for piecewise-defined functions. We highly recommend using UnitStep for such functions. Here is an example.

manyPeriodFunction[x_] = 
With[{θ = UnitStep},
(* left and right tails *) θ[-x] + θ[x - 10 Pi] +
(* the middle oscillations *)
Sum[θ[x - 2 k Pi] θ[2 (k + 1) Pi - x] Cos[(k + 1) x], {k, 0, 4}]];

This function can be plotted.

Plot[Evaluate[manyPeriodFunction[x]], {x, -2 Pi, 12 Pi},
     Frame -> True, Axes -> False]

This function can be used inside Integrate.

Integrate[manyPeriodFunction[x], {x, 0, 10 Pi}]

According to the definition of θ(x), we have the identity θ(x)=((θ(x))^2). This definition is not used automatically. To get it into effect, one has to use the function FunctionExpand (to be discussed in Chapter 3).

UnitStep[x]^2

FunctionExpand[%]

In addition to rewriting expressions in “simpler” functions, the function FunctionExpand will carry out a second class of transformations on the UnitStep function; it will rewrite θ(f(x)) in the form (∑_k)(Subscript[c, k])θ(x-(Subscript[x, k])), (Subscript[c, k])=±1. Here is an example.

FunctionExpand[UnitStep[(x - 1) (x - 3) (x - 5)]]

In the next example, there is no real x such that -(x^4)-1 becomes positive. Contrary to Mathematica’s default assumption that every variable represents a generic complex value, inside distributions inside FunctionExpand variables (as long as they can be uniquely found) are considered to be real, because, as stated, no distributions with complex arguments exist.

FunctionExpand[UnitStep[-x^4 - 1]]

UnitStep has an obvious generalization to more than one variable.

The definition for θ((Subscript[x, 1]),…,(Subscript[x, n])) is simply θ((Subscript[x, 1]),…,(Subscript[x, n]))=θ((Subscript[x, 1]))⋯ θ((Subscript[x, n])). Here is a visualization of θ((Subscript[x, 1]),(Subscript[x, 2])).

Plot3D[UnitStep[x, y], {x, -2, 2}, {y, -2, 2},
       PlotPoints -> 80, Mesh -> False]

One of the big advantages of distributions is that they posses derivatives of any order. Given the linear functional ⟨Ξ, φ⟩=(∫_(-∞)^∞)φ(t)Ξ(t)dt with the test function φ(t) and the distribution Ξ(t), one just defines the derivative Ξ'(t) by ⟨Ξ', φ⟩=-⟨Ξ, φ'⟩, this means by “partial integration (∫_(-∞)^∞)φ(t)Ξ'(t)dt=-(∫_(-∞)^∞)φ'(t)Ξ(t)dt”. This definition takes into account that the test function φ(t) is arbitrarily smooth and vanishes at infinity. We can define the derivative of any order for Ξ(t) by using this procedure recursively. The fact that distributions can be differentiated arbitrary often allows to expand any distribution Ξ(x) in derivatives of the Dirac delta function in the form Ξ(x)=(∑_(k=0)^∞)(Subscript[μ, k])[Ξ](((-1))^k)/k!(δ^((k)))(x) where the (x-independent) moments are (Subscript[μ, k])[Ξ]=(∫_(-∞)^∞)(ξ^k)Ξ(ξ)dξ. (This is the so called dual Taylor expansion) [890✶], [393✶], [539✶], [329✶], [330✶]; for some of its applications, see [471✶], [329✶], [18✶], [657✶], [58✶].)

The differentiation of the distribution θ yields the Dirac δ function. It is often used as an idealization of a point-like object with a finite characteristic and is a computable function [1634✶].

UnitStep'[x]

Similar to UnitStep, multidimensional versions of the Dirac δ distribution exist.

Because for all positive and negative x the distribution θ(x) is constant, a picture of δ(x) will just show a straight line.

Plot[DiracDelta[x], {x, -2, 2}, Frame -> True, Axes -> False,
     PlotStyle -> {Hue[0], Thickness[0.01]}]

(For convenience and following common practice, for arguments that are not in the support of a generalized function Mathematica will numerically evaluate this functions. By doing evaluations like θ(2)or δ(2) one must always keep in mind that generalized functions are not functions, but rather equivalence classes of functions defined through integrals with smooth test functions. This means that adding pointwise finite values to distributions does not change them.)

Because Plot uses not exactly regularly spaced points the nonnumerical value at x=0 was not even detected.

%[[1, 3, 1]] /. Line[{___, a:{_?Negative, _}, b:{_?NonNegative, _}, ___}] :>
                Line[{…, a, b, …}]

The Dirac δ distribution δ(x) is a so-called singular distribution. All of its support is concentrated at x=0 (a set of Lebesgue measure zero). Loosely speaking, it has the “value” infinity there. And the “size of the infinity” is such that (∫_(-∞)^∞)δ(x)dx=1. At x=0, DiracDelta does not return Infinity, but stays unevaluated.

DiracDelta[0]

Be aware that the distribution UnitStep is not just “a function that is zero for x<0 and 1 for x>0” [308✶]. Many such functions exist, but their derivative is just 0, not a Dirac δ function. Here are two examples of such functions (they are discontinuous functions, but not generalized functions inside Mathematica).

myUnitStepFunction[1][x_] := (1 + Sqrt[x^2]/x)/2
myUnitStepFunction[2][x_] := 1 - (Log[x] + Log[1/x])/(2 I Pi)

Show[GraphicsArray[
     Plot[Chop[myUnitStepFunction[#][x]], {x, -2, 2}, Frame -> True, 
          DisplayFunction -> Identity, Axes -> False, PlotRange -> All,
          PlotStyle -> {Hue[0], Thickness[0.01]}]& /@ {1, 2}]]

Table[D[myUnitStepFunction[k][x], x] // Simplify, {k, 2}]

As mentioned, for complex arguments, distributions are undefined [62✶].

{UnitStep[I], DiracDelta[1 + I]}

Because distributions are linear functionals, their natural life space is under an integral. (Writing θ(x) and δ(x) is already kind of an abuse of proper notation.) So it comes as no surprise that currently the function Integrate (and some integral transforms—see below) knows best how to deal with the functions UnitStep and DiracDelta. Let us look at some examples. The integral (∫_0^∞)log(x) ((((x^3)-1))^(-1))dx can be written as an integral over the domain {-∞,∞} as (∫_(-∞)^∞)θ(x)log(x) ((((x^3)-1))^(-1))dx. Integrate knows how to deal with this form.

Integrate[Log[x]/(x^3 + 1), {x, 0, Infinity}]

Integrate[Log[x]/(x^3 + 1) UnitStep[x], {x, -Infinity, Infinity}]

Here is an integral containing the parameter a. Inside distributions, variables are considered to be real, so we do not need Assumptions -> Im[a] == 0.

Integrate[UnitStep[x - a], {x, 0, 1}]

Plot[%, {a, -2, 2}, PlotRange -> All, Frame -> True, Axes -> False]

Here, the function inside the UnitStep is more complicated.

Integrate[UnitStep[Exp[x] - 2], {x, 0, Pi}]

This result agrees with the corresponding numerical integration.

{N[%], NIntegrate[UnitStep[Exp[x] - 2], {x, 0, Log[2], Pi}]}

Here is an integral containing the symbolic function f. The result basically says that the value of the integral is just f[c] when -a<c<a.

Integrate[DiracDelta[x - c] f[x], {x, -a, a}]

Integrals of the form (∫_(-∞)^∞)δ(f(x))g(x)dx can be transformed to the form (∑_k)(∫_(-∞)^∞)δ(x-(Subscript[x, k]))/|f'((Subscript[x, k]))|g(x)dx, where the (Subscript[x, k]) are the simple zeros of f(x) [386✶].

Integrate[DiracDelta[x^4 - 2] Sin[x], {x, -Infinity, Infinity}]

The Dirac δ distribution can be differentiated an arbitrary number of times. The distributions arising from differentiating δ(x) do not have special names. Here are the first five derivatives of the Dirac δ distribution.

Table[D[DiracDelta[x], {x, k}], {k, 3}]

The first derivative of the Dirac δ functions is often used as an ideal dipole [1179✶]. According to the definition of derivatives of distributions from above, we have the identity

(∫_(-∞)^∞)(δ^((n)))(x) f(x) dx=(((-1))^n)(∫_(-∞)^∞)δ(x) (f^((n)))(x) dx.

Here, we calculate the definite integral (∫_(-1)^ξ)(δ^((n)))(x) f(x) dx.

Integrate[# f[x], {x, -1, ξ}]& /@ %

If one views the property θ'(x)=δ(x) as an algebraic property, it makes sense to also allow the opposite transformation, meaning (∫^x)δ(ξ)dξ=θ(x) (be aware that this indefinite integral has nothing to do with the integral forming the defining linear functional). Mathematica allows for generalized functions in indefinite integrals. Here are some examples of such integrals.

Integrate[DiracDelta[x], x]

NestList[Integrate[#, x]&, %, 3]

By partial integration of (∫_(-∞)^∞)(δ^((n)))(x) (x^m) dx, it follows that (δ^((n)))(x) (x^m)=0 in the case of m≥n. Similar to the transformation of expressions containing the UnitStep functions, such transformations do not happen automatically, but they can be done using FunctionExpand.

x^2 DiracDelta[x]

FunctionExpand[%]

Here is a more complicated integral involving a fourth derivative of a Dirac delta function with a nonlinear argument.

Integrate[DiracDelta''''[x^11 - 1], {x, -2, 2}]

Mathematica can manipulate derivatives of the Dirac delta functions with arguments that have numeric roots in a variety of ways. Here is an expression containing the zeroth to fourth derivative of the Dirac delta function.

δDeriv4 = D[UnitStep[x^11 - 1], {x, 5}]

Applying the specialized simplifier Simplify`SimplifyPseudoFunctions (be aware that this special simplifier lives in the context Simplify`—together with other specialized simplifiers) yields an expression that contains only Dirac delta functions with linear arguments. Because the only real root of (x^11)-1=0 is x=1, all Dirac delta functions have now the argument x-1.

δDeriv4 = Expand[δDeriv4];

Simplify`SimplifyPseudoFunctions[δDeriv4]

The last result becomes obvious after applying Simplify`SimplifyPseudoFunctions to the original function θ((x^11)-1).

Simplify`SimplifyPseudoFunctions[UnitStep[x^11 - 1]]

Here is an integral that does not evaluate. Because the theory of distributions is based on linear functionals, squares are not allowed in this game [506✶] (within a neutrix approach products, powers, and compositions of distributions with singular support can be defined [1590✶], [958✶], [959✶], [959✶], [1224✶], [799✶], [1308✶]).

Integrate[DiracDelta[x]^2, {x, -Infinity, Infinity}]

Many other integrals are not defined for distributions. When the integrand contains distributions with singular support (such as the Heaviside θ(x) distribution or the Dirac δ  distribution), products of distributions with the same singular support are typically not unique [358✶], [1263✶] (for unique products, see [388✶]). So the following integrals stay unevaluated.

Integrate[DiracDelta''[x] Sqrt[DiracDelta[x]^2], {x, -1, 1}]

A UnitStep distribution can also appear in a numerical integration.

NIntegrate[UnitStep[Tan[x]], {x, -2, -Pi/2, Pi/2, 2}]

As already used above, a DiracDelta distribution will typically go undetected in a numerical integration. NIntegrate is a purely numerical routine that samples its first argument like a black box and does not symbolically analyze the content of the first argument. The chances to hit the x, such that sin(x-1/2) vanishes, are virtually zero.

NIntegrate[1 + DiracDelta[Sin[x] - 1/2], {x, -1,  1}]

Integrate[1 + DiracDelta[Sin[x] - 1/2], {x, -1,  1}]

Distributions like the Dirac δ distribution or the Heaviside θ distribution are often viewed as limits from continuous functions. Limits typically encountered in textbooks are [1647✶], [22✶], [591✶] (for statistics applications of such sequences, see [1626✶]; for applications to matrix arguments, see [1237✶]):

θ(x)=(1/2)((lim_(ε->0))(2/(π ))arctan((x/ε))+1)=(1/2)((lim_(ε->0))erf((x/ε))+1)

δ(x)=(1/π)(lim_(ε->0))(ε/((x^2)+(ε^2)))=(lim_(ε->0))(1/(Sqrt[π ε]))(e^(-((x^2)/ε)))=(lim_(ε->0))(1/(π x))sin((x/ε))

Be aware that Mathematica 4 will not recognize such limits.

Limit[ε/(x^2 + ε^2), ε -> 0]

Here is a similar limit [589✶], [540✶].

δ(x)=(lim_(ε->0))(1/2)(coth'(x+i ε)-coth'(x)).

Limit[D[ComplexExpand[Re[Coth[x + I ε]]], x] - D[Coth[x], x], ε -> 0]

Limit will search for a limit inside the space of continuous functions, and according to the Mathematica philosophy, lower-dimensional exceptional values (here, just the one point x=0) will be ignored.

In a similar way, the following sum evaluates to 0. Obviously, for x=0, this is not the case (in a distributional sense we get 2π δ(x)).

Sum[Exp[I k x], {k, -Infinity, Infinity}]

Let us come back to the evaluation of (∫_(-∞)^∞)Derivative[4][δ]((x^11)-1)dx from above. Instead of δ(x) we will use the sequence (Subscript[δ, ε])(x)=(((π ε))^(-1/2))exp(-(x^2)/ε) with ε->0.

δ[ε_][x_] := 1/Sqrt[Pi ε]Exp[-x^2/ε]

Evaluating the integral (∫_(-∞)^∞)(Subscript[δ, ε]^((4)))((x^11)-1)dx yields a closed form result in hypergeometric functions.

(int[ε_] = Integrate[δ[ε]''''[x^11 - 1], {x, -Infinity, Infinity}, 
                     Assumptions -> ε > 0]) // TraditionalForm

Using the asymptotic expansion of the function (Subscript[, 1])(Subscript[F, 1])(a;b;z) yields the result from above, namely 288960/161051.

hypRule = Hypergeometric1F1[a_, b_, z_] ->
    Normal[Series[Hypergeometric1F1[α, β, ζ], {ζ, Infinity, 5}]] /.
                                                {α -> a, β -> b, ζ -> z};

Limit[(* use 1F1 asymptotics and simplify integral *)
      (int[ε] /. hypRule // Together // ExpandAll // PowerExpand) /. 
                          Exp[-1/ε] -> 0, ε -> 0] // FullSimplify

Let us now use the representation (Subscript[δ, ε])(x)=1/(2 ε)(θ(ε+x)θ(ε-x)). As ε->0, we have (lim_(ε->0))(Subscript[δ, ε])(x)=δ(x). A symmetric approximation of the nth derivative of a function f(x) is

(f^((n)))(x)=(lim_(ϵ->0))(ϵ^(-n))(∑_(k=0)^n)(((-1))^(n-k)) (({{n}, {k}})) f(k ϵ+(x-n ϵ/2)).

δ1[ε_][x_] := 1/ε/2 UnitStep[ε + x] UnitStep[ε - x]
δApproxDeriv[n_, x_, ε_, ϵ_] := 
       Sum[(-1)^(n - k) Binomial[n, k] δ1[ε][(x -  n/2 ϵ) + k ϵ], {k, 0, n}]/ϵ^n

Here are the piecewise constant approximations of (Subscript[δ, ε]^((n)))(x) visualized.

With[{nMax = 60},
Show[Graphics3D[{Thickness[0.002],
       Table[{Hue[0.8 n/nMax],
       Line[Table[{x, δApproxDeriv[n, x, 1/8, 1/12]}, 
                  {x, -3/2, 3/2, 1/100}]] /.
                  (* scale maximum to 1 *)
             Line[l_] :> With[{m = Max[l]}, Line[{#1, n, #2/m}& @@@ l]]}, 
            {n, 0, nMax}]}], 
      Axes -> {True, True, False}, PlotRange -> All, 
      BoxRatios -> {2, 1, 1}, ViewPoint -> {0, -3, 2}]]

Using the Taylor expansion of a testfunction f(x), we have (∫_(-∞)^∞)(Subscript[δ, ε]^((n)))f(x)dx=(∑_(k=0)^∞)((f^((k)))(0)(∫_(-∞)^∞)(Subscript[δ, ε]^((n)))(x^k)dx). The next inputs calculate (∫_(-∞)^∞)(Subscript[δ, ε]^((4)))(x^k)dx for 0≤n≤8.

δ1Deriv4 = δApproxDeriv[4, x, ε, ϵ]

Table[{k, Integrate[1/k! x^k δ1Deriv4, {x, -Infinity, Infinity},
                    GenerateConditions -> False]}, {k, 0, 8}]

In the limit all terms with k≠n vanish [208✶].

Limit[Limit[%, ε -> 0], ϵ -> 0]

In the general case we find  (lim_(ε->0))(∫_(-∞)^∞)(Subscript[δ, ε]^((k)))(x^k)dx =k!(((-1))^k).

Limit[Limit[
Table[{k, Integrate[1/k! x^k δApproxDeriv[k, x, ε, ϵ], {x, -Infinity, Infinity},
                    GenerateConditions -> False]}, {k, 0, 8}], ε -> 0], ϵ -> 0]

Be also aware that currently only the integral transforms will return distributions in their output for inputs that do not contain distributions. Functions like D and Derivative know how to deal with certain distributions, but their output will only contain them when their input does. So in the following example (Green’s function of the Laplace operator in 3D), we just get 0 and not -4π δ(x,y,z). (In such cases one should use the proper pseudofunction θ(r)/r [536✶], [163✶], [595✶], [1532✶], [22✶], [1633✶], [980✶], [1653✶], [161✶], [776✶].)

r = Sqrt[x^2 + y^2 + z^2]; 

Together[D[1/r, x, x] + D[1/r, y, y] + D[1/r, z, z]]

In a similar sense one cannot conclude from the following input that the function (Subscript[K, 0])(((((x^2)+(y^2)))^(1/2))) fulfills the 2D Helmholtz equation everywhere. At the origin we have again a term containing δ(x,y) [265✶], [339✶], [1004✶], [70✶], [108✶], [1694✶], [366✶], [535✶], [266✶]. (We discuss the Bessel function (Subscript[K, v])(z) and the function FullSimplify in Chapter 3.)

Function[ψ, D[ψ, x, x] + D[ψ, y, y] - k^2 ψ][
         BesselK[0, k Sqrt[x^2 + y^2]]] // FullSimplify

The Dirac δ distribution plays an important role for the solution of a differential equation. Given the linear differential operator (Subscript[(OverHat[L]), x]) (acting on the variable x), the solution y(x) of the differential equation (Subscript[(OverHat[L]), x])y(x)=f(x) can be obtained easily from the fundamental solution (or Green’s function) G(x,y) by y(x)=(∫_(-∞)^∞)G(x, y)f(y)dy. The fundamental solution obeys the differential equation (Subscript[(OverHat[L]), x])G(x,y)=δ(x-y). (The fundamental solution obeys the same boundary condition as the solution y(x).) Here, we calculate the fundamental solution of the differential operator (Subscript[(OverHat[L]), x])=(∂_(x x))+1.

DSolve[{y''[x] + y[x] == DiracDelta[x]}, y[x], x]

A direct substitution of the last result in the differential equation will not immediately confirm the result.

y''[x] + y[x] /. y -> Function[x, Evaluate[%[[1, 1, 2]]]]

We have to use the properties δ'(x)f(x)=-δ(x)f'(x) and f(x)δ(x)=f(0)δ(x) by hand.

% /. DiracDelta'[x] f_[x] :> -f'[x] DiracDelta[x] /.
     DiracDelta[x] f_[x] :> f[0] DiracDelta[x]

The solution of the initial value problem is obtained using the fundamental solution G(x) (Green’s function) [1530✶] for arbitrary initial values and adding the initial conditions (y^((n)))(0) in the form (∑_(k=1)^n)(((∂^(k-1))G(x))/(∂(x^n)))(y^((n-k)))(0) to the right-hand side as an inhomogeneous term. Here is a simple example—the differential equation y''(x)+y(x)=(e^(-x)) with initial conditions y(0)=(Subscript[y, 0]) and y'(0)=(Subscript[y, p]). We use DSolve to solve the initial value problem.

sol = DSolve[{y''[x] + y[x] == Exp[-x],
             y[0] == y0, y'[0] == yp}, y[x], x][[1, 1, 2]] // Expand

This is a fundamental solution for this problem.

gf[x_] = Limit[DSolve[{y''[x] + y[x] == DiracDelta[x],
               (* right sided initial conditions; after δ kicked *)
               y[ε] == 0, y'[ε] == 1}, y[x], x][[1, 1, 2]] /.
               DiracDelta[c_] Sin[c_] :> 0 // Simplify, 
               ε -> 0, Direction -> -1]

Now, we use the fundamental solution to build the solution of the inhomogeneous equation and to fulfill the initial conditions.

sol1 = Integrate[Expand[gf[x - ξ] Exp[-ξ]], {ξ, 0, Infinity},
                 GenerateConditions -> False] +
(* the initial conditions as part of the inhomogeneous part *)
(gf[x - ξ] ys /. ξ -> 0) + (D[gf[x - ξ], x] y0 /. ξ -> 0) /.  
                                  DiracDelta[c_] Sin[c_] :> 0

For x>0 (the region under consideration), the so-obtained solution agrees with the one from DSolve.

Expand[sol - % /. _UnitStep -> 1]

Within the realm of distributions, differential equations get more solutions than just the classical ones. Let us look at the first-order differential equation (ξ^2)u'(ξ)=1.

ode = ξ^2 u'[ξ] - 1;

In the space of ordinary functions, we have the solution u(ξ)=(Subscript[c, 1])-1/ξ.

DSolve[ode == 0, u[ξ], ξ]

In the space of generalized functions we have the solution (Subscript[u, GF])(ξ)=(Subscript[c, 1])+(Subscript[c, 2])θ(ξ)+(Subscript[c, 3])δ(ξ)-1/ξ. Let us check this.

uGF[ξ_] = c[1] + c[2] UnitStep[ξ] + c[3] DiracDelta[ξ] - 1/ξ

Directly substituting the solution into Mathematica does not give zero.

ξ^2 uGF'[ξ] - 1 // Expand

Using Simplify, we can get zero.

Simplify[%]

To get the last zero, we have to add the two rules (x^n)δ(x)=0 and (x^n)(δ^((ν)))(x)=(((-1))^n) ν! /(ν-n)! Derivative[ν-n][δ](x).

δSimplify[expr_, x_] := 
With[{rules = {x^n_. Derivative[ν_][DiracDelta][x] :>
               (-1)^n ν!/(ν - n)! Derivative[ν - n][DiracDelta][x],
               x^n_. DiracDelta[x] :> 0}},
     FixedPoint[Expand[#] //. rules&, expr]]

Now it is straightforward to see that (Subscript[u, GF])(ξ) is indeed a solution of the differential equation (ξ^2)u(ξ)=1.

δSimplify[%%, ξ]

Let us deal with a slightly more complicated example, the hypergeometric differential equation

x(1-x)  y''(x)+(γ-(α+β+1) x) y'(x)-α β y(x)=0.

Classically, the solutions are hypergeometric functions (see Chapter 3). These become rational functions for integer parameters. Here is an example.

ode2F1[x_, y_, {α_, β_, γ_}] =
  x (1 - x) y''[x] + (γ - (α + β +1) x) y'[x] - α β y[x];

With[{α = 12, β = 7, γ = 10},
DSolve[ode2F1[x, y, {α, β, γ}] == 0, y, x]]

This solution fulfills the differential equation.

With[{α = 12, β = 7, γ = 10},
      ode2F1[x, %[[1, 1, 2]], {α, β, γ}]] // Together

But the following sum of derivatives of Dirac δ functions is also a solution [890✶].

yGF[x_, {α_, β_, γ_}] := 
Sum[(-1)^k Pochhammer[β - γ + 1, k]/k!/Pochhammer[β - α + 1, k]*
    Derivative[β + k - 1][DiracDelta][x], {k, 0, γ - β - 1}] /; 
          IntegerQ[α] && IntegerQ[β] && IntegerQ[γ] && α >= γ > β

Here is a distributional solution of our special case of the hypergeometric differential equation.

yGF[x, {12, 7, 10}]

Substituting this solution into the differential equation and applying our δSimplify shows that this is indeed a solution.

With[{α = 12, β = 7, γ = 10, y = Function[x, Evaluate[%]]},
      ode2F1[x, y, {α, β, γ}]] // Expand

δSimplify[%, x]

For some more uses of series of Dirac δ distributions, see [261✶], [1552✶], [881✶], [1553✶]; for distributional solutions of functional equations, see [411✶], [413✶], and [335✶].

As a little application of how to deal with the UnitStep and the DiracDelta function in Mathematica, let us check that ψ(x,t)=θ(2 (x-k t) γ+π) θ(π-2 γ (x-k t))(cos^(δ+1))(γ (x-k t)) (e^(i (k x-ω t))) is a “finite length solitonic” solution (also called compacton [1361✶], [997✶], [1057✶], [1328✶], [1058✶], [368✶], [1638✶], [507✶], [1639✶], [1692✶], [1640✶]) of the following nonlinear Schrödinger equation [272✶]:

i ((∂ψ(x,t))/(∂t))=-(1/2) (((∂^2)ψ(x,t))/(∂(x^2)))+(1/8) ξ ((((1/(ρ(x,t)))((∂ρ(x,t))/(∂x))))^2)ψ(x,t)

where ρ(x,t)=ψ(x,t)(OverBar[ψ(x,t)]), 0<ξ<1, δ=ξ/(1-ξ), and ω= ((k^2)+(γ^2) (δ+1))/2. (For arbitrarily narrow solitons, see [392✶].)

Here, we implement the equations from above.

δ = ξ/(1 - ξ); 
ω = 1/2 (k^2 + γ^2 (1 + δ));

Ω[ψ_] := Module[{ψc = ψ /. c_Complex :> Conjugate[c], ρ, j}, 
                ρ = ψ ψc; ξ/8 (D[ρ, x]/ρ)^2]

Without the finite length restriction (the terms θ(2 (x-k t) γ+π) θ(π-2 γ (x-k t)) in ψ(x,t), it is straightforward that ψ(x,t) is a solution of the equation.

ψ[x_, t_] = Cos[γ (x - k t)]^(1 + δ) Exp[I (k x - ω t)];

Factor[I D[ψ[x, t], t] + 1/2 D[ψ[x, t], {x, 2}] - Ω[ψ[x, t]] ψ[x, t]]

Including the finite length condition makes things a bit more tricky. Here is the finite length solution.

ψ1[x_, t_] = 
ψ[x, t] UnitStep[2 γ (x - k t) + Pi] UnitStep[Pi - 2 γ (x - k t)];

Just plainly redoing the calculation above will not give the desired result.

Simplify[Factor[I D[ψ1[x, t], t] + 1/2 D[ψ1[x, t], {x, 2}] - 
                Ω[ψ1[x, t]] ψ[x, t]]] === 0

So let us do the calculation step by step. First, we form the first time derivative.

D[ψ1[x, t], x]

We implement a generalization of x δ(x)=0 for the form f(t) δ(g(t)) to simplify the expression above.

δrule =  Times[factors__, DiracDelta[y_]] :>
      Module[{t0, factor1},
             (* the t such that y vanishes *)
             t0 = t /. Solve[y == 0, t][[1]];
             (* the value of factor at t0 *)
             factor1 = Times[factors] //. _UnitStep -> 1 /. t -> t0;
             (* the zero result *) 0 /; 
             ((Together //@ factor1) /. 0^_ -> 0) === 0];

Applying δrule to the first time derivative gives a better result—no Dirac δ functions appear anymore.

timeDeriv1 = Expand[D[ψ1[x, t], t]] /. δrule

In a similar way, we deal with the first and second space derivative.

spaceDeriv1 = Expand[D[ψ1[x, t], x]] /. δrule

spaceDeriv2 = Expand[D[spaceDeriv1, x]] /. δrule;

The nonlinear term still needs to be dealt with.

ψ1c = ψ1[x, t] /. c_Complex :> Conjugate[c]; 
ρ1 = ψ1[x, t] ψ1c

The rule ruleθ simplifies powers of Heaviside distributions.

ruleθ = u_UnitStep^e_ :> u

ρ1 = ρ1 /. ruleθ

After carrying out the spatial differentiation, we again apply our rule δrule.

ρDeriv1 = Expand[D[ρ1, x]] /. δrule

In the process of forming the expression 1/ρ(x,t)∂ρ(x,t)/∂x, we must be especially careful. Formally, the terms θ(π-2 (x-k t) γ) θ(2 (x-k t) γ+π) cancel because inside Times they are treated like a commutative, associative quantity.

ξ/8 (ρDeriv1/ρ1)^2 // Expand

We restore the finite length conditions “by hand”.

Ω[ψ1] = % UnitStep[2 γ (x - k t) + Pi] UnitStep[Pi - 2 γ (x - k t)]

Putting everything together, we arrive at the 0 we were hoping for. This indeed shows that ψ1[x, t] describes a finite length soliton of the above nonlinear Schrödinger equation.

Factor[Expand[I timeDeriv1 + 1/2 spaceDeriv2 - Ω[ψ1] ψ1[x, t]] /. ruleθ]

Here is a space-time picture of the absolute value of the finite length soliton for certain parameters. It is really a localized, moving, shape-invariant solution of a nonlinear wave equation that is concentrated at every time on a compact space domain.

Ψ = With[{k = 2, γ = 1/2, ξ = 1/2}, Evaluate[ψ1[x, t]]]

Plot3D[Evaluate[Abs[Ψ]], {x, -12, 12}, {t, -4, 4}, 
       Mesh -> False, PlotPoints -> 140, PlotRange -> All]

For a fixed time, one sees that the transition between the zero-elongation and the nonzero-elongation domain is smooth (which is needed to fulfill the second-order differential equation).

Plot[Evaluate[Abs[Ψ] /. t -> 2], {x, -0, 8}, 
     PlotRange -> All, AspectRatio -> 1/3,
     Frame -> True, Axes -> False]

Until now, we encountered only one possibility that Mathematica would return a Dirac δ function if we did not input one; this was by differentiation of the UnitStep function. More functions generate generalized functions, also in case one does not explicitly input the UnitStep or the DiracDelta distribution. The most important one is the Fourier transform [1246✶]. The Fourier transform (Subscript[ℱ, t])[f(t)](ω) of a function f(t) is defined as (Subscript[ℱ, t])[f(t)](ω)=(((2π))^(-1/2))(∫_(-∞)^∞)(e^(i ω t))f(t) dt [835✶]. (The square brackets in the traditional form notation (Subscript[ℱ, t])[f(t)](ω) indicate the fact that the Fourier transform of f(t) is a linear functional of f(t) and a function of ω.)

Here is the Fourier transform of an “ordinary” function.

Clear[t, ω, x, y, s, Ω, a, b, term]
FourierTransform[Exp[-x^2] x^3, x, y]

The Fourier transformation is a linear operation.

FourierTransform[α Sin[x^2] + β Exp[-x^2], x, y]

Derivative operators transform under a Fourier transformation into multiplication operators. This property makes them useful for solving ordinary and partial differential equations [481✶], [676✶], [401✶], [167✶], [797✶].

FourierTransform[y''[x], x, ξ]

The Fourier transform of the function 1 is essentially a Dirac δ distribution [232✶].

FourierTransform[1, t, ω]

The following Fourier transform of cos(t) and sin(t) too gives a result that contains Dirac Delta functions.

FourierTransform[α Cos[t] + β Sin[t], t, ω]

Be aware that carrying out the “integral” (using Integrate) will not result in a Dirac δ distribution.

Integrate[Exp[I k t] Exp[I ω t], {t, -Infinity, Infinity},
          Assumptions -> Im[k] == 0]/(2 Pi)

The asymptotic behavior of a Fourier transform measures the smoothness of a function. Here is a Fourier transform of a function that oscillates rapidly near the origin. In the Fourier transform, these oscillations result in a discontinuity at the origin (a jump of size (Sqrt[2π])) [515✶].

(* cry of a bat *)
FourierTransform[Exp[-I/x] - 1, x, y]

FourierTransform[%, y, x] // TrigToExp

The following function 𝔰𝔉[𝔤][x] is equal to its Fourier transform [271✶], [1051✶], [1670✶]. (Here 𝔤 is an arbitrary function).

𝔰𝔉[𝔤_][x_] := 𝔤[x] + 𝔤[-x] + FourierTransform[𝔤[p], p, +x] + 
                            FourierTransform[𝔤[p], p, -x]

For an unspecified function 𝔤, no transformations are carried out. (Mathematica does not now anything about asymptotics of the function 𝔤, so even the existence of the Fourier transform is not guaranteed.)

𝔰𝔉[𝔤][x] - FourierTransform[𝔰𝔉[𝔤][x], x, p] /. p -> x // Simplify

For functions 𝔤, such that FourierTransform evaluates nontrivially, we can show the identity.

With[{𝔤 = Function[x,  (* classical self-Fourier functions *) 
                       Sqrt[2 Pi] DiracDelta[x - Pi] + 
                       Sqrt[2 Pi] DiracDelta[x + Pi] +
                       Exp[I Pi x] + Exp[-I Pi x] +
                       Sech[SqrtPi2 x] +
                       Exp[-x^2/2] + (* some functions *) 
                       Exp[-x^4] + 1/(1 + x^4)]},
     𝔰𝔉[𝔤][x] - FourierTransform[𝔰𝔉[𝔤][x], x, p] /. p -> x // Simplify]

(For the self-dual functions of the Fourier sin transform, see [144✶].)
Fourier transforms can be defined for distributions too. Here is the Fourier transform of the Heaviside θ function.

FourierTransform[UnitStep[t], t, ω]

The term (1/ω) is to be understood as the principal value distribution 𝒫((1/ω)), defined by

⟨𝒫((1/ω)), φ⟩=(lim_(ε->(SuperPlus[0])))((∫_(-∞)^(-ε))((φ(ω))/ω)dω-(∫_ε^∞)((φ(ω))/ω)dω).

Be aware that for distributions with the same singular support, the law of associativity does not hold generically. A typical example is the following: ((δ(x) x) 𝒫((1/x))=0)≠((δ(x) (x 𝒫((1/x))))=δ(x)). As result the convolution theorem does not hold in the following example.

ℊ1[t_] := DiracDelta[t] t + 1
ℊ2[t_] := 1/t
FourierTransform[ℊ1[t] ℊ2[t], t, ω]

𝒻1[ω_] = FourierTransform[ℊ1[t], t, ω];
𝒻2[ω_] = FourierTransform[ℊ2[t], t, ω];
Integrate[𝒻1[𝓌 - ω] 𝒻2[𝓌], {𝓌, -Infinity, Infinity}]/Sqrt[2 Pi]

The Fourier transform of (Sqrt[2 π]) (δ(ω)-(i/(π ω))) is basically the UnitStep function. Mathematica returns the result in the form of the Sign function.

FourierTransform[Sqrt[2Pi] (DiracDelta[ω] - I/(Pi ω)), ω, t]

Here are two Fourier transforms that result in more singular results (for various possibilities to give sense to such strongly divergent integrals, see [1393✶]).

FourierTransform[t^+3, t, ω]

FourierTransform[1/t^2, t, ω]

The inverse Fourier transformation recovers the original function.

InverseFourierTransform[%, ω, t] // Expand

On the last transformation, we encountered the singularity (1/(ω^2)). This distribution occurs frequently in Fourier analysis [631✶], [163✶]. This singularity is not of Cauchy type. It was treated in the Hadamard sense Pf((1/(ω^2))), which means to discard any integer power and logarithmic singular part via ⟨Pf(f(x)),φ⟩=fp(∫_(-∞)^∞)φ(x)f(x)dx, where fp indicates the finite part in the Hadamard sense. For the special case Pf((1/(ω^2))), we have

⟨Pf((1/(ω^2))), φ⟩=(lim_(ε->(SuperPlus[0])))((∫_ε^∞)((φ(ω)-φ(-ω)-2φ(0))/(ω^2))dω).

Because the Fourier transform is an isometry in (Subscript[L, 1]), we can also “backtransform” and even extend the backtransformation to distributions. The inverse Fourier transform (Subscript[ℱ, ω]^(-1))[f(ω)](t) of a function f(ω) is defined as (Subscript[ℱ, ω]^(-1))[f(ω)](t)=(((2π))^(-1/2))(∫_(-∞)^∞)(e^(-i ω t))f(ω) dω.

Interpreting the (1/(ω^2)) from the last output as Pf((1/(ω^2))), the inverse Fourier transformation of |t| recovers |t| (in a slightly rewritten form).

FourierTransform[Abs[t], t, ω]

InverseFourierTransform[%, ω, t]

We have the important identity: (Subscript[ℱ, ω]^(-1))[ (Subscript[ℱ, t])[f(t)](ω)](t)=f(t). Here is an example in which both transformations are explicitly carried out.

InverseFourierTransform[FourierTransform[Exp[-x^2], x, y], y, x]

Mathematica also uses this identity for “symbolic” functions.

InverseFourierTransform[FourierTransform[g[x], x, y], y, x]

Be aware that this rule gets applied automatically, independent of the existence of the individual transforms.

InverseFourierTransform[(* a function that grows exponentially *)
                        FourierTransform[Exp[x^2], x, y], y, x]

Mathematica (in most cases) assumes that generically every expression is a generic complex number. But, currently, it does not make any assumptions about the function space where, say, f[x] is coming from (f[x] is just an expression, not a function in Mathematica). This means f'[x] is always considered a valid expression despite the fact that in a (Wiener-)measure sense, most continuous functions are nowhere differentiable. In a similar way, the convergence of integrals is for symbolic expressions not taken into account, but rather treated in a formal way.

We have the following important relation (Sokhotsky–Plemelj formula) [1147✶], [859✶], [402✶]:

(lim_(ε->(SuperPlus[0])))(1/(x±i ε))=𝒫((1/x))∓i π δ(x).

Let us check the relation for an example case.

Limit[Integrate[Cos[x + 1]/(x + I ε), {x, -Infinity, Infinity},
                 Assumptions -> Re[ε] > 0 && Im[ε] == 0] // 
                 Expand // PowerExpand // Simplify, ε -> 0] // Expand

The δ integral immediately yields cos(1), and the principal value integral yields -π sin(1).

Integrate[-I Pi DiracDelta[x] Cos[x + 1], {x, -Infinity, Infinity},
          PrincipalValue -> True] +
Integrate[Cos[x + 1]/x, {x, -Infinity, Infinity},
          PrincipalValue -> True]

We encountered already two of the options of FourierTransform in the discussion of the options of Integrate (but be aware that the option setting for the Assumption option is now False, for Integrate the default setting was True), but a third one is new.

Options[FourierTransform]

The meaning of the option FourierParameters is best seen by forming the Fourier transform of a constant function and comparing it with the default behavior.

{FourierTransform[1, x, y],
 FourierTransform[1, x, y, FourierParameters -> {a, b}]}

The setting FourierTransform[f(t), t, ω, FourierParameters -> {a, b}] represents the integral

(a, b)(Subscript[ℱ, t])[f(t)](ω)=(Sqrt[((|b|)/(((2π))^(1-a)))])(∫_(-∞)^∞)(e^(i b ω t))f(t) dt.

Be aware that FourierTransform does not have the PrincipalValue option that Integrate has. 1/x is automatically interpreted in the principal value sense. Be also aware that 𝒫((1/x)) does not exist as a named function in Mathematica. 
The next input demonstrates the Poincaré–Bertrand identity [1194✶], [694✶], [403✶], [149✶], [1651✶]

𝒫((1/x))𝒫((1/y))=𝒫((1/(x-y)))(𝒫((1/y))-𝒫((1/x)))+(π^2)δ(x)δ(y)

by using the option setting PrincipalValue -> True.

Module[{ℐ = Integrate[##, PrincipalValue -> True]&},
       ℐ[1/x, {x, -1, 1}] ℐ[1/y, {y, -1, 1}] ==
       ℐ[1/(x - y) 1/y, {y, -1, 1}, {x, -1, 1}] - 
       ℐ[1/(x - y) 1/x, {x, -1, 1}, {y, -1, 1}] +
       Pi^2 ℐ[DiracDelta[x] DiracDelta[y], {x, -1, 1}, {y, -1, 1}]]

Applying an operation to a function (such as differentiation, shifting the argument, …) often possesses an equivalent for the Fourier transform of the function. The following input shows differentiation as an example.

FourierTransform[Derivative[2][x][t], t, ω]

But for many other cases FourierTransform does not do the corresponding operation for the Fourier-transformed functions. The reason that Mathematica does not carry out these operations is the following: Depending on the circumstances, the direction in which the identities should be applied varies. (In addition, for an abstract function f(t) the existence of the Fourier transform is not guaranteed; f(t)∈(Subscript[L, loc]^1)(ℝ,dμ) is needed.) Here are two examples of Fourier transforms that do not get rewritten.

FourierTransform[x[t + α], t, ω]

FourierTransform[Integrate[x[t + τ] y[τ], 
                 {τ, -Infinity, Infinity}], t, ω]

Be aware of the sometimes unexpected consequence of setting the option GenerateConditions to False in FourierTransform.

Options[FourierTransform]

Be aware of the following consequence of the option setting GenerateConditions -> False in FourierTransform: FourierTransform could correctly (within the properties that follow from its definition) return 0 when the Fourier transform is not identically zero or not defined mathematically. The latter case could happen do to a Hadamard regularization (exponentially divergent integrals would result in distributions of infinite order) and the former case could happen because not all possible values of the variable will be considered. Here is an example where the default option setting of FourierTransform returns 0. Using GenerateConditions -> True, we get the appropriate restrictions on the independent variable. (For applications of such-type integrals, see [1462✶].)

ft = FourierTransform[Sqrt[α^2 - x^2] UnitStep[x + α] UnitStep[α - x], 
                      x, y]

{FourierTransform[ft, y, x],
 FourierTransform[ft, y, x, Assumptions -> Im[α] == 0 && α/x > 1],
 FourierTransform[ft, y, x, GenerateConditions -> True]}

Another important integral transform implemented in Mathematica is the Laplace transform. The Laplace transform (Subscript[ℒ, t])[f(t)](s) of an ordinary function f(t) is defined as (Subscript[ℒ, t])[f(t)](s)=(∫_0^∞)(e^(-s t))f(t) dt [1299✶].

Here is the Laplace transform of an “ordinary” function.

LaplaceTransform[Exp[-x^2] x^3, x, y]

Here is a more complicated Laplace transform. The result contains Bessel and Struve functions (see Chapter 3).

LaplaceTransform[1/(1 + s^2)^ν, s, t]

Like the Fourier transform, the Laplace transform is a linear operation. Here, we use two abstract (meaning no explicit definitions are given) functions a(x) and b(x).

LaplaceTransform[a[x] + b[x], x, y]

Similar to the Fourier transform, differential operators transform into multiplication operators (plus some boundary terms).

LaplaceTransform[Ω''[x], x, y]

Derivative[-n] (n∈ℕ) is interpreted as n-fold integration. This interpretation is in accord with the Laplace transform of an integral corresponding to multiplication of (s^(-1)) [481✶], [676✶].

LaplaceTransform[Integrate[Ω[ξ], {ξ, 0, x}], x, y]

Laplace transforms are understood as right-sided Laplace transforms for distributions. This means that the classical definition is generalized in such a way that the test functions for the linear functional are 1 on the support of the distribution. This definition allows for a nontrivial Laplace transform of the Dirac δ function.

LaplaceTransform[DiracDelta[t], t, s]

InverseLaplaceTransform[%, t, s]

The Laplace transform can also be inverted [159✶]. The inverse Fourier transform (Subscript[ℒ, s]^(-1))[f(s)](t) of a function f(s) is defined as (Subscript[ℒ, s]^(-1))[f(s)](t)=(((2π i))^(-1))(∫_(c-i ∞)^(c+i ∞))(e^(s t))f(s) ds for an appropriately chosen c.

Again, we have the property (Subscript[ℒ, s]^(-1))[(Subscript[ℒ, t])[f(t)](s)](t)=f(t).

InverseLaplaceTransform[1/(1 + s^2 + s^4), s, t]

LaplaceTransform[%, t, s] // Simplify

Using the Laplace transformation, we can understand some results returned by Sum better. Let us take the following sum [1107✶]: (∑_(n=0)^∞)(((-1))^n) n! (z^n). It obviously has a zero convergence radius. But nevertheless Sum returns an answer, containing the incomplete Gamma function—to be discussed in Chapter 3.

Sum[(-1)^n n! z^n, {n, 0, Infinity}]

And the answer returned by Sum is sensible [1342✶]. A divergent sum of the form (∑_(k=0)^∞)(Subscript[c, k])(z^k) is called Borel summable [1487✶], [132✶], [1293✶], [1243✶] if (Subscript[ℒ, t])[ϕ(z t)](1) exists [537✶], [487✶], [849✶], [577✶], [488✶], [929✶], [257✶], [908✶], [1493✶] ([1242✶] in case poles are present). Here, ϕ(z) is defined by ϕ(z)=(∑_(k=0)^∞)(Subscript[c, k])/k!(z^k). Using these definitions, we get exactly the above result returned by Sum.

ϕ[z_] = Sum[(-1)^n n!/n! z^n, {n, 0, Infinity}]

LaplaceTransform[ϕ[z t], t, 1] // Simplify

Looking at the Laplace transform of the single terms of the series, it becomes obvious that the trick is effectively to cancel n!  terms from the numerators [713✶].

LaplaceTransform[Sum[c[k]/k! (z t)^k, {k, 0, 6}], t, 1]

The summed form (e^(1/z)) Γ(0,1/z)/z for the divergent series (∑_(n=0)^∞)(((-1))^n) n! (z^n) is actually very sensible. If we calculate the partial sums for small z and truncate at the point where the series starts to grow (excluding the smallest element), we obtain a very close numerical agreement between the sum and its closed form. For z=(10^(-2)), we obtain more than 30 agreeing digits!

With[{z = 10^-2},
     ListPlot[Log[10, Abs[(* difference *)
              N[(Exp[1/z] Gamma[0, 1/z])/z - 
              Rest[FoldList[Plus, 0, Table[(-1)^n n! z^n, 
              {n, 0, 270}]]], 22]/(Exp[1/z] Gamma[0, 1/z])/z]]]]

By summing up to a finite upper bound, we see explicitly the “size” of the diverging part.

Sum[(-1)^n n! z^n, {n, 0, o}] // Expand

(The inverse operation, meaning multiplying the terms of sum by k!, is carried out by the Sumudu transform [1635✶], [1646✶], [82✶].)

Using the function SymbolicSum`SymbolicSum, we can also sum a near relative of the last sum [1107✶].

SymbolicSum`SymbolicSum[ζ^k k!, {k, Infinity}, 
                        GenerateConditions -> False]

Here is another, slightly more complicated example. This time, the Borel summed form contains a Bessel function (see Chapter 3).

s2[z_] = Sum[Evaluate[term = z^n (3n)!/(3^n n!^2)], 
             {n, 0, Infinity}]

ϕ[z_] = Sum[Evaluate[term/n!], {n, 0, Infinity}]

LaplaceTransform[ϕ[z t], t, 1] // Simplify

Borel summation is an important ingredient in the resummation for divergent series arising from perturbation theory. For the Borel treatment of the anharmonic oscillator see, [979✶], [1295✶], [686✶], and [653✶]. Here is an example from quantum electrodynamics in external fields [1214✶], [1583✶], [1584✶], [489✶], [263✶].

𝓉ℯ𝓇𝓂[n_] := (2(-1)^(-1 + n) e^(2n) (-3 + 2n)!)/Pi^(2n)

ϕ[x_] = SymbolicSum`SymbolicSum[Evaluate[𝓉ℯ𝓇𝓂[n] x^n/n!], 
                    {n, 2, Infinity}, GenerateConditions -> False]

LaplaceTransform[ϕ[x t], t, 1] /. x -> 1 // PowerExpand

Sometimes a Borel-summed divergent sum can have opposite sign than the original summands or even have an unexpected imaginary part [1448✶], [1449✶], [1094✶]. Here is a divergent sum of purely positive summands.

(∑_(k=0)^∞)((∏_(j=0)^(k-1))((1/2)+j)(z^k))=(∑_(k=0)^∞)(Subscript[((1/2)), k])(z^k)

((Subscript[(a), k]) is the Pochhammer symbol and formally the last sum can be expressed as the hypergeometric function (Subscript[, 2])(Subscript[F, 0])(1,1/2;;z).) The sum calculated by Mathematica contains the special function Erfi (which is real-valued for real arguments).

SymbolicSum`SymbolicSum[Product[1/2 + j, {j, 0, k - 1}] z^k, 
                 {k, 0, Infinity}, GenerateConditions -> False] // 
                                           Simplify[#, z > 0]&

Such “spurious” contributions are often unavoidable. They arise when the modified sum (made convergent with the additional 1/k! term) has branch cuts along the integration path of the Laplace transform to be carried out [1450✶], [596✶]. This is the case for the current example.

ϕ[z_] = Sum[Pochhammer[1/2, k] z^k/k!, {k, 0, Infinity}]

LaplaceTransform[ϕ[z t], t, 1] // Simplify[#, z > 0]&

Ignoring the imaginary contribution shows that the sum agrees favorably with a numerical summation of the divergent sum that takes into account all decreasing in absolute value summands [1493✶]. For z=0.005 the two results agree to about 87 digits. (For an optimal truncation, one should sum until the smallest element occurs, but not taking the smallest element itself into account.) (By subtracting an appropriate integral term, one can achieve a good agreement for all values of z [1318✶].)

sumUntilGrowing[summand_, {k_, k0_, k1_}] := 
Block[{sum = 0, oldSummand = Infinity, k = k0},
      While[newSummand = summand;
            Abs[newSummand] < Abs[oldSummand],
            oldSummand = newSummand;
            sum = sum + newSummand; k++];
      sum]

With[{z = N[5/1000, 100]},
     Abs[# - sumUntilGrowing[Pochhammer[1/2, k] z^k, {k, 0, Infinity}]]/#&[
     Sqrt[Pi] Exp[-1/z] Erfi[1/Sqrt[z]]/Sqrt[z]]]

A direct call to the function (Subscript[, 2])(Subscript[F, 0]) too returns an imaginary part.

HypergeometricPFQ[{1, 1/2}, {}, 1/2.]

To make sure a sum is summed in Borel sense, one can use SymbolicSum`SymbolicSum[body, iterator, GenerateConditions -> False].

We could now go on and use Sum (and Series or Limit) to invert a Laplace transform via the following formula [1661✶], [1567✶], but we end here.

(Subscript[ℒ, s]^(-1))[f(s)](t)=(lim_(t->∞)) t (∑_(k=1)^∞)(((((-1))^(k-1)) )/((k-1)!))(e^(k s t))f(k t).

The Laplace and the inverse Laplace transforms are frequently used to solve linear differential equations. In the following, we will use the Laplace and the inverse Laplace transform to find approximate solutions to nonlinear initial value problems [928✶]. To linearize the nonlinear problem, we use the Adomian decomposition [17✶], [611✶], [1388✶], [1036✶].

Given a nonlinear function of appropriate smoothness f(x) and making the ansatz x=(∑_(k=0)^∞)(λ^k)(Subscript[ξ, k]) yields the following expansion f(x)=(∑_(k=0)^∞)(Subscript[A, k])((Subscript[ξ, 0]),…,(Subscript[ξ, k-1])) where the Adomian polynomials (Subscript[A, k])((Subscript[ξ, 0]),…,(Subscript[ξ, k-1])) are

(Subscript[A, k])((Subscript[ξ, 0]),…,(Subscript[ξ, k-1]))=(1/(k!))((d^k)/(d(λ^k)))f((∑_(k=0)^∞)(λ^k)(Subscript[ξ, k]))(Subscript[|, λ=0]).

The function AdomianPolynomials calculates the first o Adomian polynomials [1✶], [4✶], [320✶]. The usefulness of the Adomian decomposition stems from the fact that Adomian polynomial (Subscript[A, k])((Subscript[ξ, 0]),…,(Subscript[ξ, k-1])) is a linear function in (Subscript[ξ, k-1]).

AdomianPolynomials[f_, ξ_, o_] := 
Module[{x, λ}, CoefficientList[Series[f[Sum[λ^k x[k],  
                       {k, 0, o}]], {λ, 0, o}], λ] /. x -> ξ]

Clear[f, 𝒻, x, y, η, ξ, a, b, s];
AdomianPolynomials[𝒻, x, 3] /. x[k_] :> Subscript[x, k]

We consider the second order nonlinear initial value problem y''(x)+a(x)y'(x)+b(x)y(x)=f(y(x)) with initial conditions y(0)=(Subscript[y, 0]), y'(0)=(Subscript[y, 1]). Laplace transforming the differential equation yields the following equation.

Solve[LaplaceTransform[y''[x] + a[x] y'[x] + b[x] y[x] - 
                       f[y[x]], x, s] == 0,
      LaplaceTransform[y[x], x, s]]

Expanding now y(x) in an Adomian way y(x)=(∑_(k=0)^∞)(Subscript[η, k])(x), the following iteration procedure arises naturally.

(Subscript[ℒ, x])[(Subscript[η, k])(x)](s)=-(1/(s^2))((Subscript[ℒ, x])[a(x)(Subscript[η, k-1]^′)(x)](s)+(Subscript[ℒ, x])[b(x)(Subscript[η, k-1])(x)](s)+(Subscript[ℒ, x])[(Subscript[A, k-1])((Subscript[η, 0])(x),…,(Subscript[η, k-2])(x))](s))

Let us calculate the first few (Subscript[η, k])(x) for the differential equation y''(x)+cos(x)y(x)=((y(x))^3) under the initial conditions y(0)=1, y'(0)=0. A direct implementation of the last formula allows to calculate the (Subscript[η, k])(x) through inverse Laplace transform (Subscript[ℒ, s]^(-1))[(Subscript[ℒ, x])[(Subscript[η, k])(x)](s)](x).

a[x_] := 0; b[x_] := Cos[x]; f[y_] := y^3;

η[0][x_] = 1;
η[n_][x_] := η[n][x] = InverseLaplaceTransform[
     Together[-s^-2 TrigExpand[LaplaceTransform[
     (* presimplify integrand for faster transform *)
     Expand[TrigToExp[a[x] D[η[n - 1][x], x] + b[x] η[n - 1][x] - 
     AdomianPolynomials[f, Η, n][[n]] /. Η -> (η[#][x]&)]], x, s]]], 
                                                     s, x] // Expand

Here are the first three partial sums of the (Subscript[η, k])(x) shown.

yApproxList[x_] = Rest[FoldList[Plus, 0, Table[η[k][x], {k, 0, 5}]]];
Take[yApproxList[x], 3]

We compare the approximate solutions with a high-precision numerical solution ndsol.The following graphics show that with each (Subscript[η, k])(x) the solution becomes substantially better and the fifth approximation has an error less than (10^(-10)) for 0≤x≲0.8.

(* high-precision numerical solution *)
ndsol = NDSolve[{yN''[x] + a[x] yN'[x] + b[x] yN[x] == f[yN[x]], 
                 yN[0] == 1, yN'[0] == 0}, yN, {x, 0, 5/2},
                WorkingPrecision -> 50, MaxSteps -> 10^5,
                PrecisionGoal -> 30, AccuracyGoal -> 30];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity, 
       (* order increases from red to blue *) 
       𝓉 = Table[Hue[k/7], {k, 0, 5}]}, 
{(* absolute differences *)
 Plot[Evaluate[Join[yApproxList[x], yN[x] /. ndsol]], {x, 0, 5/2},
      PlotRange -> All, PlotStyle -> Prepend[𝓉, GrayLevel[0]]],
 (* logarithms of the differences *)
MapIndexed[(δN[#2[[1]]][x_?NumberQ] := 
    Log[10, Abs[SetPrecision[#1, 60] - yN[SetPrecision[x, 60]] /. 
                                  ndsol[[1]]]])&, yApproxList[x]];
 (* show logarithms of the differences *)
 Plot[Evaluate[Table[δN[k][x], {k, 6}]], {x, 0, 5/2}, 
      PlotRange -> {All, {-10, 2}}, PlotStyle -> 𝓉]}]]]

For the application of the Adomian decomposition to boundary value problems, see [412✶], [1637✶].

Now, we are nearly at the end of our chapter about symbolic computations. Many features of Mathematica have been discussed, but as many have not been discussed. The next section will deal with some applications of the discussed functions. In addition to the functionality built into the Mathematica kernel, a number of important packages in the standard package directory of Mathematica are useful for symbolic calculations, and they enhance the power of the corresponding built-in functions and offer new functionality. In addition to Calculus`Limit`, Calculus`PDSolve1`, and Calculus`DSolve`, which were already mentioned above, the following packages are often very useful: Calculus`VectorAnalysis`, DiscreteMath`RSolve`, and Calculus`VariationalMethods`. The functions contained in these packages can be deduced immediately from their names. Because of space and time limitations, we look only briefly at what these packages can accomplish.

The package Calculus`VariationalMethods` implements the calculation of variational derivatives of integrals and the associated Euler-Lagrange equation (for an introduction to variational calculations, see, e.g., [217✶], [599✶], or for somewhat more detail, see [397✶] and [1628✶]).

Needs["Calculus`VariationalMethods`"]

?VariationalD

Here is a well-known example.

VariationalD[Sqrt[1 - y'[x]^2], y[x], x]

Here are the Newton equations of motion for a 2D harmonic oscillator.

EulerEquations[m/2(x'[t]^2 + y'[t]^2) + (x[t]^4 + x[t] y[t] + y[t]^4),
               {x[t], y[t]}, t]

The package DiscreteMath`RSolve` implements the transformation of recursive definitions to explicit form [7✶], [20✶], [1594✶], [1128✶], [764✶], [541✶].

Needs["DiscreteMath`RSolve`"]

?RSolve

Here is a simple example.

RSolve[{𝒶𝒯[n + 1] == 𝒶𝒯[n] + 2 𝒶𝒯[n - 1], 𝒶𝒯[0] == 3}, 𝒶𝒯[n], n]

Another sometimes useful functionality provided by the package DiscreteMath`RSolve` is the possibility to calculate symbolic terms of power series for the nth term. The function SeriesTerm does this. Here is a simple example—the nth term of sin((x^2)) around x=0.

SeriesTerm[Sin[x^2], {x, 0, n}]

Here, we use the last result and compare it with the explicit terms returned by Series.

Plus @@ MapIndexed[#1 x^(#2[[1]] - 1)&, Table[%, {n, 0, 36}]]

Series[Sin[x^2], {x, 0, 36}] // Normal

Let us have a look at the integral (∫_0^∞)(((e^(-(x^2)))(1-α x))^(-2))dx. Assuming that α<0, the integrand is free of poles, and we can directly carry out the integral.

int = Integrate[Exp[-x^2]/(1 - α x)^2, {x, 0, Infinity},
                Assumptions -> α < 0]

Expanding the denominator in a series around x=0 results in the following series term.

SeriesTerm[1/(1 - α x)^2, {x, 0, k}]

For α x>1 the series is divergent (corresponding to the singularity of 1/(1-α (x^2)) at x=1/α).

Exchanging summation and integration yields a divergent sum. But due to the automatic Borel summation of Sum for such type sums, we get the same result as for the integral.

(∫_0^∞)((e^(-(x^2)))/(((1-α x))^2))dx(OverDot[=])(∫_0^∞)(e^(-(x^2)))((∑_(k=0)^∞)(1+k)(α^k)(x^k))dx(OverDot[=])
(∑_(k=0)^∞)(1+k)(α^k)((∫_0^∞)(e^(-(x^2)))(x^k)dx)(OverDot[=])(∑_(k=0)^∞)(1+k)(α^k)((Γ((1+k)/2))/2)

Integrate[x^k Exp[-x^2], {x, 0, Infinity}, Assumptions -> k >= 0]

sum = SymbolicSum`SymbolicSum[α^k (1 + k) Gamma[(1 + k)/2]/2, 
                              {k, 0, Infinity},
                              GenerateConditions -> False]

Simplify[int - sum, α < 0]

Here is another example. We first sum a series [661✶] and then recover the nth term.

Sum[(ℱ[x] - ℱ[y])^n/(x - y)^(n + 1) λ^n (-1)^n, {n, Infinity}] // Simplify

SeriesTerm[%, {λ, 0, n}]

As a small application of the function SeriesTerm, we will prove the following identity (due to Ramanujan) about the Taylor series coefficients of three rational functions [775✶], [516✶].

((([(x^k)](((9 (x^2)+53 x+1)/((x^3)-82 (x^2)-82 x+1)))))^3)+((([(x^k)](((-12 (x^2)-26 x+2)/((x^3)-82 (x^2)-82 x+1)))))^3)=((([(x^k)](((-10 (x^2)+8 x+2)/((x^3)-82 (x^2)-82 x+1)))))^3)+(((-1))^k)

Using the function Series, we can easily explicitly verify the identity for the first few coefficients.

abc = {1 + 53 x + 9 x^2, 2 - 26 x - 12 x^2, 2 + 8 x - 10 x^2}/
       (1 - 82 x - 82 x^2 + x^3);
       
(#1 + #2 - #3)& @@@ Transpose[#[[3]]^3& /@ Series[abc, {x, 0, 12}]]

SeriesTerms gives us a closed form for the kth term of the Taylor series.

{aS[k_], bS[k_], cS[k_]} = SeriesTerm[abc, {x, 0, k}] // Simplify

Simplifying the resulting expressions proves the above identity.

aS[k]^3 + bS[k]^3 - cS[k]^3 // RootReduce // 
          Simplify[#, Element[k, Integers] && k > 0]&

We end with another application of the series terms also due to Ramanujan: Calculating integrals through series terms. For a sufficiently nice function f(x), the kth moment (Subscript[μ, k])[f(x)]=(∫_0^∞)(x^k)f(x)dx can be calculated through the analytic continuation of the series coefficient c(k)=[(x^k)](f(x)) to negative integer k by (Subscript[μ, k])=-(((-1))^(-k))k!  (-k-1)! (Subscript[c, -k-1]) (Ramanujan’s master theorem [142✶]).

Here is a simple example.

f[x_] = x^2 Exp[-x] Sin[x]^2;

c[k_] = SeriesTerm[f[x], {x, 0, k}];
intc[k_] = k! (-1)^(-k - 1) (-k - 1)! c[-k - 1]

This is the result of the direct integration.

intI[k_] = Integrate[x^k f[x], {x, 0, Infinity}, Assumptions -> k > 0]

For negative integer k, intc[k] is indeterminate. For concrete k we could use Limit or Series to obtain a value. For generic k, we simplify first the Gamma functions using FullSimplify.

intI[k]/intc[k] // FullSimplify // Simplify[#, Element[k, Integers]]&

1.9 Three Applications

1.9.0 Remarks

In this section, we will discuss three larger calculations. Here, “larger” mainly refers to the necessary amount to calculate the result and not so much to the number of lines of Mathematica programs to carry out the calculation. The first two are “classical” problems. Historically, the first one found its solution by an ingenious solution. Here we will carry out a straightforward calculation—for the first time. Carrying out the calculation of an extension of the second one (cos(2π/65537)) took more than 10 years at the end of the last century. The third problem is a natural continuation from the visualizations discussed in Section 3.3 of the Numerics volume [1561✶] of the GuideBooks. Although in principle the three problems can be formulated as a few lines of Mathematica code, it is also necessary to develop some specialized code to solve them efficiently. The code is adapted to Mathematica Version 4. As mentioned in the Introduction, later versions of Mathematica may allow for a shorter implementation and more efficient calculation.

1.9.1 Area of a Random Triangle in a Square

In the middle of the last century, J. J. Sylvester proposed calculating the expectation value of the convex hull of n randomly chosen points in a plane square. For n=1, the problem is trivial, and for n=2, the question is relatively easy to answer. For n≥3, the straightforward formulation of the problem turns out to be technically quite difficult because of the multiple integrals to be evaluated. In 1885, M. W. Crofton came up with an ingenious trick to solve special cases of this problem. (His formulae are today called Crofton’s theorem.) At the same time, he remarked:

The intricacy and difficulty to be encountered in dealing with such multiple integrals and their limits is so great that little success could be expected in attacking such questions directly by this method [direct integration]; and most what has been done in the matter consists in turning the difficulty by various considerations, and arriving at the result by evading or simplifying the integration. [940✶]

The general setting of the problem is to calculate the expectation value of the min(n-1,d)-dimensional volume of the convex hull of n points in d dimensions, for instance, the volume of a random tetrahedron formed by four randomly chosen points in (ℝ^3). For details about what is known, the Crofton theorem and related matters, see [32✶], [237✶], [509✶], [238✶], [1097✶], [751✶], [940✶], [1116✶], [249✶], and [1268✶]. For an ingenious elementary derivation for the n=3 case, see [1432✶]; for a tetrahedron in a cube, see [1727✶]. For the case of a tetrahedron inside a tetrahedron, see [1079✶].)

In this subsection, we will show that using the integration capabilities of Mathematica it is possible to tackle such problems directly—this means by carrying out the integrations. (This subsection is based on [1557✶].)

In the following, let the plane polygon be a unit square, and let us calculate the expectation value of the area of a random triangle within the unit square (by an affine coordinate transformation, the problem in an arbitrary convex polygon can be reduced to this case).
Here is a sketch of the situation.

With[{P1 = {0.2, 0.3}, P2 = {0.8, 0.2}, P3 = {0.4, 0.78}},
Show[Graphics[
		{{Thickness[0.01], 
		  Line[{{0, 0}, {1, 0}, {1, 1}, {0, 1}, {0, 0}}]},
		 {Thickness[0.002], Hue[0], Line[{P1, P2, P3, P1}]},
		 {Text["P1", {0.16, 0.26}], Text["P2", {0.84, 0.16}],
		  Text["P3", {0.40, 0.82}]}}],
     AspectRatio -> Automatic]]

Let {(Subscript[x, 1,])(Subscript[y, 1])}, {(Subscript[x, 2,])(Subscript[y, 2])}, and {(Subscript[x, 3,])(Subscript[y, 3])} be the vertices of the triangle. Then, the area (Subscript[A, T]) of the triangle is given by the absolute value of the determinant:

(Subscript[A, T])=(1/2)||({{({{(Subscript[x, 1]), (Subscript[y, 1])}, {(Subscript[x, 2]), (Subscript[y, 2])}, {(Subscript[x, 3]), (Subscript[y, 3])}}), ({{1}, {1}, {1}})}})||=(1/2)|(Subscript[x, 3]) (Subscript[y, 1])-(Subscript[x, 2]) (Subscript[y, 1])+(Subscript[x, 1]) (Subscript[y, 2])-(Subscript[x, 3]) (Subscript[y, 2])-(Subscript[x, 1]) (Subscript[y, 3])+(Subscript[x, 2]) (Subscript[y, 3])|.

This means the integral to be calculated is

A=(1/2)(∫_0^1)(∫_0^1)(∫_0^1)(∫_0^1)(∫_0^1)(∫_0^1)|(Subscript[x, 3]) (Subscript[y, 1])-(Subscript[x, 2]) (Subscript[y, 1])+(Subscript[x, 1]) (Subscript[y, 2])-(Subscript[x, 3]) (Subscript[y, 2])+(Subscript[x, 2]) (Subscript[y, 3])-(Subscript[x, 1]) (Subscript[y, 3])|d(Subscript[y, 3 ])d(Subscript[x, 3 ])d(Subscript[y, 2 ])d(Subscript[x, 2 ])d(Subscript[y, 1 ])d(Subscript[x, 1 ]).

Depending on the orientation of the triangle, the determinant changes sign, and there are two obvious possibilities to take care of this. The first is to use (Sqrt[((((Subscript[x, 3]) (Subscript[y, 1])+(Subscript[x, 1]) (Subscript[y, 2])-(Subscript[x, 3]) (Subscript[y, 2])-(Subscript[x, 1]) (Subscript[y, 3])+(Subscript[x, 2]) (Subscript[y, 3])-(Subscript[x, 2]) (Subscript[y, 1])))^2)]) as the integrand, and the second would be to divide the six-dimensional integration region into such subregions, so that inside each the expression (Subscript[x, 3]) (Subscript[y, 1])+(Subscript[x, 1]) (Subscript[y, 2])-(Subscript[x, 3]) (Subscript[y, 2])-(Subscript[x, 1]) (Subscript[y, 3])+(Subscript[x, 2]) (Subscript[y, 3])-(Subscript[x, 2]) (Subscript[y, 1]) does not change sign.
We will follow this second approach here, because it makes interesting use of various Mathematica functions.

A subdivision of the six-dimensional unit cube into polytopes where the expression (Subscript[x, 3]) (Subscript[y, 1])-(Subscript[x, 2]) (Subscript[y, 1])+(Subscript[x, 1]) (Subscript[y, 2])-(Subscript[x, 3]) (Subscript[y, 2])+(Subscript[x, 2]) (Subscript[y, 3])-(Subscript[x, 1]) (Subscript[y, 3]) has a constant sign can be most easily obtained using the cylindrical algebraic decomposition. Because for integration purposes we are only interested in subregions that have a nonvanishing six-dimensional Lebesgue measure, we use the function GenericCylindricalAlgebraicDecomposition. Here is the cylindrical algebraic description of the areas where the area of the triangle is positive; it can be calculated quickly.

AppendTo[$ContextPath, "Experimental`"]

Timing[cad = 
GenericCylindricalAlgebraicDecomposition[
   (* the triangle area *)
	-x2 y1 + x3 y1 + x1 y2 - x3 y2 - x1 y3 + x2 y3 > 0 &&
   (* the six-dimensional unit cube *)
	0 < x1 < 1 && 0 < y1 < 1 && 0 < x2 < 1 && 0 < y2 < 1 &&
	0 < x3 < 1 && 0 < y3 < 1, {x1, y1, x2, y2, x3, y3}];]

We convert the resulting nested expression to a list of single six-dimensional polytopes.

l1 = cad[[1]] //. a_ && (b_ || c_) :> a && b || a && c;

This is one of the resulting regions.

l1[[99]]

Because we want to integrate the area function over the regions, we will convert from (Subscript[ξ, l])<ξ<(Subscript[ξ, u]) to {(Subscript[ξ, l]),ξ,(Subscript[ξ, u])}, a form that can be easily used inside Integrate as the integration regions.

polytopes = Apply[List, Apply[{#3, #1, #5} &, l1, {2}], {0, 2}];

We have 216 individual polytopes (while not bounded by plane faces, we use the word polytopes anyway).

Length[polytopes]

There is no need to calculate the polytopes where the area of the triangle has a negative sign. The resulting integrals will give exactly the same contribution by symmetry of the problem. Here is the resulting description of one of the polytopes.

polytopes[[111]]

Now, inside each of the 216 six-dimensional polytopes, we have to integrate the area as a function of (Subscript[x, 1]),(Subscript[y, 1]),(Subscript[x, 2]),(Subscript[y, 2]),(Subscript[x, 3]),(Subscript[y, 3]). The area is only a multilinear polynomial in each of the six integration variables. Because the limits of the integrations are rational functions of the outer integration variables, the integrals we deal with will be typically quite complicated and contain rational functions, logarithms, and polylogarithms in the result after carrying out some integrations.

We will not use Mathematica’s definite integration here. We mentioned the following already in Subsection 1.6.2: If a definite integral contains parameters, Mathematica tries to determine if the integral exists for all parameters and if the integrand contains singular points. Because the integrals involved possess up to five parameters (the outer integration variables), this turns out to be quite a complicated integration. Mathematica can carry out the integrations, but some for some regions, it will be a time-consuming task. Here is a typical result for one of the regions. The result contains the transcendental numbers π and ln(2).

area = Det[{{x1, y1, 1}, {x2, y2, 1}, {x3, y3, 1}}]/2;

Integrate[area, Sequence @@ polytopes[[2]]]

On the other hand, by the construction of the integration regions and by the nature of the area function, we do not have to worry about any of these problems—inside each of the integration regions the integrand is a smooth, not sign-changing function. So, we use the much faster indefinite integration capabilities of Mathematica and calculate the definite integrals from the indefinite ones. If we are lucky, we just substitute the integration limits into the indefinite integral to obtain the definite integral. But sometimes this might give indeterminate expressions. In such a situation, we must be more careful and must calculate the needed limits by using a series expansion around the integration endpoints.

Now, let us implement the integration described above: The function multiDimensionalIntegrate is our own multidimensional, definite integration function. It recursively calls the function fastIntegrate, defined below.

multiDimensionalIntegrate[int_, iters__, iter_] :=
 multiDimensionalIntegrate[fastIntegrate[int, iter], iters];

multiDimensionalIntegrate[int_, iter_] := fastIntegrate[int, iter]

The function fastIntegrate is our 1D integrator. It carries out the indefinite integral first. When substituting limits does not generate infinite or indeterminate quantities, we just subtract the integral values at the upper and lower limits. In case infinite or indeterminate quantities get generated, we make a series expansion around the limits.

fastIntegrate[integrand_, {x_, l_, u_}] :=
Module[{indefiniteIntegral, lValue, uValue},	
    (* the indefinite integral *)
	indefiniteIntegral = LogExpand[Integrate[
               LogExpand[integrand //. x -> ξ], ξ]];
    (* the lower limit *)           
	If[limitsNeededQ[lValue = indefiniteIntegral /. ξ -> l],
       lValue = Normal[Series[indefiniteIntegral, {ξ, l, 0}]]];
	(* the upper limit *) 
	If[limitsNeededQ[uValue = indefiniteIntegral /. ξ -> u],
  	   uValue = Normal[Series[indefiniteIntegral, {ξ, u, 0}]]];
	Factor[Together[uValue - lValue]]]

(* test if infinite or indeterminate quantities get generated *)
limitsNeededQ[expr_] := 
  MemberQ[expr, _DirectedInfinity | Indeterminate, {0, Infinity}]

To speed up the indefinite integration and the calculation of the limits, we apply some transformation rules implemented in LogExpand to the expressions. LogExpand splits all Log[expr] into as many subparts as possible to simplify the integrands. Because we know that the integrals we are carrying out are real quantities, we do not have to worry about branch cut problems associated with the logarithm function, and so drop all imaginary parts at the end.

LogExpand[expr_] := Together[
   expr /. Log[a_] :> Log[Factor[Together[a]]] //. 
          {(* split powers *) 
           Log[a_^n_Integer] -> n Log[a], 
           (* split products *)            
           Log[a_Times] :> Plus @@ (Log /@ List @@ a)} //. 
           (* split Logs of numeric quantities *)
          {Log[Rational[p_, q_]] :> Log[p] - Log[q], 
           Log[p_Integer] :>  
               Plus @@ Apply[#2 Log[#1]&, FactorInteger[p], {1}]}]

Now, we have all functions together and can actually carry out the integration. To get an idea about the form of the expressions appearing in the six integrations, let us have a look at the individual integration results of the first region. (The indefinite integrals are typically quite a bit larger than the definite ones, as shown in the following results.)

(* suppress messages arising from blind limit substitution *)
Off[Infinity::indet]; Off[Power::infy];

This is the description of the first polytope.

polytopes[[1]]

After the integration with respect to y3, we get a rational function in the remaining five variables x3, y2, x2, y1, and x1.

fastIntegrate[area, polytopes[[1, -1]]]

After the second integration with respect to x3, we still have a rational function in five variables y2, x2, y1, and x1.

fastIntegrate[%, polytopes[[1, -2]]]

After the third integration with respect to y2, logarithmic terms emerge.

fastIntegrate[%, polytopes[[1, -3]]]

After the fourth integration with respect to x2, we still have a mixture of rational and logarithmic terms. The size of the result increases.

fastIntegrate[%, polytopes[[1, -4]]] // Simplify

After the fifth integration with respect to y1, we get a special function, the dilogarithm (Subscript[Li, 2])(x).

fastIntegrate[%, polytopes[[1, -5]]] // Simplify

The sixth integration with respect to x1 results in the final result for the first polytope, a numeric quantity containing π, ln(2), and (ln^2)(2).

fastIntegrate[%, polytopes[[1, -6]]]

All of the last six integrations get carried out recursively using our above-defined function multiDimensionalIntegrate.

multiDimensionalIntegrate[area, Sequence @@ polytopes[[1]]]

Now, we carry out all of the 216 multidimensional integrations. This will take just a few minutes.

Re[Together[Plus @@ 
  Apply[multiDimensionalIntegrate[area, ##]&, polytopes, {1}]]] // Timing

All π and log(2) terms cancelled, and we got (taking into account the triangles with negative orientation) for the expectation value, the simple result A=11/144.
Using numerical integration, we can calculate an approximative value of this integral to support the result (11/144).

(SeedRandom[111];
 NIntegrate[Evaluate[Abs[area]], {x1, 0, 1}, {y1, 0, 1},
            {x2, 0, 1}, {y2, 0, 1}, {x3, 0, 1}, {y3, 0, 1}, 
            Method -> QuasiMonteCarlo, MaxPoints -> 10^6,
            PrecisionGoal -> 3])

This result confirms the above result.

N[2 %%[[2]]]

We could now go on and calculate the probability distribution for the areas. The six-dimensional integral to be calculated is now

p(A)=(1/2)(∫_0^1)(∫_0^1)(∫_0^1)(∫_0^1)(∫_0^1)(∫_0^1)δ(A-𝒜( (Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])))d(Subscript[y, 3 ])d(Subscript[x, 3 ])d(Subscript[y, 2 ])d(Subscript[x, 2 ])d(Subscript[y, 1 ])d(Subscript[x, 1 ]),
𝒜( (Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3]))=|(Subscript[x, 3]) (Subscript[y, 1])-(Subscript[x, 2]) (Subscript[y, 1])+(Subscript[x, 1]) (Subscript[y, 2])-(Subscript[x, 3]) (Subscript[y, 2])+(Subscript[x, 2]) (Subscript[y, 3])-(Subscript[x, 1]) (Subscript[y, 3])|.

We will not carry out this in detail here, but just sketch the modifications compared with the above calculations. This time, before subdividing the integration variable space into subregions, we carry out the integral over (Subscript[y, 3]) to eliminate the Dirac delta function. To do this, we use the identity

(∫_a^b)δ(y-f(x))dx=(∫_a^b)(∑_k)((δ(y-(Subscript[x, 0,k])))/(|f'((Subscript[x, 0,k]))|))dx

where the (Subscript[x, 0,k]) are the zeros of f(x) in [a,b].

Expressing (Subscript[y, 3]) through (Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3]), (Subscript[y, 1]), (Subscript[y, 2]), and A yields the following expression.

soly3 = Solve[A == (* or - *) (-x2 y1 + x3 y1 + x1 y2 - x3 y2 - 
                                x1 y3 + x2 y3), y3][[1, 1, 2]]

And the derivative from the denominator becomes |(Subscript[x, 1])-(Subscript[x, 2])|.

D[-x2 y1 + x3 y1 + x1 y2 - x3 y2 - x1 y3 + x2 y3, y3]

Now is a good time to carry out a decomposition of the space into subregions. In addition to the constraints following from the geometric constraints of the integration variables being from the unit square, we add three more inequalities: 1) 0<(Subscript[y, 3])( (Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[y, 1]),(Subscript[y, 2]);A)<1 to ensure the existence of a zero inside the Dirac Delta function argument; 2) A>0 for positive oriented areas; and 3) (Subscript[x, 1])>(Subscript[x, 2]) to avoid the absolute value in the denominator.

cad = Experimental`GenericCylindricalAlgebraicDecomposition[
                    0 < soly3 < 1 && A > 0 && x1 > (* or < *) x2 && 
                    0 < x1 < 1 && 0 < x2 < 1 && 
                    0 < x3 < 1 && 0 < y2 < 1 && 0 < y1 < 1,
                  {A, x1, x2, x3, y1, y2}];

This time, we get a total of 1282 subregions.

(l1 = cad[[1]] //. a_ && (b_ || c_) :> (a && b) || (a && c)) // Length

One expects the probability distribution p(A) to be a piecewise smooth function of λ. Six λ-interval arose naturally from the decomposition.

Union[First /@ l1]

ASortedRegions = {#[[1, 1, 2]] < A < #[[1, 1, 3]] , Rest /@ #}& /@
   Split[Sort[(# /. Inequality[a_, Less, b_, Less, c_] :>
         {b, a, c} /. And -> List)& /@ (List @@ l1)], #1[[1]] === #2[[1]]&];

Here are the number of regions for the six λ-intervals.

{#1, Length[#2] "subregions"}& @@@ ASortedRegions

The regions themselves look quite similar to the above ones.

{#1, #2[[1]]}& @@@ ASortedRegions

To carry out the remaining five-dimensional integration, we could use a function like x1x2x3y1y2Integration. The optional functions 𝒮 and 𝒯 could carries out simplifications of the integrands to ease the work of Integrate and the results of Integrate to  ease the work of Limit.

x1x2x3y1y2Integration[region_, startIntegrand:i0_,
                      𝒮_:Identity, 𝒯_:Identity] :=
Module[{𝒟ℒ, y2y1x3x2x1Regions},
  (* 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 *)
  y2y1x3x2x1Regions = Reverse[region];
  (* carry out the five integrations *)
  Fold[𝒟ℒ[𝒯[Integrate[𝒮[#1], #2[[1]]]], #2]&, i0, 
      y2y1x3x2x1Regions]]

Here is a typical result for one of the 1282 five-dimensional integrals.

(* no special simplifiers needed for the subregion {5, 40} *)
x1x2x3y1y2Integration[ASortedRegions[[5, 2, 40]], 1/(x1 - x2)] // 
                                              Simplify[#, A > 0]&

We do not carry out all integrals for the current set of regions, but rather end here and leave further investigations to the reader.

For a similar probabilistic problem, the Heilbronn triangle problem, see [851✶].

1.9.2 cos(((2π)/257)) à la Gauss

In the early morning of March 29 in 1796, Carl Friedrich Gauss (while still in bed) recognized how it is possible to construct a regular 17-gon by ruler and compass; or more arithmetically and less geometrically speaking, he expressed cos(((2π)/17)) in terms of square roots and the four basic arithmetic operations of addition, subtraction, multiplication, and division only. (This discovery was the reason why he decided to become a mathematician [1325✶], [633✶], [1615✶].) His method works immediately for all primes of the form (2^(2^j))+1, so-called Fermat numbers (Subscript[F, j]) [988✶]. For j=0 to 4, we get the numbers 3, 5, 17, 257, and 65537. (j=5,…,14 do not give primes; we return to this at the end of this section.) The problem to be solved is to express the roots of (z^p)=1, where p is a Fermat prime in square roots. One obvious solution of this equation is z=1. After dividing (z^p)=1 by this solution, we get as the new equation to be solved:

(z^(p-1))+(z^(p-2))+⋯+z+1=0.

It can be shown that there are no further rational zeros; so this equation cannot be simplified further in an easy way. Let us denote (by following Gauss’s notation here and in the following) the solution exp(((λ 2π i)/p)), λ integer, 1≤λ≤p-1 of this equation by (OverBar[λ]) (which is, of course, a solution, but which contains a pth root). Gauss’s idea, which solves the above equation exclusively in square roots, is to group the roots of the above equation in a recursive way such that the explicit values of the sums of these roots can be expressed in numbers and square roots. Each step then rearranges these roots until finally only groups of length two remain. These last groups are then just of the form cos(((j  2π)/p)). 
Let us describe this idea in more detail. First, we need the number-theoretic notion of a primitive root: the number g is called a primitive root of p if the set of numbers (Subscript[{(g^i)modp}, i=0,…,p-2]) are (up to their order) identical with the numbers 1,…,p-1. The following input shows that the number 3 is a primitive root of 5, 17, 257, and 65357. (To avoid the calculation of huge numbers caused by exponentiation, we use PowerMod[g, i, n], which is mathematically equivalent to Mod[(g^i), n], but much faster.)

Function[p, Sort[Array[PowerMod[3, #, p]&, p - 1, 0]] ==
                       Range[p - 1]] /@ {5, 17, 257, 65537}

(Only integers n of the form 2,4,(p^j),2(p^j), where p is an odd prime and j>0 have primitive roots; they have ϕ(ϕ(n)) different ones; ϕ(n) is Euler’s totient function.) The order of the integers in Array[PowerMod[base, #, prime]&, p - 1, 0] exhibits some interesting symmetry, as can be visualized for the "prime"=257 case with the following input.

primitiveRootsGraphics[b_] := Graphics[
  {Thickness[0.002], Line[Append[#, First[#]]&[
(* connect numbers in their permuted order *)
{Cos[#], Sin[#]}& /@ N[2Pi Array[
     PowerMod[b, #, 257]&, 256, 0]/257]]]},
    PlotRange -> All, AspectRatio -> Automatic]

(* reduced residue system exists for the following 128 numbers *)
rssNumbers = Flatten[Position[Table[Sort[Array[
                PowerMod[i, #, 257]&, 256, 0]] ==
                    Range[256], {i, 256}], True]];

Function[bs, Show[GraphicsArray[Function[b, 
   primitiveRootsGraphics[b]] /@ bs]]] /@ (* display nine examples *)
          Partition[rssNumbers[[{1, 2, 3, 33, 42, 43, 66, 106, 114}]], 3]

Show[primitiveRootsGraphics[#]]& /@ rssNumbers

(For some interesting discussions about the number of crossings and the number of regions in such pictures, see [1284✶].)

The next concept we need is that of the so-called periods. A period (Overscript[(Overscript[λ, ⏞]), f]) to the primitive root g, containing the root (OverBar[λ]) and having length f, is defined by the expression below. (The dependence on the fixed quantities p and g is suppressed.)

(Overscript[(Overscript[λ, ⏞]), f])=(∑_(j=0)^(f-1))(OverBar[λ(g^((j(p-1))/f))])

Because the root (OverBar[λ+p]) is equivalent to the root (OverBar[λ]), we implement the construction of the periods in the following way. (We again use PowerMod because of speed and denote (OverBar[λ]) by R[λ].)

period[λ_, f_, p_, g_] := Plus @@ (R /@ Mod[Mod[λ, p] Array[
                     PowerMod[g^((p - 1)/f), #, p]&, f, 0], p])

Let us look at two examples for the prime 17 and the primitive root 3.

period[1, 8, 17, 3]

period[3, 8, 17, 3]

We see that their sum just gives the sum of all roots. This is always the case if p is a Fermat prime; here, the case p=257 is checked.

period[1, 128, 257, 3] + period[3, 128, 257, 3] == Plus @@ Array[R, 256]

period[5, 128, 257, 3] + period[9, 128, 257, 3] == Plus @@ Array[R, 256]

Dividing the last period again into subperiods by using the above definition for the periods, we find that the period period[3, 8, 17, 3] can be expressed as the sum of the following periods.

period[3, 4, 17, 3]

period[11, 4, 17, 3]

It can be shown that one can always represent a period in this way: One root of one of the new periods is identical to the old one ((OverBar[λ])), whereas one root of the other period is generated by the root (OverBar[(λ(g^((p-1)/f)))mod(p-1)]). The other roots of the two periods under consideration follow immediately from the above definition of the periods. In our example, we have this for one root of the second period: ((33^((17-1)/8)))mod16=11. In doing this division process for the periods repeatedly, we end up in periods of length two. These periods are of the form (OverBar[1])+(OverBar[p-1]),(OverBar[2])+(OverBar[p-2]),…, which give immediately 2cos(((2π)/p)),2cos(2×2(π/p)),…. To explicitly calculate the values of the periods in square roots, we need the following theorem: The (numerical) values (Subscript[Λ, 1]),(Subscript[Λ, 2]) of two periods (Subscript[λ, 1]),(Subscript[λ, 2]) (which contain no higher roots than square roots and are to be discriminated from the periods (Subscript[λ, 1]),(Subscript[λ, 2]) themselves) obtained by splitting one period are the solutions of a quadratic equation. If (Subscript[Λ, 1]) and (Subscript[Λ, 2]) are the solutions of (Λ^2)+(Subscript[a, 1])Λ+(Subscript[a, 2])=0; by Vieta’s theorem, we have (Subscript[Λ, 1])(Subscript[Λ, 2])=-(Subscript[a, 1]) and (Subscript[Λ, 1])+(Subscript[Λ, 2])=(Subscript[a, 2]). The sum of the two periods is just the period before splitting, and the (numerical) value of the starting period is -1. It is important to observe that the product of two periods of length f, obtained by splitting a period (Overscript[(Overscript[λ, ⏞]), 2f]), can always be expressed as a linear combination of periods of length 2f. The explicit formula for carrying out this multiplication of two periods is given by

(Overscript[(Overscript[λμ, ⏞]), f])=(Overscript[(Overscript[(Subscript[λ, 1])(Subscript[μ, 1]), ⏞]), f])+(Overscript[(Overscript[(Subscript[λ, 2])(Subscript[μ, 1]), ⏞]), f])+⋯+(Overscript[(Overscript[(Subscript[λ, f])(Subscript[μ, 1]), ⏞]), f])

where

({{(Overscript[(Overscript[λ, ⏞]), f])=, (OverBar[(Subscript[λ, 1])])+(OverBar[(Subscript[λ, 2])])+⋯+(OverBar[(Subscript[λ, f])])    and }}) ({{(Overscript[(Overscript[μ, ⏞]), f])=, (OverBar[(Subscript[μ, 1])])+(OverBar[(Subscript[μ, 2])])+⋯+(OverBar[(Subscript[μ, f])]).}})

After this multiplication, the periods on the right-hand side can then be expressed as periods of length 2f or as pure numbers. (For f=((p-1)/2), they can always be expressed as pure numbers, which ensures that we have appropriate starting values for the recursive calculation.) Here, the above two periods of length 8 of p=17 (period[1, 8, 17, 3] and period[3, 8, 17, 3]; (Subscript[μ, 1])=1, (Subscript[λ, 1])=3, (Subscript[λ, 2])=5, (Subscript[λ, 3])=6, (Subscript[λ, 4])=7, (Subscript[λ, 5])=10, (Subscript[λ, 6])=11, (Subscript[λ, 7])=12, (Subscript[λ, 8])=14) are multiplied in this manner.

period[ 3 + 1, 8, 17, 3] + period[ 5 + 1, 8, 17, 3] +
period[ 6 + 1, 8, 17, 3] + period[ 7 + 1, 8, 17, 3] +
period[10 + 1, 8, 17, 3] + period[11 + 1, 8, 17, 3] +
period[12 + 1, 8, 17, 3] + period[14 + 1, 8, 17, 3] // Factor

By taking into account the original equation this obviously simplifies to -4. (The value of the period of length 16 was -1.) 
The two values for the periods of length ((p-1)/2) can be given in closed form.

{1/2 (-1 + I^(((p - 1)/2)^2) Sqrt[p]),
 1/2 (-1 - I^(((p - 1)/2)^2) Sqrt[p])};

This agrees with the direct numerical calculation, as shown here for p=17.

% /. p -> 17 // N

{period[1, 8, 17, 3] /. (R -> (Exp[2Pi I #/17.]&)),
 period[3, 8, 17, 3] /. (R -> (Exp[2Pi I #/17.]&))} // N // Chop

In the general case, the values of the periods with f<((p-1)/2) and their products have to be determined by the above-described recursive procedures. 
By calculating the values of the periods (Subscript[Λ, 1]) and (Subscript[Λ, 2]) in this manner (up to the correspondence between periods and their numerical values), we can recursively continue splitting periods until we end at the periods of length 2. 
Now, we implement the calculation of cos(((2π)/257)) via the routine GaussSolve[p, Λ]. Its arguments are the prime p and the name of the periods Λ. The eight functions introduced inside GaussSolve, λ, newλs, Timesλ, allλs, rules1, rules, Simplifyλ, and solStep, have the following meanings. (In every case, we use the primitive root g=3, which is possible as we have proved above by explicit calculation for the primes p of interest here.) 
λ[t, f] gives the numbers of the roots of the period of length f containing the root t (without using the head R as above). 
newλs[t, f] returns a list with two roots that generate the two periods of length f/2 by splitting the period (Overscript[(Overscript[t, ⏞]), f]) of length f, which contains the root (OverBar[t]). 
Timesλ[t, u, f] carries out the above-described multiplication of the two periods (Overscript[(Overscript[t, ⏞]), f]) and (Overscript[(Overscript[u, ⏞]), f]). 
allλs[f] gives a list containing one root from every period of length f with 2≤f≤((p-1)/2). 
rules1[f] gives a list of rules that replace all of the (Overscript[(Overscript[(Subscript[λ, 2]), ⏞]), f]),(Overscript[(Overscript[(Subscript[λ, 3]), ⏞]), f]),…, (Overscript[(Overscript[(Subscript[λ, f]), ⏞]), f]) by (OverBar[(Subscript[λ, 1])]) if the (Overscript[(Overscript[(Subscript[λ, i]), ⏞]), f]) arise from (Overscript[(Overscript[λ, ⏞]), f])=(OverBar[(Subscript[λ, 1])])+(OverBar[(Subscript[λ, 2])])+⋯+(OverBar[(Subscript[λ, f])]). (This is possible because obviously the relation (Overscript[(Overscript[(Subscript[λ, 1]), ⏞]), f])=(Overscript[(Overscript[(Subscript[λ, 2]), ⏞]), f])=⋯=(Overscript[(Overscript[(Subscript[λ, f]), ⏞]), f]) holds because of (Overscript[(Overscript[λ, ⏞]), f])=(OverBar[(Subscript[λ, 1])])+(OverBar[(Subscript[λ, 2])])+⋯+(OverBar[(Subscript[λ, f])]) (a period can be generated by any of its roots) and ensures that we have only the value of one root from every period to calculate.) 
rules2[f] replaces the period containing the root (OverBar[(λ(g^((p-1)/f)))mod(p-1)]) by (Overscript[(Overscript[λ, ⏞]), 2f])-(Overscript[(Overscript[λ, ⏞]), f]) to have only one new period introduced explicitly in solList at each subdivision. 
Simplifyλ[t, u, f] simplifies the product of two periods calculated with Timesl[t, u, f] using the rules rules1 and rules2. 
solStep[t, f] carries out one subdivision of the period (Overscript[(Overscript[t, ⏞]), f]), and calculates the values of the periods (Overscript[(Overscript[u, ⏞]), f/2]) and (Overscript[(Overscript[v, ⏞]), f/2]) after splitting. For the determination of which root belongs to which period, we compare the numerical values of the periods. (This comparison could be done with much more effort symbolically, but because this has no influence on the result, we use this quick way.) Carrying out solStep[t, f] has no result, but only a side effect: The symbolic values for the new periods obtained by splitting (Overscript[(Overscript[t, ⏞]), f]) are added to the list solList. 
The algorithm carried out by GaussSolve is quite simple: After the definition of the just-described functions and the calculation of all numerical values of the periods (which are stored in solNList), we collect in solArgs the ordered list of all periods (Overscript[(Overscript[λ, ⏞]), f]) that have to be subdivided in the form {λ, f}. Then, solStep is applied to all of the elements of solArgs. The result of GaussSolve[p, Λ] gives a list of replacement rules for the symbolic values of the periods Λ[λ, f]. We collect not only the result, but also all values for the periods, using this list, we can later also easily get cos(j2π/p) (j other than 1). Because for p>17 the various lists of rules that are in use inside GaussSolve are quite big, we use Dispatch to accelerate their application (with the exception of the list solList, which is not used actively internally, but only serves as a container for the results).

GaussSolve[p:(3 | 5 | 17 | 257 | 65537), Λ_Symbol] :=
Module[{g = 3, λ, newλs, Timesλ, allλs, rules1, rules2, Simplifyλ, 
        solStep, solArgs, solNList, solList = {Λ[1, p - 1] ->  - 1}},
(* the λ’s *)
λ[t_, f_] := λ[t, f] = Function[γ, Mod[Mod[t, p] Array[
                 PowerMod[γ, #, p]&, f, 0], p]][g^((p - 1)/f)];
(* newλs function definition with remembering *)
newλs[t_, f_] := newλs[t, f] =
     {t, Mod[Mod[t, p] PowerMod[g, (p - 1)/f, p], p]};
(* Timesλ function for λ multiplication *)
Timesλ[t_, u_, f_] := Plus @@ (Λ[#, f]& /@ Mod[λ[u, f] + t, p]);
(* allλs lists *)
allλs[p - 1] = {1};
allλs[f_] := allλs[f] = Flatten[Map[newλs[#, 2f]&, allλs[2f], {-1}]];
(* rules1 for λ canonicalization *)
rules1[f_] := rules1[f] =
Dispatch[Map[Λ[#, f]&, Flatten[Function[a,
 Apply[Rule, Transpose[{Rest[a], Table[#,
  {Length[Rest[a]]}]&[First[a]]}], {1}]] /@
             (λ[#, f]& /@ allλs[f])], {-1}]];
(* rules2 for λ eliminating one λ *)
rules2[(p - 1)/2] = Λ[g, (p - 1)/2] ->  - 1 - Λ[1, (p - 1)/2];
rules2[f_] := rules2[f] = Dispatch[
  Λ[#[[2, 2]], f] -> Λ[#[[1]], 2f] - Λ[#[[2, 1]], f]& /@
         Map[{#, newλs[#, 2f]}&, allλs[2f], {-1}]];
(* Simplifyλ for simplifying products of λs *)
Simplifyλ[t_, u_, f_] := Fold[Expand[#1 //. #2]&,
     Expand[Timesλ[t, u, f] //. rules1[f]],
       rules2 /@ (f 2^Range[0, Log[2, (p - 1)/f] - 1])];
(* solStep for period subdivision *)
solStep[t_, f_] :=
Module[{u, v, x1Px2, x1Tx2, sol1, sol2, sol1N, sol2N, numSol1},
{u, v} = newλs[t, f];
 x1Px2 = Λ[t, f]; x1Tx2 = Simplifyλ[u, v, f/2];
 {sol1, sol2} = # + Sqrt[#^2 - x1Tx2]{1, -1}&[x1Px2/2];
 numSol1 = Λ[u, f/2] //. solNList;
 {sol1N, sol2N} = N[{sol1, sol2} //. solNList];
 solList = Flatten[{solList,
 If[Abs[sol1N - numSol1] < Abs[sol2N - numSol1],
    {Λ[u, f/2] -> sol1, Λ[v, f/2] -> sol2},
    {Λ[u, f/2] -> sol2, Λ[v, f/2] -> sol1}]}]; ];
(* solNList for numerical values of the periods *)
solNList = Dispatch[Apply[(Λ @ ##) ->
   (Plus @@ Exp[N[2Pi I λ[##]/p]])&,
     Flatten[Function[i, {#, i}& /@ allλs[i]] /@
            (2^Range[Log[2, p - 1], 1, -1]), 1], {1}]];
(* stepArgs for period arguments *)
stepArgs = Flatten[Function[i, {#, i}& /@
   allλs[i]] /@ (2^Range[Log[2, p - 1], 2, -1]), 1];
(* do the work *) solStep @@ #& /@ stepArgs; solList]

Now, let us calculate the two simple cases p=3 and p=5 as a warm up.

(Λ[1, 2] //. GaussSolve[3, Λ])/2

(Λ[1, 2] //. GaussSolve[5, Λ])/2 // Expand

The results agree with the well-known expressions for cos(2π/3) and cos(2π/5). Here is the list of the values of the periods for p=17.

(list17 = GaussSolve[17, Λ]) // InputForm

Here is the final expression for cos(((2π)/17)).

(Λ[1, 2] //. list17)/2 // Expand // Factor

We numerically check this result. Because the result is 0, we cannot get any significant digit, and so the $MaxExtraPrecision::meprec message is issued.

N[% - Cos[2Pi/17], 200]

Next is the result for cos(2×2π/17). (Because we have eliminated most of the L[j, 2]’s with even j, we make use of cos(2jπ/p)=cos(2(p-j)π/p) and use L[15, 2].)

(Λ[15, 2] //. list17)/2 // Expand // Factor

N[% - Cos[2 2Pi/17], 200]

Using the powerful function RootReduce we could also prove the last equality symbolically.

(%% // Simplify // RootReduce) -
(Together[TrigToExp[Cos[2 2Pi/17]]] // RootReduce)

Together[TrigToExp[Cos[2 2Pi/17]]]

The last value of interest here is cos(8×2π/17).

(Λ[9, 2] //. list17)/2 // Expand // Factor

Here is again a quick numerical check for the last result.

N[% - Cos[8 2Pi/17], 200]

Now, as promised in the title of this subsection, we calculate cos(2π/257) [1339✶], [574✶].

list257 = GaussSolve[257, Λ];

We select out only those parts that are explicitly needed for the evaluation of cos(2π/257).

Flatten[Function[{lhs, rhs},
(* until we have all needed Λ’s *)
FixedPoint[{#, Complement[Union[Cases[
(* what is in the rhs *)
rhs[[#]]& /@ Flatten[Position[lhs, #]& /@
    Last[#]], _Λ, {0, Infinity}]], Flatten[#]]}&,
(* this we need of course *) {{Λ[1, 2]}},
SameTest -> (Last[#2] === {}&)]][
          (* all lhs and rhs from list257 *) 
          First /@ list257, Last /@ list257]];

solListPiD257 = (list257[[#]]& /@ Flatten[Function[lhs,
     Position[lhs, #]& /@ %][First /@ list257]]);

Here is a shortened version of this list of replacement rules necessary to express cos(((2π)/257)).

solListPiD257 // Short[#, 6]&

The value for cos(((2π)/257)) is now easily obtained, but because of its size, we do not display it here.

(cos2PiD257 = (Λ[1, 2] //. Dispatch[solListPiD257])/2) // ByteCount

It contains only square roots, but it contains a lot of them.

Cases[cos2PiD257, Power[_, 1/2],
      {0, Infinity}, Heads -> True] // Length

If the reader wants to see all of them, the following code opens a new notebook with the typeset formula for the square root version of cos(2π/257).

NotebookPut[Notebook[{Cell[BoxData[
               FormBox[MakeBoxes[#, TraditionalForm]&[cos2PiD257],
                           TraditionalForm]], "Output",
    ShowCellBracket -> False, CellMargins -> {{0, 0}, {5, 5}},
    PageWidth -> Infinity, FontColor -> GrayLevel[1],
    (* allow to see all square roots *) CellHorizontalScrolling -> True]}, 
    WindowSize -> {Automatic, Fit},
    Background -> RGBColor[0.31, 0., 0.51],
    ScrollingOptions  -> {"HorizontalScrollRange" -> 500000},
    WindowMargins -> {{0, 0}, {Automatic, 10}},
    WindowElements -> {"HorizontalScrollBar"},
    WindowFrameElements -> {"CloseBox"}]]

We also check this result numerically. (So as not to build up the huge symbolic expression and then apply N[#, 200]& with brute force to the whole expression, we map N[#, 200]& to the right-hand side of the first rule to cause intermediate expressions to collapse down to approximate numbers.)

(Λ[1, 2] //. (* Dispatch first, it is applied often *)
 Dispatch[MapAt[N[#, 200]&, solListPiD257,
 (* where to map N *)
 {Position[First /@ solListPiD257,
  Λ[1, 256]][[1, 1]], 2}]])/2 - N[Cos[2Pi/257], 200]

One could now go on and calculate the following quite large calculation for the denominator 65537.

l65537 = GaussSolve[65537, L]

It will take around one day on a modern workstation. Here are the first lines of the result (of size 55 MB).
 {Λ[ 1, 65536] -> -1, 
  Λ[ 1, 32768] -> Λ[1, 65536]/2 + Sqrt[16384 + Λ[1, 65536]^2/4], 
  Λ[ 3, 32768] -> Λ[1, 65536]/2 - Sqrt[16384 + Λ[1, 65536]^2/4], 
  Λ[ 1, 16384] -> Λ[1, 32768]/2 - Sqrt[ 4096 + Λ[1, 32768]^2/4], 
  Λ[ 9, 16384] -> Λ[1, 32768]/2 + Sqrt[ 4096 + Λ[1, 32768]^2/4], 
  Λ[ 3, 16384] -> Λ[3, 32768]/2 - Sqrt[ 4096 + Λ[3, 32768]^2/4], 
  Λ[27, 16384] -> Λ[3, 32768]/2 + Sqrt[ 4096 + Λ[3, 32768]^2/4], 
  Λ[ 1,  8192] -> Λ[1, 16384]/2 - Sqrt[ 1040 + 32 Λ[1, 16384] + 
                  Λ[1, 16384]^2/4 + 16 Λ[1, 32768]], 
  Λ[81, 8192] -> Λ[1, 16384]/2 + Sqrt[1040 + 32 Λ[1, 16384] + 
                 Λ[1, 16384]^2/4 + 16 Λ[1, 32768]], 
  Λ[ 9, 8192] -> Λ[9, 16384]/2 + Sqrt[1040 - 32 Λ[1, 16384] + 
                 48 Λ[1, 32768] + Λ[9, 16384]^2/4], 
  Λ[729, 8192] -> Λ[9, 16384]/2 - Sqrt[1040 - 32 Λ[1, 16384] + 
                  48 Λ[1, 32768] + Λ[9, 16384]^2/4], 
  Λ[ 3, 8192] -> Λ[3, 16384]/2 + Sqrt[1024 - 16 Λ[1, 32768] + 
                 32 Λ[3, 16384] + Λ[3, 16384]^2/4]}

(Although the above implementation strictly follows Gauss’s original work, we could have used more efficient procedures. See [754✶].) 
Let us briefly discuss the numbers n for which the value cos(2π/n) can be expressed in square roots (or geometrically speaking, which n-gons can be constructed by ruler and compass [420✶], [744✶]?). 
The above-mentioned number (2^(2^5))-1=4294967295 is not a prime number; the factors are all Fermat numbers (Subscript[F, j]) with j=0,…,4.

FactorInteger[2^(2^5) - 1]

(It is not by accident that we have the relation (Subscript[F, n])=2+(Subscript[F, n-1])(Subscript[F, n-2])⋯ (Subscript[F, 0]); for factorizations of Fermat numbers, see [987✶] and [683✶].) By solving some simple linear diophantine equations (how to do this in Mathematica is discussed in [1623✶]), we easily find that 1/((2^(2^5))-1) can be expressed as the following sum.

1/(3 5 17 257 65537) -
(29129863/3 - 58259726/5 + 33291272/17 - 4194176/257 + 32768/65537)

In general, it is possible to calculate cos(2π/n) in square roots if n is a product q of prime Fermat numbers that contains no factor more than once or if n=q(2^j) (j is a nonnegative integer). 
For an explicit ruler and compass construction of the regular 257-gon, see [684✶].

It should be noted that the above approach could be easily generalized to the case of splitting one period into more than two periods. Then, the resulting equations obeyed by the periods are no longer quadratic, but of the order of the number of newly generated periods. For more details on this subject, see [95✶], [432✶], [459✶], [988✶], [1161✶], [1515✶], [1155✶], [801✶], [338✶], [1489✶], [1543✶], [865✶], [598✶], [1196✶], [1642✶], and [1641✶]. See [116✶], [858✶], [280✶], [1602✶], [967✶], and [1498✶] for the explicit geometrical construction of the n-gon.

1.9.3 Implicitization of a Trefoil Knot

In this subsection, we carry out a larger symbolic calculation, the implicitization of a trefoil knot. Implicitization of a parametrically defined surface is, in general, a very useful operation because both the parametric and implicit representations have advantages (see [101✶], [1429✶], and [1269✶]). The parametric version is easy to plot, and the implicit one allows an easy decision on which side of the surface a given point lies or if a point lies on the surface. In Chapter 3 of the Graphics volume [1560✶] of the GuideBooks, we discussed and constructed several polynomial surfaces, but not a knotted one. Using the technique described there of gluing together simple implicitly defined objects (like ellipsoids, spheres, tori, cones, tubes) appropriately spaced and oriented, we could generate knotted objects. 
But we consider this approach cheating, and so we will construct a clean “knot tube” here. Because some of the calculations to be carried out take about five hours on a good year 2002 PC, we do not explicitly carry them out here, but rather only give the results. All code to calculate the implicit surface representation is given; so the reader can decide whether to redo the calculation or a variant of it for another knot later. (Knot tubes that result in much smaller problems than does a trefoil knot exist, for instance, a tube along a curve given by the parametrization {sin(t)+2sin(2t),cos(t)-2cos(2t),sin(3t)}; but because the trefoil knot is so famous, and because we are going in this subsection to discuss some details of organizing a larger calculation in Mathematica, we treat here the trefoil knot.)

If one has to solve a larger symbolic problem, the most important choice is that of an appropriate algorithm to carry out the calculation in a reasonable time and with the available memory resources. In the following, we split the main calculation into subproblems that can be carried out independently from each other (if the reader has the corresponding hardware, maybe in parallel). 
Using the function TubeFunctionalShort from Chapter 2 of the Graphics volume [1560✶] of the GuideBooks, here is a picture of the trefoil knot under consideration.

TubeFunctionalShort[
       curve_List       (* parametric representation     *),
       cp_              (* curve parameter               *),
       rr_              (* tube radius                   *),
       cpInt_List       (* domain of the curve parameter *),
       ppq_             (* PlotPoints cross section      *),
       ppl_             (* PlotPoints transversal        *),
       opts___          (* possible options for the plot *)] :=
Show[Graphics3D[Drop[MapThread[Polygon[{#1, #2, #3, #4}]&,
 {#[[1]], #[[2]], RotateRight[#[[3]]], #[[3]]}&[
  {#, RotateRight[#], Transpose[RotateRight[
   Transpose[#]]]}&[ Function[u1n,
 MapThread[Map[Function[temp, temp + #1], #2]&,
   {Function[cp, Evaluate[N[curve]]] /@ u1n,
    Partition[(Plus @@ #)& /@ Distribute[{
     Transpose[Function[{d1n, d2n},
     {(#/Sqrt[#.#])& /@ MapThread[(#2/(#1.#1) -
      (#1.#2) #1/(#1.#1)^2)&, {d1n, d2n}],
 MapThread[(Function[{t1, t2, t3, k1, k2, k3},
         {t2 k3 - t3 k2, t3 k1 - t1 k3, t1 k2 - t2 k1}] @@
          Flatten[{##}]&), {(#/Sqrt[#.#])& /@
    d1n, (#/Sqrt[#.#])& /@ MapThread[(#2/(#1.#1) -
     (#1.#2) #1/(#1.#1)^2)&, {d1n, d2n}]}]}][
  Function[cp, Evaluate[N[D[curve, cp]]]] /@ u1n,
  Function[cp, Evaluate[N[D[curve, {cp, 2}]]]] /@ u1n]],
    rr N[{Cos[#], Sin[#]}& /@
   N[Range[0, 2Pi(1 - 1/ppq), 2Pi/ppq]]]},
             List, List, List, Times], {ppq}]}]][
       N[Range[cpInt[[1]], cpInt[[2]],
       -Subtract @@ cpInt/ppl]]]]], 2], 1]], opts]

TubeFunctionalShort[
      {Sin[t] + 2 Sin[2 t], Cos[t] - 2 Cos[2 t], Sin[3 t]}
                     (* parametric representation     *),
       t             (* curve parameter               *),
       1/2           (* tube radius                   *),
       {0, 2Pi}      (* domain of the curve parameter *),
       12            (* PlotPoints cross section      *),
       100           (* PlotPoints transversal        *)]

Our trefoil knot is a tube of radius 1/2 along the space curve parametrized by {(Subscript[c, x])(t),(Subscript[c, y])(t),(Subscript[c, z])(t)}={sin(t)+2sin(2t),cos(t)-2cos(2t),sin(3t)} (a so-called canal surface [176✶]). Our goal is to find a function f(x,y,z), such that the tuboidal surface shown above is given by f(x,y,z)=0. To make use of Mathematica’s built-in function to construct such an implicit representation, we calculate a polynomial p(x,y,z) describing the above curve.

A first attempt could be to explicitly write down the parametric representation {x(s,t),y(s,t),z(s,t)} of the trefoil knot and then try to eliminate the two parametric variables s and t. Because of the normalization conditions on the normal and the binormal vectors to ensure the tube radius of 1/2, this parametrization is quite a complicated function, involving square roots of polynomials in trigonometric functions of s and t. Therefore, there seems little chance to eliminate s and t from these expressions. So we choose another approach based on the following two equations [1166✶]:

((|{x,y,z}-{(Subscript[c, x])(t),(Subscript[c, y])(t),(Subscript[c, z])(t)}|)^2)-((((1/2)))^2)=0
{((d(Subscript[c, x])(t))/(dt)),((d(Subscript[c, y])(t))/(dt)),((d(Subscript[c, z])(t))/(dt))}·({x,y,z}-{(Subscript[c, x])(t),(Subscript[c, y])(t),(Subscript[c, z])(t)})=0.

The meaning of these two equations is the following: The first equation expresses the condition that every point {x,y,z} of the tube is an element of a sphere of radius 1/2 around a point {(Subscript[c, x])(t),(Subscript[c, y])(t),(Subscript[c, z])(t)} of the space curve. The second equation ensures that the vector from the space curve point {(Subscript[c, x])(t),(Subscript[c, y])(t),(Subscript[c, z])(t)} to the point {x,y,z} of the tube is always perpendicular to the tangent at the space curve, so that a constant radius in the cross section of the tube is obtained. So, these two equations describe exactly the tube we want to implicitize. 
The advantage of this description is that now we have only one parameter, the curve parameter t, to eliminate. We do this by using rational parametrization of the trigonometric functions to transform the problem into a polynomial one. If this is done, we can use known elimination algorithms to eliminate the curve parameter. The resulting polynomial then contains the implicit representation we are looking for as some factor. (For the inverse problem—the derivation of a parametrized description from an implicit description, see [1408✶].)

There are basically two ways to implicitize equations of the above type [977✶], [1122✶]. The first possibility is to add the equation ((sin(t))^2)+((cos(t))^2)-1=0 to the equations under consideration and then to eliminate sin(x) and cos(x) from the resulting set of polynomial equations. The second possibility is to use the new variable s=tan(t/2). In this case, we keep the number of variables, but introduce fractions of polynomials. After clearing denominators (we will not care here about the zeros of the denominators; for how to take these single points into account properly, see [375✶], [391✶]), we eliminate s from the resulting equations. In the following, we choose the second way. Here, we demonstrate this method for calculating the implicit representation of a torus, making use of the built-in function Eliminate to eliminate the one variable s.

With[{c = {R Sin[t], R Cos[t], 0} (* the spine curve of a torus *)},
Factor @ (Subtract @@ (Eliminate[# == 0& /@
(({#.#&[{x, y, z} - c] - r^2, D[c, t].({x, y, z} - c)} /.
    {Cos[t] -> (1 - s^2)/(1 + s^2), Sin[t] -> 2 s/(1 + s^2)})), {s}]))]

This is the implicit representation of the torus. 
For our trefoil knot, the two equations described above are given by the following inputs.

c = {Sin[t] + 2 Sin[2t], Cos[t] - 2 Cos[2t], Sin[3t]}

{#.#&[{x, y, z} - c] - (1/2)^2, D[c, t].({x, y, z} - c)}

We express all trigonometric functions of multiple arguments in sin(t) and cos(t).

% // TrigExpand

Using rational parametrizations for sin(t) and cos(t), we get the following two polynomials in s after writing both equations over a common denominator.

% /. {Cos[t] -> (1 - s^2)/(1 + s^2), 
      Sin[t] -> 2 s/(1 + s^2)}

{p1, p2} = Numerator /@ Together /@ %

If we now eliminate s from these two polynomials, we immediately get the implicit representation of the knot we are looking for. Unfortunately, this turns out to be difficult to do. Just using Resultant[p1, p2, s] will very probably end with an Internal error: out of memory. message in Mathematica V. 4.0.

(* in Mathematica version 5 or later, carry out the following
   and skip the next inputs until the plots *)
If[$VersionNumber >= 5, 
   treFoilKnotPoly[x_, y_, z_] = 
      Factor[Resultant[p1, p2, s, Method -> Modular]]]

The reason is that calculating the resultant of two polynomials of degree 12 with symbolic coefficient is quite a large calculation. So, for a version 4.0 Mathematica, we will “by hand” split up this calculation into smaller parts. To do so, we have to choose a method for calculating the resultant. There are various possibilities, for instance, the subresultant method [1131✶], [227✶], [1149✶], [349✶], [350✶], and [1049✶] (which requires calculating greatest common divisors of multivariate polynomials, which we are not going to do here to avoid very complicated polynomial work), using Sylvester’s determinant formulation (which, as discussed in Section 1.2, results in calculating the determinant of a not sparse 24×24 matrix with symbolic entries, a very stunning task, too), or making an ansatz for the resulting polynomial in x, y, and z and determining the unknown coefficients (for instance, via interpolation [1080✶], [1081✶], [628✶]) or Cayley’s method [892✶], [1644✶], [1645✶], [696✶], and [637✶] for the resultant calculation. We choose the last one because it is conceptually very simple, without explicitly comparing its speed with the other possible methods. Further on, it results in computing the determinant of a large matrix with symbolic entries, a problem that comes up also in other contexts from time to time. In this formulation, the resultant for two polynomials (Subscript[p, 1])(s) and (Subscript[p, 2])(s) of the same degree is given as the determinant of the coefficient matrix (Subscript[c, "ij"]) of

m(s,α)=(((Subscript[p, 1])(s)(Subscript[p, 2])(α)-(Subscript[p, 1])(α)(Subscript[p, 2])(s))/(s-α))=(∑_(i,j=0)^(n-1))(Subscript[c, "ij"])(s^i)(α^j)

(which turns out to be a polynomial in s and α because the numerator contains by construction the factor s-α) with respect to s and α. 
The advantage of this formulation in comparison to the Sylvester formulation is that the resulting square matrix has only the dimension of the degree of the polynomials, although now the matrix is densely filled and the polynomials are more complicated. Let us explicitly calculate this coefficient matrix m(s,α).

m = p1 (p2 /. s -> α) - (p1 /. s -> α) p2;

mat1 = CoefficientList[#, α]& /@ CoefficientList[Cancel[m/(s - α)], s];

Short[mat1, 6]

Dimensions[mat1]

Because m(s,α) is by construction a symmetric matrix, it has only 78 different matrix elements.

mat2 = Map[Replace[#, _Integer rest_ -> rest]&, mat1, {2}];

allElems = Union[Flatten[mat2]];

Length[allElems]

This means that the “effective” dimension of the problem is around a 9×9 determinant calculation. Introducing common symbols for common matrix elements simplifies our matrix considerably.

vars = Array[ToExpression["a" <> If[# < 10, "0", ""] <>  
                         ToString[#]]&, 78];

repRules = Apply[Rule, Transpose[{allElems, vars}], {1}];

For later use, to replace occurrences of a by the explicit x-, y-, and z-dependent polynomials, we define aRules.

aRules = Dispatch[Reverse /@ repRules];

Short[aRules, 6]

So we finally have the following matrix for which we have to find its determinant.

mat3 = mat2 //. repRules

Calculating the determinant of this matrix is a large calculation, and just calling Mathematica’s Det will not give a result on most computers. Unfortunately, in comparison to many other functions from linear algebra, Det does not have a method option; so there is no way to influence Mathematica’s behavior. So we have to organize the calculation of this determinant by ourselves. Because mat3 contains only roughly one-half as many different matrix elements as there are elements, a good idea might be to use Laplace’s expansion [1012✶], [1601✶] recursively of the determinant and to look for common subdeterminants. We use lowercase det to avoid the actual calculation of the matrix. detRule carries out the expansion using the first column. (If the matrix under consideration contained some 0, we should look for the raw or column with the most occurrences 0, but unfortunately our mat3 has no 0 at all.)

minor[mat_, {column_, raw_}] := Delete[#, column]& /@ Delete[mat, raw]

detRule = det[mat_] :>
 Sum[(-1)^(1 + raw) mat[[raw, 1]] det[minor[mat, {1, raw}]],
     {raw, 1, Length[mat]}];

Because after a few steps the resulting expressions become quite large, we implement inside the function LaplaceStep a function that collects with respect to the more than once occurring subdeterminants. The function LaplaceStep returns the input with one step of Laplace’s expansion carried out on every det in the input, and as a side effect, it adds one set of replacement rules to oldCoeffsRepRules[j]. These replacement rules are the recursively defined relations of the prefactors of the subdeterminants.

LaplaceStep[expr_, j_] :=
 Module[{oldCoeffs, a0, a1, a2, a3, ar, allDets, tempVars, repRules, 
         repRulesDis, expa, res, collected, RevRepRules},
 a0 = List @@ expr;
 (* the coefficients from the input det sum *)
 oldCoeffs = a0 /. {_det -> 1};
 (* every coefficient becomes a new variable of the form B[j][k] *)
 oldCoeffsRepRules[j] = Apply[Rule, Transpose[{oldCoeffs,
                     ar = Array[B[j], Length[oldCoeffs]]}], {1}];
 (* use the abbreviated coefficients *)
 a1 = a0/oldCoeffs;
 (* reduce every det *)
 a2 = a1 /. detRule;
 (* all determinants of the input expression *)
 allDets = Union[Cases[a2, _det, {0, Infinity}]];
 (* form auxiliary variables (in the form of powers) *)
 tempVars = Array[C^(# + 2)&, Length[allDets]];
 (* for faster collecting, we use the C^i powers, 
    not the det's itself *)
 repRules = Apply[Rule, Transpose[{allDets, tempVars}], {1}];
 (* after a few iterations, we have many replacements here;
    so we dispatch the resulting list *)
 repRulesDispatched = Dispatch[Apply[Rule, 
                      Transpose[{allDets, tempVars}], {1}]];
 (* we collect with respect to the new dets *)
 a3 = a2 /. repRulesDispatched;
 a4 = a3.ar;
 expa = Expand[a4];
 res = Table[Coefficient[expa, C, i], {i, 0, Exponent[a4, C]}];
 collected = Drop[res, 3].tempVars;
 RevRepRules = Dispatch[Reverse /@ repRules];
 collected /. RevRepRules]

Here, four iterations of Laplace’s expansion are carried out on mat3.

j = 0;
σ = NestList[(j = j + 1; LaplaceStep[#, j])&, 
             det[mat3] /. detRule, 3];

At this stage, we have 495 different subdeterminants of matrices of size 8×8.

Length[Last[σ]]

The rules that recursively define the prefactors are contained in oldCoeffsRepRules.

Reverse /@ oldCoeffsRepRules[1]

Short[Reverse /@ oldCoeffsRepRules[2], 6]

Short[Reverse /@ oldCoeffsRepRules[3], 6]

Length[Union[Cases[#, _det, {0, Infinity}]]]& /@ σ

Here is the typical structure of the terms of the resulting sum; they are of the form det[…]×prefactor.

Take[Last[σ], {1, 2}]

After the threefold application of LaplaceStep, we have a sum of 495 terms.

Length[Last[σ]]

This procedure allows us to divide the calculation of the determinant of mat3 into smaller, individually manageable subproblems. Now, the question is how often do we want to iterate the application of LaplaceStep before explicitly multiplying out all occurring polynomials. To determine this, we first calculate the following.

j = 0;
σ = NestList[(j = j + 1; LaplaceStep[#, j])&, det[mat3] /. detRule, 11];

Doing this shows that the number of different dets is given by the following sequence {12, 66, 220, 495, 792, 924, 792, 495, 220, 66, 12}. The price we have to pay for increasingly smaller determinants that remain to be calculated is increasingly large prefactors of the remaining determinants, given by the information stored recursively in oldCoeffsRepRules. To find the optimal number of iterations, two things must be taken into account. The first is the time needed to explicitly calculate the individual terms of the form "prefactor""remainingDeterminant" as a function of x, y, and z by expanding the whole expression, and the second is the memory needed to store the individual expression temporarily. Just calling Det with the single 12 × 12 matrix is as inappropriate, as using LaplaceExpand 10 times to get rid of all determinants and so on and having instead only large prefactors remaining for which expansion will be very time-consuming. By analyzing the time needed to calculate a few of the terms in the remaining sum for various levels of iteration of LaplaceExpand and by assuming that these timings are representative for all terms of the whole sum, one finds the following relative timings.

({{LaplaceExpand
Iterations, Expansion
Time, Number of
Determinants, Time of Determinant Calculation/
Time of Prefactor Expansion	}, {3, 120, 495, 1500}, {4, 15, 792, 120}, {5, 2, 924, 7}, {6,  1, 792, 0.16}, {7, 7, 495,  0.003}})

This table can be calculated based on timings obtained with the following routine.

j = 0;
σ = NestList[(j = j + 1; LaplaceStep[#, j])&, det[mat3] /. detRule, 7];

Do[deterSum = σ[[λ + 1]];
   (* the prefactor definitions *)
   BRules = Dispatch[Join @@ Table[Reverse /@ oldCoeffsRepRules[i], {i, 1, λ}]];
   (* the first determinant *)
   deter = Cases[deterSum[[1]], _det][[1]];
   (* the prefactor itself *)
   preFactor = (deterSum[[1]]/deter);
   (* expand the determinant; result is a sum of products of the as *)
   timeDeter = Timing[(expDeter = Expand[deter /. det -> Det]);];
   (* replace explicit x, y, z dependent expressions for the as and expand *)
   timeDeterElementExpand = 
       Timing[(d = (Expand[Take[expDeter, 1] //. BRules //. aRules]));];
   (* expand the prefactor *)
   timePrefactorExpand = Timing[(p = Expand[preFactor //. BRules //. aRules]);];
   timeProduct = Timing[(product = Expand[d p]);];
   (* estimating the time it would take to calculate the whole expression *)
   Print[{λ, Length[deterSum] *(
            (r1 = (timeProduct[[1]] + timePrefactorExpand[[1]] + 
                   timeDeter[[1]])) +
            (r2 = (timeDeterElementExpand[[1]] Length[expDeter])))/
                   3600 hours/Second, r2/r1}], {λ, 3, 7}]

These timing considerations give a clear advantage to a fivefold iteration of LaplaceExpand. Fortunately, the resulting single determinants as well as the prefactors have a reasonable size at this level of iteration, so that we will use this level in the following. 
Now we expand the determinant and the prefactor for all 792 terms of the sum. The expansion of all 792 terms will take some minutes (around 2 seconds for every single determinant on a 2 GHz-computer) for each determinant; so the whole calculation will take quite a few hours. Each of the resulting terms will have around 3750 summands and will have a ByteCount of roughly 600 kB (resulting in file sizes of 240 kB). So from a memory point of view, we should store these intermediate expressions and not have them all at the same time in a Mathematica session (if the reader has the resources to store all expressions at the same time inside one Mathematica session, this can be done, too, of course). Here is the corresponding code.

(* all of the replacement rules we need here *)
BRules = Dispatch[Join @@ Table[Reverse /@ oldCoeffsRepRules[i], {i, 1, 6}]];
(* the expression to calculate *)
symbDeter = σ[[7]];
(* the loop for each term of the sum symbDeter *)
  Do[(* to see some progress *) Print[i];
     Module[{elem, deter, preFactor, expaDeter, d, p, product},
            elem = symbDeter[[i]];
            deter = Cases[elem, _det][[1]];
            preFactor = elem/deter;
            expaDeter = Expand[deter /. det -> Det];
            d = Expand[expaDeter //. BRules //. aRules];
            p = Expand[preFactor //. BRules //. aRules];
            product = Expand[d p];
            Save["directoryAndFileName" <> ToString[i], product];
            (* save memory *) Share[]],
     {i, 1, 792}]

After all of the 792 terms have been calculated and are now in the form of an expanded polynomial in x, y, and z, we simply sum all of the nearly three million terms we have calculated via the following inputs.

sum = 0;
Do[Get["directoryAndFileName" <> ToString[i]]; sum = sum + product, 
   {i, 1, 792}];
sum;

After factoring, we get the final result.

treFoilKnotPoly[x_, y_, z_] = Factor[sum];

For the convenience of the reader, we display the polynomial (for better line breaking, we use StandardForm here).

Let us check it.

Block[{x = -1, y = 2, z = 3}, 
  {Resultant[##, s]& @@ {p1, p2}, treFoilKnotPoly[x, y, z]}]

To make a picture of a knot, we could now use the following. Here, the resulting picture is shown.

Needs["Graphics`ContourPlot3D`"]

(* the following needs quite some time *)
ContourPlot3D[Evaluate[treFoilKnotPoly[x, y, z]],
              {x, -4, 4}, {y, -4, 4}, {z, -3/2, 3/2},
              MaxRecursion -> 1, Boxed -> False,
              PlotPoints -> {{21, 4}, {21, 4}, {13, 4}}]

We could now continue and slowly morph the knot into a ball (similar to Section 3.3 of the Graphics volume) [1569✶]. Here are the coordinate plane cross sections of such a morphing. We leave it to the reader to implement the corresponding 3D animation.

Show[GraphicsArray[Show /@ Transpose[Table[
ContourPlot[Evaluate[treFoilKnotPoly[#1, #2, #3] - 
                     (* build connections *) 10^ε],
              {#4, -5, 5}, {#5, -4, 4}, PlotPoints -> 120,
              Contours -> {0}, ContourShading -> False,
              ContourStyle -> {Hue[0.8 (ε - 55)/6]},
              DisplayFunction -> Identity, Frame -> False,
              PlotLabel -> #6 <> "-plane"]& @@@
       (* the 3 coordinate plane data *)
       {{x, y, 0, x, y, "x,y"}, {x, 0, z, x, z, "x,z"}, 
        {0, y, z, y, z, "y,z"}}, {ε, 55, 61, 1/3}]]]]

In a similar manner, one can implicitize many other surfaces, in case their parametrization is in terms of trigonometric or hyperbolic functions, for instance, the Klein bottle from Section 2.2.1 of the Graphics volume [1560✶] of the GuideBooks. Here is their implicit form together with the code for making a picture of the resulting polynomial. (For the implicitization of a “realistic looking” Klein bottle, see [1558✶].)

Needs["Graphics`ContourPlot3D`"]

Clear[x, y, z, r, φ]

Show[Graphics3D[
(* convert back from polar coordinates to Cartesian coordinates *)
Apply[{#1 Cos[#2], #1 Sin[#2], #3}&,
Cases[ContourPlot3D[Evaluate[
768 x^4 - 1024 x^5 - 128 x^6 + 512 x^7 - 80 x^8 - 64 x^9 + 16 x^10 +
144 x^2 y^2 - 768 x^3 y^2 - 136 x^4 y^2 + 896 x^5 y^2 - 183 x^6 y^2 -
176 x^7 y^2 + 52 x^8 y^2 + 400 y^4 + 256 x y^4 - 912 x^2 y^4 +
256 x^3 y^4 + 315 x^4 y^4 - 144 x^5 y^4 - 16 x^6 y^4 + 4 x^8 y^4 -
904 y^6 - 128 x y^6 + 859 x^2 y^6 - 16 x^3 y^6 - 200 x^4 y^6 +
16 x^6 y^6 + 441 y^8 + 16 x y^8 - 224 x^2 y^8 + 24 x^4 y^8 - 76 y^10 +
16 x^2 y^10 + 4 y^12 - 2784 x^3 y z + 4112 x^4 y z - 968 x^5 y z -
836 x^6 y z + 416 x^7 y z - 48 x^8 y z + 1312 x y^3 z + 2976 x^2 y^3 z -
5008 x^3 y^3 z - 12 x^4 y^3 z + 2016 x^5 y^3 z - 616 x^6 y^3 z -
64 x^7 y^3 z + 32 x^8 y^3 z - 1136 y^5 z - 4040 x y^5 z +
2484 x^2 y^5 z + 2784 x^3 y^5 z - 1560 x^4 y^5 z - 192 x^5 y^5 z +
128 x^6 y^5 z + 1660 y^7 z + 1184 x y^7 z - 1464 x^2 y^7 z -
192 x^3 y^7 z + 192 x^4 y^7 z - 472 y^9 z - 64 x y^9 z + 128 x^2 y^9 z +
32 y^11 z - 752 x^4 z^2 + 1808 x^5 z^2 - 1468 x^6 z^2 + 512 x^7 z^2 -
64 x^8 z^2 + 6280 x^2 y^2 z^2 - 5728 x^3 y^2 z^2 - 4066 x^4 y^2 z^2 +
5088 x^5 y^2 z^2 - 820 x^6 y^2 z^2 - 384 x^7 y^2 z^2 + 96 x^8 y^2 z^2 -
136 y^4 z^2 - 7536 x y^4 z^2 + 112 x^2 y^4 z^2 + 8640 x^3 y^4 z^2 -
2652 x^4 y^4 z^2 - 1152 x^5 y^4 z^2 + 400 x^6 y^4 z^2 + 2710 y^6 z^2 +
4064 x y^6 z^2 - 3100 x^2 y^6 z^2 - 1152 x^3 y^6 z^2 + 624 x^4 y^6 z^2 -
1204 y^8 z^2 - 384 x y^8 z^2 + 432 x^2 y^8 z^2 + 112 y^10 z^2 +
3896 x^3 y z^3 - 7108 x^4 y z^3 + 3072 x^5 y z^3 + 768 x^6 y z^3 -
768 x^7 y z^3 + 128 x^8 y z^3 - 3272 x y^3 z^3 - 4936 x^2 y^3 z^3 +
8704 x^3 y^3 z^3 - 80 x^4 y^3 z^3 - 2496 x^5 y^3 z^3 + 608 x^6 y^3 z^3 +
2172 y^5 z^3 + 5632 x y^5 z^3 - 2464 x^2 y^5 z^3 - 2688 x^3 y^5 z^3 +
1056 x^4 y^5 z^3 - 1616 y^7 z^3 - 960 x y^7 z^3 + 800 x^2 y^7 z^3 +
224 y^9 z^3 + 752 x^4 z^4 - 1792 x^5 z^4 + 1472 x^6 z^4 - 512 x^7 z^4 +
64 x^8 z^4 - 3031 x^2 y^2 z^4 + 1936 x^3 y^2 z^4 + 2700 x^4 y^2 z^4 -
2304 x^5 y^2 z^4 + 448 x^6 y^2 z^4 + 697 y^4 z^4 + 3728 x y^4 z^4 +
24 x^2 y^4 z^4 - 3072 x^3 y^4 z^4 + 984 x^4 y^4 z^4 - 1204 y^6 z^4 -
1280 x y^6 z^4 + 880 x^2 y^6 z^4 + 280 y^8 z^4 - 800 x^3 y z^5 +
1488 x^4 y z^5 - 768 x^5 y z^5 + 128 x^6 y z^5 + 992 x y^3 z^5 +
1016 x^2 y^3 z^5 - 1728 x^3 y^3 z^5 + 480 x^4 y^3 z^5 - 472 y^5 z^5 -
960 x y^5 z^5 + 576 x^2 y^5 z^5 + 224 y^7 z^5 + 16 x^4 z^6 +
388 x^2 y^2 z^6 - 384 x^3 y^2 z^6 + 96 x^4 y^2 z^6 - 76 y^4 z^6 -
384 x y^4 z^6 + 208 x^2 y^4 z^6 + 112 y^6 z^6 - 64 x y^3 z^7 +
32 x^2 y^3 z^7 + 32 y^5 z^7 + 4 y^4 z^8 /.
 (* to polar coordinates *)  {x -> r Cos[φ], y -> r Sin[φ]}],
{r, 0.6, 3.3}, {φ, 0, 2Pi}, {z, -1.3, 1.3}, PlotPoints -> {18, 40, 24},
MaxRecursion -> 0, DisplayFunction -> Identity], _Polygon, Infinity], {-2}]]]

For more on the subject of implicitization of surfaces, see [1080✶], [315✶], and [1427✶] and references cited therein.

We end with another implicit surface originating from a trefoil knot. Starting with a parametrized space curve c(t), we construct the parametrized surface (c(t+α/2)+c(t+α/2))/α (the average of two symmetrically located points with respect to t). The following code calculates the implicit form of this surface for the trefoil knot. We use the function Resultant to eliminate the parametrization variables. For brevity, we express the resulting surface in cylindrical coordinates.

(* a function to convert from trigonometric to polynomial variables *)
ℱ[expr_] := Numerator[Together[TrigToExp[expr] /. 
                                {t -> Log[T]/I, α -> Log[Α]/I}]]
(* make algebraic form of average *)
cAv = ((c /. t -> t + α) + (c /. t -> t - α))/2
cAvAlg = ℱ[{x, y, z} - cAv]/{I, 1, I}
(* eliminate parametrization variables *)
res1 = Resultant[cAvAlg[[1]], cAvAlg[[2]], Α] // Factor
res2 = Resultant[cAvAlg[[1]], cAvAlg[[3]], Α] // Factor
res3 = Resultant[res1[[-1]] /. T -> Sqrt[T2],  
                 res2[[-1, 1]] /. T -> Sqrt[T2], T2,
                 Method -> SylvesterMatrix];
(* express implicit form of surface in cylindrical coordinates *)
cAvImpl  = Factor[res3][[3, 1]] /. 
                 {x -> r Cos[φ], y -> r Sin[φ]} // FullSimplify

cAvImpl = r^6 (2 + r) (r - 2) (1 - 44 r^2 + 64 r^4) + 
 24 r^4 (-12 - 3 r^2 + 80 r^4) z^2 - 
 128 r^2 (-123 + 36 r^2 + 64 r^4) z^4 - 8192 z^6 + 
 r^3 (2 z (993 r^4 - 80 r^6 - 4144 z^2 + 8192 z^4 + 
 r^2 (84 - 5760 z^2)) Cos[3 φ] + r^3 (-4 + 177 r^2 - 300 r^4 + 64 r^6 - 
                 32 (-109 + 48 r^2) z^2) Cos[6 φ] - 64 r^6 z Cos[9 φ] - 
 16 (3 r^6 (-4 + r^2) + 2 r^2 (69 - 114 r^2 + 64 r^4) z^2 - 
                                        256 (-2 + 3 r^2) z^4) Sin[3 φ] + 
 4 r^3 z (157 - 174 r^2 + 512 z^2) Sin[6 φ] - 48 r^6 (-4 + r^2) Sin[9 φ]);

Needs["Graphics`ContourPlot3D`"]

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

The next pair of graphics show the parametrized and the implicit version of this surface. We make use of the threefold rotational symmetry of the surface in the generation of the implicit plot.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity, polysCart,
       ℛ = {{-1, Sqrt[3], 0}, {-Sqrt[3], -1, 0}, {0, 0, 2}}/2.},
{(* the parametrized 3D plot *)
 ParametricPlot3D[Evaluate[Append[
   ((c /. t -> t + α) + (c /. t -> t - α))/2,
   {EdgeForm[], SurfaceColor[#, #, 3]&[Hue[(t + Pi)/(2Pi)]]}]],
                     {t, -Pi, Pi}, {α, 0, Pi/2}, Axes -> False,
                      PlotPoints -> {64, 32}, BoxRatios -> {1, 1, 0.6}, 
                      PlotRange -> {{-3, 3}, {-3, 3}, {-1, 1}}] /.
                      p_Polygon :> makeHole[p, 0.76],
 (* the implicit 3D plot; use symmetry *)                       
 polysCart = Apply[{#1 Cos[#2], #1 Sin[#2], #3}&, 
  Cases[(* contour plot in cylindrical coordinates *)
  ContourPlot3D[cAvImpl, {r, 0, 3}, {φ, -Pi/3, Pi/3}, {z, -1, 1},
                   PlotPoints -> {28, 24, 32}, MaxRecursion -> 0], 
                         _Polygon, Infinity], {-2}];
 Graphics3D[{EdgeForm[], (* generate all three parts of the surface *)
    {polysCart, Map[  ℛ.#&, polysCart, {-2}], 
                Map[ℛ.ℛ.#&, polysCart, {-2}]}} /.
     p_Polygon :> {SurfaceColor[#, #, 2.4]&[
                   Hue[Sqrt[#.#]&[0.24 Plus @@ p[[1]]/Length[p[[1]]]]]], 
                      makeHole[p, 0.72]}, BoxRatios -> {1, 1, 0.6}]}]]]

Get[ToFileName[ReplacePart[
            "FileName" /. NotebookInformation[EvaluationNotebook[]],
            "ChapterOverview.m", 2]]];

ChapterOverview["Symbolics", 1]

a) Program a function which finds all i for which numbers other than 0 or ±1 appear as coefficients of (x^j) (0≤j≤i) in the factorized decomposition of (x^j)-1 (1≤i≤500) [529✶]. Do not use temporary variables (no Block or Module constructions).

b) Let (Subscript[P, 1]), (Subscript[P, 2]), and (Subscript[P, 3]) be three points in the plane. Starting from the formula A=|((Subscript[P, 2])-(Subscript[P, 1]))×((Subscript[P, 3])-(Subscript[P, 1]))|/2 for the area A of the triangle formed by (Subscript[P, 1]), (Subscript[P, 2]), and (Subscript[P, 3]), derive a formula for the area which only contains the lengths of the three sides of the triangle (Heron’s area formula).

c) Let (Subscript[P, 1]), (Subscript[P, 2]), (Subscript[P, 3]), and (Subscript[P, 4]) be four points in (("ℝ")^3). Starting from the formula V=("areaOfOneFace" "height"/3) for the volume V of the tetrahedron formed by (Subscript[P, 1]), (Subscript[P, 2]), (Subscript[P, 3]), and (Subscript[P, 4]), derive a formula for the volume which only contains the lengths of the six edges of the tetrahedron [760✶].

d) Given are three circles in the plane that touch each other pairwise. In the “middle” between these three circles now put a fourth circle which touches each of the three others. Calculate the radius of this circle as an explicit function of the radius of the three other circles (see [1459✶], [377✶], [140✶], [1508✶], [758✶], and [624✶]).

e) Calculate the differential equation that governs all circles in the x,y-plane (from I.I.5.6 of [813✶]).

f) Show that the three equations

(u^4)-((v(u))^4)-2 u v(u) (1-(u^2) ((v(u))^2))=0
(u^6)-((v(u))^6)+5 ((v(u))^2)(u^2) ((u^2)-((v(u))^2)) -4 u v(u) (1-(u^4) ((v(u))^4))=0
(1-(u^8)) (1-((v(u))^8))-(((1-u v(u)))^8)=0

are solutions of the (so-called modular) differential equation [1294✶]

((((((1+(k^2))/(k-(k^3)))))^2)-(((((1+l)/(l-(l^3)))))^2)((l'(k))^2)) ((l'(k))^2)+3 ((l''(k))^2)-2 l'(k) l'''(k)=0.

The change of variables between {k,l} and {u,v} is given by (k^(1/4))=u and (l^(1/4))=v.

g) The function

w(x)=(Subscript[c, 1]) (e^(-∫((f(x))/(1-h(x)))dx)) ((Subscript[c, 2])+∫((e^(∫g(x)dx+∫((f(x))/(1-h(x)))dx))/(1-h(x)))dx)

fulfills a linear second-order differential equation [629✶]. Derive this differential equation.

h) Prove the following two identities (from [1659✶] and [814✶]):

tan((1/4) (tan^(-1))(4))=2 (cos(((6 π)/17))+cos(((10 π)/17)))
cos((π/7))=(1/6)+ ((Sqrt[7])/6) (cos((1/3) (cos^(-1))((1/(2 (Sqrt[7])))))+(Sqrt[3]) sin((1/3) (cos^(-1))((1/(2 (Sqrt[7]))))))

i) Given a rectangular box of size (Subscript[w, 1])×(Subscript[h, 1])×(Subscript[d, 1]). Is it possible to put a second box of size (Subscript[w, 2])×(Subscript[h, 2])×(Subscript[d, 2]) in the first one such that 1/(Subscript[w, 2])+1/(Subscript[h, 2])+1/(Subscript[d, 2]) is equal to, less than, or greater than (Subscript[w, 1])+(Subscript[h, 1])+(Subscript[d, 1])?

j) What geometric object is described by the following three inequalities?

|ϕ x|+|y|<1 ∧ |ϕ y|+|z|<1 ∧ |x|+|ϕ z|<1

(ϕ is the Golden ratio.)

k) Check the following integral identity [971✶]:

(∫_0^ξ)((((∫_x^∞)((f(t))/t)dt))^2)dx=(∫_0^ξ)((((1/x)(∫_0^x)f(t)dt))^2)dx+((((Sqrt[ξ])(∫_ξ^∞)((f(t))/t)dt +(1/(Sqrt[ξ]))(∫_0^ξ)f(t)dt))^2).

l) Check the following identity [1717✶] for small integer n and r:

(∑_(k=1)^n)((p((Subscript[a, k])))/((((x-(Subscript[a, k])))^(r+1)) (∏_(l(Underscript[=, l≠k])1)^n)((Subscript[a, k])-(Subscript[a, l]))))=(((((-1))^r) )/(r! (∏_(k=1)^n)(x-(Subscript[a, k]))))(Derivative[r][p](x)+(∑_(j=1)^r)(((-1))^j) (({{r}, {j}})) Derivative[r-j][p](x) A((∑_(i=1)^n)(((x-(Subscript[a, i])))^(-1)),(∑_(i=1)^n)(((x-(Subscript[a, i])))^(-2)),…,(∑_(i=1)^n)(((x-(Subscript[a, i])))^(-j))))

Here p(z) is a polynomial of degree equal to or less than n; the (Subscript[a, k]) are arbitrary complex numbers and the multivariate polynomials A((Subscript[τ, 1]),…,(Subscript[τ, j])) are defined through

A((Subscript[τ, 1]),(Subscript[τ, 2]),…,(Subscript[τ, j]))=(∑_(Underscript[(Subscript[k, 1]),(Subscript[k, 2]),…,(Subscript[k, j]), (Subscript[k, 1])+2(Subscript[k, 2])+⋯+j (Subscript[k, j])=j]))((j!)/((Subscript[k, 1])!(Subscript[k, 2])!⋯ (Subscript[k, j])!))(((((Subscript[τ, 1])/1)))^(Subscript[k, 1]))(((((Subscript[τ, 2])/2)))^(Subscript[k, 2]))⋯ (((((Subscript[τ, j])/j)))^(Subscript[k, j])).

m) Given five points in (ℝ^2), find all relations between the oriented areas (calculated, say, with the determinantal formula from Subsection 1.9.2) of the nine triangles that one can form using the points.

n) Is it possible to position six points (Subscript[P, 1]),…,(Subscript[P, 6]) in the plane in such a way that they have the following integer distances between them [734✶]?

({{ , (Subscript[P, 1]), (Subscript[P, 2]), (Subscript[P, 3]), (Subscript[P, 4]), (Subscript[P, 5]), (Subscript[P, 6])}, {(Subscript[P, 1]), 0, 87, 158, 170, 127, 68}, {(Subscript[P, 2]), 87, 0, 85, 127, 136, 131}, {(Subscript[P, 3]), 158, 85, 0, 68, 131, 174}, {(Subscript[P, 4]), 170, 127, 68, 0, 87, 158}, {(Subscript[P, 5]), 127, 136, 131, 87, 0, 85}, {(Subscript[P, 6]), 68, 131, 174, 158, 85, 0}})

o) Show that there are no 3×3 Hadamard matrices [69✶], [1686✶], [612✶]. (An n×n Hadamard matrix (Subscript[H, n]) is a matrix with elements ±1 that fulfills (Subscript[H, n]).(Subscript[H, n]^T)=n (Subscript[1, n]).)

p) The two-point Taylor series of order for a function f(z) analytic in (Subscript[z, 1]), (Subscript[z, 2]) is defined through [1054✶]

f(z)=(∑_(n=0)^o)((Subscript[𝒸, n])((Subscript[z, 1]),(Subscript[z, 2]))(z-(Subscript[z, 1])) +(Subscript[𝒸, n])((Subscript[z, 2]),(Subscript[z, 1]))(z-(Subscript[z, 2])) ) (((z-(Subscript[z, 1])))^n) (((z-(Subscript[z, 2])))^n)+(Subscript[R, o+1])(z,(Subscript[z, 1]),(Subscript[z, 2])).

Here (Subscript[R, o+1])(z,(Subscript[z, 1]),(Subscript[z, 2])) is the remainder term and the coefficients (Subscript[𝒸, n])((Subscript[z, 1]),(Subscript[z, 2])) are given as

(Subscript[𝒸, 0])((Subscript[z, 1]),(Subscript[z, 2]))=((f((Subscript[z, 2])))/((Subscript[z, 2])-(Subscript[z, 1])))
(Subscript[𝒸, n])((Subscript[z, 1]),(Subscript[z, 2]))=(∑_(k=0)^n)(((k+n-1)!)/(k! n! (n-k)!))(( (((-1))^k) k Derivative[n-k][f]((Subscript[z, 1]))+(((-1))^(n+1)) n Derivative[n-k][f]((Subscript[z, 2])))/((((Subscript[z, 1])-(Subscript[z, 2])))^(k+n+1))).

Calculate the two-point Taylor series (Subscript[𝒯, 0,2π]^((20)))[sin](z) of order 20 for f(z)=sin(z), (Subscript[z, 1])=0, and (Subscript[z, 2])=2π. Find (max_((Subscript[z, 1])≤z≤(Subscript[z, 2])))|f(z)-(Subscript[𝒯, 20])(z)|.

q) While for a smooth function y(x), the relation  dy(x)/dx=1/(dx(y)/dy) holds; the generalization ((d)^n)y(x)/d(x^n)=1/(((d)^n)x(y)/d(y^n)) for n≥2 in general does not hold. Find functions y(x) such that the generalization holds for n=2 [222✶]. Can you find one for n=3?

r) Define a function (similar to the built-in function D) that implements the quotential derivatives (𝔮^n)./𝔮(x^n) of a function f(x) defined recursively by [1168✶]

(((𝔮^n)f(x))/(𝔡(x^n)))=(𝔮/(𝔮x))((((𝔮^(n-1))f(x))/(𝔡(x^(n-1)))))

with the first quotential derivatives 𝔮./𝔮x defined as

(((𝔮^1)f(x))/(𝔮(x^1)))=((𝔮f(x))/(𝔮x))=(lim_(q->1))ln(((f(q x))/(f(x)))).

Show that 𝔮f(y(x))/𝔮x=𝔮f(y(x))/𝔮y  𝔮y(x)/𝔮x.
Define the multivariate quotential derivative recursively starting with the rightmost ones, meaning

(((𝔮^2)f(x,y))/(𝔮x 𝔮y))=(𝔮/(𝔮x))(((𝔮f(x,y))/(𝔮y))).

Show by explicit calculation that

((𝔮f(x,y))/(𝔮y))(((𝔮^2)f(x,y))/(𝔮x 𝔮y))=((𝔮f(x,y))/(𝔮x))(((𝔮^2)f(x,y))/(𝔮y 𝔮x)).

s) Conjecture the value of the following sum: (∑_(k=1)^∞)((∏_(j=1)^k)(Subscript[a, j-1])/(x+(Subscript[a, j]))). Here (Subscript[a, 0])=1, (Subscript[a, k])∈ℂ, (Subscript[a, k])≠0, x≠0 [1477✶].

a) Given a polynomial p(x), rewrite it in Horner’s form.

b) Bernoulli polynomials (Subscript[B, n])(x) are uniquely characterized by the property (∫_x^(x+1))(Subscript[B, n])(t)"dt"=(x^n). Use this method to implement the calculation of Bernoulli polynomials (Subscript[B, n])(x). Try to use only built-in variables (with the exception of x and n, of course).

c) Given the polynomial (x^4)+(Subscript[a, 3])(x^3)+(Subscript[a, 2])(x^2)+(Subscript[a, 1])x+(Subscript[a, 0]) with zeros (Subscript[x, 1]), (Subscript[x, 2]), (Subscript[x, 3]), and (Subscript[x, 4]), calculate the coefficients (as functions of (Subscript[a, 0]), (Subscript[a, 1]), (Subscript[a, 2]), and (Subscript[a, 3])) of a polynomial that has the zeros (Subscript[x, 1]^2), (Subscript[x, 2]^2), (Subscript[x, 3]^2), and (Subscript[x, 4]^2).

d) Express the real zeros of

-1+x+2(Sqrt[1+(x^2)])-3((1+(x^3))^(1/3))+5((1+(x^5))^(1/5))-4=0

as the zeros of a polynomial.

e) Show that all nontrivial solutions of (x^10)+11 (x^5)-1=0 stay invariant under the following 60 substitutions:

x⟶(ϵ^i) x
x⟶-((ϵ^i)/x)
x⟶(((ϵ^j) ((ϵ^i)+x ((ϵ^4)+ϵ)))/(x-(ϵ^i) ((ϵ^4)+ϵ)))
x⟶-(((ϵ^j) (x-(ϵ^i) ((ϵ^4)+ϵ)))/((ϵ^i)+x ((ϵ^4)+ϵ)))

f) Iterated exponentials exp((Subscript[c, 1])z exp((Subscript[c, 2])z exp((Subscript[c, 3])z ⋯))) can be used to approximate functions [878✶], [1699✶], [1700✶], [43✶]. Find values for (Subscript[c, 1]), (Subscript[c, 2]), …, (Subscript[c, 10]) such that exp((Subscript[c, 1])z exp((Subscript[c, 2])z exp((Subscript[c, 3])z ⋯))) approximates the function 1+ln(1+z) around z=0 as best as possible.

g) Motivate symbolically the result of the following input.

m = Table[1/(i + j + 1), {i, 5}, {j, 5}];

FixedPoint[(# + Inverse[#])/2&, N[m], 100]

h) Efficiently calculate the list of coefficients of the polynomial

((((x^4)+(x^3)+(x^2)+x+1))^500)((((x^2)+x+1))^1000)(((x+1))^2000)

without making use of any polynomial function like Expand, Coefficient, CoefficientList, ….

i) What is the minimal distance between the roots of (z^3)+(c^2)z+1=0 for real c?

j) Let (f^((k)))(z)=f((f^((k-1)))(z)), (f^((1)))(z)=f(z)=(z^2)-c. Then the following remarkable identity holds [1034✶], [105✶]:

exp(-(∑_(k=1)^∞)(Subscript[c, k])((z^k)/k))=1+(∑_(k=1)^∞)(((((z/2)))^k)/((∏_(j=1)^k)(f^((j)))(0)))

where

(Subscript[c, k])=(∑_(j=1)^(2^k))(1/((f^((k)′))((Subscript[z, j]))((f^((k)′))((Subscript[z, j]))-1))).

The sum appearing in the definition of the (Subscript[c, k]) extends over all (2^k) roots of (f^((k)))(z)=z. Expand both sides of the identity in a series around z=0 and check the equality of the terms up to order (z^4) explicitly.

k) Write a one-liner that, for a given integer m, quickly calculates the matrix of values

(Subscript[c, e,d])=(lim_(x->0))(((∂^d)((((x/(sin(x)))))^e))/(∂(x^d)))

for 1≤e≤m, 0≤d≤m.

l) The Appell–Nielsen polynomials (Subscript[p, n])(z) are defined through the recursion (Subscript[p, n]^′)(z)=(Subscript[p, n-1])(z), the symmetry constraint (Subscript[p, n])(z)=(((-1))^n)(Subscript[p, n])(-z-1), and the initial condition (Subscript[p, 0])(z)=1 [291✶], [1207✶]. Write a one-liner that calculates the first n Appell–Nielsen polynomials. Visualize the polynomials.

m) Write a one-liner that uses Integrate (instead of the typically used D) to derive the first n terms of the Taylor expansion of a function f around x that is based on the following identity [655✶], [497✶]

f(x+h)=(∑_(k=0)^(n-1))((h^k)/(k!))(f^((k)))(x)+(∫_0^h) (∫_0^(Subscript[h, 1])) ⋯(∫_0^(Subscript[h, n-1]))Derivative[n][f](x+(Subscript[h, n]))d(Subscript[h, n])… d(Subscript[h, 2])d(Subscript[h, 1]).

n) A generalization of the classical Taylor expansion of a function f(x) around a point (Subscript[x, 0]) into functions (Subscript[φ, k])(x), k=0,1,…,n (where the (Subscript[φ, k])(x) might be other functions that the monomials (x^k)) can be written as [1660✶]

f(x)≈-(1/(W((Subscript[φ, 0])((Subscript[x, 0])),…,(Subscript[φ, n])((Subscript[x, 0])))))|(({{0, (Subscript[φ, 0])(x), (Subscript[φ, 1])(x), ⋯, (Subscript[φ, n])(x)}, {f((Subscript[x, 0])), (Subscript[φ, 0])((Subscript[x, 0])), (Subscript[φ, 1])((Subscript[x, 0])), ⋯, (Subscript[φ, n])((Subscript[x, 0]))}, {f'((Subscript[x, 0])), (Subscript[φ, 0]^′)((Subscript[x, 0])), (Subscript[φ, 1]^′)((Subscript[x, 0])), ⋯, (Subscript[φ, n]^′)((Subscript[x, 0]))}, {⋮, ⋮, ⋮, ⋱, ⋮}, {(f^((n)))((Subscript[x, 0])), (Subscript[φ, 0]^((n)))((Subscript[x, 0])), (Subscript[φ, 1]^((n)))((Subscript[x, 0])), ⋯, (Subscript[φ, n]^((n)))((Subscript[x, 0]))}}))|.

Here the W((Subscript[φ, 0])(ξ),…,(Subscript[φ, n])(ξ)) is the Wronskian of the (Subscript[φ, 0])(ξ), …, (Subscript[φ, n])(ξ) and it is assumed not to vanish at (Subscript[x, 0]). Implement this approximation and approximate f(x)=cos(x) around (Subscript[x, 0])=0 through exp(x), exp(x/2), …, exp(x/m). Can this formula be used for m=25?

o) Show that the function [1101✶]

w(z)=(((((((𝓊(z)+2 z 𝓊'(z)))^2)-4 z ((𝓊'(z))^2)))^2)/(8 (𝓊(z) 𝓊'(z) (𝓊(z)+2 (z-1) 𝓊'(z)) (𝓊(z)+2 z 𝓊'(z)))))

where 𝓊(z)=(Subscript[c, 1])(Subscript[𝒻, 1])(z)+(Subscript[c , 2])(Subscript[𝒻, 2])(z) and (Subscript[f, 1,2])(z) are solutions of (1-z) z 𝒻''(z)+(1-2 z) 𝒻'(z)-f(z)/4=0 fulfills the following special case of the Painlevé VI equation:

w''(z)=(1/2) ((1/(w(z)))+(1/(w(z)-1))+(1/(w(z)-z))) ((w'(z))^2)-((1/z)+(1/(z-1))+(1/(w(z)-z))) w'(z)+
        ((w(z)(w(z)-1)  (w(z)-z) )/(2 (((z-1))^2) (z^2)))((( z(z-1))/(((w(z)-z))^2))+4).

a) Given that the following definition is plugged into Mathematica, what will be the result of f[2][x]?

f[n_][x_] := Integrate[f[n - 1][x - z], {z, 0, x}]
f[0][x_] = Exp[-x];

Consider the evaluation process. How would one change the first two inputs to get the “correct” result as if from

Nest[Integrate[# /. {x -> x - z}, {z, 0, x}]&, Exp[-x], 2]

b) Find two (univariate) functions f and g, such that Integrate[f, x] + Integrate[g, x] gives a different result than does Integrate[f + g, x]. Find a (univariate) functions f and integration limits (Subscript[x, l]), (Subscript[x, m]), and (Subscript[x, u]), such that Integrate[f, {x, (Subscript[x, l]), (Subscript[x, u])}] gives a different result than does Integrate[f, {x, (Subscript[x, l]), (Subscript[x, m])}] + Integrate[f, {x, (Subscript[x, m]), (Subscript[x, u])}].

c) What does the following code do?

Derivative[i_Integer?Negative][f_] :=
With[{pI = Integrate[f[C], C]},
      derivative[i + 1][Function[pI] /. C -> #] /;
                               FreeQ[pI, Integrate, {0, Infinity}]]

Predict the results of Derivative[+4][Exp[1 #]&] and Derivative[-4][Exp[1 #]&].

d) Is it possible to find a function f(x,y) such that D[Integrate[f(x, y), x], y] is different from Integrate[D[f(x, y), y], x]?

e) Write a function PowerFactor that does the “reverse” of the function PowerExpand. It should convert products of radicals into one radical with the base having integer powers. It should also convert sums of logarithms into one logarithm and s log(a) into log((a^s)).

f) The rational solutions of w''(z)=2 ((w(z))^3)-4 z w(z)+4 k, k∈(SuperPlus[ℕ]) (a special Painlevé II equation) can be expressed in the following way [879✶], [826✶], [1095✶]:
Let the polynomials (Subscript[q, k])(z) be defined by the generating function (∑_(k=0)^∞)(Subscript[q, k])(z)(ξ^k)=exp(z ξ +(ξ^3)/3) (for k<0, let (Subscript[q, k])(z)=0).
Let the determinants (Subscript[σ, k])(z) be defined by matrices (Subscript[((Subscript[a, i j])), 0≤i,j≤k-1]) with (Subscript[a, i j])=(Subscript[q, k+i-2j])(z) (for k=0, let (Subscript[σ, 0])(z)=1). Then, (Subscript[w, k])(z) is given as (Subscript[w, n])(z)=∂log((Subscript[σ, k+1])(z)/(Subscript[σ, k])(z))/∂z. Calculate the first few (Subscript[w, k])(z) explicitly.

Let (Subscript[y, 1])(z) and (Subscript[y, 2])(z) be two linear independent solutions of

y''(z)+f(z)y'(z)+g(z)y(z)=0

The product u(z)=(Subscript[y, 1])(z)(Subscript[y, 2])(z) obeys a linear third-order differential equation

u'''(z)+(Subscript[a, p])[f(z),g(z)]u''(z)+(Subscript[b, p])[f(z),g(z)]u'(z)+(Subscript[c, p])[f(z),g(z)]u(z)=0

The quotient w(z)=(Subscript[y, 1])(z)/(Subscript[y, 2])(z) obeys (Schwarz’s differential operator, see, for instance, [766✶] and [1723✶])

w'''(z)w'(z)+(Subscript[a, q])[f(z),g(z)]((w''(z))^2)+(Subscript[b, q])[f(z),g(z)]((w'(z))^2)=0

Calculate (Subscript[a, p]),(Subscript[b, p]),(Subscript[c, p]) and (Subscript[a, q]),(Subscript[b, q]). (For analogous equations for the solutions of higher-order differential equations, see [933✶].)

a) First-order ordinary differential equations of the form y'(x)=P(x,y)/Q(x,y) possess singular points {(Subscript[x, i]^( * )),(Subscript[y, i]^( * ))} [196✶], [1261✶], [1570✶], [1008✶], [421✶], [862✶]. These are defined by P((Subscript[x, i]^( * )),(Subscript[y, i]^( * )))=Q((Subscript[x, i]^( * )),(Subscript[y, i]^( * )))=0. It is possible to trace the typical form of the solution curves in the neighborhood of a singular point by solving y'(x)=("a x"+"b y")/("c x"+"d y"). Some typical forms include the following examples:

({{"a knot point  ", y'(x)=((2y(x))/x),  y'(x)=((y(x)+x)/x),  y'(x)=((y(x))/x) }, {"a vortex point", y'(x)=-((y(x))/x)}, {"an eddy point", y'(x)=((y(x)-x)/(y(x)+x)).}})

Investigate which of the given differential equations can be solved analytically by Mathematica, and plot the behavior of the solution curves in a neighborhood of the singular point {0,0}.

b) Consider the general case (meaning λ is a regular value) of the Fredholm integral equation of the second kind

y(x)-λ (∫_a^b)𝒦(x,ξ) y(ξ) dξ=f(x)

with a separable kernel (meaning 𝒦(x,ξ)  can be written in the form 𝒦(x,ξ)=(∑_(j=1)^n)(Subscript[g, j])(x)(Subscript[h, j])(ξ)). Implement a function that solves such Fredholm integral equations in the classical manner, by forming and solving a linear system in the (Subscript[r, j])=(∫_a^b)(Subscript[h, j])(ξ)y(ξ)=(∫_a^b)(Subscript[h, j])(x)y(x).

The solution y(x) can be written in the form y(x)=f(x)+λ (∫_a^b)Γ(x,ξ) f(ξ) dξ with the resolvent kernel Γ(x,ξ) .
Implement a function that calculates the truncated form of the Fredholm resolvent [1458✶], [1283✶], [1309✶], [1702✶], [1006✶], [563✶]

(Γ^F)(x,ξ) =((D(x,ξ;λ))/(D(λ)))

D(x,ξ;λ)=(∑_(k=0)^∞)((((-1))^k)/(k!))(λ^k)(Subscript[d, k])(x,ξ),    D(λ)=(∑_(k=0)^∞)((((-1))^k)/(k!))(λ^k)(Subscript[c, k]).

where the (Subscript[c, k]) and (Subscript[d, k])(x,ξ) are recursively defined through

(Subscript[c, 0])=1,     (Subscript[c, k])=(∫_a^b)(Subscript[d, k-1])(ξ,ξ) dξ
(Subscript[d, 0])(ξ,ξ)=𝒦(ξ,ξ) ,     (Subscript[d, k])(x,ξ)= (Subscript[c, k])𝒦(x,ξ)-k(∫_a^b)𝒦(x,ρ) (Subscript[d, k-1])(ρ,ξ)dρ.

Finally, implement a function that calculates a truncated form of the Neumann form of the resolvent (valid for a limited set of λ) that utilizes iterated kernels.

(Γ^N)(x,ξ) =(∑_(k=1)^∞)(λ^k)(Subscript[𝒦, n])(x,ξ)

(Subscript[𝒦, 1])(x,ξ)=𝒦(x,ξ),     (Subscript[𝒦, n])(x,ξ)=(∫_a^b)𝒦(x,ρ) (Subscript[𝒦, n-1])(ρ,ξ)dρ.

Use the implemented functions to solve the equation y(x)-λ (∫_0^1)sin(x+ξ) y(ξ)dξ=cos(x) exactly and up to O((λ^5)).

a) In recent years, so-called “inverse problems” have assumed an increasingly important role (see, e.g., [290✶], [699✶], [647✶], [1704✶], [1372✶], [80✶], and [146✶]). Very roughly speaking, they are as follows: For a given result, find the associated problem that led to the result. For Sturm–Liouville eigenvalue problems

-y''(x)+v(x)y(x)=λy(x)

with given eigenvalues (Subscript[λ, i]), the solution is completely known. We consider the following special case: Given eigenvalues (Subscript[λ, 1]),…,(Subscript[λ, n]) of the problem

-(Subscript[y, i]^(′′))(x)+v(x)(Subscript[y, i])(x)=(Subscript[λ, i])(Subscript[y, i])(x),(Subscript[y, i])(0)=0,    0≤x≤∞

find one (eigenvalue-independent) potential that leads to these eigenvalues (given only finitely many eigenvalues, of course, infinitely many solutions exist). The following method solves this problem constructively:

({{(Subscript[φ, 0])(x,λ), =((sin(λx))/λ)}, {u(Subscript[(x), "ij"]), =(Subscript[δ, "ij"])+(∫_0^x)(Subscript[φ, 0])(s,(Sqrt[(Subscript[λ, j])]))(Subscript[φ, 0])(s,(Sqrt[(Subscript[λ, i])]))"ds"    i,j=1,2,…,n}, {v(x), =-2(((d^2)ln(detU(x)))/(("dx")^2)).}})

Here, U(x) is a matrix with matrix elements (Subscript[u, i j])(x). Then, the corresponding (normalizable) eigenfunctions (Subscript[ψ, i])(x) are given by

(Subscript[ψ, i])(x)=(∑_(j=1)^n)(Subscript[u, "ij"]^(-1))(x)(Subscript[φ, 0])(x,(Sqrt[(Subscript[λ, j])]))

Implement these formulas, and for n=1, verify that the resulting v(x) and (Subscript[ψ, 1])(x) satisfy the equation

-(Subscript[ψ, 1]^(′′))(x)+v(x)(Subscript[ψ, 1])(x)=(Subscript[λ, 1])(Subscript[ψ, 1])(x)

Plot the result for n=2. For details see [1491✶], [1127✶], [1703✶], [1577✶], [771✶], [496✶], [791✶], [30✶], [1417✶], [1394✶], [1234✶], [1617✶], [367✶], [289✶], and [1301✶]. For the vector-valued version, see [306✶].

a) Implement the Graeffe method [748✶], [796✶], [1074✶], [1075✶], [1484✶] to calculate the roots of the polynomial p=(z^5)+5 (z^4)-10 (z^3)-10 (z^2)+5 z+2=0 to 100 digits. The Graeffe method calculates the polynomials

(Subscript[p, n+1])((z^2))=(Subscript[p, n])(z)(Subscript[p, n])(-z)
(Subscript[p, 0])(z)=p.

The distinct real roots (Subscript[z, k]) of the polynomial p of degree d are then given by

|(Subscript[z, k])|=(lim_(n->∞))((|((Subscript[a, n,k-1])/(Subscript[a, n,k]))|)^(2^(-n)))

where (Subscript[p, n+1])(z)=(∑_(k=0)^d)(Subscript[a, n,k])(z^k).

This problem is meant for readers who are familiar with the finite element method (FEM). This is not the right place to give a detailed account of the method itself. Interested readers should consult any typical FEM book, such as [336✶], [248✶], [1423✶], [72✶], [73✶], [74✶], [494✶], [119✶], [721✶], [1588✶], [28✶], and [125✶] for some computer algebra applications. For applications in physics, see, for example, [706✶], [1183✶], [964✶], [1320✶], [216✶], [756✶], [14✶], [946✶], [735✶], [1030✶], [1425✶], [13✶], and [651✶], and the references therein.

a) Suppose we are given an elliptic partial differential equation of second order in two space dimensions

(((∂^2)u(x,y))/(∂(x^2)))+(((∂^2)u(x,y))/(∂(y^2)))+λu(x,y)=f(x,y)

For most finite-element calculations, it is common to use Lagrange basis functions of the first or second order on triangles. Higher-order elements may be needed in some applications to get higher accuracy (say up to eighth order in some applications [720✶]). To carry out the calculation, we need to compute the corresponding stiffness matrices, element vectors, and, for eigenvalue problems, the corresponding mass matrices. These should be computed for the case of linear isoparametric maps of the unit triangle onto arbitrary triangles. (If this mapping is nonlinear, this will not be possible, in general, without using numerical integration.) To accomplish this, solve the following subproblems: 
◼ Compute and plot the position of the data points for Lagrange interpolation [423✶], [1045✶]. Usually, the data points are numbered as follows: The three outer vertices are given the numbers 1, 2, and 3. Now starting with vertex 1, continue in a spiral winding in the same sense as 1, 2, 3 to the center. 
◼ Compute the Lagrange shape functions of nth-order for the unit triangle. 
◼ Program a corresponding integration routine to efficiently compute integrals of the form

(∫_0^1)(∫_0^(1-ξ))(ξ^p)(η^q)dηdξ=((p! q!)/((p+q+2)))

◼ Compute the element vectors, the mass matrices, and the stiffness matrices for various orders.

b) Now consider the 1D case. The Hermite element functions (Subscript[χ, k,l]^((p,d)))(ξ) are defined through their smooth interpolation property

(((∂^n)(Subscript[χ, k,l]^((p,d)))(ξ))/(∂(ξ^n)))(Subscript[|, ξ=(Subscript[ξ, m])])=(Subscript[δ, k,m])(Subscript[δ, l,n]).

Here p+1 indicates the number of nodes in one cell and the index d indicates the order of smoothness. The two integer labels k and l range over 0≤k≤p and 0≤l≤d, and ξ runs from 0 to 1. (In most cases, one uses equidistantly spaced (Subscript[ξ, m]), meaning (Subscript[ξ, m])=m/p.)

Consider the eigenvalue problem for a harmonic oscillator [1509✶], [508✶], [1310✶], [1311✶], [1578✶]

-(Subscript[ψ, j])''(x)+(x^2)(Subscript[ψ, j])(x)=(Subscript[ε, j])(Subscript[ψ, j])(x)
ψ(-∞)=ψ(∞)=0

with the exact eigenvalues (Subscript[ε, j])=2j+1,j∈ℕ. Discretize the problem in the interval [-L,L] into e elements and use the ansatz

(Subscript[ψ, j])(x)=(∑_(j=0)^(e-1))(∑_(k=0)^p)(∑_(l=0)^d)(Subscript[c, k,l]^((j,p,d)))(Subscript[χ, k,l]^((p,d)))(ξ(x))θ(x-(Subscript[x, j]))θ((Subscript[x, j+1])-x).

Here ξ(x)=(x-(Subscript[x, j]))/δ, (Subscript[x, j])=-L+j/e δ, δ=2L/e and the Dirichlet boundary conditions enforce (Subscript[c, 0,0]^((0,p,d)))=(Subscript[c, 0,0]^((e-1,p,d)))=0. Continuity and smoothness at the left-most and right-most nodes enforces (Subscript[c, p,l]^((j,p,d)))=(Subscript[c, 0,l]^((j+1,p,d))) for 1≤j≤j-2.

Construct the algebraic eigenvalue problem corresponding to the minimization problem

(∫_(-L)^L)((((((∂(Subscript[ψ, j])(x))/(∂x))))^2)+((x^2)-(Subscript[ε, j]))(Subscript[ψ, j])(x))dx

and calculate the lowest eigenvalues. 
Is it possible to get the lowest eigenvalue correct to 20 digits with resulting matrices of dimension 64×64 or less?

The subject of finite elements contains many other opportunities for programming with Mathematica. For example, we mention algorithms for minimizing the bandwidth of sparse matrices (following, e.g., Cuthill–McKee [384✶], Gibbs–Poole–-Stockmeyer [650✶], [640✶], or Sloan [1455✶]). Because of their special nature, we do not go any further into the explicit implementation of these finite-element computations.

a) In 1933, Hylleraas and Undheim ([805✶], see also [152✶], [1157✶], [583✶], [1232✶], and [773✶]) published the results of a variational calculation [1648✶] of the ground-state ((Subscript[, 2])S state) energy (Subscript[λ, 0])((Subscript[k, min]),(Subscript[c, min])) of an (ortho) Helium atom [902✶]. Without going into the physical background (see [1126✶], or for more depth, see [153✶], [970✶], [1304✶], [934✶], [1256✶], [806✶], [741✶], [68✶], [960✶], [961✶], [1539✶], [1159✶], [664✶], [1202✶], [1233✶], [1721✶], and [1528✶], and the references therein), we present the underlying mathematical problem. 
Find the smallest zero (Subscript[λ, 0])(k,c) of the determinant of the 6×6 matrix D with elements (Subscript[D, "ij"]) defined below. (The minimum is around (Subscript[k, min])≈0.5, (Subscript[c, min])≈0.5.) The experimental value of the ground-state energy is -1.08762. How well does the calculation perform?

(Subscript[D, "ij"])=λ(Subscript[N, "ij"])(c)+k ((Subscript[L, "ij"])(c)+(Subscript[L, "ij"]^′)(c))-(k^2)(Subscript[M, "ij"])(c)
(Subscript[N, "ij"])(c)=(∫_0^∞)"ds"(∫_0^s)"du"(∫_0^u)"dt"((u((s^2)-(t^2)))/8)(Subscript[φ, i])(Subscript[φ, j])
(Subscript[L, "ij"])(c)=(∫_0^∞)"ds"(∫_0^s)"du"(∫_0^u)"dt"2s u (Subscript[φ, i])(Subscript[φ, j])
(Subscript[L, "ij"]^′)(c)=(∫_0^∞)"ds"(∫_0^s)"du"(∫_0^u)"dt"((((s^2)-(t^2)))/4)(Subscript[φ, i])(Subscript[φ, j])
(Subscript[M, "ij"])(c)=(∫_0^∞)"ds"(∫_0^s)"du"(∫_0^u)"dt"(u((s^2)-(t^2))((Subscript[φ, i,s])(Subscript[φ, j,s])+(Subscript[φ, i,t])(Subscript[φ, j,t])+(Subscript[φ, i,u])(Subscript[φ, j,u]))+
                 s((u^2)-(t^2))((Subscript[φ, i,s])(Subscript[φ, j,u])+(Subscript[φ, i,u])(Subscript[φ, j,s]))+t((s^2)-(u^2))((Subscript[φ, i,t])(Subscript[φ, j,u])+(Subscript[φ, i,u])(Subscript[φ, j,t]))).

Here are the (Subscript[φ, i])(u,s,t):

(Subscript[φ, 1])(u,s,t)=(e^(-s/2))sinh("ct"/2)
(Subscript[φ, 2])(u,s,t)=s(Subscript[φ, 1])(u,s,t)
(Subscript[φ, 3])(u,s,t)=t(e^(-s/2))cosh("ct"/2)
(Subscript[φ, 4])(u,s,t)=u(Subscript[φ, 1])(u,s,t)
(Subscript[φ, 5])(u,s,t)=u(Subscript[φ, 2])(u,s,t)
(Subscript[φ, 6])(u,s,t)=u(Subscript[φ, 3])(u,s,t).

(Subscript[φ, i,s]) is the partial derivative ∂(Subscript[φ, i])(u,s,t)/∂s, and the analogous formula holds for (Subscript[φ, i,t]) and (Subscript[φ, i,u]).

b) A possible scheme for improving variational calculations with one variational parameter is the following (see [1503✶] and [1722✶]): Given a (real) trial function (Subscript[ψ, 0])(β;x) in which β is the variational parameter, one constructs additional functions (which we take here orthonormalized) (Subscript[ψ, 1])(β;x), (Subscript[ψ, 2])(β;x), and so on (all depending on the same parameter β) via

(Subscript[ψ, i])(β;x)=((∂(Subscript[ψ, i-1])(β;x))/(∂β))
(∫_L)(Subscript[ψ, i]^2)(β;x)dx=1.

(Here, the integration extends over the range where the (Subscript[ψ, 0])(β;x) are defined.) As the trial function, it uses

Ψ(β;x)=(∑_(i=0)^n)(Subscript[c, i])(β)(Subscript[ψ, i])(β;x)

For the eigenvalue problem for a hermitian operator H, H(x)ψ(x)=ε (Subscript[ψ, i])(x), the condition for ε(β) to be the best approximation to the lowest eigenvalue becomes

det|(Subscript[H, "ij"])(β)-ε(β)(Subscript[M, "ij"])(β)|=0

Here, (Subscript[H, "ij"])(β) and (Subscript[M, "ij"])(β) (which reflects the nonorthogonality of the (Subscript[ψ, i])(β;x)) are defined as

(Subscript[H, "ij"])(β)=(∫_L)(Subscript[ψ, i])(β;x) H(x) (Subscript[ψ, j])(β;x)dx
(Subscript[M, "ij"])(β)=(∫_L)(Subscript[ψ, i])(β;x) (Subscript[ψ, j])(β;x)dx.

Carry out the above calculations for the following particular realizations of the described scheme [1722✶] in L=(-∞,∞):

H=-(1/2)((d^2)/(d(x^2)))+(1/2)(x^2)+(x^4)
(Subscript[ψ, 0])(β;x)=(Sqrt[(β/(Sqrt[π]))])(e^(-(β^2)((x^2)/2))).

Use different techniques to calculate explicit numerical values for the lowest eigenvalue for n≤6. The so-defined ε(β) has to be minimized with respect to β.

a) The standard n-dimensional spherical coordinates are defined by the following relations [1566✶], [170✶] (for nonstandard n-dimensional spherical coordinates, see [1205✶]):

({{(Subscript[x, 1]), =rcos(Subscript[ϑ, 1])}, {(Subscript[x, 2]), =rsin(Subscript[ϑ, 1])cos(Subscript[ϑ, 2])}, {(Subscript[x, 3]), =rsin(Subscript[ϑ, 1])sin(Subscript[ϑ, 2])cos(Subscript[ϑ, 3])}, {⋮, }, {(Subscript[x, "n"-1]), =rsin(Subscript[ϑ, 1])sin(Subscript[ϑ, 2])⋯ (Subscript[sinϑ, n-2])cos(Subscript[ϑ, n-1])}, {(Subscript[x, "n"]), =rsin(Subscript[ϑ, 1])sin(Subscript[ϑ, 2])⋯ (Subscript[sinϑ, n-2])sin(Subscript[ϑ, n-1]).}})

Here, the (Subscript[x, i]) are Cartesian coordinates. Compute and simplify the Jacobian of this coordinate transformation for the first n. Compare the times needed by Simplify with the times needed by manual simplification.

b) The following gives a parametric description of a family of constant negative curvature [1572✶] surfaces [1108✶] (0<c<1 is the family parameter) [1354✶], [1409✶], [1410✶], [1355✶], [1411✶].

r(u,v)={0,0,x}+((2d cosh(c x)  sin(d y) )/(c 𝒟)){sin(y),-cos(y),0}+((2 (d^2)cosh(c x)  ((cosh^2)(c x)-(sin^2)(d y)) )/(c 𝒟 (OverTilde[𝒟]))){cos(y) cos(d y),sin(y) cos(d y),-sinh(c x)}
𝒟 =(d^2) (cosh^2)(c x)+(c^2) (sin^2)(d y)
(OverTilde[𝒟]) =(cos^2)(d y) (cosh^2)(c x)+(sin^2)(d y) (sinh^2)(c x)
c=(Sqrt[1-(d^2)])
x=u+v,y=u-v

Show that r(u,v) has a constant curvature 𝒦. The curvature 𝒦 can be calculated through the following formulas.

𝒦=(1/((|n|)^2))((ℯℊ - (𝒻^2))/(ℰ 𝒢-(ℱ^2)))

ℰ=((∂r(u,v))/(∂u)).((∂r(u,v))/(∂u)),  𝒢=((∂r(u,v))/(∂v)).((∂r(u,v))/(∂v)), ℱ=((∂r(u,v))/(∂u)).((∂r(u,v))/(∂v))
ℯ=(((∂^2)r(u,v))/(∂(u^2))).n, 𝒻=(((∂^2)r(u,v))/(∂u ∂v)).n, ℊ=(((∂^2)r(u,v))/(∂(v^2))).n
n=((∂r(u,v))/(∂u))×((∂r(u,v))/(∂v))

Visualize some of the surfaces of the family.

a) Determine the optimal throw angle (optimal with respect of achieving the furthest possible throw distance) for a throw starting from a finite height h. Visualize the optimality of this angle. Calculate the envelope of all throw curves for a variable throw angle [456✶], [597✶], [94✶], [67✶], [457✶].

b) Consider a mathematical pendulum with mass m, length l, and minimum height h above the ground. Suppose during the movement of the pendulum that the string is suddenly cut. The subsequent trajectory of the mass is a parabola. Determine the angle of release φ for which the point of contact (Subscript[x, s])=w of the pendulum with the horizontal floor is farthest. Try to find an analytic solution. The horizontal distance is measured from the abscissa of the point from which the pendulum is hung, and the angle φ is measured from the vertical. The maximum angle should be less than π/2. Plot the solution.

c) Take a Platonic solid and replace all edges by springs of identical stiffness and the vertices with point masses. For small elongations, analyze the “breathing mode” (meaning all vertices move radial and in phase) of the resulting structure. How many normals modes contribute to the “breathing mode” and how does its frequency compare with other eigenmodes.

The general eigenvalue problem for a linear differential equation of second order takes the form

(Subscript[f, 2])(x)y''(x)+(Subscript[f, 1])(x)y'(x)+((Subscript[f, 0])(x)+λg(x))y(x)=0.

Often, it is useful to rewrite this eigenvalue problem in the Liouville normal form

η''(ξ)+(λ+ν(ξ))η(ξ)=0.

In this form, we can better determine the ν(ξ) for which there is an analytical solution of the problem (see [98✶], [1371✶], [1162✶], [25✶], [584✶], [1141✶], [113✶], [1190✶], [1060✶], [121✶], and [1664✶]; for multidimensional analytic solutions, see [1605✶]). This transformation is given by (we assume sufficient smoothness for the corresponding functions)

({{η(ξ), =Φ(x) y(x)}, {ξ, =ξ(x)=(∫^x)(Sqrt[((g(x))/((Subscript[f, 2])(x)))])"dx"}, {Φ(x), =(((g(x))/((Subscript[f, 2])(x)))^(1/4))exp((1/2)(∫^x)(((Subscript[f, 1])(x))/((Subscript[f, 2])(x)))"dx").}})

Determine the resulting ν(η), and implement this transformation. Try to generate error messages when the function is called with inappropriate arguments.

a) A sphere of mass M is at rest at the point {0,0}. Suppose a second sphere (of the same diameter) with velocity {(Subscript[v, x]),(Subscript[v, y])} collides with the first one in an elastic noncentral collision. Suppose the coordinates of the center of the second sphere at the time of collision are {x,y}. Compute the velocity of both spheres after of the collision, and plot their motion. Suppose the momentum, energy, and angular momentum conservation laws hold (the angular momentum law implies that no tangential forces are present).

b) Calculate a closed form of the envelope of the scaled maxima (n^(1/2))(Subscript[x, m]) of the Bernstein polynomials (Subscript[b, n,k])(x)=(∑_(k=0)^n)(({{n}, {k}}))(((x^k)(1-x))^(n-k)), 0≤k≤n as n->∞ [1062✶].

c) The eigenvectors of the Bernstein operator (Subscript[(OverHat[B]), n])

(Subscript[(OverHat[B]), n])(f(x))=(∑_(k=0)^n)(({{n}, {k}}))(((x^k)(1-x))^(n-k))f((k/n))

are polynomials of degree less than or equal to n. Find the eigenvectors for n=36 and visualize them in the interval 0≤x≤1.

a) Suppose we are given the following linear inhomogeneous system of equations [1378✶]:

({{-, 367296t, -,    43199u, +,   519436v, -,   954302w, =, 1}, {, 259718t, -, 477151u, -,   367295v, -, 1043199w, =, 1}, {, 886731t, +,    88897u, -, 1254026v, -, 1132096w, =, 1}, {, 627013t, +, 566048u, -,   886732v, +,   911103w, =, 0}})

How many digits are needed to be sure that the solution is correct to 10 digits? How sensitive to a small change of the coefficients is the solution of this system? (See also [668✶] and [1332✶].)

b) The bisector surface of two geometrical objects (points, lines, surfaces) is the set of points that have the same distance to each of the two geometrical objects [553✶], [513✶], [512✶], [552✶], [931✶], [147✶], [514✶], [1264✶], [739✶]. Calculate the implicit form of the bisector surface of a torus and a point in generic position. Visualize the bisector surface for the point at the center of the torus.

c) Construct a polynomial surface p(x,y,z)=0 that in a smooth way connects the three half-infinite cylinders [102✶], [1679✶], [565✶], [1632✶], [301✶] given by their parametric representations

{x,cos(φ),sin(φ)}        0≤φ≤2π,3≤x<∞
{cos(φ),y,sin(φ)}        0≤φ≤2π,3≤y<∞
{cos(φ),sin(φ),z}         0≤φ≤2π,3≤z<∞.

Make a picture of that part of the polynomial p(x,y,z)=0 that connects the three cylinders and the three cylinders themselves.

d) Calculate the implicit form of a polynomial surface of a double torus, such that the two holes of the double torus tightly enclose the hole of the given torus with radii r=1 and R=3, and the given torus tightly encloses the “middle bridge” of the double torus.

a) Program a function DerivativeVariableTransformation that carries out transformations of variables in expressions that contain partial derivatives. Starting with Cartesian coordinates, use it to transform Δf(x,y,z) into spherical coordinates.

b) Given the result of evaluating the following determinant. 
𝔸 = Array[𝕒, {3, 3}]; Det[MatrixExp[𝔸]]
By virtue of det((e^𝔸))=(e^(Tr𝔸)) [660✶] this simplifies to Exp[𝕒[1, 1] + 𝕒[2, 2] + 𝕒[3, 3]]. Use Mathematica to carry out this simplification.

c) Construct a one-liner that proves the matrix identity

(1/(1-λ A))=(∑_(k=0)^∞)(λ^k)(A^k)

for a generic symbolic 3×3 matrix A.

d) The differential quotient (Subscript[𝒹, ℍ])(t,𝔸) of the matrix exponential exp(t 𝔸) in (matrix) direction ℍ is defined as [1182✶], [1340✶], [1562✶], [1517✶]

(Subscript[𝒹, ℍ])(t,𝔸)=(lim_(ε->0))(((e^(t(𝔸+ε ℍ)))-(e^(t 𝔸)))/ε).

(Subscript[𝒹, ℍ])(t,𝔸) can be expressed in the following way:

(Subscript[𝒹, ℍ])(t,𝔸)=(∫_0^t)(e^((t-τ)𝔸))ℍ (e^(τ 𝔸))dτ.

For n=2, show the equivalence of the two expressions for (Subscript[𝒹, ℍ])(t,𝔸) by explicit calculation.

f) Take a generic 3×3 matrix 𝒜 and the resulting 81 matrices of size 2×2 that arise from extracting two columns and two rows from 𝒜 and the 9 matrices of size 1×1 that arise from using one columns and one row from 𝒜. Find algebraic relations that are obeyed by the determinants of these 91 matrices.

a) Often, in physics books and journals, one sees the following sum: 1+2+3+…=-1/12 [1031✶], [518✶], [168✶], [1083✶]. Motivate this finite result for this divergent sum.

b) Calculate the following expression (the order of the limits matter):

(lim_(λ->0))(lim_(m->∞))((∑_(n=0)^m)(n^3)(e^(-λn))-(∫_0^m)(x^3)(e^(-λx))"dx")

c) Consider the following formally divergent expression [1405✶], [1720✶], [207✶] (arising from the classical limit of the Casimir effect)

𝒜(l,L)=(∫_(-∞)^∞)(∫_(-∞)^∞)(∑_(n=-∞)^∞)(ln((Sqrt[(((π^2) (n^2))/(l^2))+(Subscript[k, x]^2)+(Subscript[k, y]^2)])/(Sqrt[(((π^2) (n^2))/(((L/2))^2))+(Subscript[k, x]^2)+(Subscript[k, y]^2)]))+
                               ln((Sqrt[(((π^2) (n^2))/(((L-l))^2))+(Subscript[k, x]^2)+(Subscript[k, y]^2)])/(Sqrt[(((π^2) (n^2))/(((L/2))^2))+(Subscript[k, x]^2)+(Subscript[k, y]^2)])))d(Subscript[k, x])d(Subscript[k, y]).

Find a finite result for 𝒜(l,L).

a) Implement a function (of one variable) RandomFunction that produces a random function (of a given depths n) sometimes involving trigonometric functions, sometimes power functions, sometimes trigonometric functions of power functions, …. Use such a random function to find an integral that could be done, but Mathematica is not able to do it.

b) Find at least ten functions discussed in this chapter that, when called with purely symbolic input (this means input with infinite precision), potentially make internal use of numerical techniques. Show convincingly that these functions really use approximative numbers internally.

c) Find all built-in functions for which Derivative[2][function] evaluates to a nontrivial result.

a) Iteratively compute the first few terms of a series expansion of a solution f(x) of the differential equation

f''(x)=((Sqrt[((f(x))^3)])/(Sqrt[x]))

satisfying the initial conditions

f(0)=(Subscript[f, 0]), f'(0)=(Subscript[f, s0])

(This is the differential equation for the radial electron density distribution of atoms in the Thomas–Fermi approximation. For details on the Thomas–Fermi approximation, see [669✶], [103✶], [1474✶], [601✶], [1239✶], [470✶], [441✶], [1540✶], [1541✶], [525✶], [1086✶], [1085✶], [936✶], [1023✶], [129✶], [285✶], [866✶], [1163✶], [527✶], [562✶], and [779✶].)

b) Carrying out the Majorana substitution {x, φ(x)}->{t,u(t)} defined through [531✶], [532✶], [533✶]

t=(1/(144^(1/6)))(Sqrt[x])((φ(x))^(1/6))
u(t)=-((16/3)^(1/3))((φ'(x))/(((φ(x))^4)^(1/3)))

in the Thomas–Fermi equation φ''(x)=(x^(-1/2))((φ(x))^(3/2)) yields a first-order differential equation for u(t). Derive this differential equation for u(t).

c) The Yoccoz function [1090✶], [1696✶] u(z) is the limit u(z)=(lim_(n->∞))(Subscript[u, n])(z) of the polynomials

(Subscript[u, 0])(z)=1
(Subscript[u, n])(z)=(Subscript[u, n-1])(z)-((z^(n-1))/2)(Subscript[u, n-1]^2)(z).

Calculate the first 100 terms of the expansion of u(z) around z=0:

u(z)=(∑_(k=0)^∞)(Subscript[c, k])(z^k).

Is the calculation of the first 1000 terms feasible? Make a graphics of arg(u(0.999 (e^(i  φ)))) and conjecture some properties of arg(u(r (e^(i  φ)))) as r->(SuperMinus[1]).

d) The inverse function x(y) to y(x)=x/ln(x) can be asymptotically for x->∞, expressed in the form (see [174✶], [356✶], [580✶], [770✶], [839✶], and [110✶])

x(y)=y ln(y)+y ln(ln(y))+y(∑_(i=1)^∞)(∑_(j=1)^i)(Subscript[a, "ij"])((((ln(ln(y))))^j)/((ln^i)(y))).

Determine the coefficients (Subscript[a, "ij"]) for i,j<5.

e) Calculate the series expansion up to order three of g(z)=tan(z) if z=z(w) is defined as the inverse function of exp(z)+ln(z+1) around (Subscript[z, 0])=1. Calculate the result one time directly and one time using the Lagrange–Bürmann theorem [1658✶], [1341✶], [297✶], [804✶], [275✶], [1447✶], [1476✶]. It states that if w=f(z),(Subscript[w, 0])=w((Subscript[z, 0])),w'((Subscript[z, 0]))≠0, the series expansion of g((f^(-1))(w)) around (Subscript[w, 0]) is given by

g((f^(-1))(w))=g((Subscript[z, 0]))+(∑_(i=1)^∞)(Subscript[(1/(i!))[((d^(i-1))/(d(ξ^(i-1))))(g'(ξ)(((((ξ-(Subscript[z, 0]))/(f(ξ)-(Subscript[w, 0])))))^i))], ξ=(Subscript[z, 0])])(((w-(Subscript[w, 0])))^i)

Determine the coefficients (Subscript[a, "ij"]) for i,j<5.

f) Using the three functions

P(q)=1-24 (∑_(k=1)^∞)((k (q^k))/(1-(q^k)))
Q(q)=1+240 (∑_(k=1)^∞)(((k^3) (q^k))/(1-(q^k)))
Q(q)=1-504 (∑_(k=1)^∞)(((k^5) (q^k))/(1-(q^k)))

it is possible to express many sums of the form [1312✶], [1603✶]

(Subscript[𝒮, α,o])(q)=(∑_(k=1)^∞)(k^α)(Subscript[σ, o])(k)(q^k)

((Subscript[σ, o])(k) being the divisor sum function) as polynomials in P(q), Q(q), and R(q). Find at least ten such polynomials.

g) The Eisenstein series (Subscript[ℰ, n])(q), defined by

(Subscript[ℰ, n])(q)=1-((2 n )/(Subscript[B, n]))(∑_(k=1)^∞)(Subscript[σ, n-1])(k) (q^k)

(where (Subscript[B, n]) are the Bernoulli numbers and (Subscript[σ, n])(k) are the divisor sums) fulfill identities of the form [649✶], [634✶]

(∑_(m=1)^o)(∏_(k=1)^(l^((m))))(Subscript[c, m,k])(((Subscript[ℰ, (Subscript[n, k]^((m)))])(q))^(Subscript[e, k]^((m))))=0

with integer (Subscript[c, m]),k. In the last identity, the indices (Subscript[n, k]^((m))) and the exponents (Subscript[e, k]^((m))) fulfill the constraint

(∑_(k=1)^(l^((m))))((Subscript[n, k]^((m)))^(Subscript[e, k]^((m))))=d, m=1,…,o

where d is a given positive even integer. Examples of such relations are (((Subscript[ℰ, 4])(q))^2)-(Subscript[ℰ, 8])(q)=0 and 250 (((Subscript[ℰ, 6])(q))^2)+441 (Subscript[ℰ, 4])(q)(Subscript[ℰ, 8])(q)-691 (Subscript[ℰ, 12])(q)=0. Based on comparing coefficients of powers of q, implement a search for such identities and find at least ten.

h) The polynomials (Subscript[S, k])(x) defined by

(Subscript[S, k])(x)=(1/(k+1))(∑_(j=0)^k)(((-1))^j) (((k+1)/j))(Subscript[B, j]) (x^(k+1-j))

(here (Subscript[B, j]) are the Bernoulli numbers) have the property (Subscript[S, k])(n)=(∑_(j=1)^n)(j^k). In addition they fulfill identities of the form [1331✶]

(((Subscript[S, k])(x))^2)=(∑_(j=0)^o)(Subscript[c, j])(Subscript[S, j])(x).

Implement a one-liner that calculates this identity for a given k.

i) Consider the following infinite product representation of the function exp [1565✶]:

(e^z)=(∏_(k=1)^∞)((1-(Subscript[a, k])(z^k))/(1+(Subscript[a, k])(z^k))).

Calculate the first 100 of the (Subscript[α, k]). How good an approximation of e (meaning z=1) results from this? What is the radius of convergence of this infinite product?

j) Given a vector-valued differential equation (Subscript[x, i]^′)(s)=(Subscript[f, i])((Subscript[x, 1])(s),…,(Subscript[x, n])(s)), the higher derivatives (((∂^2)(Subscript[x, i])(s))/(∂(s^2))), (((∂^3)(Subscript[x, i])(s))/(∂(s^3))), … can be expressed as functions of partial derivatives of the (Subscript[f, i]) with respect to the (Subscript[x, j])s. Using the convention that a sum is understood over all doubly occurring subscripts and that (Subscript[f, i;j,k,…]) stands as a shortcut for (((∂^n)(Subscript[f, i])(s))/(∂(Subscript[x, j])∂(Subscript[x, k])⋯)), the derivatives can be concisely written as ((∂(Subscript[x, i])(s))/(∂s))=(Subscript[f, i]), (((∂^2)(Subscript[x, i])(s))/(∂(s^2)))=(Subscript[f, i;j])(Subscript[f, j]), (((∂^3)(Subscript[x, i])(s))/(∂(s^3)))=(Subscript[f, i;j,k])(Subscript[f, j])(Subscript[f, k])+(Subscript[f, i;j])(Subscript[f, j;k])(Subscript[f, k]), … [594✶]. Calculate explicit expressions for the first six (((∂^n)(Subscript[x, i])(s))/(∂(s^n))). Write the result in the most concise form by renaming dummy summation indices.

a) If possible, compute exact values (containing only square and cube roots and no exponentials and logarithms) for cos(jπ/n) and sin(jπ/n) (let 2<n<10 and j<n/2).

b) Write a program that expresses every trigonometric function with argument p/qπ (p,q integer) that can be expressed as a function containing only addition, subtraction, multiplication, division, and square rooting. (Do not use the function FunctionExpand.)

c) Prove the following three identities that are from Ramanujan [143✶]:

((sin(2π/7))/((sin^2)(3π/7)))-((sin(π/7))/((sin^2)(2π/7)))+((sin(3π/7))/((sin^2)(π/7)))=2(Sqrt[7])
	
(((sin^2)(2π/7))/((sin^4)(3π/7)))+(((sin^2)(π/7))/((sin^4)(2π/7)))+(((sin^2)(3π/7))/((sin^4)(π/7)))=28

(((sin^2)(3π/7))/((sin^4)(π/7)))(2 ((sin(2π/7))/(sin(3π/7)))+4 ((sin(3π/7))/(sin(π/7))))+
(((sin^2)(π/7))/((sin^4)(2π/7)))(-2 ((sin(3π/7))/(sin(π/7)))+4 ((sin(π/7))/(sin(2π/7))))-
(((sin^2)(2π/7))/((sin^4)(3π/7)))(2 ((sin(π/7))/(sin(2π/7)))+4 ((sin(2π/7))/(sin(3π/7))))=280.

After making the following substitutions, for which n do these identities remain true?

({{sin(π/7), ⟶sin(nπ/7)}, {sin(2π/7), ⟶sin(2nπ/7)}, {sin(3π/7), ⟶sin(3nπ/7).}})

d) Determine all transformations of the form (modular transformations [1614✶], [1643✶])

y(x,k)=((α(k)+β(k)x)/(α'(k)+β'(k)x))

such that the following equation holds:

(((((∂y(x,k))/(∂x))))^2)=(1/(M(k)))(((1-((y(x,k))^2))(1-((l(k))^4)((y(x,k))^2)))/((1-(x^2))(1-(k^4)(x^2))))

Calculate all corresponding ((l(k))^4) and M(k). Represent the results in a “ nice” form.

a) Suppose we are given the differential equation of a 1D oscillation subject to a harmonic force [55✶]

mx''(t)+γx'(t)+kx(t)=(Subscript[F, 0])cos(ωt)

Compute the series expansion (in γ) of the maximum of the nth derivative (with respect to ω) of the amplitude of the resulting oscillation in the forced state.

b) Calculate the first 10 terms of the series of (((1+z/n))^n) around n=∞.

c) To improve the well known formula (lim_(n->∞))(((1+1/n))^n)=e, we write [136✶]

e=(((1+(1/n)))^(n+(∑_(k=0)^∞)(Subscript[α, k])(n^(-k)))).

Calculate the first 100 of the (Subscript[α, k]). How precise is the approximation for n=1? Find the optimal (Subscript[α, 0]), (Subscript[α, 1]), (Subscript[β, 2]), and (Subscript[β, 3]) in the following formula:

e=(lim_(n->∞))(((1+(1/n)+((Subscript[β, 2])/(n^2))+((Subscript[β, 3])/(n^3))))^(n+(Subscript[α, 0])+((Subscript[α, 1])/n))).

d) The q-logarithm (Subscript[ln, q])(x) can be defined through (Subscript[ln, q])(x)=((x^(1-q))-1)/(1-q) [1191✶] and fulfills the following identity for positive q and (Subscript[x, i]) [1691✶]

(Subscript[ln, q])((∏_(k=1)^n)(Subscript[x, k]))=(∑_(k=0)^n)(((1-q))^(k-1))((∑_((Subscript[l, 1])=1)^n)(∑_((Subscript[l, 2])=(Subscript[l, 1])+1)^n)⋯(∑_((Subscript[l, k])=(Subscript[l, k-1])+1)^n)(∏_(j=1)^k)(Subscript[ln, q])((Subscript[x, (Subscript[l, j])]))).

Verify this identity for 2≤n≤10 by explicit calculation of the left and right sides.

Implement an efficient computation for [1226✶], [1435✶], [871✶]

" "(Subscript[S, "mn"])=Ψ(m n+1)-(((∫_0^∞)(Subscript["dq", 1])(∫_0^∞)(Subscript["dq", 2])⋯(∫_0^∞)(Subscript["dq", m])(Subscript[Q, m n])((Subscript[q, 1]),(Subscript[q, 2]),…,(Subscript[q, m])))/(m n(∫_0^∞)(Subscript["dq", 1])(∫_0^∞)(Subscript["dq", 2])⋯(∫_0^∞)(Subscript["dq", m])(Subscript[P, "mn"])((Subscript[q, 1]),(Subscript[q, 2]),…,(Subscript[q, m])))),    m≤n
" "(Subscript[Q, "mn"])((Subscript[q, 1]),(Subscript[q, 2]),…,(Subscript[q, m]))=(∏_((i,j=1)/(i<j))^m)((((Subscript[q, i])-(Subscript[q, j])))^2)(∏_(k=1)^m)(e^(-(Subscript[q, k])))(Subscript[q, k]^(n-m))
" "(Subscript[P, "mn"])((Subscript[q, 1]),(Subscript[q, 2]),…,(Subscript[q, m]))=(Subscript[Q, "mn"])((Subscript[q, 1]),(Subscript[q, 2]),…,(Subscript[q, m]))(∑_(k=1)^m)(Subscript[q, k])ln((Subscript[q, k])).

where Ψ(z) is the digamma function. Compute the results for (Subscript[S, i j]), 1≤i,j≤4. Can one compute (Subscript[S, 55]) by brute force?

b) Let the symmetrized determinant of a matrix X of dimension n×n and elements (Subscript[x, i,j]) be defined as [112✶]

sdet X = (1/(n!))(∑_(σ∈(Subscript[S, n])))(∑_(τ∈(Subscript[S, n])))signature(σ)signature(τ)(Subscript[x, σ(1)τ(1)])… (Subscript[x, σ(n)τ(n)]).

The summations run over all elements of the permutations (Subscript[S, n]) of {1,2,…,n}.
Does there exist a 4×4 matrix X with elements

(Subscript[x, i,j])=(Subscript[c, i,j]^((a)))a +(Subscript[c, i,j]^((b)))b +(Subscript[c, i,j]^((c)))c +(Subscript[c, i,j]^((e)))e

where the (Subscript[c, i,j]^((.))) are ±1 or 0 and a, b, c, and e are noncommuting quantities with the multiplication table

({{" ", a" ", b" ", c" ", e" "}, {" "  a, e" ", c" ", b" ", a" "}, {" "  b, c" ", e" ", a" ", b" "}, {" "  c, b" ", a" ", e" ", c" "}, {" "  e, a" ", b" ", c" ", e" "}})

such that sdet X =a+b+c+e?

b) Show that the following expression R (from [1035✶] and http://www.bway.net/~lewis/fermat/FerTest1) vanishes identically.

R=(Subscript[q, 2]^2) (Subscript[q, 3]^2) ((Subscript[l, 1])-1) ((Subscript[l, 2])-1)((g^2)-(Subscript[n, 1,1]) (Subscript[n, 2,2]))+(Subscript[q, 3]^2)(Subscript[l, 1]) (Subscript[l, 2])  ((g^2)+(Subscript[n, 1,1])+(Subscript[n, 2,2])-(Subscript[n, 1,1]) (Subscript[n, 2,2])-1)+ (Subscript[q, 2]) (Subscript[q, 3]^2) ((g^2) (Subscript[l, 1])+(g^2) (Subscript[l, 2])-2 (g^2) (Subscript[l, 1]) (Subscript[l, 2])+(Subscript[l, 2]) (Subscript[n, 1,1])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 1,1])+(Subscript[l, 1]) (Subscript[n, 2,2])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 2,2])-(Subscript[l, 1]) (Subscript[n, 1,1]) (Subscript[n, 2,2])-(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[n, 2,2])+2 (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[n, 2,2]))-(Subscript[q, 3]) (Subscript[q, 4]) ((g^2)+(Subscript[n, 1,1])+(Subscript[n, 2,2])-(Subscript[n, 1,1]) (Subscript[n, 2,2])-1) ((Subscript[l, 2]) (Subscript[p, 1,1])+(Subscript[l, 1]) (Subscript[p, 2,2]))-(Subscript[q, 2]^2) (Subscript[q, 3]) ((g^2)-(Subscript[n, 1,1]) (Subscript[n, 2,2])) (2-(Subscript[l, 1])-(Subscript[l, 2])-(Subscript[p, 1,1])+(Subscript[l, 2]) (Subscript[p, 1,1])-(Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[p, 2,2]))+ (Subscript[q, 1]) (Subscript[q, 2]) (Subscript[q, 3]) (Subscript[q, 4]) ((Subscript[l, 1])-1) ((Subscript[l, 2])-1)((Subscript[n, 2,2]) (Subscript[p, 1,1])-g (Subscript[p, 1,2])-g (Subscript[p, 2,1])+(Subscript[n, 1,1]) (Subscript[p, 2,2]))+ (Subscript[q, 1]) (Subscript[q, 3]) (Subscript[l, 1]) (Subscript[l, 2])(2-(Subscript[n, 1,1])-(Subscript[n, 2,2])-(Subscript[p, 1,1])+(Subscript[n, 2,2]) (Subscript[p, 1,1])-g (Subscript[p, 1,2])-g (Subscript[p, 2,1])-(Subscript[p, 2,2])+(Subscript[n, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 1]) (Subscript[q, 3]) (Subscript[q, 4]) (-(Subscript[l, 2]) (Subscript[p, 1,1])+(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 1,1])+(Subscript[l, 2]) (Subscript[n, 2,2]) (Subscript[p, 1,1])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 2,2]) (Subscript[p, 1,1])-g (Subscript[l, 2]) (Subscript[p, 1,2])+g (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 1,2])-g (Subscript[l, 1]) (Subscript[p, 2,1])+g (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 2,1])-(Subscript[l, 1]) (Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[n, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 1]) (Subscript[q, 2]) (Subscript[q, 3]) (-(Subscript[l, 2]) (Subscript[n, 1,1])+(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 1,1])-(Subscript[l, 1]) (Subscript[n, 2,2])+(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 2,2])+(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 1,1])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 2,2]) (Subscript[p, 1,1])-g (Subscript[l, 1]) (Subscript[p, 1,2])+g (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 1,2])-g (Subscript[l, 2]) (Subscript[p, 2,1])+g (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 2,1])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 2]) (Subscript[q, 3]) (-(g^2) (Subscript[l, 1])-(g^2) (Subscript[l, 2])-(Subscript[l, 2]) (Subscript[n, 1,1])-(Subscript[l, 1]) (Subscript[n, 2,2])+(Subscript[l, 1]) (Subscript[n, 1,1]) (Subscript[n, 2,2])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[n, 2,2])+(g^2) (Subscript[l, 2]) (Subscript[p, 1,1])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 1,1])-(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 1,1])+g (Subscript[l, 1]) (Subscript[p, 1,2])+g (Subscript[l, 2]) (Subscript[p, 2,1])+(g^2) (Subscript[l, 1]) (Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 2,2]))+(Subscript[q, 2]) (Subscript[q, 3]) (Subscript[q, 4]) (-(g^2) (Subscript[p, 1,1])+(g^2) (Subscript[l, 2]) (Subscript[p, 1,1])-(Subscript[n, 2,2]) (Subscript[p, 1,1])+(Subscript[l, 2]) (Subscript[n, 2,2]) (Subscript[p, 1,1])+(Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 1,1])-(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 1,1])+g (Subscript[p, 1,2])-g (Subscript[l, 1]) (Subscript[p, 1,2])+g (Subscript[p, 2,1])-g (Subscript[l, 2]) (Subscript[p, 2,1])-(g^2) (Subscript[p, 2,2])+(g^2) (Subscript[l, 1]) (Subscript[p, 2,2])-(Subscript[n, 1,1]) (Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[n, 1,1]) (Subscript[p, 2,2])+(Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 2,2]))+ (Subscript[q, 1]^2) (Subscript[q, 4]^2) ((Subscript[l, 1])-1) ((Subscript[l, 2])-1)((Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[p, 1,1]) (Subscript[p, 2,2]))-(Subscript[q, 1]) (Subscript[q, 4]^2) (2-(Subscript[l, 1])-(Subscript[l, 2])-(Subscript[n, 1,1])+(Subscript[l, 2]) (Subscript[n, 1,1])-(Subscript[n, 2,2])+(Subscript[l, 1]) (Subscript[n, 2,2])) ((Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[p, 1,1]) (Subscript[p, 2,2]))-(Subscript[q, 4]^2) ((g^2)+(Subscript[n, 1,1])+(Subscript[n, 2,2])-(Subscript[n, 1,1]) (Subscript[n, 2,2])-1) ((Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[p, 1,1]) (Subscript[p, 2,2]))- (Subscript[q, 1]^2) (Subscript[l, 1]) (Subscript[l, 2])(1-(Subscript[p, 1,1])-(Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[p, 2,2])+(Subscript[p, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 1]) (Subscript[q, 2]) ((Subscript[l, 2]) (Subscript[n, 1,1])+(Subscript[l, 1]) (Subscript[n, 2,2])) (1-(Subscript[p, 1,1])-(Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[p, 2,2])+(Subscript[p, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 2]^2) ((g^2)-(Subscript[n, 1,1]) (Subscript[n, 2,2])) (1-(Subscript[p, 1,1])-(Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[p, 2,2])+(Subscript[p, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 1]^2) (Subscript[q, 4]) ((Subscript[l, 2]) (Subscript[p, 1,1])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 1,1])+(Subscript[l, 1]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[l, 2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])-2 (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[l, 1]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 2]) (Subscript[p, 1,1]) (Subscript[p, 2,2])+2 (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[p, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 1]) (Subscript[q, 4]) (-(Subscript[l, 2]) (Subscript[p, 1,1])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 1,1])+g (Subscript[l, 2]) (Subscript[p, 1,2])+g (Subscript[l, 1]) (Subscript[p, 2,1])-(Subscript[l, 1]) (Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[l, 2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[l, 1]) (Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 2,2])+(Subscript[l, 1]) (Subscript[p, 1,1]) (Subscript[p, 2,2])+(Subscript[l, 2]) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 1]) (Subscript[q, 2]) (Subscript[q, 4]) (-(Subscript[n, 2,2]) (Subscript[p, 1,1])+(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 1,1])+g (Subscript[p, 1,2])-g (Subscript[l, 2]) (Subscript[p, 1,2])+g (Subscript[p, 2,1])-g (Subscript[l, 1]) (Subscript[p, 2,1])-(Subscript[n, 1,1]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[n, 2,2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])-(Subscript[n, 1,1]) (Subscript[p, 2,2])+(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 2,2])+(Subscript[n, 1,1]) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 2]) (Subscript[n, 1,1]) (Subscript[p, 1,1]) (Subscript[p, 2,2])+(Subscript[n, 2,2]) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[l, 1]) (Subscript[n, 2,2]) (Subscript[p, 1,1]) (Subscript[p, 2,2]))+(Subscript[q, 2]) (Subscript[q, 4]) ((g^2) (Subscript[p, 1,1])+(Subscript[n, 2,2]) (Subscript[p, 1,1])-(Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 1,1])-g (Subscript[p, 1,2])-g (Subscript[p, 2,1])+2 (g^2) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[n, 1,1]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(Subscript[n, 2,2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])-2 (Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 1,2]) (Subscript[p, 2,1])+(g^2) (Subscript[p, 2,2])+(Subscript[n, 1,1]) (Subscript[p, 2,2])-(Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 2,2])-2 (g^2) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[n, 1,1]) (Subscript[p, 1,1]) (Subscript[p, 2,2])-(Subscript[n, 2,2]) (Subscript[p, 1,1]) (Subscript[p, 2,2])+2 (Subscript[n, 1,1]) (Subscript[n, 2,2]) (Subscript[p, 1,1]) (Subscript[p, 2,2]))

The (Subscript[q, i]) in the last polynomial are given by the following rational functions:

(Subscript[q, 1])=-(((Subscript[c, 2]) (Subscript[c, 6]))/((Subscript[c, 3]) (Subscript[c, 5]))),   (Subscript[q, 2])=(((Subscript[c, 2]) (Subscript[c, 4]))/((Subscript[c, 1]) (Subscript[c, 5]))),   (Subscript[q, 3])=(((Subscript[c, 2]) (Subscript[c, 9]))/((Subscript[c, 3]) (Subscript[c, 8]))),   (Subscript[q, 4])=(((Subscript[c, 2]) (Subscript[c, 7]))/((Subscript[c, 1]) (Subscript[c, 8]))),

(Subscript[c, 1])=((Subscript[l, 1])-1) (Subscript[a, 1,2]) (Subscript[a, 2,1])-((Subscript[l, 2])-1) (Subscript[a, 2,2])
(Subscript[c, 2])=(Subscript[l, 1]) (Subscript[a, 1,2]) (1+(Subscript[a, 2,1]))-(Subscript[l, 2]) ((Subscript[a, 1,2])+(Subscript[a, 2,2]))
(Subscript[c, 3])=(Subscript[l, 1]) (1+(Subscript[a, 2,1])) (Subscript[a, 2,2])+(Subscript[l, 2]) (((Subscript[l, 1])-1) (Subscript[a, 1,2]) (Subscript[a, 2,1])-((Subscript[l, 1])+(Subscript[a, 2,1])) (Subscript[a, 2,2]))
(Subscript[c, 4])=-(Subscript[a, 2,1]) (g-(Subscript[a, 1,2]) ((Subscript[n, 1,1])-1))+(Subscript[a, 2,2]) (1+g (Subscript[a, 1,2])-(Subscript[n, 2,2]))
(Subscript[c, 5])=-g+g (Subscript[a, 1,2]^2)-g (Subscript[a, 2,1])+(Subscript[a, 1,2]) (g (Subscript[a, 2,2])+(1+(Subscript[a, 2,1])) (Subscript[n, 1,1])-(Subscript[n, 2,2]))-(Subscript[a, 2,2]) (Subscript[n, 2,2])
(Subscript[c, 6])=g (Subscript[a, 2,1]^2)-(Subscript[a, 2,2]) ((g^2)+g ((Subscript[a, 1,2])+(Subscript[a, 2,2]))-(Subscript[n, 1,1]) ((Subscript[n, 2,2])-1))+
      (Subscript[a, 2,1]) (g+(Subscript[a, 2,2]) ((Subscript[n, 2,2])-(Subscript[n, 1,1]))+(Subscript[a, 1,2]) ((g^2)-((Subscript[n, 1,1])-1) (Subscript[n, 2,2])))
(Subscript[c, 7])=-(Subscript[a, 2,1]) (Subscript[p, 1,2])+(Subscript[a, 1,2]) ((Subscript[a, 2,1]) ((Subscript[p, 1,1])-1)+(Subscript[a, 2,2]) (Subscript[p, 2,1]))-(Subscript[a, 2,2]) (-1+(Subscript[p, 2,2]))
(Subscript[c, 8])=-(1+(Subscript[a, 2,1])) (Subscript[p, 1,2])+(Subscript[a, 1,2]^2) (Subscript[p, 2,1])+(Subscript[a, 1,2]) ((1+(Subscript[a, 2,1])) (Subscript[p, 1,1])+(Subscript[a, 2,2]) (Subscript[p, 2,1])-(Subscript[p, 2,2]))-(Subscript[a, 2,2]) (Subscript[p, 2,2])
(Subscript[c, 9])=(Subscript[a, 2,2]^2) (Subscript[p, 2,1])+(Subscript[a, 2,1]) (-(Subscript[p, 1,2]) (1+(Subscript[a, 2,1])+(Subscript[a, 1,2]) (Subscript[p, 2,1]))+(Subscript[a, 1,2]) ((Subscript[p, 1,1])-1) (Subscript[p, 2,2]))+(Subscript[a, 2,2]) ((1+(Subscript[a, 2,1])) (Subscript[p, 1,1])+((Subscript[a, 1,2])+(Subscript[p, 1,2])) (Subscript[p, 2,1])-((Subscript[a, 2,1])+(Subscript[p, 1,1])) (Subscript[p, 2,2]))

a) This problem is meant for those who are already familiar with WKB approximations in quantum mechanics [1436✶]—an approximate solution for the eigenvalue of the 1D Schrödinger equation. (In the following, m=1 and   ℏ=h/(2π) explicitly stand for the derivation of the relevant equations determined by a “small” parameter, the so-called WKB approximation.)

(-((("ℏ")^2)/2)((d^2)/(("dx")^2))+V(x)-E)Ψ(x)=0

We restrict ourselves here to the case in which the potential has just one minimum. Assuming a solution of the form

Ψ(x)=exp(i"ℏ"(∫^x)S(x)"dx")
S(x)=(∑_(k=0)^∞)((((("ℏ")/i)))^k)(Subscript[S, k])(x)

for the Schrödinger equation, we get the following recurrence formula for (Subscript[S, n])(x) [1018✶], [724✶], [1351✶], [654✶], [478✶]:

(Subscript[S, 0])(x)=(Sqrt[E-V(x)])
(Subscript[S, n-1]^′)(x)=(∑_(m=0)^n)(Subscript[S, n-m])(x)(Subscript[S, m])(x).

Now, interpreting x as a complex variable and V(x) as a complex function, we are led to the following condition for the eigenvalue E [1563✶]:

∮(Subscript[S, 0])(x)"dx"+(∑_(k=1)^∞)((((("ℏ")/i)))^k)∮(Subscript[S, k])(x)"dx"=(n+(1/2))"ℏ"

Thus, (Subscript[E, j]) (j=0,1,…) is an eigenvalue for the above differential equation if and only if this equation is satisfied. The x-integrals are taken along a path in the complex x-plane that contains both of the classical turning points (Subscript[x, 1]) and (Subscript[x, 2]). Both (Subscript[x, 1]) and (Subscript[x, 2]) are solutions of the equation V(x)=E. 
Frequently, the potential V(x) is given only for real numbers x (perhaps from a numerical calculation). Then, the above integral formula is of little use. Even if we put the integration path on the real axis, for n>1, in general, (Subscript[S, n])(x) has a nonintegrable singularity. Moreover, the integrands which arise can be greatly simplified by integration by parts. 
One way out of these difficulties is to use integration by parts with respect to x, and to reduce the strongly singular integrands to integrable integrands using integration by parts over E [590✶], [1194✶]. (For details, see [985✶], [984✶], [485✶], [1142✶], [127✶], [63✶], [16✶], [1677✶], [145✶], [917✶], [918✶], [577✶], [1349✶], [309✶], [298✶], [919✶], [920✶], [41✶], [492✶], [560✶], [537✶], [245✶], [1695✶], and [1619✶].) 
Implement the computation of these reduced forms of the integrals over the (Subscript[S, n])(x) for n=1 to 10. To this end, first find (Subscript[S, n])(x), and then integrate the parts containing V'(x) as often as possible by parts. Write the resulting expressions over all denominators that appear, and integrate the terms so obtained as often as possible by parts, without increasing the maximum singularity in the current denominator. Finally, integrate the expressions thus obtained by parts with respect to E, and write the results in an appropriate form.

For V(x)=(x^4) [1350✶], [1620✶], calculate the correction terms explicitly. Compare for the value ℏ=1/10 and ℏ=1/100 the convergence behavior of n=3 and n=100.

b) Another problem for readers who are with quantum mechanics. For the three-particle Greenberger–Horne–Zeilinger state [1125✶], [407✶], [124✶], [1050✶], [1715✶], [260✶], [11✶], [708✶], and [1545✶] |Ψ⟩=((Subscript[|↑⟩, 1])(Subscript[|↑⟩, 2])(Subscript[|↑⟩, 3]) -(Subscript[|↓⟩, 1])(Subscript[|↓⟩, 2])(Subscript[|↓⟩, 3]))/(2^(1/2)) find the most general observable (Subscript[(OverHat[Ξ]), ±])=(Subscript[((Subscript[(OverVector[n]), 1]).(OverVector[σ])), 1])⊗1⊗1+1⊗(Subscript[((Subscript[(OverVector[n]), 2]).(OverVector[σ])), 2])⊗1+1⊗1⊗(Subscript[((Subscript[(OverVector[n]), 3]).(OverVector[σ])), 3]) (with normalized |(Subscript[(OverVector[n]), k])|=1) such that (Subscript[(OverHat[Ξ]), ±])|Ψ⟩=±1|Ψ⟩. ((OverVector[σ]) is the vector of the three Pauli matrices.)

c) And one more exercise for the friends of quantum mechanics: Does there exists a pure (entangled) state of four (different) spin 1/2 particles [1384✶], [288✶], [1483✶], [511✶], [763✶], [490✶], [303✶], [1247✶] such that all two-particle reduced density matrices are multiples of the identity?

d) The entropic uncertainty relation is δx δp≥π e ℏ [1395✶], [798✶], [1069✶]. Here the δa is the exponential of the differential entropy δa=exp(-(∫_(-∞)^∞)w(a) ln(w(a))da) of the normalized to (∫_(-∞)^∞)w(a)da=1 probability density p(a) [798✶]. For the simplest case of a 1D scattering on a slit of length 2L with the position probability density w(x)=θ(L+x) θ(L-x)(((2L))^(-1/2)), calculate δp whose probability density is w(p)=((|(∫_(-∞)^∞)exp(i p x) ((w(x))^(1/2))dx|)^2) [1395✶].

a) Calculate the symbolic value of α such that 𝒾=(∫_(-(Subscript[x, 0]))^(Subscript[x, 0]))(Sqrt[α-(x^6)+4(x^2)])dx, where (Subscript[x, 0]) is the real positive root of a α-(x^6)+4 (x^2)=0 takes the value 𝒾=2π. (The answer for α is a “nice” algebraic number [130✶], [1577✶].)

b) Calculate the value of the integral (∫_(-∞)^∞)((((z^8)+7 (z^6)+5 (z^4)+3 (z^2)+1))^(-4))dz. Express the result in a nice form [192✶], [1158✶].

c) Calculate the following integral (x>1) [1430✶]:

(lim_(γ->0))(∫_1^∞)(((z^γ)-1)/(γ (z^2) ))(((1+x ((z^γ)-1)))^(-(1/γ)-1))dz.

d) Let (Subscript[ℛ, k])(ξ, (Subscript[a, 0])+(Subscript[a, 1])ξ+⋯+ (Subscript[a, n])(ξ^n)) stand for the root that is represented by the Root-object Root[(Subscript[a, 0])+(Subscript[a, 1])#+⋯+(Subscript[a, n])((#)^n), k]. Calculate the following integrals symbolically (express the results using Root-objects):

∫ln((x^2))(Subscript[ℛ, 1])(ξ, -x-x ξ+(ξ^6))dx

∫exp((Subscript[ℛ, 3])(ξ, -x-(ξ^2)+(ξ^7)))ln((Subscript[ℛ, 3])(ξ, -x-(ξ^2)+(ξ^7)))(Subscript[ℛ, 3])(ξ, -x-(ξ^2)+(ξ^7))dx

∫(Sqrt[(((Subscript[ℛ, 2])(ξ, -x- ξ+(ξ^3)))/((Subscript[ℛ, 3])(ξ, -x- ξ+(ξ^3))))])dx

∫((((Subscript[ℛ, 2])(ξ, -x-x ξ+(ξ^3)))/((Subscript[ℛ, 3])(ξ, -x- x ξ+(ξ^3))))^(1/3))dx

(∫_0^1)(((Subscript[ℛ, 2])(ξ, -x-ξ+(ξ^3)))/((Subscript[ℛ, 2])(ξ, x-ξ+(ξ^3))-1))dx

(∫_1^∞)((1/((Subscript[ℛ, 1])(ξ,- x+ξ+(ξ^5))))-(1/(5x))-(1/(x^(1/5))))dx

e) Under which conditions on (Subscript[a, 1]), (Subscript[a, 2]), (Subscript[a, 3]) can the three roots of the cubic (x^3)+(Subscript[a, 1])(x^2)+(Subscript[a, 2])x+(Subscript[a, 3])=0 be interpreted as the side length of a nondegenerate triangle [1204✶]? Visualize the volume in (Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3])-space for which this happens. For random (Subscript[a, 1]), (Subscript[a, 2]), (Subscript[a, 3]) from the interval [-1,1], what is the probability that the roots are the side length of a nondegenerate triangle?

Visualize the Riemann surface of x(a), where x=x(a) is implicitly given by (x^3)+(x^2)+a x-1/2=0. Do not use ContourPlot3D.

a) For the so-called Kepler equation (see [1199✶], [1525✶], [1370✶], [704✶], [1114✶], [275✶], [307✶], and [351✶]) L=M+ϵsin(L) find a series solution for small ϵ in the form

L≈M+(∑_(i=1)^n)((∑_(j=i)^(norn-1))(Subscript[a, "ij"])(ϵ^j))sin(i M)

with n around 10.

b) Find a short time-series solution (power series in t up to order 10, for example) for the equation of motion for a body in a spherical symmetric gravitational field (to avoid unnecessary constants, appropriate units are chosen)

("r")''(t)=(("r"(t))/((r(t))^3))

with the initial conditions "r"(0)=(Subscript["r", 0]), ("r")'(0)=(Subscript["v", 0]). Here, "r"(t) is the time-dependent position vector of the body and r(t)=|"r"(t)|. To shorten the result, introduce the abbreviations

s=(((Subscript["r", 0]).(Subscript["v", 0]))/(Subscript[r, 0]^2))    w=(((Subscript["v", 0]).(Subscript["v", 0]))/(Subscript[r, 0]^2))    u=(1/(Subscript[r, 0]^3))

(Do not use explicit lists as vectors, first because this is explicitly dependent on the dimension, and second because it slows down the calculation considerably. It is better to implement an abstract vector type for "r"(t) and define appropriate rules for it.)

c) The Lagrange points {x(μ),y(μ)} of the restricted three-body problem are the solutions of the following system of equations [389✶], [1279✶], [1579✶], [723✶], [1289✶], [671✶], [122✶]:

-((∂V(x,y))/(∂x))=0 and -((∂V(x,y))/(∂y))=0

The potential V(x,y) is given by the following expression:

V(x,y)=-(1/2) ((x^2)+(y^2))-((1-μ)/(Subscript[r, 1]))-(μ/(Subscript[r, 2]))
(Subscript[r, 1])=(Sqrt[(((x-(Subscript[x, 1])))^2)+(y^2)])
(Subscript[r, 2])=(Sqrt[(((x-(Subscript[x, 2])))^2)+(y^2)])
(Subscript[x, 1])=-μ
(Subscript[x, 2])=1-μ

Calculate explicit symbolic solutions for the Lagrange points. For the parameter value μ=(1/10), calculate all real solutions (do not do this by a direct call to Solve).

a) Derive an implicit representation f(x,y) of the Lissajous curves {x(t),y(t)}={cos(t),sin(2t)}, {x(t),y(t)}={cos(3t),sin(2t)} and some higher order Lissajous curves.

b) Describe the region that is given implicitly by

(((9(x^2)-24(x^4)+16(x^6)-4(y^2)+4(y^4)))^2)-(1/2)<0

explicitly in terms of a conjunction of 2D sets. Each set described by a pair of inequalities of the form

(Subscript[x, l])≤x≤(Subscript[x, u]),(Subscript[y, l])(x)≤y≤(Subscript[y, u])(x)

Use this description to generate a picture of this region (the name lissa stems from the fact that 9(x^2)-24(x^4)+16(x^6)-4(y^2)+4(y^4) is the implicit description of a Lissajous curve). (Do not use CylindricalAlgebraicDecomposition.)

c) Derive the implicit representation f(x,y) of the evolute of the Lissajous curves {x(t),y(t)}={cos(t),sin(2t)}. For an implicitly defined curve g(x,y), the points {ξ,η} of the evolute are given by

ξ=x-(((Subscript[g, x])(((Subscript[g, x])^2)+((Subscript[g, y])^2)))/(((Subscript[g, y])^2)(Subscript[g, "xx"])-2(Subscript[g, x])(Subscript[g, y])(Subscript[g, "xy"])+((Subscript[g, x])^2)(Subscript[g, "yy"])))                   η=y-(((Subscript[g, y])(((Subscript[g, x])^2)+((Subscript[g, y])^2)))/(((Subscript[g, y])^2)(Subscript[g, "xx"])-2(Subscript[g, x])(Subscript[g, y])(Subscript[g, "xy"])+((Subscript[g, x])^2)(Subscript[g, "yy"])))

where

(Subscript[g, x])=((∂g(x,y))/(∂x)),(Subscript[g, y])=((∂g(x,y))/(∂y)), and so on.

d) Make an animation showing how the orthopodic locus [769✶], [1685✶] of the Lissajous curves {x(t),y(t)}={cos(t),sin(2t)} is generated. The orthopodic locus of a curve is the set of all points where two tangents on the given point intersect perpendicularly. Derive the implicit representation f(x,y) of the orthopodic locus of the Lissajous curves under consideration. Do not solve nonpolynomial equations numerically here.

e) Calculate the implicit equation of the cissoid [769✶] of the Lissajous curves {x(t),y(t)}={cos(t),sin(2t)}. The cissoid of a curve and a given point P is the set of all points that lie on a line through P and are at the same time the midpoint of the line segment formed by two points of the given curve. For P={1/2,1/2}, make a picture of the implicit representation and compare it with a straightforward calculation of the cissoid.

f) Make a picture with the implicit equation of the {cos(3φ)-sin(φ)/5,sin(2φ)+cos(φ)/3},0≤φ≤2π written along the curve itself.

g) Follow a light ray that is ideally reflected multiple times inside the two-dimensional region defined by (x^4)+(y^4)-2(x^3)+2y+2x-1≤0 (a billiard problem [867✶]). Determine some (and if possible all) stationary light rays.

h) The hedgehog of a function h(t) is the envelope of the family of lines x cos(t)+y sin(t)=h(t) [1092✶]. Calculate and visualize the hedgehog of h(t)=-cos(t)+2 cos(6t).

i) Make an animation of the following function inside the region (x^4)+(y^4)<1 as k varies from 0 to 150:

(Subscript[ℐ, k])(x,y)=(∫_0^L)exp(i k d({x,y},{ξ(s),η(s)}))δ(g({x,y},{ξ(s),η(s)}))ds.

Here s is the arclength of the curve C implicitly described through (x^4)+(y^4)=1, L its length, g({x,y},{ξ(s),η(s)})=a(s)y+b(s)x+c(s) is the implicit equation for the lines through the point {x,y} that are perpendicular to C at {ξ(s),η(s)} , and d({x,y},{ξ(s),η(s)}) is the distance of the point {x,y} to the point {ξ(s),η(s)}. For some selected k, compare the resulting graphics with a corresponding graphic of

a) Given the following initial value problem [561✶]:

y''(x)=(x^3)+((y(x))^3)+((y'(x))^3)
y(0)=0
y'(0)=0

Derive a new differential equation for u((Subscript[x, 1])) when using the following change of variables on the above differential equation:

(Subscript[x, 1])=y'(x)
u((Subscript[x, 1]))=y(x)

Calculate 10 terms of the series of u((Subscript[x, 1])) around (Subscript[x, 1]) and compare the quality of the series solution with a numerical solution.

b) Let the function (Subscript[f, q])(z) be defined through the functional equation (Subscript[f, q])(q z)= (q (((Subscript[f, q])(z))^2)-q+2)/2 [688✶], [632✶], [1546✶], [373✶], [225✶], [1071✶], [1072✶]. Make an animation of (Subscript[f, 1.6 exp(i φ)])(z) as a function of real φ.

a) Make a picture of the surface [1600✶], [1673✶], [904✶] defined implicitly by

256(z^3)+128(x^2)(z^2)+16(x^4)z-144xz(y^2)-4(x^3)(y^2)+27(y^4)=0

in the x,y-region (-1,2)×(-3/2,3/2) and in the corresponding z-region. Using ContourPlot3D will not show all details with sufficient quality.

b) Make a picture of the following implicitly defined surface

sin(x) cos(y)+sin(y) cos(z)+sin(z) cos(x)=0

in the cube 0≤x≤2π, 0≤y≤2π, 0≤z≤2π. Do not use ContourPlot3D for generating the picture.

c) The Clebsch surface (see also Exercise 7 of Chapter 1 of the Numerics volume [1561✶] of the GuideBooks), defined by the implicit equation

32-216(x^2)+648(x^2) y-216(y^2)-216(y^3)-150z+216(x^2) z+216(y^2) z+231(z^2)-113(z^3)=0

has the remarkable property that 27 straight lines lie on it [498✶], [1353✶], [749✶], [942✶], [575✶], [1431✶], [1426✶], [26✶], [774✶]. Calculate these 27 lines explicitly. Visualize these lines that lie on the surface.

d) Calculate the implicit representations of “generalized” Clebsch surfaces, which, instead of a threefold rotation symmetry, have an n-fold rotation symmetry (n=4,5,6,…) and has a similar shape. Visualize some of them.

a) In [503✶], the following implicit equation for a plane quartic with 28 real bitangents is given. (A bitangent is a line that is tangent to two points, including the degenerate case in which these two points coincide) and to a curve at the same time.

(x^4)+(y^4)-6((x^2)+(y^2))+10=0

Calculate the explicit form of the bitangents, and make a picture that illustrates that these lines are bitangents.

b) Consider the parametric curve {Re(z(φ)), Im(z(φ))} where z(φ) is implicitly defined by 2((z(φ))^6)=q(φ)+((q(φ))^3) and q=R exp(i φ), R=9/10. Find exact values for the points where the curve self-intersects.

c) An ellipse can be defined as the set of points whose sum of distances from two points is a constant. A natural generalization of this definition is the set of points whose sum of distances from n points is a constant c [555✶], [1434✶], [1265✶]. For the case of n=5 and the five points being the vertices of a regular pentagon, derive a polynomial (Subscript[p, c])(x,y) (with integer coefficients) such that (Subscript[p, c])(x,y)=0 contains the pentaellipse. Visualize (Subscript[p, c])(x,y)=0.

a) Show that the vacuum Maxwell equations [844✶] (the fields (OverVector[E]), (OverVector[H]) are functions of the coordinates x, y, z.)

((∂(OverVector[E]))/(∂t))=curl (OverVector[H])
((∂(OverVector[H]))/(∂t))=-curl (OverVector[E])
div(OverVector[E])=0
div(OverVector[H])=0

are invariant under the Galilei transformation

(OverVector[r])'=(OverVector[r])+(OverVector[v])t
t'=t

if the fields are transformed in the following way:

(OverVector[E])'=(OverVector[E])-(OverVector[v])×(OverVector[H])-((OverVector[v]).(OverVector[r])+(t/2) (OverVector[v]).(OverVector[v])) rot(OverVector[H])+(1/2) (((v )^2)(OverVector[E])-(OverVector[v]) (OverVector[v]).(OverVector[E])+ +(OverVector[r]).(OverVector[v]) (∇(OverVector[.v])  (OverVector[E])-2 (OverVector[v])×rot(OverVector[E])) +((((OverVector[r]).(OverVector[v])))^2) Δ(OverVector[E]))+O((v^3))
(OverVector[H])'=(OverVector[H])+(OverVector[v])×(OverVector[E])-((OverVector[v]).(OverVector[r])+(t/2) (OverVector[v]).(OverVector[v])) rot(OverVector[E])+(1/2) (((v )^2) (OverVector[H])-(OverVector[v]) (OverVector[v]).(OverVector[H])+ +(OverVector[r]).(OverVector[v]) (∇(OverVector[.v])  (OverVector[H])-2 (OverVector[v])×rot(OverVector[H])) +((((OverVector[r]).(OverVector[v])))^2) Δ(OverVector[H]))+O((v^3))
ν=|(OverVector[v])|

For the derivation of these formulae, see [610✶] and [973✶]. (For related discussions see [1028✶], [662✶], [974✶].)

b) The relativistic relations between the electric and magnetic vacuum fields ℰ, ℋ and the electric and magnetic fields in media 𝒟, ℬ [1352✶] are given by [753✶], [1716✶], [1112✶]

𝒟+(1/c)v×ℋ=ε (ℰ+(1/c)v×ℬ)
ℬ-(1/c)v×ℰ=μ (ℋ-(1/c)v×𝒟)

Here, v is the velocity of the moving media, ε and μ are the relative permittivity and permeability. Express the fields 𝒟, ℬ as a function of ℰ, ℋ in compact vector form. (Do not guess the form; derive it.)

c) Show that Re((Subscript[φ, v])(ρ,z;t)) where [1707✶], [1437✶], [150✶]

(Subscript[φ, v])(ρ,z;t)=((z-v t +i α)/((((((z-v t +i α))^2)+(1-((v^2)/(c^2))) (ρ^2)))^(3/2)))

is a solution of the 3D wave equation (ρ, and z are cylindrical coordinates, c is the group velocity, α and v are arbitrary parameters). Visualize the solution for v⋚c.

d) Solve the following set of equations for ψ=ψ(ξ,η,α), eliminating the variables ρ, and θ [316✶].

(e^(-ξ (Subscript[σ, 3])))(e^(η (sin(α) (Subscript[σ, 1])+cos(α) (Subscript[σ, 3]))))=(e^(ρ(sin(θ) (Subscript[σ, 1])+cos(θ) (Subscript[σ, 3]))))(e^(i ψ (Subscript[σ, 2])))

Here (e^matrix) denotes the matrix exponential functions and the three (Subscript[σ, k]) are the Pauli matrices

(Subscript[σ, 1])=(({{0, 1}, {1, 0}})), (Subscript[σ, 2])=(({{0, -i}, {i, 0}})), (Subscript[σ, 3])=(({{1, 0}, {0, -1}})).

(ψ(ξ,η,α) is the Thomas precession angle [372✶], [1389✶], [1575✶], [141✶], [916✶], [1574✶], [1173✶], [757✶], [317✶], [837✶], [114✶] that arises from two successive Lorentz transformations in different directions as one Lorentz transformation and a rotation.)

e) Calculate the first few terms of the expansion in (c^(-1)) [414✶], [681✶], [1688✶], [682✶], [772✶], [617✶], [1621✶], [909✶], [1622✶], [164✶], [203✶], [714✶], [1115✶] of the Lienárd–Wiechert potential φ(𝕣,t)

φ(𝕣,t)=(e/(r(τ)-(1/c)𝕣(τ).𝕧(τ))).

Here e is the electric charge, c is the speed of light, 𝕣(τ)=ℝ-(Subscript[ℝ, e])(τ), where ℝ is the observation point and (Subscript[ℝ, e])(τ) the position of the charge. The scalar distance is r(τ)=|𝕣(τ)| and 𝕧(τ)=∂(Subscript[ℝ, e])(τ)/∂τ is the velocity of the charge. The retarded time τ is defined through t=τ+𝕣(τ)/c.

f) Find a nontrivial “spherical”, standing wave-like solutions of the homogeneous Maxwell equations.

div ℰ(r,t)=0
div ℬ(r,t)=0
((∂ℰ(r,t))/(∂t))=curl ℬ(r,t)
((∂ℬ(r,t))/(∂t))=-curl ℰ(r,t)

Here by “spherical” we mean a solution that does not depend on the azimuthal coordinate φ, but only on r and ϑ. By “standing wave-like”, we mean ℰ(r).ℬ(r)=0. For a wave-like solution, assume the time dependence of the form ℰ(r)~sin(t) and ℬ(r)~cos(t). Use for the spatial part of the components (Subscript[e, 𝕒])∈{(Subscript[ℰ, r]),(Subscript[ℰ, ϑ]),(Subscript[ℰ, φ]),(Subscript[ℬ, r]),(Subscript[ℬ, ϑ]),(Subscript[ℬ, φ])} of the fields in spherical coordinates ℰ(r)=(Subscript[ℰ, r])(Subscript[e, r])+(Subscript[ℰ, ϑ])(Subscript[e, ϑ])+(Subscript[ℰ, φ])(Subscript[e, φ]), ℬ(r)=(Subscript[ℬ, r])(Subscript[e, r])+(Subscript[ℬ, ϑ])(Subscript[e, ϑ])+(Subscript[ℬ, φ])(Subscript[e, φ]) an ansatz of the form [333✶]

(Subscript[ℯ, 𝕒])~(∑_((Subscript[ρ, r])=-3)^1)(∑_((Subscript[ρ, c]),(Subscript[ρ, s])=0)^1)(∑_(k,l=0)^o)(∑_((Subscript[α, c,k]),(Subscript[α, s,k])=0)^1)(Subscript[c, (Subscript[ρ, r]),(Subscript[ρ, c]),(Subscript[ρ, s]),k,l,(Subscript[α, c,k]),(Subscript[α, s,k])]^((e,𝕒)))(r^(Subscript[ρ, r]))((cos(r))^(Subscript[ρ, c]))((sin(r))^(Subscript[ρ, s]))((cos(k ϑ))^(Subscript[α, c,k]))((sin(l ϑ))^(Subscript[α, s,l]))

for some (small integer) o. Here the (Subscript[c, (Subscript[ρ, r]),(Subscript[ρ, c]),(Subscript[ρ, s]),k,l,(Subscript[α, c,k]),(Subscript[α, s,k])]^((e,𝕒))) are constants independent of r and ϑ. Visualize the motion of a charged particle in such fields.

a) The series of n! is around n=∞ asymptotic. So to get the best numerical result from such a series in dependence of n, the series should be truncated in an n-dependent manner. Calculate after how many terms it is best to truncate the series for n=1…15! (For a detailed exposition on the optimal truncation of divergent series, see [107✶] and [439✶].)

b) Ramanujan gave the following expansion for the factorial function for large n [142✶], [42✶]:

n!=(Sqrt[π])((((n/e)))^n)(((8 (n^3)+4 (n^2)+n+(1/30)+R(n)))^(1/6)).

Assuming that R(n) is of the form (∑_(k=1)^∞)(Subscript[c, k])(n^(-k)), calculate the first few (Subscript[c, k]). How many (Subscript[c, k]) are needed to calculate 100! to 100 correct digits?

c) Given a q-series Σ = 1+(∑_(k=1)^n)(Subscript[c, k])(q^k), (Subscript[c, k])∈ℤ, write a one-liner 𝕢SeriesTo𝕢Product expressing Σ as a product

Π = (∏_(k=1)^m)(((1-(q^k)))^(Subscript[α, k])),(Subscript[α, k])∈ℤ,

such that Π-Σ=((O(q))^(n+1)) [627✶], [193✶].

d) The q-binomial coefficients [543✶], [83✶], [1480✶], [52✶], [968✶], [126✶], [1412✶], [998✶], [935✶], [1383✶]

(Subscript[[(n/k)], q])=(((∏_(j=1)^(n-k+1))(1-(q^j)))/((∏_(j=1)^k)(1-(q^j))))

that are seemingly rational functions in q, are actually polynomials in q. For 1≤k,n≤250, visualize the number of factors in the factored form of the q-binomial coefficient s. (The coefficient of (q^k) of (Subscript[[((m+n)/n)], q]) is the number of partitions of k elements into at most n parts each part having at most m elements.)

e) A Taylor series (Subscript[c, 0])+(∑_(j=1)^∞)(Subscript[c, j])(q^k) is called multiplicative if (Subscript[c, k×l])=(Subscript[c, k])(Subscript[c, l]) for all pairs k, l, such that gcd(k,l)=1. Products of the form

(((∏_(j=1)^𝓂)(∏_(k=1)^∞)(((1-(q^((Subscript[α, j])k))))^(Subscript[μ, j])))/((∏_(j=1)^𝓃)(∏_(k=1)^∞)(((1-(q^((Subscript[β, j])k))))^(Subscript[ν, j]))))

where (∑_(j=1)^𝓂)(Subscript[α, j])(Subscript[μ, j])=(∑_(j=1)^𝓃)(Subscript[β, j])(Subscript[ν, j])=s and the (Subscript[α, j]), (Subscript[β, j]) are all divisors of n=max((Subscript[α, j]),(Subscript[β, j])) are sometimes multiplicative series [572✶], [1315✶]. Find all such type multiplicative series for 1≤n,s≤24.

f) Given a set of distinct primes {(Subscript[p, 1]),…,(Subscript[p, r])}, the number of partitions (Subscript[P, (Subscript[p, 1]),…,(Subscript[p, k])])(n) of a positive integer n into integers {(Subscript[m, 1]),…,(Subscript[m, j])} (meaning (∑_(l=1)^j)(Subscript[m, l])=n) such that gcd((Subscript[m, l]),(Subscript[p, q]))=1, 1≤l≤j, 1≤q≤r is given by [1348✶]

(Subscript[P, (Subscript[p, 1]),…,(Subscript[p, k])])(n)=[(z^n)]((∏_(o=1)^∞)(((Subscript[C, s])((z^o)))^(((-1))^(r-1))))

where s=(∏_(q=1)^r)(Subscript[p, q]) and (Subscript[C, s])(z) is the sth cyclotomic polynomial (in Mathematica Cyclotomic[s, z]). 
Use this formula to calculate (Subscript[P, 2,3,5,7,11])(111). Compare the result with a direct calculation of the partitions themselves.

a) Construct one differential equation for the x-component x(t) of the radius vector of the 2D Kepler problem:

x''(t)=((x(t))/(Sqrt[((x(t))^2)+((y(t))^2)]))
y''(t)=((y(t))/(Sqrt[((x(t))^2)+((y(t))^2)]))

b) Construct one differential equation for the x(t) of the radius vector of equations of motion for a freely rotating body:

x'(t)=A y(t) z(t)
y'(t)=B x(t) z(t)
z'(t)= C x(t) y(t)

c) Find a polynomial differential equation P(u(x), u'(x),u''(x),u'''(x))=0 for the function u(x)=α exp(β/(Sqrt[z-(Subscript[z, 0])])) [992✶].

d) Given the Darboux–Halphen system of differential equations [8✶]

(Subscript[w, 1]^′)(z)=(Subscript[w, 1])(z)((Subscript[w, 2])(z)+(Subscript[w, 3])(z))-(Subscript[w, 2])(z)(Subscript[w, 3])(z)
(Subscript[w, 2]^′)(z)=(Subscript[w, 2])(z)((Subscript[w, 1])(z)+(Subscript[w, 3])(z))-(Subscript[w, 1])(z)(Subscript[w, 3])(z)
(Subscript[w, 3]^′)(z)=(Subscript[w, 3])(z)((Subscript[w, 1])(z)+(Subscript[w, 2])(z))-(Subscript[w, 1])(z)(Subscript[w, 2])(z)

find an (ordinary nonlinear) differential equation for W(z)=2((Subscript[w, 1])(z)+(Subscript[w, 2])(z)+(Subscript[w, 3])(z)).

e) Derive x-free, polynomial differential equations for the two functions f(x)=exp(exp(exp((e^x)))) and g(x)=(x^x).

f) The following function (Subscript[G, α])(w) [1443✶], [1160✶], [1386✶], [499✶], [903✶], [869✶], [870✶] fulfills a linear homogeneous differential equation with respect to w with polynomial coefficients in α and w [827✶], [422✶], [868✶]:

(Subscript[G, α])(w) =(1/(π^3))(∫_0^π)(∫_0^π)(∫_0^π)(1/(w-(cos((Subscript[ϑ, 1]))+cos((Subscript[ϑ, 2]))+α cos((Subscript[ϑ, 3])))))d(Subscript[ϑ, 1])d(Subscript[ϑ, 2])d(Subscript[ϑ, 3])

Use a series expansion in w to find such a differential equation.

a) Can one find an example in which DSolve[eqs, vars] remains unsolved, but applying ExpandAll[DSolve[eqs, vars]] gives a result?

b) What will be the result of the following inputs?

Integrate[Integrate[x^x, x]^3, Integrate[x^x, x]]

D[D[1[1], 1]^2, D[1[1], 1]]

Sum[Sum[k, {1, 4}]^2, {Sum[k, {1, 4}], 1, 4}]

Unprotect[Sum]; Sum[Sum[k, {1, 4}]^2, {Sum[k, {1, 4}], 1, 4}]

Solve[Positive[x]^2 == 1, Positive[x]]

Integrate[x[1], {x, 0, 2}, {x[1], -1, 1}]

Sum[x[1], {x, 0, 2}, {x[1], -1, 1}]

c) What will be the result of the following input?

Unprotect[Message];

Message /: Message[___] := Null /; (Abort[]; False);

Integrate[1/(Sqrt[C^2] - C), {C, -1, 1}]

d) Find a short (surely less than 20 characters) symbolic input that results in a mathematically wrong result. Do not use any variables or approximative numbers.

e) Why does the following input (mathematically equal to 1) generate messages, instead of returning just 0?

𝕥[x_] := ((x + 1)^2 - x^2 - x - 1)/x
𝕥'[0]

f) What will be the result of the following input?

Block[{E}, D[E[x], x] /. head_[arg_] :> arg[head]]

g) Find a rational function 𝕣(x, y, z) (with rational coefficients) such that Together does not act idempotent on it (meaning Together[𝕣(x, y, z)] and Together[Together[𝕣(x, y, z)]] are different).

h) Predict the result of the following input:

f1 = Factor[(x[2] - x[1])^3];
f2 = Factor[(x[2] - x[3])^3];
x[1] = x[3];
f1 - f2 === 0

i) Is there a Mathematica function (from the System` context), that, independently from any current and further progress in Mathematica, one will always be able to fool to give wrong result?

j) The function Developer`ZeroQ tries quickly to determine if an expression is identical to zero. Often it will correctly determine if an expression is zero, but it might sometimes give wrong results. (In physics terminology one would call Developer`ZeroQ a FAPP-function [123✶]; for PEF see [1195✶].) For exact, numeric input this function will, among other techniques, use high-precision numericalization to find this out. Find a short (surely less than 10 characters) expression for which Developer`ZeroQ erroneously asserts that it is zero.

k) Find a function f(x,y), such that Mathematica can evaluate Integrate[f(x,y), {x, 0, 1}, {y, 0, 1}] in closed form, but cannot evaluate Integrate[f(x,y), {y, 0, 1}, {x, 0, 1}] in closed form.

l) Predict the result of the following inputs:

makeDef1[𝕕_, f_, 𝒜_] := 
 f /: 𝕕[1][f] /; (clearDef1[𝕕, f, 𝒜]; makeDef2[𝕕, f, 𝒜]; False) := Null

clearDef1[𝕕_, f_, 𝒜_] := 
 f /: 𝕕[1][f] /; (clearDef1[𝕕, f, 𝒜]; makeDef2[𝕕, f, 𝒜]; False) =.

makeDef2[𝕕_, f_, 𝒜_] := 𝕕 /: HoldPattern[𝕕[1][f][0]] := 
(clearDef2[𝕕, f]; makeDef1[𝕕, f, 𝒜]; 𝒜)

clearDef2[𝕕_, f_] := 𝕕 /: HoldPattern[𝕕[1][f][0]] =.

makeDef1[Derivative, 𝕗, 𝔣0];
D[𝕗[x], x] /. x -> 0

m) Write a function that generates functions f(x) that are compositions of elementary functions, such that Limit[f(x), x -> 0] stays unevaluated.

n) Can you find a rational function in trigonometric functions for which the the built-in Integrate cannot find the indefinite integral, but can after a substitution of variables?

o) Find an example of a quadratic polynomial p in the variable x with exact, numeric coefficients, such that Solve[p == 0, x] gives a mathematically wrong result.

p) What is wrong, from a scoping point of view, with the following naive definition of the Fourier transform (Subscript[ℱ, t])[f(t)](ω)=(((2π))^(-1/2))(∫_(-∞)^∞)exp(i ω t)f(t) dt?

myFourierTransform[f_, t_, ω_, opts___] := 
 1/Sqrt[2 Pi] Integrate[f Exp[I t ω], {t, -Infinity, Infinity}, opts]

q) Find pairs of univariate functions f and their inverses (f^(-1)), such that 
◼ f((f^(-1))(z))=f((f^(-1))(z))=z holds for all complex z
◼ f((f^(-1))(z))=f((f^(-1))(z))=z holds for almost all complex
◼ f((f^(-1))(z))=z holds for all complex z, but f((f^(-1))(z))=z does not
◼ neither f((f^(-1))(z))=z nor f((f^(-1))(z))=z holds for all complex z.

r) Why does the following input give a mathematically wrong result?

Simplify[x DiracDelta`[x], x == 0]

a) Consider the following double integral:

(∫_o^1)(∫_0^1)(Sqrt[(((x-y))^2)])dx dy.

Substituting limits in the (double) indefinite integral does not give the right result, despite the fact that the integrand and the (double) indefinite integral are continuous functions. How can one “fix” the double indefinite integral?

b) Calculate an exact answer for the following integral: (∫_0^∞)exp(-2x) (coth(x)-1/x)dx.

c) Compositions of the differential operator ∂/∂x can be formally defined through the two symbolic identities [1730✶], [638✶], [1666✶], [711✶], [93✶], [712✶], [1193✶], [609✶], [729✶], [1212✶]

((∂^i)/(∂(x^i)))(((∂^j)/(∂(x^j))).)=((∂^(i+j))/(∂(x^(i+j)))).

((∂^i)/(∂(x^i)))(f(x).)=(∑_(k=0)^∞)(({{i}, {k}}))(f^((k)))(x)((∂^i)/(∂(x^i))).

representing order independence and the Leibniz rule.

Here (∂^i)/∂(x^i) for negative i are understood as the inverse positive i, meaning (∂^i)/∂(x^i)((∂^(-i))./∂(x^(-i)))=identity(.). (Practically this means that (∂^(-1))/∂(x^(-1)) represents one-time indefinite integration [(∂^(-1))./∂(x^(-1))=(∫_(-∞)^x).dx] [609✶], [1396✶], [321✶] and the Leibniz rule represents partial integration in this formalism.)

Use these definitions to calculate the first ten (Subscript[α, k]) of the square root [394✶], [431✶], [1415✶], [1718✶], [1611✶]

(Sqrt[ℒ])=(∂/(∂x)). +(∑_(k=0)^∞)(Subscript[α, -k])(x)((∂^(-k))/(∂(x^(-k)))).

where ℒ is the differential operator ℒ=(∂^2)./∂(x^2) +u(x). containing an unspecified function u(x).

a) Find all polynomials (x^3) + a (x^2) + b x + c that have a, b, c as their roots.

b) The amoeba of a system of polynomial equations (Subscript[p, j])((Subscript[z, 1]),(Subscript[z, 2]),…,(Subscript[z, n]))=0, j=1,…,m is the image of all solutions {(Subscript[z, 1]),(Subscript[z, 2]),…,(Subscript[z, n])} under the map {(Subscript[z, 1]),(Subscript[z, 2]),…,(Subscript[z, n])}->{log(|(Subscript[z, 1])|), log(|(Subscript[z, 2])|), …,log(|(Subscript[z, 2])|)} [1608✶], [1537✶], [1136✶], [1135✶], [1137✶], [1357✶], [637✶]. Describe and visualize the amoeba of the equation w=1+2z-(z^3).

c) A bivariate function f(x,y) with (lim_(|x|+|y|->∞))f(x,y)=∞ induces a tiling of the plane with a tile defined as the set of all points {x,y}, such that |f(x,y)|≤|f(x+i,y+j)| for all points {i,j}, i,j∈ℤ of a square lattice the plane [409✶]. Find an exact parametric description for the tile in case f(x,y)=(3x+y)(y+3x) (this example comes from [409✶]). Calculate the volume of the tile through integration and visualize the resulting tiling.

a) Calculate the 2D area given by (x^3)-3 y x+(y^3)<0 in the first quadrant [460✶].

b) Find the value of the following integral [725✶]:

(∫_0^1)(∫_0^1)(∫_0^1)(1/(((1+(x^2)+(y^2)+(z^2)))^2))dx dy dz

Use a spherical coordinate system to calculate the integral.

c) Find the value of the following integral [501✶]:

(∫_0^∞)(∫_0^∞)((((x^2)+x y+(y^2)))^ν)(e^(-(x+y)))dx dy

d) Determine analytically the average distance between two randomly selected points in the unit square [483✶]. Use the independence of the components of the Cartesian coordinates to determine the probability that two randomly selected points in the interval (0,1) are separated by a distance l. Find the average distance of two randomly chosen points in a 3D unit cube [1531✶], [1097✶].

e) The April 2003 issue of the American Mathematical Monthly contains the problem to calculate [502✶]

ℐ(a,b,c)=(∫_0^∞)(∫_0^∞)(∫_0^∞)(((e^(-x-y-z))sin(a x + b y + c z))/(Sqrt[x+y+z]))dz dy dx.

Write a one-liner that calculates this integral. Simplify the result for real a, b, c and calculate the exact value of ℐ(1,1,1).

a) Given the differential equation (Duffing equation) [863✶], [48✶], [1444✶], [922✶], [877✶]

y''(t)+y(t)+ϵ ((y(t))^3)==0
y(0)=0, y'(0)=0

(ϵ is a small parameter) using an ansatz of the form y(t)=(∑_(i=0)^n)(ϵ^i)(Subscript[y, i])(t) calculate the first six terms (Subscript[y, i])(t) [1446✶]. Compare with the exact solution for ϵ =1/10.
Derive the first three orders for general initial conditions [1244✶], [1077✶].

b) Frequently one is interested in periodic solutions of differential equation. Consider, for instance, the following nonlinear differential equation [1711✶]

(Ω^2)(((∂^2)X(t))/(∂(t^2)))+(Subscript[ω, 0]^2)X(t)=(∑_(k=2)^∞)(Subscript[J, k])((X(t))^k).

Here Ω, (Subscript[ω, 0]), and the (Subscript[J, k]) are given parameter. Assume we can expand Ω and X(t) naturally in a power series in ϵ:

Ω=(∑_(k=0)^∞)(ϵ^k)(Subscript[ω, k])
X(t)=ϵ(∑_(k=0)^∞)(ϵ^k)(Subscript[x, k])(t).

For the lowest order solution, we take (Subscript[x, 0])(t)=(Subscript[c, 0,c])cos(t). The differential equations for the (Subscript[x, k])(t) are inhomogeneous harmonic oscillator differential equations with solutions (Subscript[x, k])(t)= (Subscript[c, k,c])cos(t)+(Subscript[c, k,s])sin(t)+(Subscript[x, k]^((inh)))(t). Calculate conditions for the first 10 of the (Subscript[ω, k]), such that the (Subscript[x, k])(t) become periodic functions.

Calculate polynomial implicit representations p(x,y,z)=0 for the following five surfaces:
a) A “spindle” (come up with your own parametric description of a spindle).
b) A cube-rooted sphere (this means a surface obtained by taking the third root (in case of negative values ξ, take -(((-ξ))^(1/3)) of the coordinate values of a sphere) [1724✶].
c) A cubed sphere (this means a surface obtained by taking the third power of the coordinate values of a sphere).
d) A torus with a cross section of a cubed circle, in which the cubed circle is rotated when moved along the “outer” circle.
e) A circle that is rotated around its diameter and its radius changes periodically.
Use ContourPlot3D to make pictures of all calculated implicit surfaces.

Make a picture of the imaginary part of K=K(e), where K(e) is defined implicitly by [1488✶]

cos(K)=cos((Sqrt[e]))+(4/(Sqrt[e])) sin((Sqrt[e])).

Include all sheets of the Riemann surface in the picture, and let the region of the complex e-plane be
-10≤Re(e)≤60, -10≤Im(e)≤10.
(This equation comes up in the quantum-mechanical treatment of a particle in a periodic potential; and it is the eigenvalue equation of the Kronig–Penney model [962✶], [35✶].)

a) Given an ellipse (x^2) + 4 (y^2) - 4 = 0, imagine all possible line segments with a start point and an end point on this ellipse, such that the length of the line segments is exactly 1. These line segments envelope a closed region inside the ellipse. Calculate the implicit representation of this region. Visualize how this region becomes formed by the enveloping line segments.

b) Given four generic lines in (ℝ^3), how many lines (generically) exist that cross all for lines? (See [1303✶], [777✶], [1468✶], and [1536✶]; for similar problems see [1467✶] and [1469✶].)

Given the triangle (Subscript[P, 1])(Subscript[P, 2])(Subscript[P, 3]) with vertices (Subscript[P, 1])={0,0}, (Subscript[P, 2])={1,0}, (Subscript[P, 3])={1,2}. Now, imagine a ball that starts at a point Q inside the triangle bounces against wall (Subscript[P, 1])(Subscript[P, 2]), is reflected there, bounces against wall (Subscript[P, 2])(Subscript[P, 3]), is reflected there, bounces against (Subscript[P, 3])(Subscript[P, 1]) and comes back to the point Q. Calculate the exact value of the smallest length of such a path [460✶].

a) Find a numerical approximation for the distance of the nearest singularity of

y'(x)=1-x ((y(x))^2) 
y(0)=0

from the origin [128✶].

b) In [1580✶], [23✶], [24✶], [1356✶], [202✶], [1463✶], [1464✶] (see also [479✶]) the following peculiar identity was given (η is a real variable):

(∑_(k=0)^n)(Subscript[c, k]^((n)))(η)f(x-(Subscript[d, k]^((n))))≈f(x-η)

Here the shifts (Subscript[d, k]^((n))) and the weights (Subscript[c, k]^((n)))(η) are given by

(Subscript[d, k]^((n)))=(k/n)
(Subscript[c, k]^((n)))(η)=(({{n}, {k}}))(((η^k)(1-η))^(n-k)).

(The identity is peculiar because the superposition of shifted copies of f with, for \[LeftBracketingBar]η\[RightBracketingBar]>1 large coefficients approximates another shifted copy of f.)
Assuming a Fourier expansion of f(x) exists, show that for n->∞, exact equality holds. Under which conditions does the identity hold approximately for finite n?

c) Let f(z)=(∑_(k=-n)^∞)(Subscript[c, k])(z^k) for some positive integer n. Then we have the residue (Subscript[res, z=0])(f(z))=(Subscript[c, 1]). For 1≤n≤10, express the residue as a function of F(0) and (Φ^((k)))(0) where F(z)=(z^n)f(z) and Φ(z)=F'(z)/F(z) [1048✶].

Let ABC be a triangle. The sides (OverBar[AB]) and (OverBar[AC]) have the same length. A line starting from C intersects the line AB at the point D, and a line starting from B intersects the line AC at the point E. The following angles are given: ∢EBC=60°, ∢BCD=70°, and ∢ABE=20°. Determine the angle ∢CDE. Here is a sketch of the problem:

Determine the angle ∢CDE. From [1019✶], see also http://www.dcs.st-andrews.ac.uk/~ad/mathrecs/advent/advent.html.

a) Given a polynomial p(x,y) in two variables, the y in p(x,y)=0 can be viewed as an implicitly defined function of x. Write a program, in which given an explicit bivariate polynomial p(x,y), it derives a linear differential equation for y(x) [951✶], [952✶], [954✶], [342✶], [343✶].

b) Calculate the eigenvalues of the Laplace operator for the graph formed by the vertices (nodes) and edges (connections between nodes) of a stellated icosahedron. The action of Laplace Δ operator on a function f at node q of a graph is given by [659✶], [156✶], [834✶], [1330✶], [195✶]

Δ f(q) =numberOfNeighborsOfq f(q) - (∑_(neighbor nodes of q))f(p).

c) Conjecture exact values for the smallest and the largest eigenvalues of the Laplace operator for the graph formed by the vertices (nodes) and edges (connections between nodes) of the 120-cell (see Exercise 17 of Chapter 2 of the Graphics volume [1560✶] of the GuideBooks).

a) The eigenfunctions of the Fourier transform are of the form exp(-(x^2)/2)(∑_(k=0)^n)(Subscript[c, k])(x^k). Find the eigenvalues and eigenfunctions corresponding to 0≤n≤12.

b) Find explicit sequences (Subscript[δ, ε])(x) and (Subscript[θ, ϵ])(x) such that (lim_(ε->0))(Subscript[δ, ε])(x)=δ(x) and (lim_(ϵ->0))(Subscript[θ, ϵ])(x)=θ(x) and (∫_(-∞)^∞)(Subscript[δ, ε])(x)(Subscript[θ, ϵ])(x)dx takes on different values depending on how fast ε and ϵ approach 0. (This shows that (∫_(-∞)^∞)δ(x)θ(x)dx is not a well-defined integral.)

c) Let ξ be a the only simple zero of f(x)=0. Using the following three formulas [890✶]:

g(x) (δ^((n)))(x-ξ)=(∑_(k=0)^n)(((-1))^k) (({{n}, {k}})) (g^((k)))(ξ) (δ^((n-k)))(x-ξ),
δ(f (x))=((δ(x-ξ))/(|f'(ξ)|)),
(δ^((n)))(f(x))=(1/(f'(x)))(∂/(∂x))(δ^((n-1)))(f(x)),

find expansions for (δ^((n)))(f(x)) of the form (δ^((n)))(f(x))=(∑_(k=0)^n)(Subscript[c, k])(ξ) (δ^((k)))(x-ξ) for 2≤n≤10. Check some of the resulting formulas numerically.

d) The probability density (Subscript[p, z])(ξ) for a sum z=x+y of two random variables x and y with distribution functions (Subscript[p, x])(ξ) and (Subscript[p, y])(ξ) is given by [194✶], [467✶], [1726✶] , [1096✶]

(Subscript[p, z])(ξ)=(∫_(-∞)^∞)(∫_(-∞)^∞) (Subscript[p, x])(s)(Subscript[p, y])(t)δ(ξ-s-t)ds dt.

(This can also be viewed as a rewritten definition for B-splines.) Use this formula to calculate the distribution functions for n (n=2,…, 5) uniformly in [0,1] distributed random numbers [1665✶].

e) Calculate the probability distribution of the determinant of a 2×2 matrix with random, uniform in [0,1] distributed elements. Carry out a numerical simulation, and compare it with the theoretical distribution.

f) The divided differences [(Subscript[x, 1])(Subscript[x, 2])… (Subscript[x, n])] of a function f at the points (Subscript[x, 1]), …, (Subscript[x, n]) have the integral representation [876✶], [1140✶]

[(Subscript[x, 1])(Subscript[x, 2])… (Subscript[x, n])]=(∫_0^∞)(∫_0^∞)⋯(∫_0^∞)δ(1-((Subscript[x, 1])+⋯+(Subscript[x, n])))(f^((n-1)))((Subscript[τ, 1])(Subscript[x, 1])+(Subscript[τ, 2])(Subscript[x, 2])+⋯+(Subscript[τ, n])(Subscript[x, n]))d(Subscript[x, n])… d(Subscript[x, 2])d(Subscript[x, 1]).

Use this formula to calculate [(Subscript[x, 1])(Subscript[x, 2])… (Subscript[x, 8])].

g) Calculate the limits (lim_(ε->0))(Subscript[f, ε]^((ξ)))(x) and (lim_(ε->1))(Subscript[f, ε]^((ξ)))(x) where [418✶], [932✶], [1164✶]

(Subscript[f, ε]^((ξ)))(x)=(1/(2 (Sqrt[π]) (Sqrt[1-ε])))(e^((i π)/4)) (e^(-(i/2) ((ε (x^2)-2 ξ x+ε (ξ^2))/( 1-ε)))).

Derive a first-order and an x-free differential equation for (Subscript[f, ε]^((ξ)))(x).

h) Given the Fourier transform (F^((L)))(k)=(((2π))^(-1/2))(∫_(-L)^L)exp(i k x) f(x)dx of a function f(x), visualize how the Fourier transform (Subscript[F, o]^((L)))(k) of 2o+1 periodic continuations of f(x)

(Subscript[F, o]^((L)))(k)=(1/(Sqrt[2π]))(∫_(-∞)^∞)exp(i k x) (Subscript[f, o])(x)dx
(Subscript[f, o])(x)=(∑_(j=-o)^o)θ(x-(2j L-L))θ((2j L+L) -x)f(x+2j L)

approaches the Fourier series coefficients (Subscript[c, n]^((L)))=1/(2L)(∫_(-L)^L)exp(i n x π/L) f(x)dx for o->∞ [1323✶]. Use f(x)=exp(-(x^2)) as the example function.

i) The functional derivative of a functional F[f(x)] is defined through (see for instance [158✶], [930✶], [658✶], [1470✶], [815✶], [1616✶], [822✶])

((δ F[f(x)] )/(δ f(y)))=(lim_(ϵ->0))((F[f(x)+ϵ δ(x-y)]-F[f(x)])/ϵ).

Implement a function that attempts the functional differentiation for a given functional F[f(x)] . Use this function to calculate

((δ )/(δ f(y)))(∫_(-∞)^∞)((f(x))^3) ((f'(x))^2) f''(x)dx  .

Defining the Korteweg–de Vries bracket {F,G}=(∫_(-∞)^∞)δ F(y)/δ u(y)∂(δ F(y)/δ u(y))/∂y dy [1091✶], show that {(Subscript[𝒬, i]),(Subscript[𝒬, j])}=0 where

(Subscript[𝒬, 0])=(∫_(-∞)^∞)u(x)dx
(Subscript[𝒬, 1])=(∫_(-∞)^∞)(1/2)((u(x))^2)dx
(Subscript[𝒬, 2])=(∫_(-∞)^∞)((1/2) ((u'(x))^2)-((u(x))^3))dx
(Subscript[𝒬, 3])=(∫_(-∞)^∞)((5/2) ((u(x))^4)-5 u(x)((u'(x))^2) +(1/2) ((u''(x))^2))dx.

Implement multiple functional differentiation defined through

(((δ^n) F[f(x)])/(δ f((Subscript[y, 1]))⋯ δ f((Subscript[y, n]))))=(δ/(δ f((Subscript[y, 1]))))((((δ^(n-1)) F[f(x)])/(δ f((Subscript[y, 2]))⋯ δ f((Subscript[y, n])))))

and calculate

(((δ^3) exp((∫_(-∞)^∞)f(x)h(x)dx))/(δ f((Subscript[y, 1]))δ f((Subscript[y, 2]))δ f((Subscript[y, 3]))))(Subscript[|, f(y)=0]).

For many applications, it is useful to decompose exponentials of sums of operators into a product of exponentials of only one operator. (Examples are the solution of the time-dependent Schrödinger equation and the calculation of higher order Runge–Kutta formulas for the solution of ordinary differential equations.) Calculate the real-valued coefficients (Subscript[ω, 1]),(Subscript[ω, 2]),(Subscript[ω, 3]),(Subscript[ω, 4]),(Subscript[ω, 5]),(Subscript[ω, 6]), and  (Subscript[ω, 7]) of the fifth-order splitting formula [463✶], [593✶], [312✶], [1109✶], [1219✶], [1697✶], [1725✶], [1398✶], [1518✶], [166✶], [1174✶], [1134✶], [906✶], [907✶], [1133✶], [313✶], [1519✶], [1314✶], [1218✶], [899✶], [314✶]:

(e^(t((OverHat[A])+(OverHat[B]))))= (e^(t (Subscript[ω, 1])(OverHat[A])))(e^(t (Subscript[ω, 2])(OverHat[B])))(e^(t (Subscript[ω, 3])(OverHat[A])))(e^(t (Subscript[ω, 4])(OverHat[B])))(e^(t (Subscript[ω, 5])(OverHat[A])))(e^(t (Subscript[ω, 6])(OverHat[B])))(e^(t (Subscript[ω, 7])(OverHat[A])))+O((t^5)).

Here, (OverHat[A]) and (OverHat[B]) are the two (in general noncommuting) operators.

a) Given three concentric circles of radius (Subscript[r, 1]), (Subscript[r, 2]), and (Subscript[r, 3]), calculate the maximal area of the triangle that has one vertex at each of the circles. For (Subscript[r, 1])=1, (Subscript[r, 2])=2,(Subscript[r, 3])=3 calculate the explicit value of the area [576✶].

b) Given the areas of the four faces of a tetrahedron, find the maximal volume that the tetrahedron can have. Express the result in a compact way. For the two sets of four areas, {(9/10),(10/10),(11/10),(12/10)} and {1,1,1,1}, calculate a closed-form symbolic result for the maximal volume. [641✶], [39✶], [761✶]

Array[Function[n,
   If[# != {}, (* use Print here to see progress *)
      Print["Exponent = ", n, "  ", #]]&[
        Cases[Union @@ (* investigate all coefficients *)
                (CoefficientList[#, C]& /@
    If[Head[#] == Times, List @@ #, {#}]&[Factor[C^n - 1]]),
                 (* anything other than + 1, 0  and - 1 *)
                _?(((# != 1) && (# != -1) && (# != 0))&)]]], 500, 0];

p1 = {0, 0, 0}; p2 = {0, p2y, 0}; p3 = {p3x, p3y, 0};

This is the square of the area.

ASquare = (Cross[p2 - p1, p3 - p1].Cross[p2 - p1, p3 - p1])/4

We start with a step-by-step method to derive the result. Because the area has dimension (("length")^2), it should be expressed as a homogeneous polynomial of degree 2 in the squares of the lengths of the three edges. So we make the following ansatz for the square of the area.

ASquareAnsatz = c1 lS12^2 + c2 lS13^2 + c3 lS23^2 +
                c5 lS12 lS13 + c5 lS12 lS23 + c6 lS13 lS23

Expanding the expression ASquareAnsatz - ASquare and comparing the coefficients, we can derive a linear system of equations in the (Subscript[c, i]).

eq1 = 4 (ASquareAnsatz /.
        {lS12 -> (p2 - p1).(p2 - p1), lS13 -> (p3 - p1).(p3 - p1),
         lS23 -> (p3 - p2).(p3 - p2)}) - 4 ASquare

(eq2 = Expand[eq1]) // Length

These are all monomials in the polynomial eq2.

monomials = Union[((List @@ eq2) //. {i_Integer f_ -> f}) //.
                    {c1 -> 1, c2 -> 1, c3 -> 1, c4 -> 1, c5 -> 1, c6 -> 1}];
Length[monomials]

We extract the equations.

eqns = Coefficient[eq2, #] == 0& /@ monomials;

Then we solve them.

sol = Solve[eqns, {c1, c2, c3, c4, c5, c6}]

We replace the symbolic squares of the side length by explicit squares of side length.

ASquare = Factor[((ASquareAnsatz /. sol)[[1]]) /.
                   {lS12 -> l12^2, lS13 -> l13^2, lS23 -> l23^2}]

Factoring the result yields the square of the area (Heron’s formula).

Factor[ASquare]

Instead of using the previous step-by-step way to derive the result we can use more powerful commands to carry out the whole calculation at once. In the next input, GroebnerBasis is used to derive the result.

GroebnerBasis[
     {(* area^2 expressed in vertices coordinates *)
      areaSquared - p2y^2 p3x^2/4,
      (* edges expressed in vertices coordinates *)
      lS12 - (p2 - p1).(p2 - p1), 
      lS13 - (p3 - p1).(p3 - p1),
      lS23 - (p3 - p2).(p3 - p2)},
      (* variables to keep *) {areaSquared, lS12, lS13, lS23},
      (* variables to eliminate *)
      {p2y, p3x, p3y}, MonomialOrder -> EliminationOrder]

p1 = {0, 0, 0}; p2 = {p2x, 0, 0}; p3 = {p3x, p3y, 0}; p4 = {p4x, p4y, p4z};

The square of the area of the triangle in the x,y-plane and the corresponding height are given by "areaOfOneFace""heightAboveThisFace"/3 ([693✶], [1481✶], [318✶]).

cr = Cross[p2 - p1, p3 - p1]

ASquare = (cr.cr)/4 // Expand

hSquare = Together[(cr.(p4 - p1))^2/(cr.cr)] // Expand

We make for the volume V an ansatz in the form (V^2)=homogeneousPolynomialOfDegree3InTheEdgeLengths. These are all degree-three monomials that we can form with the squares of the four side lengths.

lList = {lS12, lS13, lS14, lS23, lS24, lS34}

tab1 = Table[lList[[i]]^3, {i, 6}]

tab2 = Complement[Flatten[Table[lList[[i]]^2 lList[[j]],
                                {i, 6}, {j, 6}]], tab1];

tab3 = Complement[Flatten[Table[lList[[i]] lList[[j]] lList[[k]],
                                {i, 6}, {j, 6}, {k, 6}]], tab1, tab2];

This is the corresponding ansatz for the volume V. (We use Unique to generate the coefficients to be determined because there are 56 of them now, and we do not want to write them all explicitly down.)

(VSquareAnsatz = Plus @@ MapIndexed[Unique[c] #&,
                    Join[tab1, tab2, tab3]]) // Short[#, 6]&

(* the variables *)
allVars = List @@ VSquareAnsatz //.
      {lS12 -> 1, lS13 -> 1, lS14 -> 1, lS23 -> 1, lS24 -> 1, lS34 -> 1}

Expanding the expression VSquareAnsatz - ASquare×hSquare/9 and comparing the coefficients, we can derive a linear system of equations in the c$i.

eq1 = 9 4 (VSquareAnsatz /.
           {lS12 -> (p2 - p1).(p2 - p1), lS13 -> (p3 - p1).(p3 - p1),
            lS14 -> (p4 - p1).(p4 - p1), lS23 -> (p3 - p2).(p3 - p2),
            lS24 -> (p4 - p2).(p4 - p2), lS34 -> (p4 - p3).(p4 - p3)}) *
           Denominator[hSquare] -  4 ASquare Numerator[hSquare];

(eq2 = Expand[eq1]) // Length

monomials = Function[{localVars},
(* locally inside Block set all the c$i to 1 *)
 Block[localVars,
       Union[((List @@ eq2) //. {i_Integer f_ -> f})]], {HoldAll}] @@
       (* setting all c$i to 1, enclosed in Hold *)
       DeleteCases[Hold @@ {Map[Hold[Set[#, 1]]&, allVars]},
                   Hold, {3}, Heads -> True];

Length[monomials]

The polynomial is now a bit larger in comparison to the 2D case of the last subexercise, but we can proceed in an analogous way.

eqns = Coefficient[eq2, #] == 0& /@ monomials;

(sol = Solve[eqns, allVars]) // Short[#, 12]&

We obtain the following.

Factor[((VSquareAnsatz /. sol)[[1]]) /.
       {lS12 -> l12^2, lS13 -> l13^2, lS14 -> l14^2,
        lS23 -> l23^2, lS24 -> l24^2, lS34 -> l34^2}]

This result for the square of the volume agrees with the textbook version written in the form of a determinant ([220✶], [319✶]).

(1/288 Det[{{0, l23^2, l24^2, l12^2, 1}, {l23^2, 0, l34^2, l13^2, 1},
            {l24^2, l34^2, 0, l14^2, 1}, {l12^2, l13^2, l14^2, 0, 1},
            {1, 1, 1, 1, 0}}] // Factor) == %

Instead of carrying out many relatively simple steps (as one would do it with paper and pencil), as done in the above calculation, we could again use the very powerful GroebnerBasis command to solve this problem. We express the volume as a function of the coordinates and then eliminate the coordinates in favor of the length of the six edges. This approach leads, of course, to the same result.

GroebnerBasis[
     {(* volume^2 expressed in vertices coordinates *)
      volumeSquared - p2x^2 p3y^2 p4z^2/36,
      (* edges expressed in vertices coordinates *)
      lS12 - (p2 - p1).(p2 - p1), lS13 - (p3 - p1).(p3 - p1),
      lS14 - (p4 - p1).(p4 - p1), lS23 - (p3 - p2).(p3 - p2),
      lS24 - (p4 - p2).(p4 - p2), lS34 - (p4 - p3).(p4 - p3)},
      (* variables to keep *)
     {volumeSquared, lS12, lS13, lS14, lS23, lS24, lS34},
      (* variables to eliminate *) {p2x, p3x, p3y, p4x, p4y, p4z},
      MonomialOrder -> EliminationOrder]

For generalizations of such formulas see [1380✶], [1381✶], and [1064✶]. For related problems, see [1047✶], [1344✶], and [1343✶].

Solve[(* the three circles touch the fourth one *)
      {(x - x1)^2 + (y - y1)^2 == (r1 + r )^2,
       (x - x2)^2 + (y - y2)^2 == (r2 + r )^2,
       (x - x3)^2 + (y - y3)^2 == (r3 + r )^2
      (* the three circles touch each other *)
       (x1 - x2)^2 + (y1 - y2)^2 == (r1 + r2)^2,
       (x1 - x3)^2 + (y1 - y3)^2 == (r1 + r3)^2,
       (x2 - x3)^2 + (y2 - y3)^2 == (r2 + r3)^2},
      {r}, {x, y, x1, y1, x2, y2, x3, y3}]

Unfortunately, such a direct call to Solve with the full set of equations does not return an answer in a reasonable time. 
So we have to guide the calculation. Without restricting generality, we can assume the midpoint of one of the three circles to be the origin and the midpoint of another one of the three circles to be on the x-axis. This decreases the number of variables involved by 3, and so reduces the complexity of the problem.

x1 = 0; y1 = 0; y2 = 0;

As a first step, we eliminate the midpoint coordinates of the fourth circle from the describing equations of the fourth circle touching the three others, not taking into account the fact that the three circles touch each other pairwise.

fa = Factor[Subtract @@ Eliminate[
{(x - x1)^2 + (y - y1)^2 == (r1 + r)^2,
 (x - x2)^2 + (y - y2)^2 == (r2 + r)^2,
 (x - x3)^2 + (y - y3)^2 == (r3 + r)^2}, {x, y}]]

Because the triangle formed by the midpoints of the three circles determines a triangle that at the same time is determined uniquely by the radii of the three circles, we eliminate the explicit coordinates of the midpoints and express all quantities as functions of the three radii.

GroebnerBasis[
{fa, (x1 - x2)^2 + (y1 - y2)^2 - (r1 + r2)^2,
     (x1 - x3)^2 + (y1 - y3)^2 - (r1 + r3)^2,
     (x2 - x3)^2 + (y2 - y3)^2 - (r2 + r3)^2},
{r1, r2, r3, r}, (* variables to eliminate *) {x2, x3, y3},
MonomialOrder -> EliminationOrder]

The result is a simple quadratic equation for r.

Solve[% == 0, r] // Simplify

To see which of the two solutions is the correct one, we just substitute numerical values for the radii of the three circles.

% /. {r1 -> 1, r2 -> 1, r3 -> 1} // N

This means, that the first of the above solutions is the one of interest.

%%[[1, 1, 2]]

Taking into account that r1, r2, and r3 are positive real numbers, we can simplify the result.

Factor //@ (
  % /. {Sqrt[r1^3 r2^3 r3^3 (r1 + r2 + r3)] ->
         r1 r2 r3 Sqrt[r1 r2 r3 (r1 + r2 + r3)],
        Sqrt[r1] Sqrt[r2] Sqrt[r3] Sqrt[r1 + r2 + r3] ->
         Sqrt[r1 r2 r3 (r1 + r2 + r3)]})

Multiplying numerator and denominator of the last expression by the numerator with reversed sign of the square root, the expression simplifies further.

Simplify[Factor[Expand[
   Numerator[%] (Numerator[%] /. p : Power[_, 1/2] :> -p)]] /
(Denominator[%] (Numerator[%] /. p : Power[_, 1/2] :> -p))]

The coordinates of the midpoint of the circle are straightforward to calculate once the radius is determined. For the corresponding problem of placing a fifth sphere between four given spheres (when possible), see [1555✶], [469✶].

circle = (y[x] - y0)^2 + (x - x0)^2 - r^2

We differentiate the implicit equation three times (we want to eliminate the three parameters (Subscript[x, 0]), (Subscript[y, 0]), and r) with respect to x to obtain a set of algebraic equations.

eqs = Table[D[circle, {x, i}], {i, 0, 3}]

Using GroebnerBasis with EliminationOrder, we get the nonlinear differential equation of third order obeyed by all circles in the x,y-plane.

GroebnerBasis[eqs, {x, y[x], y'[x], y''[x], y'''[x]},
              {x0, y0, r}, MonomialOrder -> EliminationOrder]

l1 = 1/(4u^3) D[v[u]^4, u]

l2 = Together[1/(4u^3) D[l1, u]]

l3 = Together[1/(4u^3) D[l2, u]]

Using the three quantities l1, l2, and l3, we obtain the following differential equation for v(u).

ode = 3 l2^2 - 2 l1 l3 + l1^2 (((1 + u^8)/(u^4 - u^12))^2 - 
          ((1 + v[u]^8)/(v[u]^4 - v[u]^12))^2 l1^2)

Now we use the modular equations under consideration to derive expressions for v'(u), v''(u), and v'''(u).

derivatives[poly_] := Reverse[Flatten[Table[
       Solve[D[poly, {u, i}] == 0, Derivative[i][v][u]], {i, 3}]]]

The first equation, supposedly a solution of ode, is the following.

modularEquation3 = u^4 - v^4 - 2 u v (1 - u^2 v^2) /. v -> v[u];

We calculate explicit forms for v'(u), v''(u), and v'''(u) from the last equation.

derivatives3 = derivatives[modularEquation3]

Inserting these derivatives into ode and clearing denominators gives the following result.

modularInserted3 = Factor[Numerator[Together[ode //. derivatives3]]]

One of the factors of the last equation is simply the starting polynomial modularInserted3.

Cancel[PolynomialGCD[modularInserted3, modularEquation3]/
		            modularEquation3]

This means that modularInserted3 satisfies ode.
In a similar way, we can deal with the second and third equations.

modularEquation5 = 
  u^6 - v^6 + 5 u^2 v^2 (u^2 - v^2) - 4 u v (1 - u^4 v^4) /. v -> v[u];
(* repeat steps from above *)
derivatives5 = derivatives[modularEquation5];
modularInserted5 = Factor[Numerator[Together[ode //. derivatives5]]];
Cancel[PolynomialGCD[modularInserted5, modularEquation5]/
		            modularEquation5]

modularEquation7 = (1 - u^8)(1 - v^8) - (1 - u v)^8 /. v -> v[u];
(* repeat steps from above *)
derivatives7 = derivatives[modularEquation7];
modularInserted7 = Factor[Numerator[Together[ode //. derivatives7]]];
Cancel[PolynomialGCD[modularInserted7, modularEquation7]/
		             modularEquation7]

W[x_] := (c1 E^-Integrate[f[x]/(1 - h[x]), x] *
    (c2 +  Integrate[E^(Integrate[g[x], x] + 
                     Integrate[f[x]/(1 - h[x]), x])/(1 - h[x]), x]))

We will differentiate the function twice and replace the exponentials of the undone integrals with new variables.

rules = {Exp[-Integrate[f[x]/(1 - h[x]), x]] -> int1, 
         Integrate[1/(1 - h[x]) Exp[Integrate[f[x]/(1 - h[x]), x]]* 
                Exp[Integrate[g[x], x]], x] -> int2, 
         Exp[Integrate[g[x], x]] -> int3};

w0 = W[x] /. rules

w1 = D[W[x], x] /. rules

w2 = D[W[x], x, x] /. rules

A polynomial system, formed from the above three results, allows us to eliminate the three auxiliary variables int1, int2, and int3.

Factor[GroebnerBasis[Numerator[
         Together[{w[x] - w0, w'[x] - w1, w''[x] - w2}]], {}, 
         {int1, int2, int3}, MonomialOrder -> EliminationOrder]]

The second factor of the last result is the differential equation we were looking for.

Collect[%[[1, -1]], {w[x], w'[x], w''[x]}]

% /. w -> W // Together

Tan[1/4 ArcTan[4]] - 2 (Cos[6Pi/17] + Cos[10 Pi/17]) //  Simplify

Also, the function FullSimplify—to be discussed in Chapter 3— is not able to establish the identity.

FullSimplify[%]

However, it is nevertheless straightforward to prove this identity: we transform both sides of the equation into explicit algebraic numbers (using TrigToExp to get rid of the trigonometric functions and Together and ExpandAll to eliminate the exponential functions) by applying various functions that change the form, but not the mathematical content, of an expression. Then a call to RootReduce will transform this algebraic number into a canonical form.

RootReduce[Together[ExpandAll[TrigToExp[Tan[1/4 ArcTan[4]]]]]]

RootReduce[Expand[Together[TrigToExp[2 (Cos[6Pi/17] + Cos[10 Pi/17])]]]]

Also, the radical form of this expression looks kind of neat.

ToRadicals[%]

Now let us prove the second identity. This is the right-hand side of the identity to be proved.

rhs = (1/6 + 1/6 Sqrt[7] (Cos[1/3 ArcCos[1/(2 Sqrt[7])]] + 
       Sqrt[3] Sin[1/3 ArcCos[1/(2 Sqrt[7])]]))

Numerically, the identity holds to a high precision.

N[Cos[Pi/7] - rhs, 22]

Making all numbers algebraic and applying RootReduce again proves the identity.

(* apply RootReduce to parts and then to whole expression *)
RootReduce[RootReduce /@ Expand[Simplify[Together //@ TrigToExp[rhs]]]]

Together[TrigToExp[Cos[Pi/7]]] // RootReduce

existsSecondBox[relation_] := 
Exists[{w1, h1, d1}, 
	   Element[{w1, h1, d1}, Reals] && 
	           (* first box has positive size *)
	           w1 > 0 && h1 > 0 && d1 > 0,
	  Exists[{w2, h2, d2}, Element[{w2, h2, d2}, Reals] && 
	                    (* second box is inside the first box *)
	                    w1 > w2 > 0  && h1 > h2 > 0 && d1 > d2 > 0,
	 (* the relation to be tested *)       
	 (1/w2 + 1/h2 + 1/d2) ~ relation ~ (w1 + h1 + d1)]]

Resolve shows that a second box for all three cases exists.

AppendTo[$ContextPath, "Experimental`"];

Resolve[existsSecondBox[#]]& /@ {Equal, Less, Greater}

AppendTo[$ContextPath, "Experimental`"]

cad = CylindricalAlgebraicDecomposition[
         Abs[ϕ x] + Abs[y] < 1 &&  Abs[ϕ y] + Abs[z] < 1 &&
         Abs[ϕ z] + Abs[x] < 1 &&
         (* algebraic definition of GoldenRatio *)
         (2 ϕ - 1)^2 == 5 && ϕ > 0, {ϕ, x, y, z}]

The result cad contains the numerical value of ϕ and the regions in the x,y,z-space.

{cad[[1]], cad[[2]] // Length, cad[[2]] // Head}

We expand the Or and obtain 16 single subregions.

(regions = cad[[2]] /. (xi_ && rest_Or) :> (And[xi, #]& /@ rest) /.
                        LessEqual -> Less /. Or -> List) // Length

They are three- and two-dimensional.

Take[regions, 5]

The function toPolygon forms the six polygons bounding the 3D and forms the one polygon forming the 2D regions.

f = {#1, #2 /. x -> #1, #3 /. y -> #2 /. x -> #1}&;

toPolygon[Inequality[x1_, Less, x, Less, x2_] &&
          Inequality[y1_, Less, y, Less, y2_] &&
          Inequality[z1_, Less, z, Less, z2_]] :=
Module[(* points *)
{p111 = f @@ {x1, y1, z1}, p112 = f @@ {x1, y1, z2},
 p121 = f @@ {x1, y2, z1}, p122 = f @@ {x1, y2, z2},
 p211 = f @@ {x2, y1, z1}, p212 = f @@ {x2, y1, z2},
 p221 = f @@ {x2, y2, z1}, p222 = f @@ {x2, y2, z2}},
 (* the six bounding polygons *) Polygon /@ 
{{p111, p211, p221, p121}, {p112, p212, p222, p122},
 {p111, p211, p212, p112}, {p121, p221, p222, p122},
 {p111, p121, p122, p112}, {p211, p221, p222, p212}} /. 
                                       ϕ -> GoldenRatio]

(* make polygon from Boolean expression *)
toPolygon[(x == x1_) && Inequality[y1_, Less, y, Less, y2_] &&
                        Inequality[z1_, Less, z, Less, z2_]] :=
Module[{p1 = f @@ {x1, y1, z1}, p2 = f @@ {x1, y2, z1},
        p3 = f @@ {x1, y2, z2}, p4 = f @@ {x1, y1, z2}},
       (* the single polygon *)
Polygon[{p1, p2, p3, p4} /. ϕ -> GoldenRatio]]

Here are the 16 regions shown individually.

SeedRandom[123];
Show[GraphicsArray[#]]& /@ Partition[
(* the individual 3D graphics *) tab = 
Table[Graphics3D[{SurfaceColor[Hue[Random[]], Hue[Random[]], 2.1], 
                    toPolygon[regions[[k]]]},
                 PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}} 0.6],
      {k, Length[regions]}] // N, 4]

Displaying them together, let us conjecture that the body is a dodecahedron.

Show[tab, PlotRange -> All, Axes -> True]

The next picture shows more clearly how the 16 subregions form the dodecahedron.

(* contract all polygons of the graphics gr *)
contract[gr_, α_] := 
Module[{vertices, center}, 
 vertices = Level[N[Cases[gr, _Polygon, Infinity]], {-2}];
 center = Plus @@ vertices/Length[vertices];
 gr /. Polygon[l_] :> Polygon[(center + α (# - center))& /@ l]]

(* cut a hole in a polygon *)
holePolygon[Polygon[l_], factor_] :=
Module[{mp = Plus @@ l/4, g = Partition[Append[#, First[#]], 2, 1]&},
MapThread[Polygon[Join[#1, Reverse[#2]]]&, 
          {g[l], g[(mp + factor(# - mp))& /@ l]}]]

Show[(contract[#, 0.8]& /@ tab) /. p_Polygon :> holePolygon[p, 0.7],
     Boxed -> False]

The resulting polyhedron looks like a dodecahedron. Now we will show that it actually is a dodecahedron. These are all the vertices of the subregions.

vertices = Union[RootReduce[Union[Together //@ (
            Level[Cases[tab, _Polygon, Infinity], {3}] /.
             GoldenRatio -> (1 + Sqrt[5])/2)]]];

Length[vertices]

Twenty of these vertices are the vertices of the dodecahedron.

squaredDistances = RootReduce[#.#]& /@ vertices;

(dodeVertices = Select[vertices, 
       RootReduce[#.#] == Max[squaredDistances]&]) // Length

Groups of five of the dodecahedron vertices form the 12 faces of the dodecahedron. Each of the 12 vertices has three nearest neighbors.

vertexVertexDistances =
Table[RootReduce[#.#&[dodeVertices[[i]] - dodeVertices[[j]]]],
      {i, 20}, {j, 20}];

With[{edgeLength = Min[DeleteCases[vertexVertexDistances, 0, {2}]]},
     Count[#, edgeLength]& /@ vertexVertexDistances]

For the general descriptions of polyhedra through inequalities, see [201✶], [702✶].

Integrate[Integrate[f[t]/t, {t, x, Infinity}]^2, {x, 0, ξ}] -
(Integrate[(1/x Integrate[f[t], {t, 0, x}])^2, {x, 0, ξ}] +
 (Sqrt[ξ] Integrate[f[t]/t, {t, ξ, Infinity}] +
  1/Sqrt[ξ] Integrate[f[t], {t, 0, ξ}])^2)

D[%, ξ] // Simplify

In addition we have to check an initial value; we choose ξ=0.

Series[%%, {ξ, 0, 1}]

(* add the context of IntegerPartitions to context path *)
AppendTo[$ContextPath, #]& /@ 
         Union[Context /@ Names["*`*IntegerPartition*"]];

partitions[n_] :=  (Last /@ Sort[Join[#, {#, 0}& /@ 
    Complement[Range[n], First /@ #]]])& /@ 
              IntegerPartitions[n]

A[varList_] := 
Module[{n = Length[varList],
        v = MapIndexed[#1/#2[[1]]&, varList]},
        Plus @@ ((n!/(Times @@ Factorial[#])(Times @@ (v^#)))& /@ 
        partitions[n])]

Here are the first few A-polynomials.

Table[A[Table[Subscript[τ, k], {k, n}]], {n, 5}]

The implementation of the relation itself is straightforward.

relation[as_List, r_] :=
With[{n = Length[as], (* left-hand side *)
      p = Function[Evaluate[Sum[c[i] #^i, {i, 0, Length[as] - 1}]]]},
     Sum[p[as[[k]]]/(x - as[[k]])^(r + 1)/
         Product[If[k == l, 1, as[[k]] - as[[l]]], {l, 1, n}], {k, n}] ==
                      (* right-hand side *)
     (-1)^r/(r! Product[x - as[[k]], {k, n}])*
     (Derivative[r][p][x] +
      Sum[(-1)^j Binomial[r, j] Derivative[r - j][p][x] *
          A[Table[Sum[(x - as[[i]])^-m, {i, n}], {m, j}]], {j, r}])]

The relation either autoevaluates to True or is a rational function. This means that Together is the appropriate function to apply. Here we check the first 16 relations of this type.

checkRelation[n_, r_] := 
With[{expr = relation[Table[Subscript[τ, k], {k, n}], r]},
     If[expr === True, True,
        Factor[Together[Subtract @@ expr]] === 0]]

Table[checkRelation[n, r], {n, 4}, {r, 4}]

Needs["DiscreteMath`Combinatorica`"]

n = 5;
allTriangles = KSubsets[Table[P[j], {j, n}], 3]

Without loss of generality, we can assume that the first point is at the origin and that the second one lies on the x-axis.

P[1][1] = 0; P[1][2] = 0;

To obtain relations between the areas of the triangles, we express the areas through the vertex coordinates and then eliminate the vertex coordinates. We use the oriented areas (Subscript[𝔸, i,j,k]).

A[{{x1_, y1_}, {x2_, y2_}, {x3_, y3_}}] := 
               Det[{{x1, y1, 1}, {x2, y2, 1}, {x3, y3, 1}}]/2;

eqs = Map[Subscript[𝔸, Sequence @@ (First /@ #)] - 
          A[Table[#[k], {k, 2}]& /@ #]&, allTriangles]

We have ten equations, and we have to eliminate eight vertex coordinates.

pointCoords = Union[Cases[eqs, _P[_], Infinity]]

{Length[eqs], Length[pointCoords]}

These are the resulting relations between the oriented areas. The last one, quadratic in the areas, may be unexpected.

gb1 = GroebnerBasis[eqs, {}, pointCoords,
                    MonomialOrder -> EliminationOrder]

For similar relations between the volumes of five tetrahedra formed by five points in (ℝ^3), see [1093✶].

(* pairwise distances *)
MapIndexed[Set[d[#2[[1]], #2[[1]] + #2[[2]]], #1]&,
{{87, 158, 170, 127, 68}, {85, 127, 136, 131}, 
 {68, 131, 174}, {87, 158}, {85}}, {2}];

(* fix position of two points *)
p[1][1] = 0; p[1][2] = 0; p[2][1] = 87; p[2][2] = 0;

(* Euclidean distance between two points *)
𝒹2[i_, j_] := (p[i][1] - p[j][1])^2 + (p[i][2] - p[j][2])^2;
(* 15 equations describing the distances *)
eqs = Flatten[Table[𝒹2[i, j] - d[i, j]^2, {i, 5}, {j, i + 1, 6}]];

(* undetermined point coordinates *)
ps = Cases[eqs, p[_][_], Infinity] // Union;
sol = Solve[# == 0& /@ eqs, ps]

The following graphic visualizes the relative positions of the six points.

Show[Graphics[{PointSize[0.02], 
Table[Point[Table[p[i][j], {j, 2}]], {i, 6}]}] /. sol[[1]], 
     Frame -> True, AspectRatio -> Automatic, PlotRange -> All]

H[n_] := Array[h, {n, n}];

Forming the defining equations and imposing the condition that the matrix elements can only take the values ±1 through (Subscript[h, i j]^2)=1 yields ten equations for the nine unknowns (Subscript[h, i j]). The inconsistency of this set of equations can be easily shown through GroebnerBasis.

With[{n = 3}, 
GroebnerBasis[Flatten[{H.Transpose[H] - n IdentityMatrix[n], H^2 - 1}], 
              Flatten[H[n]], MonomialOrder -> DegreeReverseLexicographic]]

TwoPointTaylorSeries[𝒻_, z_, {z1_, z2_}, o_] :=
Module[{𝒸}, 
       𝒸[0][ζ1_, ζ2_] := 𝒻[ζ2]/(ζ2 - ζ1);
       𝒸[n_][ζ1_, ζ2_] := 𝒸[n][ζ1, ζ2] = 
         (* simplify coefficients *) Together @ Factor @
          Sum[(n + k - 1)!/(k! n! (n - k)!)*
              ((-1)^(n + 1) n Derivative[n - k][𝒻][ζ2] +
              (-1)^(k) k Derivative[n - k][𝒻][ζ1])/
              (ζ1 - ζ2)^(n + k + 1), {k, 0, n}];
       (* the series *)
       Sum[(𝒸[n][z1, z2] (z - z1) + 𝒸[n][z1, z2] (z - z2))*
           (z - z1)^n (z - z2)^n, {n, 0, o}]]

The two-point Taylor series (Subscript[𝒯, 0,2π]^((20)))[sin](z) of order 20 for f(z)=sin(z) can be calculated in a fraction of a second.

(tps20[z_] = TwoPointTaylorSeries[Sin, z, {0, 2Pi}, 20];) // Timing

Here are the first two and the last term of the just-calculated series.

(List @@ tps20[z])[[{2, 1, -1}]]

At z=(Subscript[z, 1]) and z=(Subscript[z, 2]) the approximation tps20[z] reproduces the local Taylor expansion.

Normal[Series[tps20[z], {z, #, 20}]& /@ {0, 2Pi} // Simplify]

The two-point Taylor series is just the hermite interpolating polynomial at (Subscript[z, 1]) and (Subscript[z, 2]) [206✶], [405✶]. Using InterpolatingPolynomial and specifying the derivatives at (Subscript[z, 1]) and (Subscript[z, 2]) confirms this.

With[{o = 10}, Together @
 (TwoPointTaylorSeries[Sin, z, {0, 2Pi}, o] -
  InterpolatingPolynomial[
  Table[{j 2Pi, Table[Derivative[k][Sin][j 2Pi], 
                      {k, 0, o}]}, {j, 0, 1}], z])]

Now let us determine the precision of the approximation in the interval [0,2π]. A visualization shows that the maximum error occurs near z≈2.7 and z=3.3.

$MaxExtraPrecision = 200;
δ[z_?NumericQ] := N[tps20[SetPrecision[z, Infinity]] - 
                    Sin[SetPrecision[z, Infinity]], 20]

data = Table[{z, δ[z]}, {z, 0 - 1, 2Pi + 1, (2Pi - 0 + 2)/555}];

Show[GraphicsArray[
   ListPlot[#, PlotJoined -> True, DisplayFunction -> Identity]& /@ 
            N[{data, {#1, Log[10, Abs[#2]]}& @@@ data}]]]

A numerical minimization yields (max_((Subscript[z, 1])≤z≤(Subscript[z, 2])))|sin(z)-(Subscript[𝒯, 0,2π]^((20)))[sin](z)|≈3.3×(10^(-33)).

FindMinimum[δ[z], {z, 2, 2.1}, WorkingPrecision -> 100]

reciprocalOdE[p_, y_, o_] := Cancel[Numerator[Together[
              Nest[p[y] D[#, y]&, p[y], o - 1] - 
              1/D[1/p[y], {y, o - 1}]]]/p[y]] == 0

The complexity of the differential equations increases quickly with n.

Table[reciprocalOdE[p, y, o], {o, 2, 4}] // Simplify

For n=2, we obtain the simple solution (x-(Subscript[c, 1]))(y-(Subscript[c, 2]))=4.

DSolve[{x'[y] == 1/p[y], reciprocalOdE[p, y, 2]}, {x[y], p[y]}, y]

The general solution for n=3 would contain integrals over elliptic integrals.

TimeConstrained[DSolve[{x'[y] == 1/p[y], reciprocalOdE[p, y, 3]}, 
                       {x[y], p[y]}, y], 100]

Guided by the solution for n=2, we try a similar ansatz for n=3.

eq = (x - C[1]) (y - C[2]) - C[3];
{X = x /. Solve[eq == 0, x][[1]], Y = y /. Solve[eq == 0, y][[1]]}

Demanding that ((d)^n)y(x)/d(x^n)=1/(((d)^n)x(y)/d(y^n)) holds yields immediately (Subscript[c, 3])=6.

Together[D[Y, {x, 3}] D[X, {y, 3}] /. y -> Y] == 1

Trying now the same ansatz for n=4,5,… yields the conjecture (x-(Subscript[c, 1]))(y-(Subscript[c, 2]))=((n!)^(2/(n-1))) [222✶].

Table[Together[D[Y, {x, k}] D[X, {y, k}] /. y -> Y] == 1,
      {k, 2, 6}]

Series[Log[q, f[q x]/f[x]], {q, 1, 2}] // Simplify

The function 𝔮 implements the quotential derivative in straightforward way, according to the definition.

𝔮[f_, {x_, n_Integer}] := Module[{q},
Nest[Together[Limit[Log[q, (# /. x -> q x)/#], q -> 1, 
                    Analytic -> True]]&, f, n]]
                    
𝔮[f_, x_] := 𝔮[f, {x, 1}]

Here are the first few quotential derivatives of the univariate functions f(x).

Table[𝔮[f[x], {x, n}], {n, 0, 3}]

The first of the above identities is easily proved.

𝔮[f[g[x]], x] - 𝔮[f[g[x]], g[x]] 𝔮[g[x], x]

Next, we extend the definition of 𝔮 to the multivariate case. We follow closely the syntax of D.

𝔮[f_, vars__] := Fold[𝔮, f, Reverse @ {vars}]

Here are the two simplest second quotential derivatives.

{𝔮[f[x, y], x, y], 𝔮[f[x, y], y, x]}

The last two quotential derivatives differ from each other. Multiplying with the first quotential derivatives makes them equal.

𝔮[f[x, y], x] 𝔮[f[x, y], y, x] - 𝔮[f[x, y], y] 𝔮[f[x, y], x, y] //   
                                                         Together

summands = Rest[FoldList[Times, 1, 
                Table[If[k == 1, 1, a[k - 1]]/(x + a[k]), {k, 6}]]];

partialSums = Together @ Rest[FoldList[Plus, 0, summands]];

The numerators and denominators have simple forms when their coefficients in x are expressed as elementary symmetric polynomials in the (Subscript[a, k]).

Needs["Algebra`SymmetricPolynomials`"]

With[{n = 6}, Function[numDen, 
(Collect[numDen[#], x]& @ partialSums[[n]]) //.
 Table[SymmetricPolynomial[Table[a[j], {j, n}], k] ->
       Subscript[𝒮, k], {k, n}]] /@ {Numerator, Denominator}]

For each n, the ratio of numerator and denominator has the form 1/x+((O(1/x))^n). From this follows that the conjectured value of the sum is 1/x.

Table[ExpandAll @ 
Series[(x^n + Sum[x^(n - j) Subscript[𝒮, j], {j, n}])/
       (x^(n + 1) + Sum[x^(n + 1 - j) Subscript[𝒮, j], {j, n + 1}]),
       {x, Infinity, n}], {n, 6}]

ToHornerForm[poly_, x_] :=
        Fold[(#1 x + #2)&, 0, Reverse[CoefficientList[poly, x]]]

Here is an example.

ToHornerForm[Sum[a[i] x^i, {i, 0, 18}], x]

Expand[%] == Sum[a[i] x^i, {i, 0, 18}]

For a more complete implementation to rewrite polynomials in Horner form, see the package Algebra`Horner`.

Needs["Algebra`Horner`"]

??Horner

For multivariate polynomials see [1257✶]; for intervals, see [284✶].

myBernoulli[n_Integer?(# >= 0&), x_] :=
Plus @@ (Array[C[#] x^# &, n + 1, 0] /.
Solve[(* generate and solve the equations for the coefficients *)
      Thread[(* the coefficients of the powers of C *)
             CoefficientList[Plus @@ Array[
             (* the integral carried out *)
             C[#] ((C + 1)^(1 + #) - 
                   C^(1 + #))/(1 + #)&, n + 1, 0], C] ==
             (* the right-hand side *)
             Array[If[# === n, 1, 0]&, n + 1, 0]],
     (* the coefficients *)Array[C, n + 1, 0]][[1]])

The calculated and built-in polynomials agree. Here is a quick check for the first few polynomials.

Union @ Table[BernoulliB[n, z] === myBernoulli[n, z], {n, 0, 12}]

n = 4;
(eqs = Join[Thread[Table[a[i], {i, 0, n}] ==
                CoefficientList[Product[x - xa[i], {i, n}], x]],
            Thread[Table[b[i], {i, 0, n}] ==
                CoefficientList[Product[x - xb[i], {i, n}], x]],
            Table[xb[i] == xa[i]^2, {i, n}],
                {Sum[b[i] x^i, {i, 0, n}] == 0}]) // TableForm

Using Eliminate, we express all xb[i] through the old coefficients xa[i].

Eliminate[eqs, Join[Table[xa[i], {i, n}], Table[xb[i], {i, n}],
                    Table[b[i], {i, 0, n}]]]

So the new polynomial is given by the following expression.

Collect[-Subtract @@ (%[[1]]), x]

Here is a short numerical check for random coefficients.

SeedRandom[999];
randomCoeffs = Table[a[i] -> Random[Complex, {-1 - I, 1 + I}], 
                     {i, 0, 3}];

(* the squared roots of the original polynomial *)
Sort[x^2 /. {ToRules[
         NRoots[(Sum[a[i] x^i, {i, 0, 3}] + x^4 == 0) /. 
                                       randomCoeffs, x]]}]

(* the roots of the calculated polynomial *)
Sort[x /. {ToRules[NRoots[(x^4 + x^3 (2a[2] - a[3]^2) + 
       x^2 (2a[0] + a[2]^2 - 2a[1] a[3]) +
 x (2a[0] a[2] - a[1]^2) + a[0]^2 == 0) /. randomCoeffs, x]]}]

f[x_] = -(1 + x) + 2 (1 + x^2)^(1/2) - 3 (1 + x^3)^(1/3) + 
         5 (1 + x^5)^(1/5) - 4

Plot[Evaluate[f[x]], {x, -1, 5}, AxesOrigin -> {0, 0}]

A direct call to Solve will not yield a result in a reasonable amount of time. (Of course, Solve will calculate all, not only the real, solutions.)

TimeConstrained[Solve[f[x] == 0, x], 100]

Using numerical techniques, such as FindRoot, we can find a numerical approximation for the real zeros.

FindRoot[Evaluate[f[x]], {x, #}]& /@ {-0.99, -0.5, 2.}

To find a polynomial in x, which includes among its zeros the zeros of the expression under consideration, we rewrite the roots in the form in a polynomial form (("squareRoot")^2)=(1+(x^2)), (("cubeRoot")^2)=(1+(x^3)), and (("quintRoot")^2)=(1+(x^5)) and eliminate the variables squareRoot, cubeRoot, and quintRoot from the resulting system of polynomial equations. Using Resultant, we eliminate these eliminations step by step.

Resultant[-(1 + x) + 2 squareRoot - 3 cubeRoot + 5 quintRoot - 4,
          squareRoot^2 - (1 + x^2), squareRoot]

Resultant[%, cubeRoot^3 - (1 + x^3), cubeRoot]

Resultant[%, quintRoot^5 - (1 + x^5), quintRoot]

These are the real roots greater than -1 of the resulting polynomial of degree 30.

(roots = Cases[{ToRules[Roots[% == 0, x]]}, 
            {x -> _?(Im[N[#]] == 0 && # > -1&)}]) // Short[#, 12]&

N[roots, 30]

The roots obey the original equation. Here is a quick numerical check.

f[x /. #]& /@ %

allTransformations = (x -> #)& /@ Together /@
Flatten[{Table[ϵ^i x, {i, 5}], Table[-ϵ^i/x, {i, 5}],
         Table[ ϵ^j ((ϵ + ϵ^4) x + ϵ^i)/
                (x - ϵ^i (ϵ + ϵ^4)), {i, 5}, {j, 5}],
         Table[-ϵ^j (x - ϵ^i (ϵ + ϵ^4))/
               ((ϵ + ϵ^4) x + ϵ^i), {i, 5}, {j, 5}]}];

The original polynomial factors into three factors of degree 2, 4, and 4.

factors0 = Factor[-1 + 11 x^5 + x^10]

To show that the transformed equations have the same solutions as the original one, we first carry out the substitution. We do not use the explicit value of ϵ at this stage. Because (ϵ^5)=1, we then reduce all terms of the form (ϵ^n) to (ϵ^(n mod 5)). From the resulting polynomial in x and ϵ, we eliminate ϵ by using its defining equation (ϵ^5)-1=0. The resulting polynomial must then contain the three factors ((x^2)+x-1), ((x^4)+4 (x^2)-2 x-3 (x^3)+1), and  ((x^4)+2 (x^3)+4 (x^2)+3 x+1). Here, this is implemented.

Table[PolynomialGCD[Factor[Resultant[
     Numerator[Together[(-1 + 11 x^5 + x^10) /.
                     allTransformations[[i]]]] /. 
          ϵ^n_ :> ϵ^Mod[n, 5], ϵ^5 - 1, ϵ]], 
    factors0] === factors0, 
    {i, Length[allTransformations]}] // Union

iteratedExponential[n_] :=
   Fold[Exp[#2 z #1]&, Exp[c[n] z], Reverse[Table[c[i], {i, n - 1}]]]

Here is an example.

iteratedExponential[3]

To achieve the best possible matching between 1+ln(1+z) and exp((Subscript[c, 1])z exp((Subscript[c, 2])z exp((Subscript[c, 3])z ⋯))), we will adjust the constants (Subscript[c, 1]), (Subscript[c, 2]), …, (Subscript[c, 10]) in such a way that their Taylor series will agree around z=0. Here are the first terms of its series expansion. The term of (z^k) is a polynomial in (Subscript[c, 1]), (Subscript[c, 2]), …, (Subscript[c, k]).

Factor //@ Series[iteratedExponential[3], {z, 0, 4}]

The ith series term of 1+ln(1+z) is given as (((-1))^(i+1))/i.

logSeries = Series[1 + Log[1 + z], {z, 0, 10}]

1 + Sum[(-1)^(i + 1)/i z^i, {i, 1, 10}]

Taking into account that the term of (z^k) of the iterated polynomial is a polynomial in (Subscript[c, 1]), (Subscript[c, 2]), …, (Subscript[c, k]), it is straightforward to calculate recursively the first 10 of the (Subscript[c, k]). Doing it recursively by backsubstituting the previously calculated values for the (Subscript[c, k]) is much faster than making a series expansion of the iterated exponential with 10 symbolic coefficients and then solving the coupled nonlinear system of equations for the (Subscript[c, k]).

cList[n_] :=
Module[{cRules, iExp, ser, coeff, sol},
cRules = {c[1] -> 1};
Do[(* iterated exponential with backsubstituted cs *)
   iExp = iteratedExponential[i] /. cRules;
   (* series to order i of the iterated exponential *)
   ser = Series[iExp, {z, 0, i}];
   (* coefficients of the power series *)
   coeff = SeriesCoefficient[ser, i];
   (* solve for the new coefficient *)
   sol = Solve[coeff == (-1)^(i + 1)/i, c[i]][[1]];
   (* collect the value of c[i] *)
   AppendTo[cRules, sol[[1]]], {i, 2, n}];
   (* return list of all c[i], {i, 1, n} *)
   cRules]

Here are the first 10 (Subscript[c, k]).

cL = cList[10]

It seems that their numerical value approaches a constant.

Map[MapAt[N[#, 22]&, #, -1]&, cL]

Here is a quick check that the result has the series terms of 1+ln(1+z) around z=0.

lnApproximation = iteratedExponential[10] /. cL;
Series[lnApproximation, {z, 0, 10}]

Lastly, let us look at the quality of the approximation calculated. The next picture shows the logarithm of the relative difference along the real axis (we turn off messages that would be generated due to the singularity of log(ξ) at ξ=0).

Off[General::unfl]; Off[General::ovfl]; Off[Plot::plnr];
Plot[Log[10, Abs[1 + Log[1 + z] - lnApproximation]/
                                Abs[1 + Log[1 + z]]], {z, -1, 2}]

The next picture shows the logarithm of the absolute difference for complex values of z.

Off[Plot3D::plnc]; Off[Plot3D::gval];

Plot3D[Evaluate[Log[10, Abs[1 + Log[1 + z] - lnApproximation]] /.
                z -> x + I y],
       {x, -1, 2}, {y, -2, 2}, PlotPoints -> 20, PlotRange -> All]

m = Table[1/(i + j + 1), {i, 5}, {j, 5}];
FixedPoint[(# + Inverse[#])/2&, N[m], 100]

The fixed point of the map x->(x+(x^(-1)))/2 are the values x->±1. This means that x->(x+(x^(-1)))/2 represents a matrix version of the Sign function [426✶], [762✶]. To calculate the matrix version of a function, we decompose the matrix into its spectral components.

{ℰ, 𝒱} = Eigensystem[m];

We introduce the abbreviation ℛ for a root object and write the kth eigenvalues and kth eigenvector in a form that makes the dependence on k explicit.

{ℰ, 𝒱} = 
With[{ℛ = Root[(-1 + 5603255 # - 246181488000 #^2 + 191979048240000 #^3 - 
                4545067645440000 #^4 + 5175372787200000 #^5)&, #]&},
 {(* eigenvalues *)
  Table[ℛ[k], {k, 5}], 
  (* eigenvectors *)
  Table[
  {7/66 (1 - 1206272 ℛ[k] + 8667711360 ℛ[k]^2 - 767331532800 ℛ[k]^3 + 
         1408264704000 ℛ[k]^4), 
   28/33 (-1 + 643230 ℛ[k] - 1974974400 ℛ[k]^2 + 44008272000 ℛ[k]^3), 
   42/55 (+3 - 682640 ℛ[k] - 397252800 ℛ[k]^2 + 39118464000 ℛ[k]^3), 
   28/11 (-1 - 92260 ℛ[k] + 158760000 ℛ[k]^2 + 9779616000 ℛ[k]^3), 
   1 + 346080 ℛ[k] + 789566400 ℛ[k]^2 + 21337344000 ℛ[k]^3}/
 (1 + 346080 ℛ[k] + 789566400 ℛ[k]^2 + 21337344000 ℛ[k]^3), {k, 5}]}];

The symbolic spectral decomposition contains many Root-objects.

Count[{ℰ, 𝒱}, _Root, Infinity]

The eigenvalues of m give rise to the above-shown identity matrix.

Sign[DiagonalMatrix[ℰ]]

For a hermitian matrix, we know that the eigenvectors are orthogonal and the decomposition (𝒱^T).ℰ.𝒱 holds. Here, 𝒱 is the matrix of the normalized eigenvectors and ℰ is the diagonal matrix of the eigenvalues. Normalizing the eigenvectors, we can use f(m)=(𝒱^T).f(𝒟(ℰ)).𝒱 to verify that the above fixed point (𝒟(ℰ)  is the diagonal matrix of the eigenvalues ℰ).

𝒱𝓃 = RootReduce[#/RootReduce[Sqrt[#.#]]]& /@
                 (RootReduce[Simplify[#]]& /@ 𝒱);

Transpose[𝒱𝓃].Sign[DiagonalMatrix[ℰ]].𝒱𝓃;

Table[RootReduce[%[[i, j]]], (* use symmetry *) {i, 5}, {j, i, 5}]

poly = (x + 1)^2000 (x^2 + x + 1)^1000 (x^4 + x^3 + x^2 + x + 1)^500;

To obtain the coefficients of the polynomial we could use a rule-based approach for expansion. But this would be relatively slow. A fast, nonalgebraic way to get the list of coefficients is to transform the polynomial into a Taylor series. This uses the built-in functions Series and SeriesData.

(cl = (poly + O[x]^6001)[[3]]); // Timing

The next graphic visualizes the magnitude of the coefficients.

ListPlot[Log[10, N[cl]] // N, PlotRange -> All]

Show[Graphics3D[{PointSize[0.01], 
Table[roots = {Re[#], Im[#]}& /@  (z /. NSolve[z^3 + c^2 z + 1 == 0, z]);
Point[Append[#, c]]& /@ roots, {c, 0, 6, 6/200}]}],
       BoxRatios -> {1, 1, 1}, Axes -> True, ViewPoint -> {2, 2, 1}]

A graphic of the numerically calculated minimal distance d(c) between the three roots shows a clear minima around c≈±1.1.

δMin[c_] := 
With[{roots = Last /@ (List @@ NRoots[x^3 + c^2 x + 1 == 0, x])},
     Min[Abs[Flatten[Table[roots[[i]] - roots[[j]], 
                           {i, 3}, {j, i - 1}]]]]]

Plot[δMin[c], {c, -5, 5}]

To calculate an exact value for the minimal distance we express the distance between the roots in a polynomial way. To do this we separate real and imaginary parts and find a polynomial p(c,d)=0.

z = x + I y;
p = Expand[z^3 + c^2 z + 1];

{im = Plus @@ Cases[p, _Complex _] // Factor, re = p - im // Factor}

Now we eliminate the remaining variables x1, x2, y1, y2, and Z and obtain one polynomial equation in c and d.

gb = Factor[GroebnerBasis[Flatten[
{(* the two roots *)
 {re, im} /. {x -> x1, y -> y1}, {re, im} /. {x -> x2, y -> y2},
 (* the roots are different *) 1 - Z (x1 - x2),
 (* distance between the two roots *)
 d^2 - (x1 - x2)^2 - (y1 - y2)^2}],
 {c, d}, {x1, x2, y1, y2, Z}, MonomialOrder -> EliminationOrder]][[1]]

Viewing d as a function of c gives the two equations p(c,d)=0, ∂p(c,d(c))/∂c=0.

gbD = Factor[D[gb/d^2 /. d -> d[c], c] /. d'[c] -> 0 /. d[c] -> d]

Using the numerical solution of the system allows us to extract the corresponding symbolic solution.

FindRoot[Evaluate[{gb == 0, gbD == 0}], {c, 1}, {d, 1.5}]

{#, N[#]}& @ Select[{c, d} /. Solve[{gb == 0, gbD == 0}, {c, d}],
                    # == {1.09112`5, 1.54308`5}&]

Analytical bounds on the minimal distance between roots can be found in [1132✶], [1138✶] and [1403✶].

f[1, z_] := z^2 + c
f[n_, z_] := f[1, f[n - 1, z]]

The most difficult calculation of this exercise is the calculation of the (Subscript[c, k]). Because (Subscript[c, k]) is a rational function of all roots of a polynomial, it will be a rational function of the coefficients of the original polynomial. This means that it will be a rational function in c. To avoid the explicit calculation of any expressions containing radicals or/and roots of c, we use the function RootReduce in the following definition.

c[k_] := RootSum[Function[x, Evaluate[f[k, x] - x]], 
                 Function[x, Evaluate[1/(#^2 - #)&[
                                      D[f[k, x], x]]]]] // Simplify //
                                                    Together // Factor

The remaining steps are straightforward and show the identity of the first four nontrivial terms.

o = 4;
Sum[z^k/k c[k], {k, o}]

Exp[-% + O[z]^(o + 1)] // Simplify

1 + Sum[(z/2)^k/Product[f[j, 0], {j, k}], {k, o}] + O[z]^(o + 1) //
                                   MapAll[Together[Factor[#]]&, #]&

derivativeValuesL[m_] :=
Table[Limit[D[(x/Sin[x])^ℯ, {x, d}], x -> 0], {ℯ, m}, {d, 0, m}]

derivativeValuesL[6] // Timing

To avoid repeating any work, and using the fact that x/sin(x) has a Taylor series starting with 1+(x^2)/6+⋯, we can implement the following much faster function derivativeValuesS. We first form all series of the x/sin(x) recursively and then calculate the value of the oth derivative at x=0 from the coefficient of (x^o) in the Taylor series.

derivativeValuesS[m_] := 
Module[{x},
Table[Table[d! #[[d + 1]], {d, 0, m}]&[
            CoefficientList[#[[ℯ]], x]], {ℯ, m}]&[
                Function[s, NestList[s #&, s, m - 1]][
                          Series[x/Sin[x], {x, 0, m}]]]]

This resulted in a thousand times faster calculation of the (Subscript[c, e,o]).

derivativeValuesS[6] // Timing

The calculation for m=100 now takes less than a minute.

(cs = derivativeValuesS[100]); // Timing

The following graphic shows the logarithm of the (Subscript[c, e,d]) for odd d.

ListPlot3D[Log[10, MapIndexed[If[EvenQ[#2[[1]]], Sequence @@ {}, 
                                 #1]&, #]& /@ cs],
           MeshRange -> {{1, 100}, {0, 100}}, Mesh -> False]

For a semi-closed form of the (Subscript[c, e,d]), see [1203✶].

AppellNielsenPolynomialList[n_, z_] := 
(* extract polynomials *) Last /@
NestList[Function[{s, p}, {-s, Function[ℐ, ℐ /. (* use symmetry *)
         Solve[-s ℐ == (ℐ /. z -> -(z + 1)), C][[1]] /. C -> 0][
         (* use recursion *) Integrate[p, z] + C]}] @@ #&, {1, 1}, n]

The next plot shows the logarithm of the absolute value of the first 36 Appell–Nielsen polynomials. The steep vertical cusps are the zeros of the polynomials. While the majority of the roots seem to have identical numerical values, most of them are actually slightly different.

With[{o = 35},
Plot[Evaluate[Log @ Abs @ AppellNielsenPolynomialList[o, z]],
     {z, -6, 6}, PlotRange -> {-45, 5}, PlotPoints -> 200,
     Frame -> True, Axes -> False,
     PlotStyle -> Table[{Thickness[0.002], Hue[0.8 k/o]},
                        {k, o + 1}]]]

TaylorTerms[n_, {f_, x_, h_}] := Expand[f[x + h] - 
           Nest[Integrate[#, {h, 0, h}]&, Derivative[n][f][x + h], n]]

And here are the first ten Taylor terms obtained from integration for a not explicitly specified function f.

TaylorTerms[10, {f, x, h}]

The next input expands f(x)=cos(x) around x=π.

TaylorTerms[10, {Cos, Pi, h}]

For direct integral analogues of the Taylor formula, see [1222✶].

GeneralizedTaylorExpansion[f_, φs_, x_, x0_] := 
Module[{n = Length[φs], W, Φ},
 (* the Wronskian *)
 W = Det[Table[D[φs, {x, k}], {k, 0, n - 1}]] /. x -> x0;
 (* the second determinant *)
 Φ = Det[Join[{Prepend[φs, 0]}, 
         Table[D[Prepend[φs, f], {x, k}], {k, 0, n - 1}] /. x -> x0]];
 (* the approximation *) -Expand[Φ/W]]

For small m (say m≲10), it works fine.

ExpBasis[m_] := Table[Exp[x/k], {k, m}]
GeneralizedTaylorExpansion[Cos[x], ExpBasis[8], x, 0] // Timing

Due to the calculation of a determinant with symbolic entries, this form is not suited for larger m. The Taylor-like approximation carried out by GeneralizedTaylorExpansion cancels the leading monomial terms in a classical Taylor expansion of f(x)-(∑_(k=0)^n)(Subscript[c, k])(Subscript[φ, k])(x) around x=(Subscript[x, 0]). We can so reformulate the problem to the determination of the (Subscript[c, k]). Assuming no additional degeneracy and the presence of all monomials, the following function GeneralizedTaylorExpansion1 solves for the (Subscript[c, k]) and returns the resulting sum.

GeneralizedTaylorExpansion1[f_, φs_, x_, x0_] := 
Module[{n = Length[φs], vars = Table[C[k], {k, Length[φs]}], sol},
       sol = Solve[# == 0& /@ CoefficientList[Series[f - vars.φs, 
                                  {x, x0, n - 1}], x], vars];
       vars.φs /. sol[[1]]]

If all the (Subscript[c, k]) are numbers, the resulting linear system can be solved much more quickly then the above symbolic determinant.

GeneralizedTaylorExpansion1[Cos[x], ExpBasis[8], x, 0] // Timing

Now we can also deal with m=25.

𝒻Approx[x_] = GeneralizedTaylorExpansion1[Cos[x], ExpBasis[25], x, 0];

Some of the resulting numbers have up to 50 digits.

{#, N[#]}& @ Max[Abs[{Numerator[#], Denominator[#]}& /@ 
Cases[𝒻Approx[x], _Integer | _Rational, {0, Infinity}]]]

The left graphic shows the function f(x)=cos(x) and its approximation 𝒻Approx[x]. The right graphic shows the logarithm of the absolute error between f(x) and its approximation.

dataApprox = Table[{x, 𝒻Approx[N[x, 100]]} // N, {x, -5Pi, 5Pi, 10Pi/201}];

Off[Graphics::gptn];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {(* Cos[x] and approximation *)
  Show[{Plot[Cos[x], {x, -5Pi, 5Pi}, PlotStyle -> {Hue[0]}], 
   ListPlot[dataApprox // N, PlotRange -> {-2, 2}, PlotJoined -> True]}],
  (* logarithm of absolute error *)
  ListPlot[N[{#1, Log[10, Abs[#2 - Cos[#1]]]}]& @@@ dataApprox, 
           PlotRange -> All, PlotJoined -> True]}]]]

PainlevéODEVI𝒮[w_, z_] := D[w, z, z] - 
 (1/2 (1/w + 1/(w - 1) + 1/(w - z)) D[w, z]^2 -
 (1/z + 1/(z - 1) + 1/(w - z)) D[w, z] +
  1/2 w (w - 1)(w - z)/(z^2 (z - 1)^2)(4 + z (z - 1)/(w - z)^2))

yChazy is the proposed solution.

yChazy[z_] = With[{𝓊 = (c1 𝒻[1][#] + c2 𝒻[2][#])&},
1/8 ((𝓊[z] + 2z 𝓊'[z])^2 - 4z 𝓊'[z]^2)^2/
    (𝓊[z] 𝓊'[z] (2(z - 1) 𝓊'[z] + 𝓊[z])(𝓊[z] + 2z 𝓊'[z]))];

Substituting now yChazy[z] into PainlevéODEVI𝒮, replacing the second and third derivatives of 𝒻[k] by using its defining differential equation, and simplifying the result shows that yChazy[z] is a solution.

Together[PainlevéODEVI𝒮[yChazy[z], z] //. 
  {𝒻[k_]'''[z] :> (8 (1 - 2z) 𝒻[k]''[z] - 9 𝒻[k]'[z])/(4 z(z - 1)),
   𝒻[k_]''[z]  :> (4 (1 - 2z) 𝒻[k]'[z] - 𝒻[k][z])/(4 z(z - 1))}]

We end by remarking that the explicit solution of 𝓊(z) is 𝓊(z)=(Subscript[c, 1])K(z)+(Subscript[c, 2])K(1-z) where K is the complete elliptic integral of the first kind.

Together[z (1 - z) 𝒻''[z] + (1 - 2z) 𝒻'[z] - 𝒻[z]/4 /. 
    𝒻 -> Function[z, c[1] EllipticK[z] + c[2] EllipticK[1 - z]]]

f[n_][x_] := Integrate[f[n - 1][x - z], {z, 0, x}]

f[0][x_] = Exp[-x];

f[2][x]

We compare it to the following.

fn[2][x] = Nest[Integrate[# /. {x -> x - z}, {z, 0, x}]&, Exp[-x], 2]

Expand[TrigToExp[fn[2][x] - f[2][x]]]

The reason for this in the first moment unexpected result is that Integrate does not localize its integration variable. (It is impossible for Integrate to do this because it has no HoldAll attribute, and so it cannot avoid the evaluation of all its arguments before Integrate can go to work.) So the integration variables are not screened from each other in nested integrations. Here is what happens in detail by calculating f[2][x].

f[2][x] ⟶ Integrate[f[2 - 1][x - z], {z, 0, x}]

Now the two variables (from a mathematical point of view—dummy variables) z interfere.

f[1][x - z] ⟶ Integrate[f[0][(x - z) - z], {z, 0, (x - z)}]

Integrate[f[0][(x - z) - z], {z, 0, x}] ⟶ Integrate[Exp[-((x - z) - z)], {z, 0, x}]

Integrate[Exp[-((x - z) - z)], {z, 0, x}] ⟶ Exp[x - 2 z]/2 - Exp[-x]/2

Integrate[Exp[x - 2z]/2 - Exp[-x]/2, {z, 0, x}] ⟶ Exp[x]/4 - (1 + 2 x)/4 Exp[-x]

By using On[], we could follow all of the above steps in more detail, but because of the extensive output, we do not show it here. 
To screen the integration variables in nested integrations, we could, for instance, use the following construction for the function definiteIntegrate. (We implement it here only for 1D integrals—the generalization to multidimensional integrals is obvious.)

SetAttributes[definiteIntegrate, HoldAll]

definiteIntegrate[integrand_, {iVar_, lowerLimit_, upperLimit_}] :=
Function[x, Integrate[#, {x, lowerLimit, upperLimit}]& @@
(* avoid evaluation of integrand; substitute new integration variable *)
       (Hold[integrand] //. iVar -> x)][
(* create a unique integration variable *) Unique[x]]

(Note that definiteIntegrate has the attribute HoldAll and that an additional Hold on the right-hand side is necessary to avoid any evaluation. A unique integration variable is created via Unique[x].) 
Using the function definiteIntegrate in the recursive definition of f now gives the “expected” result.

f1[n_][x_] := definiteIntegrate[f1[n - 1][x - z], {z, 0, x}]

f1[0][x_] = Exp[-x];

Now we get from f[2][x] the expected result.

f1[2][x]

f1[2][x] - fn[2][x] // TrigToExp // Expand

For the simple example under consideration, we could use a simpler way of creating different dummy integration variables. Here is an example.

f2[n_][x_] := Integrate[f2[n - 1][x - z[x]], {z[x], 0, x}]

f2[0][x_] = Exp[-x];

f2[2][x]

Integrate[(1 + x)^2, x] + Integrate[x, x]

Integrate[(1 + x)^2 + x, x]

% - %% // Expand

Now, let us deal with the definite integrals. The function f should have a discontinuity at (Subscript[x, m]). We choose the branch cut of the square root function as the discontinuity. We take (Subscript[x, l]) and (Subscript[x, u]) on opposite sides of the branch cut and (Subscript[x, m]) directly on the branch cut.

Integrate[Sqrt[z], {z, -1 - I, -1 + I}]

Integrate[Sqrt[z], {z, -1 - I, 0}] + Integrate[Sqrt[z], {z, 0, -1 + I}]

% - %% // Expand

Derivative[i_Integer?Negative][f_] :=
(* because the test is the whole calculation, use With and
   then use pI as test and as the result *)
With[{pI = Integrate[f[C], C]},
      (* test if Integrate appears in result *)
      Derivative[i + 1][Function[pI] /. C -> #] /;
      FreeQ[pI, Integrate, {0, Infinity}]]

Derivative[-3][Exp]

Derivative[-3][#^3 + Sin[#]&]

Here is the difference between Derivative[+4][Exp[1 #]&] and Derivative[-4][Exp[1 #]&].

Derivative[+4][Exp[1 #]&]

Derivative[-4][Exp[1 #]&]

Actually, the rule we added to Derivative is already present in Mathematica. Derivative[negativeInterger][f] is treated as the n-fold integral of the pure function f.

Derivative[i_Integer?Negative][f_] =.

Derivative[-3][#^3 + Sin[#]&]

f[x_, y_] := Log[x + Exp[y]];
{D[Integrate[f[x, y], x], y], Integrate[D[f[x, y], y], x]}

%[[1]] - %[[2]] // Together // Factor

f[x_, y_] := Log[x + y];
(D[Integrate[f[x, y], x], y] - Integrate[D[f[x, y], y], x]) // 
                                             Together // Factor

rulePower = t:_Times?(MemberQ[#, Power[_, _Rational]]&) :>
Module[{product = List @@ t, rads, rest},
        (* select the radicals *)
        rads = Cases[product, Power[_, _Rational], {1}];
        rest = Complement[product, rads];
        (* the new exponent *)
        exp = LCM @@ Denominator[Last /@ rads];
        (Times @@ rads^exp)^(1/exp) (Times @@ rest)];

Here is an example showing rulePower at work.

a^(2/3) b^(3/4) c^(4/5) (d + e)^(5/6) f^(1/n) g /. rulePower

The rule ruleLogSum rewrites sums of logarithms as one logarithm.

ruleLogSum = p:_Plus :> 
Module[{sum = List @@ p, logs, rest},
        (* select the logarithms *)
        logs = Cases[sum, _Log, {1}];
        rest = Complement[sum, logs];
        Plus[Sequence @@ rest, Log[Times @@ (First /@ logs)]]];

Here is an example. The term -Log[c] has the head Times and is not matched by the rule ruleLogSum.

Log[a] + Log[b] - Log[c] /. ruleLogSum

The rule ruleLogProduct rewrites products involving logarithms.

ruleLogProduct = c_ Log[a_] :> Log[a^c];

Now terms of the form -Log[c] are rewritten too.

1 - Log[a] + Log[b] Log[c] /. ruleLogProduct

The rule ruleLogProduct rewrites products involving logarithms.

ruleLogPower = Log[a_]^e_ :> Log[a^(Log[a]^(e - 1))];

Here is an example.

Log[a]^3 /. ruleLogPower

Now we put all rules together in the function PowerFactor. To make sure that every rule gets applied whenever possible, we use ReplaceRepeated and MapAll.

PowerFactor[expr_] := MapAll[(# //. rulePower //. ruleLogSum //. 
                                ruleLogProduct //. ruleLogPower)&, expr]

Here is PowerFactor applied to a more complicated input.

1 + a^(1/3) b^(2/3) c /d^(5/3) (z^3)^(1/2) + Log[s^2] + 
((Log[x] + Log[z^2])^2 + 1)^(1/2) +
3(Log[a] - Log[b] Log[c]) + Log[x]^3 Log[y]^3

PowerFactor[%]

PowerExpand rewrites the expression in the opposite direction.

PowerExpand[%]

PowerFactor recovers the above expression.

PowerFactor[%]

We could now continue and extend the rulePower to complex powers. The above rule rulePower was designed to work with rational powers. For complex powers it will not work.

PowerFactor[x^I y^I (1/x)^I (1/y)^I
            (1 - I z)^((1 - I)/2) (1 + I z)^((I - 1)/2)]

Now we have to deal with exponents e and -e appropriately.

rulePower = t:_Times?(MemberQ[#, Power[_, _Complex]]&) :>
Module[{product = List @@ t, crads, rest, exp, cradsN},
        (* select the radicals *)
        crads = Cases[product, Power[_, _Complex], {1}];
        rest = Complement[product, crads];
        (* the new exponent *)
        exp = LCM @@ Denominator[Last /@ crads];
        cradsN = crads^exp;
        If[exp =!= 1, (Times @@ cradsN)^(1/exp),
           (* complementary powers *)
           Times @@ (Function[l, Times @@ 
            (#[[2, 1]]^(l[[1, 2, 2]]/
             #[[2, 2]])& /@ l)^l[[1, 2, 2]]] /@ 
             Split[{Sort[{#[[2]], -#[[2]]}], #}& /@ cradsN, 
                   #1[[1]] === #2[[1]]&])] (Times @@ rest)];

PowerFactor[x^I y^I (1/x)^I (1/y)^I
            (1 - I z)^((1 - I)/2) (1 + I z)^((I - 1)/2)]

q[_, z_] = 0;

(* make definitions for the q *)
MapIndexed[(q[#2[[1]], z_] = #1)&,
           CoefficientList[Series[Exp[z ξ + ξ^3/3], 
                       {ξ, 0, 20}], ξ] // Expand];

Given the (Subscript[q, k])(z), the definition of the (Subscript[σ, k])(z) is straightforward.

σ[0, z_] := 1;
σ[k_, z_] := σ[k, z] =
             Det[Table[q[k + i - 2 j, z], {i, 0, k - 1}, {j, 0, k - 1}]]

Now we can calculate the first few (Subscript[w, k])(z).

kMax = 10;

Do[w[k, z_] = D[Log[σ[k + 1, z]/σ[k, z]], z] // Together // Factor,
  {k, kMax}]

Here are the first four (Subscript[w, k])(z).

Table[w[k, z], {k, 4}]

Here is a quick check for the correctness of the calculated functions.

Table[Together[D[w[k, z], {z, 2}] - (2w[k, z]^3 - 4 z w[k, z] + 4 k)],
      {k, kMax}]

The degree of the numerator and the denominator is a growing function of k.

Table[Exponent[{Numerator[w[k, z]], Denominator[w[k, z]]}, z],
      {k, kMax}]

The zeros of the denominator of the w[k, z] form an interesting pattern in the complex z-plane [882✶], [824✶]. A contourplot of the lines Im((Subscript[w, k])(z))=0 also shows an interesting pattern.

Show[GraphicsArray[
{Graphics[{PointSize[0.01], Point[{Re[#], Im[#]}]& /@ 
    (z /. NSolve[Denominator[w[kMax, z]] == 0, z])},
     PlotRange -> All, Frame -> True, AspectRatio -> Automatic],
 (* the contour plot of Im[w[kMax, z]] *)
 ContourPlot[Evaluate[Im[w[kMax, z] /. z -> x + I y]],
            {x, -4, 6}, {y, -5, 5}, AspectRatio -> Automatic, 
            PlotPoints -> 400, Contours -> {0},
            DisplayFunction -> Identity]}]]

Here are some related polynomials whose zeros form pentagonal patterns [341✶].

(* bilinear Hirota derivative of order n *)
HirotaD[f_[z_], g_[z_], {z_, n_}] := 
Module[{d},
       d[p_Plus] := d /@ p;
       d[p_Times] := (p/(#1 #2) D[#1, z] #2 - p/(#1 #2)  #1 D[#2, z])& @@ 
                      (Function[fg, Select[p, MemberQ[#, fg, {0, Infinity}, 
                                               Heads -> True]&]] /@ {f, g});
       Nest[d, f[z] g[z], n]]

(* symmetric forth order Hirota derivative for f == g *)
D4[f_, z_] = (HirotaD[f[z], g[z], {z, 4}] /. g -> f);

(* recursive definition for the polynomials Q2[n] *)
Off[RuleDelayed::rhs];
Q2[0][z_] = 1; Q2[1][z_] = z;
Q2[n_][z_] := Q2[n][z_] = Factor[Cancel[Together[
              -(2 D4[Q2[n - 1], z] -  z Q2[n - 1][z]^2)/Q2[n - 2][z]]]]

Table[Subscript[𝒬, k][z] == Q2[k][z], {k, 6}] // TableForm // TraditionalForm

The following graphic shows the roots for the first 21 polynomials.

Show[Graphics[{PointSize[0.01],
Table[{Hue[k/20], Point[{Re[#], Im[#]}]& /@ 
        N[z /. {ToRules[Roots[Q2[k][z] == 0, z]]}]}, {k, 16}]}], 
     PlotRange -> All, Frame -> True, AspectRatio -> Automatic]

The idea for the determination of (Subscript[a, p]),(Subscript[b, p]),(Subscript[c, p]) and (Subscript[a, q]),(Subscript[b, q]) is to use u(z)=(Subscript[y, 1])(z)(Subscript[y, 2])(z) and w(z)=(Subscript[y, 1])(z)/(Subscript[y, 2])(z) in the third-order differential equations and to replace all second and third derivatives of (Subscript[y, 1])(z) and (Subscript[y, 2])(z) by using the differential equation, y''(z)+f(z)y'(z)+g(z)y(z)=0. In the resulting equation, we set all coefficients of (Subscript[y, 1]^n)(z)(((Subscript[y, 1]^)')^m)(Subscript[y, 2]^o)(z)(((Subscript[y, 2]^)')^p) to zero. 
Here are the rules for the replacement of (Subscript[y, 1]^(′′′))(z), (Subscript[y, 2]^(′′′))(z), (Subscript[y, 1]^(′′))(z), and (Subscript[y, 2]^(′′))(z), which directly follow from the differential equation.

derRepRule =
(* from differentiating the differential equation *)
{y1''[z]  -> -f[z] y1'[z] - g[z] y1[z],
 y2''[z]  -> -f[z] y2'[z] - g[z] y2[z],
 y1'''[z] ->  f[z] g[z] y1[z] - y1[z] g'[z] + f[z]^2 y1'[z] -
              g[z] y1'[z] - f'[z] y1'[z],
 y2'''[z] ->  f[z] g[z] y2[z] - y2[z] g'[z] + f[z]^2 y2'[z] -
              g[z] y2'[z] - f'[z] y2'[z]};

Now we carry out this replacement in the linear third-order differential equation.

expr = ((   D[y1[z] y2[z], {z, 3}] + ap D[y1[z] y2[z], {z, 2}] +
         bp D[y1[z] y2[z], z]      + cp   y1[z] y2[z]) //.
                                           derRepRule) // Expand

Next we equate the coefficients of y1[z] y2[z], y1'[z] y2[z], y1[z] y2'[z], and y1'[z] y2'[z] to zero.

Coefficient[expr, #] == 0& /@
      {y1[z]  y2[z], y1'[z]  y2[z], y1[z]  y2'[z], y1'[z]  y2'[z]}

Finally, we solve the resulting system of linear equations for a, b, and c.

Solve[%, {ap, bp, cp}] // Simplify

So the differential equation obeyed by u(z)=(Subscript[y, 1])(z)(Subscript[y, 2])(z) is

u'''(z)+3f(z)u''(z)+(2(f^2)(z)+4g(z)+f'(z))u'(z)+(4f(z)g(z)+2g'(z))u(z)=0

We follow the same technique for the quotient w(z)=(Subscript[y, 1])(z)/(Subscript[y, 2])(z).

expr = ((Numerator[Together[
      D[y1[z]/y2[z], {z, 3}] D[y1[z]/y2[z], {z, 1}] +
   aq D[y1[z]/y2[z], {z, 2}]^2 +
   bq D[y1[z]/y2[z], {z, 1}]^2]]) //. derRepRule) // Expand

Now we have many more products of the form (Subscript[y, 1]^n)(z)(Subscript[y, 1]^('m))(z)(Subscript[y, 2]^o)(z)(Subscript[y, 2]^('p))(z). Next, we collect them.

Union[(List @@ %) //.
       {f'[z] -> 1, g'[z] -> 1, f[z] -> 1, g[z] -> 1, aq -> 1, bq -> 1,
        i_Integer ws_ -> ws}]

We calculate the values of (Subscript[a, q]),(Subscript[b, q]).

Coefficient[expr, #] == 0& /@ %

Solve[%, {aq, bq}]

So for u(z), we have the differential equation

w'''(z)w'(z)-(3/2)((w''(z))^2)+((((f^2)(z))/2)-2g(z)+f'(z))((w'(z))^2)=0

Using the function GroebnerBasis, we can easily calculate the differential equations under interest by generating a closed set of polynomial equations and then eliminating all derivatives of (Subscript[y, 1])(z) and (Subscript[y, 2])(z). Here, this is done for the product w(z)=(Subscript[y, 1])(x)(Subscript[y, 2])(z).

GroebnerBasis[(* make polynomial system *)
Numerator[Together[Flatten[{
(* differentiate first equation *)
Table[D[y1''[z] + f[z] y1'[z] + g[z] y1[z], {z, k}], {k, 0, 1}],
(* differentiate second equation *)        
Table[D[y2''[z] + f[z] y2'[z] + g[z] y2[z], {z, k}], {k, 0, 1}],
(* differentiate ratio *)        
Table[D[w[z] - y1[z] y2[z], {z, k}], {k, 0, 3}]}]]], {}, 
(* variables to eliminate *)      
  {y1[z], y1'[z], y1''[z], y1'''[z],
   y2[z], y2'[z], y2''[z], y2'''[z]},
              MonomialOrder -> EliminationOrder, 
              CoefficientDomain -> RationalFunctions]

DSolve[{y'[x] == 2y[x]/x, y[x0] == y0}, y[x], x][[1]]

sol1[x0_, y0_] =  x^2 y0 /x0^2

Here is a plot of the solution.

opts[label_] = Sequence[Axes -> False, AspectRatio -> Automatic,
                        AspectRatio -> 1, PlotLabel -> 
                        StyleForm[label, FontWeight -> "Bold", 
                                  FontSize -> 11]];

Plot[Evaluate[Table[sol1[Cos[φ], Sin[φ]], {φ, Pi/30, 2Pi, 2Pi/12}]],
     {x, -1.1, 1}, Evaluate[opts["Knot point"]]]

Now, we solve y'(x)=(y(x)+x)/x.

DSolve[{y'[x] == (x + y[x])/x, y[x0] == y0}, y[x], x][[1]]

sol2[x0_, y0_] = x Log[x] + x (y0/x0 - Log[x0])

The Off[Plot::plnr] serves to suppress any error message resulting from computation of complex values.

Off[Plot::plnr];
Plot[Evaluate[Table[sol2[Cos[φ], Sin[φ]], {φ, Pi/10, 2Pi, 2Pi/22}]],
     {x, -1.1, 1}, Evaluate[opts["Knot point"]]]

Next, we solve y'(x)=y(x)/x.

DSolve[{y'[x] == y[x]/x, y[x0] == y0}, y[x], x][[1]]

sol3[x0_, y0_] =  x y0/x0

Here again is a plot.

Plot[Evaluate[Table[sol3[Cos[φ], Sin[φ]], {φ, Pi/10, 2Pi, 2Pi/22}]],
     {x, -1.1, 1}, Evaluate[opts["Knot point"]]]

Now we solve y'(x)=-y(x)/x.

DSolve[{y'[x] == -y[x]/x, y[x0] == y0}, y[x], x][[1]]

sol4[x0_, y0_] = x0 y0/x

The associated plot is as follows.

Plot[Evaluate[Table[sol4[Cos[φ], Sin[φ]], {φ, 0, 2Pi, 2Pi/13}]],
     {x, -1.1, 1}, PlotRange -> {{-2, 2}, {-2, 2}},
     Evaluate[opts["Saddle point"]]]

For y'(x)=-x/y(x), we get two solutions from DSolve.

DSolve[{y'[x] == -x/y[x], y[x0] == y0}, y[x], x]

sol5[x0_, y0_] = {-Sqrt[-x^2 + x0^2 + y0^2], Sqrt[-x^2 + x0^2 + y0^2]};

Now we plot both solutions.

Show[Table[Plot[Evaluate[sol5[x0, 0]], {x, -x0, x0}, 
                DisplayFunction -> Identity],
           {x0, 0.1, 1, 0.1}], DisplayFunction -> $DisplayFunction,
    Evaluate[opts["Vortex point"]]]

Remaining is the differential equation that gives eddy points. Again, we can find a solution, although not explicitly for y(x).

DSolve[{y'[x] == (y[x] - x)/(y[x] + x)}, y[x], x]

sol6[x_, y_] = (C[1] /. Solve[First[%], C[1]][[1]]) /. {y[x] -> y}

We now plot this result. Unfortunately, for this transcendental equation, ImplicitPlot is of little use because it can only plot polynomial equations. Also, ContourPlot does not give a very good result because of the branch cut of Log.

ContourPlot[Re[-ArcTan[y, x] + Log[1/(x Sqrt[1 + y^2/x^2])]],
            {x, -2, 2}, {y, -2, 2}, PlotPoints -> 100,
            Contours -> 20, ContourShading -> False]

Therefore, we now create a special implementation. We could try a numerical implementation using FindRoot, for example, of the following form. However, it is difficult to represent larger pieces like this. The form of the solution suggests the use of polar coordinates.

sol6[r Cos[φ], r Sin[φ]] // Simplify

Solve[% == c, r]

We arrive at the following formula.

% // PowerExpand

The final graphics of the integral curves is the following.

Show[Table[
ParametricPlot[Evaluate[Exp[c - φ]{Cos[φ], Sin[φ]}],
               {φ, c + 0.1, 3Pi + c}, DisplayFunction -> Identity],
           {c, 0, 2Pi 24/25, 2Pi/25}],
     DisplayFunction -> $DisplayFunction,
     PlotRange -> All, Evaluate[opts["Eddy point"]]]

We demonstrate the appearance of various singular points in the following example. For a “random” bivariate function ψ(x,y), we will integrate the equations x'(s)=∂ψ(x(s),y(s))/∂x(s), y'(t)=-∂ψ(x(s),y(s))/∂x(s). We see saddle points, vortex points, and knot points [75✶], [406✶].

Module[{L = 4, pp = 20, T = 5, o = 90, ms = 1000, ℓ = 3/2,
        ps = 15, λ = 2, ipo, ipoX, ipoY, pathList, nsol},
SeedRandom[123];
(* a streamfunction *)
ipo = (* smooth interpolation *) Interpolation[
(* random data *)
Flatten[Table[{x, y, Random[Real, {-1, 1}]}, 
        {x, -L, L, 2L/pp}, {y, -L, L, 2L/pp}], 1],
        InterpolationOrder -> 6];
(* derivatives *)
{ipoX, ipoY} = D[ipo[x[t], y[t]], #]& /@ {x[t], y[t]};
(* random data *)
eqs = Thread[{x'[t], y'[t]} == #/Sqrt[#.#]&[{ipoX, -ipoY}]];
(* calculate flow lines *)
pathList = Table[
((* solve for flow lines *)              Off[NDSolve::mxst];
 nsol = NDSolve[Join[eqs, {x[0] == x0, y[0] ==  y0}],
  {x, y}, {t, 0, #}, MaxSteps -> ms, PrecisionGoal -> 3,
                     AccuracyGoal -> 3]; On[NDSolve::mxst];
 (* visualize flow lines *)
 ParametricPlot[Evaluate[{x[t], y[t]} /. nsol],
               {t, 0, DeleteCases[nsol[[1, 1, 2, 1, 1]], 0.][[1]]}, 
               PlotStyle -> {{Thickness[0.002], Hue[0]}},
               DisplayFunction -> Identity,
               PlotPoints -> 200])& /@ {T, -T},
               (* grid of initial conditions *)
               {x0, -ℓ, ℓ, 2ℓ/ps}, {y0, -ℓ, ℓ, 2ℓ/ps}];
 (* display flow lines and stream function *)
 Show[(* contour plot of the stream function *)
  {ContourPlot[Evaluate[ipo[x, y]], {x, -2, 2}, {y, -2, 2},
               PlotPoints -> 200, Contours -> 30, 
               ContourLines -> False, PlotRange -> All,
               DisplayFunction -> Identity],
   Show[pathList]}, DisplayFunction -> $DisplayFunction,
      Frame -> True, Axes -> False, FrameTicks -> False, 
      PlotRange -> {{-λ, λ}, {-λ, λ}}, AspectRatio -> Automatic]]

For higher-order singularities, see [1550✶].

iSolve[eq:(y_[x_] + λ_ Integrate[𝒦_ y[ξ_], {ξ_, a_, b_}] == f_),
       y_, x_, 𝒮_:Identity] :=
Module[{ℐ = Integrate, intExpand, eq1, integrals, 𝒸Rules,
        functions, eq2, eqs, 𝒸s, separableQ},
 (* thread integrals over sums *)
 intExpand = (# //. ℐ[p_Plus, i_] :> (ℐ[#, i]& /@ p))&;
 (* separate kernel *)
 eq1 = intExpand[ExpandAll[𝒮 //@ (Subtract @@ eq)]];
 (* integrals over y[ζ] and kernel functions *)
 integrals = Union[Cases[eq1, _ℐ, Infinity]];
 (* replace integrals by variables 𝒸[i] *)
 𝒸Rules = Rule @@@ Transpose[{integrals /. ξ -> ζ_, 
                              𝒸s = Array[𝒸, Length[integrals]]}];
 (* was the kernel 𝒦 separable? *)
 separableQ = FreeQ[𝒸Rules, x, Infinity];                             
 (* kernel functions h_j[.]*)
 functions = ((First /@ integrals)/y[ξ]) /. ξ -> x;  
 (* replace integrals by variables *)
 eq2 = eq1 /. 𝒸Rules; 
 (* make linear system in the 𝒸[i] *)
 eqs  = intExpand[ExpandAll[ℐ[eq2 #, {x, a, b}]& /@ 
                  functions]] //. 𝒸Rules;        
 (* solve linear system, backsubstitute into eq2
    and solve for y[x] *)
 Solve[(eq2 /. Solve[(# == 0)& /@ eqs, 𝒸s][[1]]) == 0, y[x]] /;
                      (* was iSolve applicable? *) separableQ]

The next inputs solve the example equation y(x)-λ (∫_0^1)sin(x+ξ) y(ξ)dξ=cos(x).

𝒦[x_, ξ_] := Sin[x + ξ]
f[x_] := Cos[x]

IEq = y[x] - λ Integrate[𝒦[x, ξ] y[ξ], {ξ, 0, 1}] == f[x];

IEqSol = iSolve[y[x] - λ Integrate[𝒦[x, ξ] y[ξ], {ξ, 0, 1}] == 
                f[x], y, x, TrigExpand] // Simplify

Here is a quick check for the correctness of the result.

yExact = IEqSol[[1, 1, 2]];
IEq /. y -> Function[x, Evaluate[yExact]] // Simplify

In the calculation of the truncated Fredholm and Neumann resolvents, we have to carry out many definite integrals. Because we do not worry about convergence and hope to carry out all integrals successfully term by term, we do not use the built-in function Integrate directly, but rather implement a function integrate, that expands products and powers.

integrate[l_List, i_] := Integrate[#, i]& /@ l
integrate[p_Plus, i_] := Integrate[#, i]& /@ p
integrate[p:Times[___, _Plus] | p:Power[_Plus, _Integer], i_] := 
                                       integrate[Expand[p], i] 
integrate[e_, i_] := Integrate[e, i]

The function FredholmResolventList calculates a list of the successive resolvent approximations arising from truncating the Fredholm minor and the Fredholm determinant at (λ^(o+1)).

FredholmResolventList[𝒦_, {ξ_, a_, b_}, {x_, ξ_}, o_, 𝒮_:Identity] :=
Module[{c, d, 𝓀, 𝓍, 𝓎, 𝓏}, 
  (* make recursive definitions for Fredholm minor and determinant *)
  (* avoid variable interference by applying Set and SetDelayed *)
  Set @@ {𝓀[𝓍_, 𝓎_], 𝒦 /. {x -> 𝓍, ξ -> 𝓎}};
  Set @@ {d[0][𝓍_, 𝓎_], 𝓀[𝓍, 𝓎]};
  SetDelayed @@ {d[k_][𝓍_, 𝓎_], Unevaluated @
   With[{p𝓍 = Pattern[#, _]& @@ {𝓍}, p𝓎 = Pattern[#, _]& @@ {𝓎}}, 
     d[k][p𝓍, p𝓎] = 𝒮 @ (c[k] 𝓀[𝓍, 𝓎] -
                    k integrate[𝓀[𝓍, 𝓏] d[k - 1][𝓏, 𝓎], {𝓏, a, b}])]};
  c[0] := 1;
  c[k_] := c[k] = 𝒮 @ integrate[d[k - 1][𝓎, 𝓎], {𝓎, a, b}];
  (* calculate c[k] and d[k] recursively and form 
     successive resolvent approximations *) 
  Divide @@ Transpose[Rest[FoldList[Plus, 0, 
            Table[(-1)^k/k! λ^k {d[k][x, ξ], c[k]}, {k, 0, o}]]]]]

For the example integral equation, all higher (Subscript[c, k]) and (Subscript[d, k])(x,ξ) vanish identically and we obtain the exact solution.

FSerKernels = FredholmResolventList[𝒦[x, ξ], {ξ, 0, 1}, {x, ξ}, 3,
                                    Simplify]

yFSerSols[x_] = f[x] + λ integrate[FSerKernels f[ξ], {ξ, 0, 1}];

yFSerSols[x][[-1]] == yExact // Simplify

We end with the implementation of the iterated kernels. The function NeumannResolventList calculates the resolvent arising from o+1 iterated kernels.

NeumannResolventList[𝒦_, {ξ_, a_, b_}, {x_, ξ_}, o_, 𝒮_:Identity] :=
Module[{𝓀, 𝓍, 𝓎, 𝓏, kernels},
 Set @@ {𝓀[𝓍_, 𝓎_],  𝒦 /. {x -> 𝓍, ξ -> 𝓎}};
 kernels = NestList[𝒮[integrate[𝓀[𝓍, 𝓏] (# /. 𝓍 -> 𝓏), {𝓏, 0, 1}]]&, 
                    𝓀[𝓍, 𝓎], o] /. {𝓍 -> x, 𝓎 -> ξ};
 Rest[FoldList[Plus, 0, MapIndexed[λ^(#2[[1]] - 1) #1&, kernels]]]]

The iterated kernels become increasingly complicated functions.

NSerKernels = NeumannResolventList[𝒦[x, ξ], {ξ, 0, 1}, 
                                   {x, ξ}, 5, Simplify];
                                   
{LeafCount /@ NSerKernels, Short[NSerKernels, 12]}

yNSerSols[x_] = f[x] + λ integrate[NSerKernels f[ξ], {ξ, 0, 1}];

As expected, the terms of the series expansion of the exact solution in λ around λ=0 agree with the result obtained using the Neumann resolvent.

Series[yExact - yNSerSols[x][[-1]], {λ, 0, 6}] // Simplify

InverseSturmLiouville[listOfEigenvalues_List, var_Symbol] :=
InverseSturmLiouville[listOfEigenvalues, var] =
Module[{φ0, u, uMatrix, v, ef, s, lde},
       lde = Sqrt /@ listOfEigenvalues;
       (* direct implementation of above formulas *)
       φ0[s_, k_] = Sin[k s]/k;
       u[ki_, kj_] = (Cos[kj var] Sin[ki var])/(ki (+ki^2 - kj^2)) +
                     (Cos[ki var] Sin[kj var])/(kj (-ki^2 + kj^2));
       u[ki_, ki_] = 1 + var/(2 ki^2) - Sin[2 ki var]/(4 ki^3);
       uMatrix = Outer[u, lde, lde];
       v = (-2D[Log[#], {var, 2}])&[Det[uMatrix]];
       ef = Inverse[uMatrix].(φ0[var, #]& /@ lde);
       (* make no simplification here; it takes too long on average *)
       {v, ef}]

Here are v(x) and the eigenfunction for a given (energy) eigenvalue.

{v, ef} = InverseSturmLiouville[{k}, x] // Simplify

We now check whether the differential equation is satisfied.

- D[ef, {x, 2}] + v ef - k ef // Simplify

We now prescribe two eigenvalues. We do not write out the result or simplify it because of its size.

{pot, {ef1, ef2}} = InverseSturmLiouville[{k1, k2}, x];

Here is a plot of the result. The isolated appearance of a point spectrum inside the continuous spectrum is remarkable.

Plot[Evaluate[
(* to be shown: the potential in thick and the eigenfunctions at their 
   eigenvalues (adding the eigenvalue to their function
                value for better visibility) *)
              {pot, ef1 + k1^2, ef2 + k2^2, k1^2, k2^2} /.
              {k1 -> 1, k2 -> 3/2}],
      {x, 0, 20},
 (* setting options to get a pretty picture *)
      PlotRange -> All, PlotPoints -> 200,
      PlotStyle -> {Thickness[0.007], Thickness[0.002], Thickness[0.002],
                    {Thickness[0.002], Dashing[{0.02, 0.02}]},
                    {Thickness[0.002], Dashing[{0.02, 0.02}]}},
      Frame -> True, FrameLabel -> ({#["r"], #["V"], None, "ε"}&[
              StyleForm["r", FontWeight -> "Bold", FontSize -> 10]&])]

For the practical importance of such conditions, see [273✶], [1327✶], [1705✶], [1706✶], [99✶], and [1492✶]. For a nontrivial background potential, see [1227✶]; for bound states in gaps, see [1360✶].

Off[RuleDelayed::rhs];
GraeffeSolve[poly_, z_Symbol, prec_] := 
Module[{k = 1, oldRoots = {0, 0}, newRoots}, Clear[p];
 p[0, ζ_] = N[poly /. z -> ζ, prec];
 (* polynomial recursion *)
 p[k_, ζ_] := p[k, ζ_] = Expand[p[k - 1, 𝓏] p[k - 1, -𝓏]] /.
       (* avoid 0. z^o *) {_?(# == 0&) -> 0, 𝓏^n_ :> ζ^(n/2)};
 While[FreeQ[p[k, ζ], Overflow[] | Underflow[], Infinity] &&
       (coeffs = CoefficientList[p[k, ζ], ζ]; 
        (* next polynomial; normalized *)
        p[k, ζ_] = Expand[p[k, ζ]/Max[Abs[coeffs]]];
        (* new root approximations *)
        newRoots = Abs[Divide @@@ Partition[coeffs, 2, 1]]^(2^-k);
        (* are roots still changing? *)
        newRoots =!= oldRoots), oldRoots = newRoots; k++];
  {z -> #}& /@ (* add sign *)
  Select[Join[newRoots, -newRoots], (poly /. z -> #) == 0&]]

Here the function GraeffeSolve is used to solve p=(z^5)+5 (z^4)-10 (z^3)-10 (z^2)+5 z+2=0. We start with 100 digits.

poly[z_] := 2 + 5 z - 10 z^2 - 10 z^3 + 5 z^4 + z^5;
GraeffeSolve[poly[z], z, 110]

Substituting the so-calculated roots in the original equation shows that they fulfill the equation.

{Precision /@ %, poly[z] /. %}

The function Numeration[n] computes the data points PD[n, i], which will be globally available for further use after the call of Numeration. (Be aware that PD is not in the list of local variables of Block; it is a global variable and will be used often in the following.)

numKnots[n_] = (n + 1) (n + 2)/2;

Numeration[n_Integer?Positive] := Numeration[n] =
Block[{count, steps, ord, step, zs, σ, x, y},
(* the three given points *)
      PD[n, 1] = {0, 0};  PD[n, 2] = {1, 0};  PD[n, 3] = {0, 1};
      count = 4; steps = Quotient[n, 3] + 1; ord = n;
(* go in spiral manner, along lines parallel to
   the edges of the triangle to the center *)
(* outside *)
step = 1; ν = n - 1;
   Clear[x, y]; y = 0; x[t_] = t/n;
   Do[PD[n, count] = {x[i], y}; count = count + 1, {i, ν}];
   Clear[x, y]; y[t_] = t/n; x[t_] = 1 - t/n;
   Do[PD[n, count] = {x[i], y[i]}; count = count + 1, {i, ν}];
   Clear[x, y]; x = 0; y[t_] = 1 - t/n;
   Do[PD[n, count] = {x, y[i]}; count = count + 1, {i, ν}];
(* spiral in *)
If[steps >= 2,
Do[ord = ord - 3;
 Which[ord >= 1, ν = ord; σ = step - 1;
       Clear[x, y]; y = σ/n; x[κ_] = σ/n + (κ - 1)/n;
       Do[PD[n, count] = {x[i], y}; count = count + 1, {i, ν}];
       Clear[x, y]; y[κ_] = σ/n + (κ - 1)/n;
                    x[κ_] = 1 - 2 σ/n - (κ - 1)/n;
       Do[PD[n, count] = {x[i], y[i]}; count = count + 1, {i, ν}];
       Clear[x, y]; x = σ/n; y[κ_] = 1 - 2 σ/n - (κ - 1)/n;
       Do[PD[n, count] = {x, y[i]}; count = count + 1, {i, ν}],
      ord == 0, PD[n, count] = {(step - 1)/n, (step - 1)/n}],
     {step, 2, steps}]]]

We look at a few examples.

Do[Numeration[i], {i, 3}]
Short[DownValues[PD], 12]

Here is a plot; the idea of the numbering should become somewhat clearer.

NumerationPlot[n_Integer?Positive, opts___Rule] :=
(Numeration[n];
 Show[Graphics[{{GrayLevel[0], (* the nodes *)
                 Table[Text["P" <> ToString[i], PD[n, i]],
                       {i, numKnots[n]}]},
               (* the plot label *)
                {GrayLevel[0], Text[StyleForm["Order " <> ToString[n],
                 FontFamily -> "Times", FontWeight -> "Bold",
                                        FontSize -> 10], {0.5, 0.9}]}}],
      opts, Axes -> False, PlotRange -> All, AspectRatio -> 1,
      Prolog -> {Hue[0.17], Polygon[{{0, 0}, {1, 0}, {0, 1}}]},
      TextStyle -> {FontSize -> 11}])

Show[GraphicsArray[#]]& /@ 
          Table[NumerationPlot[3i + j, DisplayFunction -> Identity],
                {i, 0, 2}, {j, 3}]

Now we discuss the computation of the Lagrange-shape functions. (We restrict ourselves to the Lagrange case [1402✶], although in present-day FEM calculations, Hermite-shape functions are being used more and more; see [1055✶] and [921✶].) The ith shape function (Subscript[φ, i]^((e)))(ξ,η) is determined by the condition (Subscript[φ, i]^((e)))((Subscript[ξ, j]),(Subscript[η, j]))=(Subscript[δ, "ij"]), where ((Subscript[ξ, j]),(Subscript[η, j])) are the coordinates of the jth data point (Subscript[P, j]^((e))). Unfortunately, InterpolatingPolynomial works only for one variable, and so we have to program the computation of the interpolating two-dimensional polynomials.

ShapeFunction[n_Integer?Positive, i_Integer?Positive, ξ_, η_] := 
(ShapeFunction[n, i, ξ, η] =
Module[{𝓍, 𝓎, tablePoly, tableAi, eqns},
       (* do the numeration *) Numeration[n];
       (* the monomials of the polynomial *)
      tablePoly = Flatten[Table[Table[𝓍^𝒾 𝓎^(𝒿 - 𝒾), {𝒾, 0, 𝒿}], {𝒿, 0, n}]];
      (* the coefficients to be determined *)
      tableAi = Table[a[𝒾], {𝒾, numKnots[n]}];
      (* make the left-hand side of the equations
         shapeFunction[i][Node[j]] == Kronecker[i, j] *)
      eqns = tablePoly.tableAi;
      sol = Simplify[eqns /. (* solve the equations *)
        Solve[ (* replace actual node coordinates *)
        Table[(eqns /. {𝓍 -> PD[n, j][[1]],
                        𝓎 -> PD[n, j][[2]]}) == KroneckerDelta[i, j],
              {j, numKnots[n]}], tableAi]];
         (sol //. {𝓍 -> ξ, 𝓎 -> η})[[1]]]) /; (i <= numKnots[n])

We now look at a few shape functions.

Do[Do[ (* make a reasonably nice looking print *)
   Print["SF[" <> ToString[j] <> ", " <> ToString[
                           i] <> ", ξ, η] = ",
        ShapeFunction[j, i, ξ, η]], {i, numKnots[j]}], {j, 2}]

Next, we check the property (Subscript[φ, i]^((e)))((Subscript[ξ, j]),(Subscript[η, j]))=(Subscript[δ, "ij"]) explicitly for the first two sets of shape functions.

Table[ShapeFunction[1, i, ξ, η] /.
         {ξ -> PD[1, j][[1]], η -> PD[1, j][[2]]},
           {i, numKnots[1]}, {j, numKnots[1]}] // TableForm

Table[ShapeFunction[2, i, ξ, η] /.
         {ξ -> PD[2, j][[1]], η -> PD[2, j][[2]]},
             {i, numKnots[2]}, {j, numKnots[2]}] // TableForm

Now we want to plot the shape functions. Because they are defined on a triangle, the built-in commands Plot3D and ParametricPlot3D are not immediately applicable (although one could proceed with ParametricPlot3D). We thus go to a little more trouble and decompose the unit triangle into subtriangles that we can use to plot the shape functions.

ShapeFunctionPlot[n_Integer?Positive, k_Integer?Positive,
                  pp_Integer?Positive, opts___Rule] :=
Module[{x, y, 𝓈, 𝓉, tabv, tabd},
       (* calculate all z-values *)
       auxFu[ξ_, η_] = ShapeFunction[n, k, ξ, η];
       𝓉 = Table[{x, y}, {y, 0, 1, 1/pp}, {x, 0, 1 - y, 1/pp}];
       𝓈 = Table[auxFu[x, y], {y, 0, 1, 1/pp}, {x, 0, 1 - y, 1/pp}];
       (* triangulate the basic triangle {{0, 0}, {1, 0}, {0, 1}} *)
       tabv = Table[Polygon[
         {{𝓉[[i,  j,  1]], 𝓉[[i, j, 2]], 𝓈[[i, j]]},
          {𝓉[[i + 1, j, 1]], 𝓉[[i + 1, j, 2]], 𝓈[[i + 1, j]]},
          {𝓉[[i + 1, j + 1, 1]], 𝓉[[i + 1, j + 1, 2]], 𝓈[[i + 1, j + 1]]},
          {𝓉[[i, j + 1, 1]], 𝓉[[i, j + 1, 2]], 𝓈[[i, j + 1]]}}], 
                    {j, 1, pp - 1}, {i, 1, pp - j}];
       (* boundary *)            
       tabd = Table[Polygon[
         {{𝓉[[j,  - 2, 1]], 𝓉[[j, -2, 2]], 𝓈[[j,  -2]]},
          {𝓉[[j,  - 1, 1]], 𝓉[[j, -1, 2]], 𝓈[[j,  -1]]},
          {𝓉[[j + 1, -1, 1]], 𝓉[[j + 1, -1, 2]], 𝓈[[j + 1, -1]]}}], 
                   {j, pp}];
 (* display shape functions *)  
 Show[Graphics3D[{{GrayLevel[0.6], tabv, tabd}}],
      opts, Axes -> False, AxesEdge -> {{-1, -1}, {+1, -1}, {-1, -1}},
      Lighting -> False, PlotRange -> All, BoxRatios -> {1, 1, 0.7},
      AxesLabel -> {x, y, None}, Boxed -> True,
      TextStyle -> {FontFamily -> "Times", FontSize -> 10},
      PlotLabel -> "SF[" <> ToString[n] <> ", 
                   " <> ToString[k] <> "]"]] /; (k <= numKnots[n])

We can look at the shape functions for the first three orders.

Show[GraphicsArray[Table[ShapeFunctionPlot[1, i, 5,
                         DisplayFunction -> Identity],
                         {i, numKnots[1]}]]]

Show[GraphicsArray[#]]& /@ 
          Table[ShapeFunctionPlot[2, 3i + j, 12,
                     DisplayFunction -> Identity],
                {i, 0, 1}, {j, 3}]

(* suppress message for only one picture in the last row *)
Show[GraphicsArray[#]]& /@ 
          Table[ShapeFunctionPlot[3, 3i + j, 12,
                                  DisplayFunction -> Identity],
                {i, 0, 2}, {j, 3}]

ShapeFunctionPlot[3, 10, 12]

We turn now to the computation of the integrals of the element vector and to the entries in the stiffness and mass matrices. Because these involve integrals of the shape functions (Subscript[ψ, i])(x,y) over the triangle with vertices (Subscript[P, 1])={(Subscript[x, 1]),(Subscript[y, 1])}, (Subscript[P, 2])={(Subscript[x, 2]),(Subscript[y, 2])}, and (Subscript[P, 3])={(Subscript[x, 3]),(Subscript[y, 3])}, we first find the corresponding Jacobian determinant. Here is the transformation from the {ξ,η} coordinates to the {x,y} coordinates:

x(ξ,ν)=(Subscript[a, x])ξ+(Subscript[b, x])η+(Subscript[c, x]),
y(ξ,η)=(Subscript[a, y])ξ+(Subscript[b, y])η+(Subscript[c, y]).

Clear[x, y, x1, x2, x3, y1, y2, y3, ax, ay, bx, by, cx, cy, ξ, η];
      
Numeration[1];

Solve[ (* the equations made from the nodes *)
  Flatten[{Table[ax PD[1, i][[1]] + bx PD[1, i][[2]] + cx ==
                 ToExpression["x" <> ToString[i]], {i, 1, 3}],
           Table[ay PD[1, i][[1]] + by PD[1, i][[2]] + cy ==
                 ToExpression["y" <> ToString[i]], {i, 1, 3}]}],
                 (* the coefficients to be determined *)
                 {ax, ay, bx, by, cx, cy}] // TableForm[#[[1]]]&

Thus, we express the coordinates x, y through ξ and η.

x[ξ_, η_] = (ax ξ + bx η + cx) /.
  {ax -> - x1 + x2, bx -> - x1 + x3, cx -> x1} // Simplify

y[ξ_, η_] = (ay ξ + by η + cy) /.
  {ay -> - y1 + y2, by -> - y1 + y3, cy -> y1} // Simplify

We then get the following Jacobian determinant.

Simplify[Det[Outer[D, {x[ξ, η], y[ξ, η]}, {ξ, η}]]]

Next, we implement the relation (∫_0^1)(∫_0^(1-ξ))(ξ^p)(η^q)dηdξ=p! q!/(p+q+2) (for our applications p and q are positive integers).

The function TriangularIntegration implements the integration of polynomials over the unit triangle.

(* Additivity of the integration *)
TriangularIntegration[p_Plus, {x_, y_}] :=
 TriangularIntegration[#, {x, y}]& /@ p;

(* Factors that do not depend on the integration 
   variables are moved in front of the integral *)
TriangularIntegration[c_ z_, {x_, y_}] :=
 c TriangularIntegration[z, {x, y}] /; FreeQ[c, x] && FreeQ[c, y];

(* let q be 0 *)
TriangularIntegration[x_^p_., {x_, y_}] :=
        TriangularIntegration[x^p, {x, y}] = p!/(p + 2)!;

(* let p be 0 *)
TriangularIntegration[y_^q_., {x_, y_}] :=
        TriangularIntegration[x^q, {x, y}] = q!/(q + 2)!;

(* the actual integration formula *)
TriangularIntegration[x_^p_. y_^q_., {x_, y_}] :=
        TriangularIntegration[x^p y^q, {x, y}] = (p! q!) /(p + q + 2)!;

(* integration of a constant *)
TriangularIntegration[c_, {x_, y_}] := 
        (c/2) /; FreeQ[c, x] && FreeQ[c, y];

(For the efficient integration of analytic functions over triangles, see [404✶].) By comparing our triangular integration with the built-in command Integrate, we see that our work was justified.

Timing[TriangularIntegration[a + b x + c y^2 + d x^3 y^6 + 
                             e x^12 y^ 16, {x, y}]]

Timing[Integrate[a + b x + c y^2 + d x^3 y^6 + e x^12 y^ 16,
                 {x, 0, 1}, {y, 0, 1 - x}]] // Simplify

Now to the heart of this problem: the computation of the element vector and the mass and stiffness matrices. For the element vector, we have

(Subscript[f, i])=(∫_("RT"))(Subscript[ψ, i])(x,y)"dxdy"=J(∫_("UT"))(Subscript[φ, i]^((e)))(ξ,η)dξdη=J(Subscript[f, i]^((e))).

Here, RT denotes the real triangle, whereas UT denotes the unit triangle. J is the Jacobian determinant |∂(x,y)/∂(ξ,η)|. We get this relationship by means of the relations

x(ξ,η)=(∑_j)(Subscript[x, j])(Subscript[φ, j]^((e)))(ξ,η), y(ξ,η)=(∑_j)(Subscript[y, j])(Subscript[φ, j]^((e)))(ξ,η)

(where (Subscript[x, j]), (Subscript[y, j]) are the coordinates of the point (Subscript[P, j]) in the actual triangle RT), which hold for the isoparametric mappings (Subscript[ψ, i])(x(ξ,η),y(ξ,η))=(Subscript[φ, i]^((e)))(ξ,η).

Thus, we compute only the element vector in the unit triangle (Subscript[f, i]^((e))) (i.e., we do not explicitly write the Jacobian determinant).

ElementVectorElement[n_Integer?Positive, i_Integer?Positive] :=
(ElementVectorElement[n, i] =
  TriangularIntegration[Expand[ShapeFunction[n, i, ξ, η]], {ξ, η}]) /;
                                                      (i <= numKnots[n])

ElementVector[n_Integer?Positive] := ElementVector[n] =
     Table[ElementVectorElement[n, i], {i, numKnots[n]}]

Here are the element vectors of orders 1, 2, and 3.

ElementVector[1]

ElementVector[2]

ElementVector[3]

Here is the element vector for order 12 visualized.

Module[{n = 12, evec}, evec = ElementVector[n];
Show[GraphicsArray[
{(* values in consecutive order *)
 ListPlot[evec, PlotRange -> All, Frame -> True, 
          Axes -> False, PlotStyle -> {PointSize[0.008]},
          DisplayFunction -> Identity],
(* values over the base points; coloring according to size *)
Graphics3D[{Hue[0.76 #[[2]]/Max[evec]], 
 Line[{Append[#[[1]], 0], Append[#[[1]], Abs[#[[2]]]]}]}& /@ 
       Transpose[{Table[PD[n, k], {k, numKnots[n]}], evec}],
            BoxRatios -> {1, 1, 0.5}, PlotRange -> All, Axes -> True]}]]]

The computation of the mass matrix is essentially analogous to that for the eigenvector. Using similar notation as in the element vector case, we have

(Subscript[m, "ij"])=(∫_("RT"))(Subscript[ψ, i])(x,y)(Subscript[ψ, j])(x,y)"dxdy"=J(∫_("UT"))(Subscript[φ, i]^((e)))(ξ,η)(Subscript[φ, j]^((e)))(ξ,η)dξdη=J(Subscript[m, "ij"]^((e))).

Again, we find only the coordinate-free part.

MassMatrixElement[n_Integer?Positive,
                  i_Integer?Positive, j_Integer?Positive] :=
(MassMatrixElement[n, i, j] = (* because of symmetry *)
 MassMatrixElement[n, j, i] =
  TriangularIntegration[Expand[ShapeFunction[n, i, ξ, η] *
                               ShapeFunction[n, j, ξ, η]], {ξ, η}]) /;
               ((i <= numKnots[n]) && (j <= numKnots[n]))

MassMatrix[n_Integer?Positive] := MassMatrix[n] =
   Table[MassMatrixElement[n, i, j], 
         {i, numKnots[n]}, {j, numKnots[n]}]

Here are the mass matrices for the two lowest orders.

MassMatrix[1] // TableForm

MassMatrix[2] // TableForm[#, TableAlignments -> Center]&

The computation of the stiffness matrix is somewhat more complicated. Here, we need derivatives with respect to the variables x and y of the actual triangle RT, but our integration of (Subscript[φ, i]^((e)))(ξ,η) takes over the unit triangle UT:

(Subscript[s, "ij"])=(∫_("RT"))(∂/(∂x))(Subscript[φ, i])(x,y)(∂/(∂x))(Subscript[φ, j])(x,y)+(∂/(∂y))(Subscript[φ, i])(x,y)(∂/(∂y))(Subscript[φ, j])(x,y)"dx" "dy".

Now with (Subscript[ψ, i])(x(ξ,η),y(ξ,η))=(Subscript[φ, i]^((e)))(ξ,η), we have

({{(∂/(∂x))(Subscript[ψ, i])(x,y), =(∂/(∂x))(Subscript[ψ, i])(x(ξ,η),y(ξ,η))=(∂/(∂x))(Subscript[φ, i]^((e)))(ξ(x,y),η(x,y))}, {, =(∂/(∂ξ))(Subscript[φ, i]^((e)))(ξ,η)·(∂/(∂x))ξ(x,y)+(∂/(∂η))(Subscript[φ, i]^((e)))(ξ,η)·(∂/(∂x))η(x,y).}})

Similarly,

({{(∂/(∂y))(Subscript[ψ, i])(x,y), =(∂/(∂y))(Subscript[ψ, i])(x(ξ,η),y(ξ,η))=(∂/(∂y))(Subscript[φ, i]^((e)))(ξ(x,y),η(x,y))}, {, =(∂/(∂ξ))(Subscript[φ, i]^((e)))(ξ,η)·(∂/(∂y))ξ(x,y)+(∂/(∂η))(Subscript[φ, i]^((e)))(ξ,η)·(∂/(∂y))η(x,y).}})

Thus, by inversion of the above x(ξ,η), y(ξ,η), we get ξ=ξ(x,y) and η=η(x,y). Here, it is computed.

((Solve[{x1 - η x1 - ξ x1 + ξ x2 + η x3 == x,
         y1 - η y1 - ξ y1 + ξ y2 + η y3 == y}, {ξ, η}] // Simplify) //.
  {  -(x2 y1) + x3 y1 + x1 y2 - x3 y2 - x1 y3 + x2 y3  ->  J,
   -(-(x2 y1) + x3 y1 + x1 y2 - x3 y2 - x1 y3 + x2 y3) -> -J}) // Simplify

We now can calculate the following four quantities: (∂/(∂x))ξ(x,y),(∂/(∂y))η(x,y),(∂/(∂y))ξ(x,y),(∂/(∂y))η(x,y).

Ξ[x_, y_] = (x1 y - x3 y - x  y1 + x3 y1 + x y3 - x1 y3)/J;
Η[x_, y_] = (x2 y - x1 y + x  y1 - x2 y1 - x y2 + x1 y2)/J;

{dξdx = D[Ξ[x, y], x], dηdx = D[Η[x, y], x],
 dξdy = D[Ξ[x, y], y], dηdy = D[Η[x, y], y]}

We now rewrite (∂/(∂x))(Subscript[ψ, i])(x,y)(∂/(∂x))(Subscript[ψ, j])(x,y)+(∂/(∂y))(Subscript[ψ, i])(x,y)(∂/(∂y))(Subscript[ψ, j])(x,y) in the form

((∂/(∂ξ))(Subscript[φ, i]^((e)))(ξ,η)·  (∂/(∂ξ))(Subscript[φ, j]^((e)))(ξ,η))·  (((((∂/(∂x))ξ(x,y)))^2)+((((∂/(∂y))ξ(x,y)))^2))+
  ((∂/(∂η))(Subscript[φ, i]^((e)))(ξ,η)·  (∂/(∂η))(Subscript[φ, j]^((e)))(ξ,η))·  (((((∂/(∂x))η(x,y)))^2)+((((∂/(∂y))η(x,y)))^2))+
  ((∂/(∂ξ))(Subscript[φ, i]^((e)))(ξ,η)·  (∂/(∂η))(Subscript[φ, j]^((e)))(ξ,η)+(∂/(∂η))(Subscript[φ, i]^((e)))(ξ,η)·  (∂/(∂ξ))(Subscript[φ, j]^((e)))(ξ,η))×
    ((∂/(∂x))ξ(x,y)·  (∂/(∂x))η(x,y)+(∂/(∂y))ξ(x,y)·  (∂/(∂y))η(x,y))

and introduce

({{A, =(((((∂/(∂x))ξ(x,y)))^2)+((((∂/(∂y))ξ(x,y)))^2))J=((((((Subscript[x, 3])-(Subscript[x, 1])))^2)+((((Subscript[y, 3])-(Subscript[y, 1])))^2))/J)}, {C, =(((((∂/(∂x))η(x,y)))^2)+((((∂/(∂y))η(x,y)))^2))J=((((((Subscript[x, 2])-(Subscript[x, 1])))^2)+((((Subscript[y, 2])-(Subscript[y, 1])))^2))/J)}, {B, =((∂/(∂x))ξ(x,y)(∂/(∂x))η(x,y)+(∂/(∂y))ξ(x,y)(∂/(∂y))η(x,y))J=-((((Subscript[y, 3])-(Subscript[y, 1]))((Subscript[y, 2])-(Subscript[y, 1]))+((Subscript[x, 3])-(Subscript[x, 1]))((Subscript[x, 2])-(Subscript[x, 1])))/J).}})

This leads to the following result:

({{(Subscript[s, "ij"])=, (∫_("RT"))(∂/(∂x))(Subscript[ψ, i])(x,y)(∂/(∂x))(Subscript[ψ, j])(x,y)+(∂/(∂y))(Subscript[ψ, i])(x,y)(∂/(∂y))(Subscript[ψ, j])(x,y)dξdη}, {=, A(∫_("UT"))(∂/(∂ξ))(Subscript[φ, i]^((e)))(ξ,η)(∂/(∂ξ))(Subscript[φ, j]^((e)))(ξ,η)dξdη+}, {, C(∫_("UT"))(∂/(∂η))(Subscript[φ, i]^((e)))(ξ,η)(∂/(∂η))(Subscript[φ, j]^((e)))(ξ,η)dξdη+}, {, B(∫_("UT"))(∂/(∂ξ))(Subscript[φ, i]^((e)))(ξ,η)(∂/(∂η))(Subscript[φ, j]^((e)))(ξ,η)+(∂/(∂η))(Subscript[φ, i]^((e)))(ξ,η)(∂/(∂ξ))(Subscript[φ, j]^((e)))(ξ,η)dξdη.}})

StiffnessMatrixElement[n_Integer?Positive,
                       i_Integer?Positive, j_Integer?Positive] :=
(StiffnessMatrixElement[n, i, j] = (* because of symmetry *)
 StiffnessMatrixElement[n, j, i] =
With[{SF = ShapeFunction},
 (* sum of the three terms *)
 A TriangularIntegration[
      Expand[D[SF[n, i, ξ, η], ξ] D[SF[n, j, ξ, η], ξ]], {ξ, η}] +
 C TriangularIntegration[
      Expand[D[SF[n, i, ξ, η], η] D[SF[n, j, ξ, η], η]], {ξ, η}] +
 B TriangularIntegration[
      Expand[D[SF[n, i, ξ, η], ξ] D[SF[n, j, ξ, η], η] +
             D[SF[n, i, ξ, η], η] D[SF[n, j, ξ, η], ξ]], {ξ, η}]]) /;
                ((i <= numKnots[n]) && (j <= numKnots[n]))

StiffnessMatrix[n_Integer?Positive] := StiffnessMatrix[n] =
    Table[StiffnessMatrixElement[n, i, j],
          {i, numKnots[n]}, {j, numKnots[n]}]

As an example, we again look at the two lowest orders.

StiffnessMatrix[1] // TableForm

StiffnessMatrix[2] // 
  TableForm[#, TableAlignments -> Center, TableSpacing -> {1, 1}]&

For a larger order, we will visualize the resulting mass and stiffness matrices. Here are these two matrices shown for n=10 for the unit triangle.

With[{n = 10}, 
Show[GraphicsArray[
  ListDensityPlot[(* scale *) ArcTan[#], PlotRange -> All, Mesh -> False,
                  DisplayFunction -> Identity]& /@ 
    (* calculate exact mass and stiffness matrices *)              
    {MassMatrix[n], StiffnessMatrix[n] /. {A -> 1, C -> 1, B -> 0}}]]]

The subject of finite elements contains many other opportunities for programming with Mathematica. For example, we mention algorithms for minimizing the bandwidth of sparse matrices (following, e.g., Cuthill–McKee [384✶], Gibbs–Poole–Stockmeyer ([650✶] and [640✶]), or Sloan [1455✶]). Because of their special nature, we do not go any further into the explicit implementation of these finite-element computations.

χ[p_, d_][k_, l_, ξ_] := 
Expand[InterpolatingPolynomial[
Table[{j/p, Table[KroneckerDelta[j, k]*
                  KroneckerDelta[l, i], {i, 0, d}]}, {j, 0, p}], ξ]]

Here are two examples:

{χ[3, 0][0, 0, ξ], χ[2, 2][1, 1, ξ]}

We sidestep a moment and visualize some of the (Subscript[χ, k,l]^((p,d)))(ξ). The function maxAbs[p, d][k, l] calculates the maximum of the absolute value of the (Subscript[χ, k,l]^((p,d)))(ξ) over the ξ-interval [0,1].

maxAbs[p_, d_][k_, l_] :=
Module[{f = χ[p, d][k, l, ξ], extξs},
  (* solve for extrema *)
  extξs = Select[N[{ToRules[Roots[D[f, ξ, ξ] == 0, ξ,
                 Cubics -> False, Quartics -> False]]}, 50], 
                (Im[ξ /. #] == 0 && 0 <= (ξ /. #) <= 1)&];
  Max[Abs[f /. Join[extξs, {{ξ -> 0}, {ξ -> 1}}]]]]

The magnitude of the functions decreases quickly with higher-order continuity.

With[{p = 4, d = 4},
     Table[{j, Max[Table[maxAbs[p, d][i, j], {i, 0, p}]] // N}, 
           {j, 0, d}]]

The function hpPlot implements a numerically reliable plotting function that we will use to safely plot the (for larger p and d high-order) polynomials.

hpPlot[f_, {ξ_, ξ0_, ξ1_}, prec_, opts___] := 
Module[{𝒻  = Function @@ {ξ, f}, 𝕗},
       (* use high-precision arithmetic *)
       𝕗[x_?NumericQ] := 𝒻[SetPrecision[x, prec]];
       Plot[𝕗[ξ], {ξ, ξ0, ξ1}, opts, PlotRange -> All,
       Frame -> True, DisplayFunction -> Identity]]

The next four graphics show some functions from the family (Subscript[χ, k,l]^((4,5))). Be aware of the greatly different ordinate values on the four graphics.

With[{p = 4, d = 5},
Show[GraphicsArray[Table[Show[
Table[hpPlot[χ[p, d][k, l, ξ], {ξ, 0, 1}, 100, 
             PlotStyle -> {{Thickness[0.002], Hue[k/6]}}],
      {k, 0, p}]], {l, 0, 3}]]]]

For a fixed l in (Subscript[χ, k,l]^((p,d))), the functions are roughly of equal magnitude. The following graphics show this for p=d=1, p=d=2, and p=d=3.

graph[p_, d_][k_, l_] := 
Plot[Evaluate[χ[p, d][k, l, ξ]], {ξ, 0, 1},
     DisplayFunction -> Identity, FrameTicks -> None,
     PlotRange -> All, Frame -> True, Axes -> False]
     
Show[GraphicsArray[#]]& /@ Table[     
      Table[graph[μ, μ][k, l], {l, 0, μ}, {k, 0, μ}], {μ, 3}]

Before starting the implementation of the functions to solve the eigenvalue problem, we will renumber the (Subscript[χ, k,l]^((p,d))). For fixed p and d, we want to number the functions (Subscript[χ, k,l]^((p,d)))(ξ)=(Subscript[χ, h]^((p,d)))(ξ) using one index to easily assemble the global finite element matrices. We number them consecutively with increasing k, and within each k with increasing l. The function reducesIndices does the inverse: given the linear numbering h, it generates the pairs (k,l).

reducesIndices[p_, d_][h_] := 
 Sequence[Floor[h/(d + 1)], h - (d + 1) Floor[h/(d + 1)]]

Here are the sixteen pairs corresponding to (Subscript[χ, h]^((3,3)))(ξ).

Table[{k, {reducesIndices[3, 3][k]}}, {k, 0, 15}]

Here is the definition for the (Subscript[χ, k,l]^((p,d)))(ξ)=(Subscript[χ, h]^((p,d)))(ξ). The local element matrices of the shape functions (Subscript[χ, i]^((p,d)))(ξ) are defined in the interval [0,1].

χ[p_, d_][k_, ξ_] := (* remember *) χ[p, d][k, ξ] = 
                     χ[p, d][reducesIndices[p, d][k], ξ]

For the second order eigenvalue problem, we now must calculate the following element stiffness and mass matrices (Subscript[𝓉, i,j]^((p,d))), (Subscript[𝓂, i,j]^((p,d))), and (Subscript[𝓋, i,j]^((σ,p,d))) (primes denote differentiation with respect to ξ):

(Subscript[𝓉, i,j]^((p,d)))=(∫_0^1)(Subscript[χ, i]^((p,d)))'(ξ)(Subscript[χ, j]^((p,d)′))(ξ)dξ
(Subscript[𝓂, i,j]^((p,d)))=(∫_0^1)(Subscript[χ, i]^((p,d)))(ξ)(Subscript[χ, j]^((p,d)))(ξ)dξ
(Subscript[𝓋, i,j]^((σ,p,d)))=(∫_0^1)(Subscript[χ, i]^((p,d)))(ξ)(ξ^σ)(Subscript[χ, j]^((p,d)))(ξ)dξ

In the definitions of the (Subscript[𝓋, i,j]^((σ,p,d))), we used a power function (ξ^σ) because of the (x^2) potential of the harmonic oscillator.

These definitions for the matrices (Subscript[𝓉, i,j]^((p,d))), (Subscript[𝓂, i,j]^((p,d))), and (Subscript[𝓋, i,j]^((σ,p,d))) can straightforwardly be implemented. We store the calculated values for the matrix elements because they are identical for all elements and will be used repeatedly later. We use the symmetries in the indices i and j to avoid doubling the work.

𝓉[p_, d_][i_, j_] := (𝓉[p, d][i, j] = 𝓉[p, d][j, i] = 
  Integrate[Expand[D[χ[p, d][i, ξ], ξ] D[χ[p, d][j, ξ], ξ]], {ξ, 0, 1}])

𝓂[p_, d_][i_, j_] := (𝓂[p, d][i, j] = 𝓂[p, d][j, i] = 
  Integrate[Expand[χ[p, d][i, ξ] χ[p, d][j, ξ]], {ξ, 0, 1}])
                 
𝓋[p_, d_][e_, i_, j_] := (𝓋[p, d][e, i, j] = 𝓋[p, d][e, j, i] = 
  Integrate[Expand[ξ^e χ[p, d][i, ξ] χ[p, d][j, ξ]], {ξ, 0, 1}])

The next three density plots show the element matrices for p=d=4. The periodic structure results from the 1D ordering scheme. The matrix elements decrease rapidly for increasing l for each k.

Module[{p = 4, d = 4, o}, 
  (* element matrix size *) o = (p + 1) (d + 1) - 1;
  Show[GraphicsArray[
   ListDensityPlot[ArcTan[#], 
       Mesh -> False, DisplayFunction -> Identity, 
       FrameTicks -> False, PlotRange -> All,
       ColorFunction -> (Hue[0.78 #]&)]& /@ 
     (* the three matrices 𝓉, 𝓂, and 𝓋 *)
     {Table[𝓉[p, d][i, j], {i, 0, o}, {j, 0, o}],
      Table[𝓂[p, d][i, j], {i, 0, o}, {j, 0, o}],
      Table[𝓋[p, d][2, i, j], {i, 0, o}, {j, 0, o}]}]]]

The matrices (Subscript[𝓉, i,j]^((p,d))), (Subscript[𝓂, i,j]^((p,d))), and (Subscript[𝓋, i,j]^((e,p,d))) refer to the normalized element (0,1). We now construct the corresponding matrices (Subscript[𝒯, i,j]^((p,d))), (Subscript[ℳ, i,j]^((p,d))), and (Subscript[𝒱, i,j]^((e,p,d))) for the interval [(Subscript[x, j]),(Subscript[x, j])+δ]. The matrix (Subscript[ℳ, i,j]^((p,d))) gets just multiplied by the length δ of the interval. Similarly, (Subscript[𝒯, i,j]^((p,d)))scales with 1/δ. (Subscript[𝒱, i,j]^((e,p,d))) contains information about the explicitly x-dependent function (x^2) and contains information about the element length δ and the element position (Subscript[x, j]).

𝒯[p_, d_, δ_][i_, j_, ___] := 1/δ 𝓉[p, d][i, j]
𝒱[p_, d_, δ_][i_, j_, xj_] := δ (xj^2 𝓋[p, d][0, i, j] + 
                                 2 xj δ 𝓋[p, d][1, i, j] +
                                 δ^2 𝓋[p, d][2, i, j])
ℳ[p_, d_, δ_][i_, j_, ___] := δ 𝓂[p, d][i, j]

The next step is to assemble the local element matrices (Subscript[𝒯, i,j]^((p,d))), (Subscript[𝒱, i,j]^((p,d))), and (Subscript[ℳ, i,j]^((e,p,d))) into global matrices (Subscript[𝕋, i,j]), (Subscript[𝕍, i,j]) and (Subscript[𝕄, i,j]). The coefficients (Subscript[c, k,l]^((j,p,d))) multiplied by the element functions form the resulting function ψ(x). For 1<k<p-1, only element functions inside the jth element contribute. The two coefficients (Subscript[c, p,l]^((j,p,d))) and (Subscript[c, 0,l]^((j+1,p,d))) are both attached to the same x-node (being the functions associated with the left-most node of the element [(Subscript[x, j]),(Subscript[x, j])+δ] and the functions associated with the right-most node from the interval [(Subscript[x, j+1]),(Subscript[x, j+1])+δ]) and are so identical. This means that the resulting global stiffness and mass matrices have dimension (e p+1)(d+1)×(e p+1)(d+1). (Because all elements have the same length δ, we do not have to worry about prefactors in the mapping of the from [0,1] to the intervals [(Subscript[x, j]),(Subscript[x, j])+δ] for the (Subscript[χ, k,l]^((p,d))) with l>0.)

The function 𝕋𝕍𝕄 assembles the three matrices (Subscript[𝕋, i,j]), (Subscript[𝕍, i,j]) and (Subscript[𝕄, i,j]).

𝕋𝕍𝕄[{elements_, L_}, elementNodes_, diffOrder_] :=
Module[{e = elements, p = elementNodes, 
        d = diffOrder, δ = 2L/elements, ℴ, 𝕞},
 (* element matrix size *) ℴ = (p + 1)(d + 1);
 ((* blank matrix to be filled *)
  𝕞 = Table[0, {(e p + 1)(d + 1)}, {(e p + 1)(d + 1)}];
  Do[(* matrices for all elements *)
     Do[𝕞[[p (d + 1) k + i + 1, p (d + 1) k + j + 1]] = 
        𝕞[[p (d + 1) k + i + 1, p (d + 1) k + j + 1]] + 
                                    #[i, j, -L + k/e 2L], 
       {i, 0, ℴ - 1}, {j, 0, ℴ - 1}], {k, 0, e - 1}]; 𝕞)& /@
 {𝒯[p, d, δ], 𝒱[p, d, δ], ℳ[p, d, δ]}]

The resulting matrices (Subscript[𝕋, i,j]), (Subscript[𝕍, i,j]) and (Subscript[𝕄, i,j]) have a block structure due to the individual elements assembled. Here the structure of the resulting matrices is shown for e=5, p=d=3.

Show[GraphicsArray[
ListDensityPlot[Sign[#], Mesh -> False, 
                PlotRange -> All, FrameTicks -> None,
                DisplayFunction -> Identity]& /@ 𝕋𝕍𝕄[{5, 1}, 3, 3]]]

Now the boundary conditions ψ(-L)=ψ(L)=0 must be applied. To do this, the function dirichletize sets the corresponding values of the node values to zero, meaning it removes the corresponding two equations.

dirichletize[{𝕥_, 𝕧_, 𝕞_}, diffOrder_] :=
 Map[Delete[#, {{1}, {-(diffOrder + 1)}}]&, {𝕥, 𝕧, 𝕞}, {1, 2}]

The three matrices (Subscript[𝕋, i,j]), (Subscript[𝕍, i,j]) and (Subscript[𝕄, i,j]) (we use the same variables even after imposing the boundary conditions) have now to satisfy the following algebraic eigenvalue problem:

(∑_(j=1)^((e p+1)(d+1)))((Subscript[𝕋, i,j])+(Subscript[𝕍, i,j]))(Subscript[ψ, j])=ε(∑_(j=1)^((e p+1)(d+1)))(Subscript[𝕄, i,j])(Subscript[ψ, j]).

(For a finite difference approach that yields a generalized eigenvalue problem, see [486✶].) Now that we have the matrices forming the generalized eigenvalue problem, we can deal with solving it. In absence of a dedicated generalized eigenvalue solver, we have to transform the problem to a classical eigenvalue problem 𝔸.ψ=ε ψ for a matrix 𝔸. To do this, we multiply from the left with the inverse of (Subscript[𝕄, i,j]). To ensure real eigenvalues, an explicitly symmetric matrix 𝔸 is desirable. So instead of (Subscript[𝕄, i,j]^(-1))((Subscript[𝕋, i,j])+(Subscript[𝕍, i,j])) we make use of the normality of 𝔸 and form ((Subscript[𝕄, i,j]^(-1))((Subscript[𝕋, i,j]^T)+(Subscript[𝕍, i,j]^T))+(Subscript[𝕄, i,j]^(-1T))((Subscript[𝕋, i,j])+(Subscript[𝕍, i,j])))/2 [793✶].

symmetricLhs[{𝕥_, 𝕧_, 𝕞_}] := 
With[{𝕚 = Inverse[𝕞]}, 
     (𝕚.Transpose[𝕥 + 𝕧] + Transpose[𝕚].(𝕥 + 𝕧))/2];

This yields the following function lowestEigenvalues[{e, L}, p, d, m, WorkingPrecision -> wp] for the calculation of the m lowest eigenvalues. We give this function a WorkingPrecision option to allow the use of high-precision arithmetic. (For the (relatively fast) matrix inversion we use a higher precision than for the eigenvalue calculation.)

lowestEigenvalues[{elements_, L_}, elementNodes_, diffOrder_, 
                  numberOfEigenvalues_, WorkingPrecision -> wp_] := 
Take[Eigenvalues[SetPrecision[symmetricLhs @ 
     (* calculate global matrices *)
      N[dirichletize[𝕋𝕍𝕄[{elements, L}, 
        elementNodes, diffOrder], diffOrder], 2 wp], wp]], 
     -numberOfEigenvalues]

Here are two examples. The first example uses 32 elements and linear Lagrange interpolation. The resulting matrices are of size 51. The agreement with the exact values 2j+1 is moderate.

lowestEigenvalues[{50, 6}, 1, 0, 5, 
                  WorkingPrecision -> $MachinePrecision]

Now we must optimize L. For p=1,d=0, p=2,d=0, and p=2,d=2 and resulting matrix size of about 64, we calculate and display the difference between the calculated and the exact eigenvalues. Because we minimize an expression, all our eigenvalue estimates will always be above the correct values.

{evs10, evs20, evs22} = 
Table[{L, #}& /@ (lowestEigenvalues[{#1, L}, #2, #3, 5, 
                  WorkingPrecision -> $MachinePrecision] -
              (* exact values *) {9, 7, 5, 3, 1}),
      (* L-values *) {L, 2, 12, 1/2}]& @@@ 
   (* L, p, and d *) {{50, 1, 0}, {25, 2, 0}, {12, 2, 2}};

Show[GraphicsArray[Graphics[Line /@ Transpose[
     Apply[{#1, Log[10, #2]}&, #, {-2}]], Frame -> True]& /@ 
                                  {evs10, evs20, evs22}]]

For d=0, we get (Subscript[L, opt])≈4 and for larger d the value of (Subscript[L, opt]) increases. The last graphics suggest that it is possible to calculate the ground-state to 10 correct digits with a resulting matrix of dimension 50×50. Let us now try to get 20 correct digits.

With eight elements and p=d=2, we get a 61×61 matrix and 13 correct digits.

lowestEigenvalues[{10, 6}, 2, 2, 1, WorkingPrecision -> 20] - 1

We will now increase the smoothness of the eigenfunctions. To use similar resulting matrix sizes, we have to reduce the number of elements accordingly. With four elements and p=3 and d=4, we get a 63×63 matrix and 20 correct digits. Higher-order smoothness gives considerably better results than just continuity [709✶].

lowestEigenvalues[{4, 7}, 3, 4, 1, WorkingPrecision -> 60] - 1

With only two elements and p=2 and d=12 (meaning high-order continuity), we get a 63×63 matrix and 25 correct digits.

lowestEigenvalues[{2, 8}, 2, 12, 1, WorkingPrecision -> 60] - 1

Even with only one single element and p=12, d=4, we can get 24 correct digits with a resulting 63×63 matrix .

lowestEigenvalues[{1, 15/2}, 12, 4, 1, WorkingPrecision -> 60] - 1

(For some exact solutions to low degree finite element approximations of the harmonic oscillator, see [355✶]; for multidimensional oscillators, see [1285✶]. For a bra-ket formulation of the finite element method, see [1043✶].)
Using the known symmetry of the ground-state, we could solve the eigenvalue problem in the interval [0,L] with Neumann boundary conditions on the left interval end. With the same matrix size limitation of 64, this reduction would allow us to get nearly 50 correct digits. We could further optimize by using elements of different length and nonuniform distributions of nodes inside the elements [184✶]. We leave further experiments to the reader.

We will compute the matrices (Subscript[M, "ij"]), (Subscript[N, "ij"]), (Subscript[L, "ij"]), and (Subscript[L, "ij"]^′), symbolically, and then compute the values of the determinants for prescribed numerical values of c and k. 
We begin with the implementation of the wave functions (Subscript[φ, i])(u,s,t). We make use of the representation of hyperbolic functions in terms of exponential functions to speed up the integration.

ψ[1] =   Exp[-s/2] (Exp[c t/2] - Exp[-c t/2])/2;
ψ[2] = s ψ[1];
ψ[3] = t Exp[-s/2] (Exp[c t/2] + Exp[-c t/2])/2;
ψ[4] = u ψ[1];
ψ[5] = u ψ[2];
ψ[6] = u ψ[3];

A direct implementation of the triple integrals is possible, but is extremely time-inefficient as Mathematica requires quite some time for just one single (out of the many) integral.

i = 1; j = 2;
TimeConstrained[Simplify[Integrate[
u (s^2 - t^2) (D[ψ[i], s] D[ψ[j], s] + D[ψ[i], t] D[ψ[j], t] +
               D[ψ[i], u] D[ψ[j], u]) +
s (u^2 - t^2) (D[ψ[i], s] D[ψ[j], u] + D[ψ[i], u] D[ψ[j], s]) +
t (s^2 - u^2) (D[ψ[i], t] D[ψ[j], u] + D[ψ[i], u] D[ψ[j], t]),
                  {s, 0, Infinity}, {u, 0, s}, {t, 0, u}]], 10]

We thus accelerate the integration process somewhat by hand. Here is the expression to be integrated.

temp = 
u (s^2 - t^2) (D[ψ[i], s] D[ψ[j], s] + D[ψ[i], t] D[ψ[j], t] +
               D[ψ[i], u] D[ψ[j], u]) +
s (u^2 - t^2) (D[ψ[i], s] D[ψ[j], u] + D[ψ[i], u] D[ψ[j], s]) +
t (s^2 - u^2) (D[ψ[i], t] D[ψ[j], u] + D[ψ[i], u] D[ψ[j], t]);

First, we note that indefinite integration is typically many times faster than is definite integration (because it deals with convergence, possible singularities along the integration path, …), and for the integrals of interest here, it gives the same results as carrying out the indefinite integration and simply substituting the limits. This can be easily checked.

Timing[Integrate[temp, {t, 0, u}]; ]

Timing[(((# /. {t -> u}) - (# /. {t -> 0}))&[Integrate[temp, t]]);]

The time-critical problem here, however, is the s-integration. First, we carry out the other two integrations.

tInt[x_] := ((# /. {t -> u}) - (# /. {t -> 0}))&[
                                       Together[Integrate[x, t]]]

uInt[x_] := ((# /. {u -> s}) - (# /. {u -> 0}))&[Integrate[x, u]]

Short[temp1 = uInt[tInt[temp]], 8]

Integrate[temp1, {s, 0, Infinity}] // Timing

We can do better “manually”. Looking at the integrand, we note that the resulting integrand of the s-integral has the form (∑_(k=1)^m)((Subscript[f, k])(c)(s^(Subscript[n, k]))(e^(-s))+(Subscript[g, k])(c)(s^(Subscript[n, k]))(e^(c s))(e^(-s))).

Integrals of this form are easy to integrate.

Integrate[Exp[α s] s^n, {s, 0, Infinity}]

The convergence of the integral is ensured on physical grounds (all n in (s^n) are nonnegative and 0<c<1). Taking account of the structure, we thus implement the following integration over s: we first factor the exponents and then do the integration by pattern matching.

sInt[x_] := Together[(Expand[x] //. {E^y_ :> E^Factor[y]}) //.
           (* do the integration *)
           {s^e_. Exp[s f_.] -> e! (-f)^(-e - 1), Exp[s f_.] -> - 1/f}]

Now the remaining third integral can be quickly computed.

Together[sInt[temp1]] // Timing

Thus, we introduce myIntegration for carrying out these three-dimensional integrals.

myIntegration[x_] := Together[sInt[uInt[tInt[x]]]]

Note that another possible way of calculating the integrals is by using so-called perimetric coordinates. For these coordinates, the above triple integrals can be factored into three single integrals. For details, see [365✶], [1255✶], and [2✶]. 
Here are the four 6×6 matrices with their 144 triple integrals. Because of space limitations, we do not print them out. 
Here is the matrix M.

mij[i_, j_] :=
   u (s^2 - t^2) (D[ψ[i], s] D[ψ[j], s] + D[ψ[i], t] D[ψ[j], t] +
                  D[ψ[i], u] D[ψ[j], u]) +
   s (u^2 - t^2) (D[ψ[i], s] D[ψ[j], u] + D[ψ[i], u] D[ψ[j], s]) +
   t (s^2 - u^2) (D[ψ[i], t] D[ψ[j], u] + D[ψ[i], u] D[ψ[j], t])

mMat = Table[myIntegration[mij[i, j]], {i, 6}, {j, 6}];

Here is the matrix L.

lij[i_, j_] := 2 s u ψ[i] ψ[j]
lMat = Table[myIntegration[lij[i, j]], {i, 6}, {j, 6}];

Here is the matrix L'.

lsij[i_, j_] := 1/4 (s^2 - t^2) ψ[i] ψ[j]
lsMat = Table[myIntegration[lsij[i, j]], {i, 6}, {j, 6}];

Here is the matrix N.

norm[i_, j_] := 1/8 u (s^2 - t^2) ψ[i] ψ[j]
normMat = Table[myIntegration[norm[i, j]], {i, 6}, {j, 6}];

The matrices require about 70 kB of memory.

ByteCount[{mMat, lMat, lsMat, normMat}]

After some time, all integrals are computed, and we can proceed with the numerical part. (The symbolic computation of the determinants takes some time.) Here is the matrix (Subscript[D, "ij"]).

dMat[k_, c_] = l normMat + k (lMat - lsMat) - k^2 mMat;

Because (Subscript[D, "ij"]) is a symmetric matrix, the (Subscript[λ, i]) are real, and the smallest value is in first place if we sort the zeros using Sort[NSolve[…]]. We first substitute parameters and then calculate the determinant to avoid the very time-consuming symbolic calculation of the determinant. Using FindRoot, we now determine the minimum as a function of k and c. We apply InputForm to get enough digits written out.

E0[k_Real, c_Real] := Sort[l /. NSolve[Det[dMat[k, c]] == 0, l]][[1]]

FindMinimum[E0[k, c], {k, 0.65, 0.67}, {c, 0.54, 0.56},
            PrecisionGoal -> 8] // InputForm

We check the quality of the last solution by carrying out the analogous high-precision minimum finding.

E0HP[k_Real, c_Real, p_] := E0[SetPrecision[k, p], SetPrecision[c, p]]

FindMinimum[E0HP[k, c, 40], {k, 676/1000, 677/1000}, 
                            {c, 552/1000, 553/1000},
            WorkingPrecision -> 40,
            AccuracyGoal -> 30, PrecisionGoal -> 12] // InputForm

One could go a few steps more on the symbolic side by producing a polynomial equation for l in the following manner.

(* generate polynomial *)
det = Factor[Numerator[Together[Det[dMat[k, c]]]]]/c^16;
(* the two equations *)
{eqk, eqc} = Factor[{D[det, k], D[det, c]}]
(* degrees of the two polynomials in c, k, and l *)
Print[Exponent[#, {c, k, l}]& /@ {det, eqk, eqc}];
(* find solution *)
FindRoot[Evaluate[# == 0& /@ {det, eqk, eqc}],
         {c, 55/100}, {k, 76/100}, {l, -108/100}, 
         WorkingPrecision -> 22, MaxIterations -> 40]

The theoretical result is in excellent agreement with the experimental result; it agrees to almost six digits. Note that this calculation was first carried out in 1930.

For this model in dD, see [1511✶]. For the minimization of the helium ground-state energy using piecewise linear wave functions, see [1105✶], and for high precision results, see [1421✶], [464✶], [1061✶], [468✶], [898✶], and [473✶].

For the interesting problem of two electrons in a box and in a sphere and other potentials, see [873✶], [1596✶], [295✶], [33✶], [1542✶], [1248✶], and [1078✶]; for polygonal domains, see [378✶], [1390✶].

Simplify[Integrate[x^n Exp[-b^2 x^2], {x, -Infinity, Infinity},
                   GenerateConditions -> False]]

Using this result, we implement myInt. The power of x is determined by the position in the corresponding CoefficientList, which we use here to handle arbitrary polynomials in x.

myInt[int_] := 
Plus @@ MapIndexed[#1 1/2 ((1 + (-1)^(#2[[1]] - 1))*
                   b^(-#2[[1]]) Gamma[#2[[1]]/2])&,
        CoefficientList[Cancel[int/Exp[-b^2 x^2]], x]]

So we can calculate the first six normalized (Subscript[ψ, i])(β;x).

ψ[0] = #/Sqrt[myInt[#^2]]&[Exp[-b^2 x^2/2]]

Do[ψ[i] = Factor[#/Sqrt[myInt[#^2]]&[D[ψ[i - 1], x]]], {i, 6}]

??ψ

Due to the symmetry of (Subscript[H, "ij"])(β) and (Subscript[M, "ij"])(β) in i and j, we implement the following calculation of the matrix elements.

mI[i_, j_] := mI[i, j] = mI[j, i] = Factor[myInt[ψ[i] ψ[j]]]

hI[i_, j_] := hI[i, j] = hI[j, i] = Factor[myInt[ψ[i] *
             (-1/2 D[ψ[j], {x, 2}] + (1/2 x^2 + x^4) ψ[j])]]

The determinants in a factored form (dropping the irrelevant denominator) are now given by the following.

evEq[n_] := evEq[n] = Factor[Numerator[Together[Det[PowerExpand[
           Table[hI[i, j] - e mI[i, j], {i, 0, n}, {j, 0, n}]]]]]]

evEq[0]

evEq[1]

evEq[2]

evEq[3]

evEq[4]

evEq[5]

evEq[6]

To get an estimation of the value of β for the minimum of ε, we solve the case with Ψ(β;x)=(Subscript[ψ, 0])(β;x) exactly.

Select[Solve[{(D[evEq[0] /. e -> e[b], b] /. {e'[b] -> 0,
                 e[b] -> e}) == 0, evEq[0] == 0}, {b, e}],
       (Im[e] == 0 && b > 0 /. N[#])&]

Here is a sketch of the behavior of the ψ(β;x), including more terms.

Show[GraphicsArray[#]]& /@ 
Partition[Table[
ListPlot[Table[{b, NRoots[evEq[i] == 0, e][[1, 2]]},
               {b, 0.8, 2.5, 0.025}],
         PlotRange -> {0.8, 0.82}, PlotJoined -> True,
         AxesOrigin -> {0.8, 0.8}, DisplayFunction -> Identity, 
         PlotLabel -> "evEq[" <> ToString[i] <> "]"], {i, 6}], 3]

Let us now numerically compute the minimizing values for β. We compare three different methods for the case of evEq[3]. One method is to use FindMinimum for the lowest value of e, which we calculate by solving the polynomial in e with NRoots.

Timing[FindMinimum[NRoots[evEq[3] == 0, e, 20][[1, 2]],
             {b, ##}, WorkingPrecision -> 25,
             PrecisionGoal -> 12, Compiled -> False]& @@@
             (* two initial intervals *)
                        {{11/10, 12/10}, {17/10, 18/10}}]

A second method would be to eliminate ε from the two polynomial equations (after using the condition ε'(β)=0 for the lowest eigenvalue to be extremal)

({{(∂/(∂β))det((Subscript[H, "ij"])(β)-ε(β)(Subscript[M, "ij"])(β))=0}, {det((Subscript[H, "ij"])(β)-ε(β)(Subscript[M, "ij"])(β))=0}})

and solve the resulting polynomial in β with NRoots and after backsubstitution of all roots search for the lowest value of ε. The advantage of this approach is that we do not need an initial value.

Function[eq,
N[Sort[{NRoots[(evEq[3] /. b -> #) == 0, e][[1, 2]], #}& /@
        Cases[NRoots[eq == 0, b], _Real?Positive, {-1}],
        #1[[1]] < #2[[1]]&], 12]][polyInb =
  Numerator[Factor[Resultant[(D[evEq[3] /. e -> e[b], b] /.
            e'[b] -> 0) /. e[b] -> e, evEq[3], e]]]] // Timing

The disadvantage is that for larger values of n, the polynomial in β is typically of high degree.

polyInb

Furthermore, an accurate numerical solution is time-consuming. We could, of course, avoid the explicit intermediate calculation of polyInb by direct use of NSolve for the two equations {((D[evEq[3] /. e -> e[b], b] /. e'[b] -> 0) /. e[b] -> e) == 0, evEq[3] == 0}. This would not have resulted in a faster solution. Actually, the quality of the solution is not guaranteed.

Sort[Select[NSolve[{((D[evEq[3] /. e -> e[b], b] /. e'[b] -> 0) /. 
     e[b] -> e) == 0, evEq[3] == 0}, {e, b}],
     Im[e] == 0 && Im[b] == 0 && Re[b] > 0 /. #&],
                     #1[[1, 2]] < #2[[1, 2]]&] // Timing

A combined use of GroebnerBasis for preprocessing the equations and then Solve with an appropriately WorkingPrecision option setting will work fine for the smaller examples, but its running time will be prohibitive for larger examples.

gbSolve[order_] := Sort[Select[Solve[# == 0& /@ GroebnerBasis[
      {((D[evEq[order] /. e -> e[b], b] /. e'[b] -> 0) /. 
       e[b] -> e), evEq[2]}, {e, b}], {e, b}, WorkingPrecision -> 50],
     Im[e] == 0 && Im[b] == 0 && Re[b] > 0 /. #&], #1[[1, 2]] < #2[[1, 2]]&]

gbSolve[2] // N // Timing

gbSolve[3] // N // Timing

gbSolve[4] // N // Timing

gbSolve[5] // N // Timing

A further related solution method is to solve evEq[3] == 0 explicitly for e (which is possible if the evEq[i] is a polynomial of degree less than five in radicals), minimizing the resulting expressions with respect to b. Here, this is done.

Sort[{e -> #[[1]], b -> #[[2]]}& /@ Flatten[
     {{#, b} /. FindRoot[Evaluate[D[#, b] == 0], {b, 11/10}],
      {#, b} /. FindRoot[Evaluate[D[#, b] == 0], {b, 18/10}]}& /@
               (#[[1, 2]]& /@ Solve[evEq[3] == 0, e]), 1],
     #1[[1, 2]] < #2[[1, 2]]&] // Timing

A third method is to solve the above two equations in ε and β with FindRoot.

frSolve[n_, startbs_] :=
Function[eq,
FindRoot[eq, {e, 8/10}, {b, #},
         AccuracyGoal -> 20, WorkingPrecision -> 25]& /@ startbs][
{(D[evEq[n] /. e -> e[b], b] /. e'[b] -> 0) /. e[b] -> e, evEq[n]}]

Timing[frSolve[3, {12/10, 18/10}]]

Because this method seems most appropriate for the problem and parameters under consideration here, we finally use it to calculate the other values of n.

TableForm[Table[Flatten[{i, N[{e, b} /.
Function[res, res[[Position[#, Min[#]]&[#[[2, 1]]& /@
         res][[1, 1]], 1]]][
  {#, {e, b} /. #}& /@ frSolve[i, {11/10, 14/10, 19/10}]], 20]}],
  {i, 1, 6}], TableHeadings ->  {None, {"order \n \n", "e \n", "b \n"}}]

x[dim_][n_] := x[dim][n] = r Product[Sin[ϑ[i]], {i, n - 1}] Cos[ϑ[n]];

(* the last coordinate *)
x[dim_][dim_] := x[dim][dim] = r Product[Sin[ϑ[i]], {i, dim - 1}]
var[n_] := var[n] = Union[Array[ϑ, n - 1], {r}]

Now we apply Simplify to simplify the resulting sums of products of trigonometric functions.

NaivJacobiDeterminant[dim_] :=
Simplify[Det[Outer[D, Array[x[dim], dim], Union[Array[ϑ, dim - 1], {r}]]]]

For comparison, consider the following FastJacobiDeterminant, which works only with the identity ((sin(x))^2)+((cos(x))^2)=1 (in two slightly different versions at two stages).

FastJacobiDeterminant[dim_] := Factor[
 (Det[Outer[D, Array[x[dim], dim], Union[Array[ϑ, dim - 1], {r}]]] //.
               {a_ Cos[x_]^2 + a_ Sin[x_]^2 -> a})] /.
                           {Cos[x_]^2 + Sin[x_]^2 -> 1}

Here are the computations of some Jacobian determinants with the times required.

timings[k_Integer] := {k, {Timing[NaivJacobiDeterminant[k]],
                           Timing[FastJacobiDeterminant[k]]}}

Table[timings[k], {k, 2, 7}]

The enormous savings of time using an appropriate transformation rule is obvious.

r[u_, v_] = 
With[{x = u + v, y = u - v},
     {0, 0, x} + 2d/c Sin[d y] Cosh[c x]/
     (d^2 Cosh[c x]^2 + c^2 Sin[d y]^2) {Sin[y], -Cos[y], 0} +
     2d^2/c Cosh[c x] (Cosh[c x]^2 - Sin[d y]^2)/
     (d^2 Cosh[c x]^2 + c^2 Sin[d y]^2)/
     (Cos[d y]^2 Cosh[c x]^2 + Sinh[c x]^2 Sin[d y]^2)*
     {Cos[y] Cos[d y], Sin[y] Cos[d y], -Sinh[c x]}];

It is straightforward to calculate the quantities ℰ, ℱ, 𝒢, ℯ, 𝒻, and ℊ.

ℰ = D[r[u, v], u].D[r[u, v], u];
ℱ = D[r[u, v], u].D[r[u, v], v];
𝒢 = D[r[u, v], v].D[r[u, v], v];

n = Cross[D[r[u, v], u], D[r[u, v], v]];
ℯ = D[r[u, v], u, u].n;
𝒻 = D[r[u, v], u, v].n;
ℊ = D[r[u, v], v, v].n;

The resulting expression for 𝒦 is quite large (and so very probably cannot be simplified in a reasonable time using Simplify[𝒦]).

(𝒦 = (ℯ ℊ - 𝒻^2)/n.n/(ℰ 𝒢 - ℱ^2)) // ByteCount

Random numerical substitutions indicate that we have 𝒦=-1.

Table[Block[{c = Random[], d, u = Random[], v = Random[]}, 
            d = Sqrt[1 - c^2]; 𝒦], {6}]

To symbolically show 𝒦=-1 we transform the expression 𝒦 that contains trigonometric and hyperbolic functions into a purely polynomial one. We first rewrite the trigonometric and hyperbolic functions in exponential form and then use new variables for the various exponential terms.

makePoly[expr_] := expr /. 
 (trig:(Cos | Cosh | Sin | Sinh))[x_] :> TrigToExp[trig[Expand[x]]]

expOfVarToVars[E^l_] := Times @@ (Function[x, 
Which[(* one polynomial variable per exponential term *)
      x === -  u, 1/u1, x === -  v, 1/v1,
      x === -c u, 1/cu, x === -c v, 1/cv, 
      x ===  c u,   cu, x ===  c v,   cv, 
      x === -d u, 1/du, x === -d v, 1/dv, 
      x ===  d u,   du, x ===  d v,   dv,
      (* Exp[I ...] case *)
      x === -I   u, 1/iu1, x === -I   v, 1/iv1,
      x ===  I   u,   iu1, x ===  I   v,   iv1,
      x === -I c u, 1/icu, x === -I c v, 1/icv, 
      x ===  I c u,   icu, x ===  I c v,   icv,
      x === -I d u, 1/idu, x === -I d v, 1/idv, 
      x ===  I d u,   idu, x ===  I d v,   idv]] /@
                 If[Head[l] === Plus, List @@ l, {l}])

transform[expr_] := 
    Together[makePoly[expr] /. e:Power[E, l_] :> expOfVarToVars[e]]

{ℰ1, ℱ1, 𝒢1} = transform /@ {ℰ, ℱ, 𝒢};
{ℯ1, 𝒻1, ℊ1} = transform /@ {ℯ, 𝒻, ℊ};
nn1 = transform[n.n];

Writing all expressions involved over a common denominator results in an expression whose size is about 1% of the above one.

ℰ𝒢ℱ = Together[ℰ1 𝒢1 - ℱ1^2];
ℯℊ𝒻 = Together[ℯ1 ℊ1 - 𝒻1^2];
𝒦 = Together[ℯℊ𝒻/(nn1 ℰ𝒢ℱ)];

ByteCount[𝒦]

Now it is straightforward to use the relation c=c(d) and to obtain the result 𝒦=-1. c only appears in even powers in 𝒦, so that all square roots disappear.

Cases[𝒦, c^_, Infinity] // Union

Together[𝒦 /. c^n_?EvenQ :> (1 - d^2)^(n/2)]

Now let us visualize some of the surfaces for various d.

r[{u_, v_}, d_] = r[u, v] /. c -> Sqrt[1 - d^2];

picture[d_, pp_, opts___] :=
With[{L = 6},
 Show[Graphics3D[(* remove some polygons to better see inside *)
     MapIndexed[If[EvenQ[#2[[1]]], #, {}]&,
      ParametricPlot3D[Evaluate[Append[r[{u, v}, d],
    {EdgeForm[], SurfaceColor[Hue[u/L], Hue[u/L], 2.6]}]],
     {u, -L, L}, {v, -L, L}, opts, PlotPoints -> pp,
    DisplayFunction -> Identity][[1]]]],
    BoxRatios -> {1, 1, 1.8}, PlotRange -> {All, All, {-4, 4}},
    DisplayFunction -> $DisplayFunction, ViewPoint -> {3, 0, 1}]];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {picture[0.25, 101], picture[0.45, 100], picture[0.77, 101]}]]]

For similar parametrizations of constant positive curvature surfaces, see [1627✶].

x(t)=(Subscript[v, x0])t+(Subscript[x, 0]),
y(t)=-(g/2)(t^2)+(Subscript[v, y0])t+h.

Introducing the throw angle α via (Subscript[v, x0])=(Subscript[v, 0])cos(α),(Subscript[v, y0])=(Subscript[v, 0])sin(α) and eliminating the time parameter from the parametric description of the throw, we obtain the following equation.

Eliminate[{x == v0 Cos[α] t,
           y == -g/2 t^2 + v0 Sin[α] t + h}, t]

The maximum distance is obtained by setting y equal to 0 (hitting the ground). The throw distance (Subscript[x, 0]) is a function of the throw angle α, this means (Subscript[x, 0])=(Subscript[x, 0])(α).

(Subtract @@ %) /. {y -> 0, x -> x[α]}

Differentiating the last equation with respect to α and applying the condition for an extremum, we obtain the following equation for α.

Eliminate[{% == 0, (D[%, α] /. x'[α] -> 0) == 0}, x[α]]

After eliminating all Sin[α] from the last equation, Mathematica can solve for the optimal throw angle.

Solve[% /. Sin[α]^n_ -> (1 - Cos[α]^2)^(n/2), α]

Obviously, the last solution is the physically sensible one. For small heights h, we have the following series solution for the optimal throw angle. For positive heights, the optimal throw angle is smaller than (45^°).

Series[%[[-1, 1, 2]], {h, 0, 2}]

Let us now visualize the optimality of the throw angle just calculated. We do this by showing the optimal throw in comparison to other throws. Here is the description of a general throw.

throw[α_, h_, v0_, g_] := Line[
 Table[{v0 Cos[α] t, -g/2 t^2 + v0 Sin[α] t + h},
       {t, 0, #, #/50}]&[ v0/g Sin[α] + Sqrt[2h/g + v0^2/g^2 Sin[α]^2]]]

This shows two examples for different starting heights. The violet curve is for an angle of π/4, the optimal throw angle for h=0 is in red.

throwPicture[h_, v0_, l_, {α1_, α2_}, opts___] := With[{g = 10},
Graphics[{{(* the ground *) GrayLevel[0.8],
                Polygon[{{0, 0}, {l, 0}, {l, -3}, {0, -3}}]},
               (* various throws *)
                 Table[{GrayLevel[0], Thickness[0.002], 
                        throw[α, h, v0, g]}, {α, α1, α2, 5 Degree}],
               (* the optimal throw *)
                {Hue[0], Thickness[0.01],
                 throw[ArcCos[Sqrt[(2g h + v0^2)/(2g h + 2v0^2)]], h, v0, g]},
                {Hue[0.78], Thickness[0.002], throw[Pi/4, h, v0, g]}},
         opts, Frame -> True, PlotRange -> All, AspectRatio -> Automatic]]

Show[GraphicsArray[
   {throwPicture[10, 10, 20, {-20, 80} Degree] // (* name it *) (pic1 = #)&,
    throwPicture[-2, 10, 10, { 40, 80} Degree]}] // N]

We obtain the envelope by eliminating α from the following two equations C(x,y,α)=0 and ∂C(x,y,α)/∂α=0 where C(x,y,α) is the implicit description of the thow curve.

To obtain polynomial equations we use a rational parametrization for the trigonometric functions.

Eliminate[{# == 0, D[#, σ] == 0}&[
g x^2 - 2 v0^2 x Cos[α] Sin[α] - v0^2 (2 h - 2 y) Cos[α]^2 /.
 {Cos[α] -> (1 - σ^2)/(1 + σ^2), Sin[α] -> 2 σ/(1 + σ^2)}], σ]

Solve[%, y] // Simplify

Here are the above throw curves together with their envelope [182✶], [267✶], [254✶].

With[{g = 10, h = 10, v0 = 10},
     Show[{pic1, Graphics[{RGBColor[0, 1, 0], Thickness[0.006],
           (* envelope *) Line[N[
             Table[{x, -((-2 g h v0^2 - v0^4 + g^2 x^2)/
                       (2 g v0^2))}, {x, 0, 10, 1/10}]]]}]} // N]]

For the also interesting question of the maximum length of the arc length of the trajectory, see [461✶]; for the inclusion of frication, see [334✶]; for the throw process itself, see [379✶].

x(t)=(Subscript[v, x0])t+(Subscript[x, 0]),
y(t)=-(g/2)(t^2)+(Subscript[v, y0])t+(Subscript[y, 0]).

Solving the first equation for t=(x-(Subscript[x, 0]))/(Subscript[v, x0]) and substituting in the second equation, we get y(x). At this point, the initial position {(Subscript[x, 0]),(Subscript[y, 0])} and the components of the initial velocity (Subscript[v, x0]) and (Subscript[v, y0]) are still unspecified.

y = -g/2 t^2 + vy0 t + y0 /. {t -> (x - x0)/vx0}

The components of the initial velocity (Subscript[v, 0]) satisfy (Subscript[v, x0])=(Subscript[v, 0])cos(φ), (Subscript[v, y0])=(Subscript[v, 0])sin(φ). Here, (Subscript[v, 0]) is the absolute value of the initial velocity (Subscript[v, 0]).

y = y /. {vx0 -> v0 Cos[φ], vy0 -> v0 Sin[φ]}

(Subscript[v, 0]^2) follows from the conservation of energy law m g (l-lcos((Subscript[φ, m])))=mg(l-lcos(φ))+m/2(Subscript[v, 0]^2), which gives (Subscript[v, 0]^2)=2g l (cos(φ)-cos((Subscript[φ, m]))). Here, (Subscript[φ, m]) is the maximum angle, φ is the instantaneous angle, and l is the length of the pendulum. (We use v0q for (Subscript[v, 0]^2) to avoid confusion with the vector (Subscript["v", 0]).)

Solve[(* energy conservation *)
      m g (l - l Cos[φMax]) ==
      m g (l - l Cos[φ]) + m/2 v0q, v0q] // Simplify

This yields the following equation.

y = y /. {v0^(-2) -> 1/(2 l g (Cos[φ] - Cos[φMax]))}

Note that the constant of gravitational acceleration g now no longer appears! 
The components of initial position {(Subscript[x, 0]),(Subscript[y, 0])} of the trajectory can be found directly from the following geometry: (Subscript[x, 0])=lsin(φ), (Subscript[y, 0])=h+(l-lcos(φ)). Here h is the height of the bob of the pendulum at φ=0.

y = y /. {x0 -> l Sin[φ], y0 -> h + (l - l Cos[φ])}

Because y=0 holds at the point of collision with the earth, we can simplify by multiplying by 4l(cos(φ)-cos((Subscript[φ, m])))((cos(φ))^2).

y = Together[y] (4 l (Cos[φ] - Cos[φMax]) Cos[φ]^2 (-1)) // Expand

To determine the angle that results in the maximum distance, we must solve y((Subscript[x, s])(φ))=0 and ∂(Subscript[x, s])(φ)∂φ=0.

A direct implementation of the form

{eq1, eq2} = y /. Solve[y == 0, x];
{Solve[D[eq1, φ] == 0, φ], Solve[D[eq2, φ] == 0, φ]}

fails to find a result even after several hours. We thus intervene by hand. y is a polynomial of second degree in x. We write y in the form (x^2)+px+q=0.

{q, p} = Take[CoefficientList[y, x], 2];

With a=-p/2, b=(p^2)/4-q, (Subscript[x, s]) becomes a±(Sqrt[b]), and from (prime denotes differentation with respect to φ) ∂x(φ)/∂φ=a'(φ)±1/(Sqrt[2b(φ)])b'(φ)=0, we get 4((b(φ))^2)((a'(φ))^2)-((b'(φ))^2)=0.

{a, b} = {-p/2, p^2/4 - q} // Expand;
eq = 4 D[a, φ]^2 b - D[b, φ]^2 // Expand;

We simplify this a little more by multiplying by (l^2).

(eq = eq/l^2 // Expand) // Short[#, 6]&

We then replace all appearances of sin(φ) by cos(φ).

eq = eq /. {Sin[φ]^n_?EvenQ -> (1 - Cos[φ]^2)^(n/2)} // Expand;

Finally, introducing c=cos(φ), (Subscript[c, m])=cos((Subscript[φ, m])), we write the resulting expression in the following somewhat shorter form.

eq = Expand[eq l h] //. {Cos[φ] -> c, Cos[φMax] -> cm}

This polynomial of eighth degree in c=cos(φ) can be solved explicitly.

Factor[eq]

PS: A one-line input to arrive at eq starting from the above y would be the following GroebnerBasis containing input.

gb = GroebnerBasis[{y, D[y /. x -> x[φ], φ] /. {x'[φ] -> 0, x[φ] -> x}, 
                    (* algebraic relation between Sin and Cos *)
                    Sin[φ]^2 + Cos[φ]^2 - 1},
                   {Cos[φ], Cos[φMax], h, l}, {Sin[φ], x},
                   MonomialOrder -> EliminationOrder] /.
                   {Cos[φ] -> c, Cos[φMax] -> cm} // Factor

Now we look for the relevant roots of eq (we select from the last product the factor that contains the parameters of the problem).

(sol = Solve[gb[[-1, -1]] == 0, c]) // Short[#, 12]&

(Another way to solve the above two equations is given in [1554✶].) To find the solution of interest to us, we insert some physically meaningful values for l, h, and (Subscript[c, m]).

sol /. {cm -> Cos[80. Degree], l -> 1, h -> 1} // N

sol[[Position[%, {c -> _?(Im[#] === 0 && 0 < # < 1&)}][[1, 1]]]];

The relevant solution is thus the sixth one (-1<(c=cos(φ))<1), which we now incorporate into OptimalThrowAngle.

aux[h_, l_, φMax_] = 
Block[{cm}, cm = Cos[φMax];
      (* just the long result from above *) %[[1, 2]]];

optimalThrowAngle[h_, l_, φMax_] := ArcCos[aux[h, l, φMax]]

The answer does not depend explicitly on l and h, but only on l/h. This can be easily seen by replacing l with h x and testing to see if the result is independent of h.

Cancel[PowerExpand[PowerExpand[(aux[h, l, φMax] //. l -> h x) //.
      Sqrt[s_Plus] :> Sqrt[Collect[s, h]]] //.
         Power[s_Plus, n_] :> Power[Collect[s, h], n]]]

At this point, we leave the solution in the above form. We now look at some typical values for the throw angle.

Plot3D[optimalThrowAngle[1, l, φMax],
       {l, 1/3, 3}, {φMax, Pi/10, Pi/2}, PlotPoints -> 12]

The average result is around 30(^◦) measured from the vertical for a large parameter range. This is considerably smaller than the 45(^◦) angle that is the known optimal throw angle starting from a plane. Now we plot the trajectory. For an arbitrary throw angle, the horizontal throw distance corresponds to y(x)=0.

Solve[y == 0, x][[2, 1, 2]]

throwDistance[h_, l_, φMax_, φ_] :=
 N[(-(l (-2 - 4 Cos[φ]^2 + 4 Cos[φ] Cos[φMax])*
    Sin[φ]) - 4 l^(1/2) Cos[φ] (-Cos[φ] + Cos[φMax])^(1/2)*
    (-h - l + l Cos[φ] - l Cos[φ] Sin[φ]^2 +
     l Cos[φMax] Sin[φ]^2)^(1/2))/2] // Chop

The time of flight is given by t=(x-(Subscript[x, 0]))/(Subscript[v, x0]).

flightTime[h_, l_, φMax_, φ_] :=
N[(throwDistance[h, l, φMax, φ] - l Sin[φ])/
  (Cos[φ] Sqrt[2 l g (Cos[φ] - Cos[φMax])])] // Chop

The trajectory {x(t),y(t)} is given by the following.

path[t_, h_, l_, φMax_, φ_] :=
(* superposition of x- and y- motion *)
  {Cos[φ] Sqrt[2 l g (Cos[φ] - Cos[φMax])] t + l Sin[φ],
   -g/2 t^2 + Sin[φ] Sqrt[2 l g(Cos[φ] - Cos[φMax])] t +
   h + (l - l Cos[φ])} // N;

With these functions, we can construct the following schematic plot of the trajectory. The path corresponding to the largest horizontal throw distance is shown with a heavy line. For comparison, the other paths are depicted with thin lines.

flightTime[0.7, 1.8, 110 Degree, 30 Degree]

throwVisualization[h_, l_, φMax_, opts___] :=
Module[{(* for φ > 90 Degree eliminate small imaginary part *) 
        opt = Re @ N[optimalThrowAngle[h, l, φMax]]},
Block[{g = 9.81},
Show[(* a few possible trajectories *)
 {Table[ParametricPlot[Evaluate[path[t, h, l, φMax, φ]],
                       Evaluate[{t, 0, flightTime[h, l, φMax, φ]}],
                       DisplayFunction -> Identity,
                       PlotStyle -> {Thickness[0.002], Hue[0.78 φ/φMax],
                                     Dashing[{1/80, 1/80}]}],
        {φ, φMax/15, φMax 14/15, φMax/15}],
 (* the optimal trajectory *)
 ParametricPlot[Evaluate[path[t, h, l, φMax, opt]],
                Evaluate[{t, 0, flightTime[h, l, φMax, opt]}],
                DisplayFunction -> Identity,
                PlotStyle -> {GrayLevel[0], Thickness[0.006]}],
  (* the pendulum *)
  Graphics[{Thickness[0.012], GrayLevel[1/2],
            Circle[{0, l + h}, l, {3Pi/2, 3Pi/2 + φMax}]}],
  (* the ground *)
  Graphics[{GrayLevel[3/4], Rectangle[{0, 0},
            {1.1 throwDistance[h, l, φMax, opt], -(l + h)/12}]}]},
       opts, PlotRange -> All, AspectRatio -> Automatic,
       Axes -> None, PlotLabel -> StyleForm[
        "optimal angle = " <> ToString[N[opt/Pi 180, 3]] <> " Degree",
        FontFamily -> "Courier", FontWeight -> "Bold", FontSize -> 13]]]]

Here are two examples.

Show[GraphicsArray[{throwVisualization[0.7, 1.8,  75 Degree],
                    throwVisualization[1.8, 0.7, 110 Degree]}]]

An important application of this exercise is to the problem of maximizing the distance that one can jump from a moving swing. In this application, for solving the further very important problem of how to get maximum impetus, see [588✶], [281✶], [1042✶], [382✶], [37✶], [31✶], [1025✶], [1667✶], and [247✶]. For the related problem of when to throw something from a rotating wheel to achieve the maximal height, see [1200✶] and [679✶]; for jumping from a bungee chord, see [1538✶]; for jumping from a springboard, see [603✶].

Needs["Graphics`Polyhedra`"]

breathingData[plato_] :=
Module[{dim = Length[Vertices[plato]], edges, neighbors, ℱ, force,
        ℱLinearized, coefficientRules, M, evals, evecs, 
        allEigenvalues, iVec, iCoeffs, breatingModeEigenvalue},
(* the edges *)
edges = Union[Sort /@ 
   Flatten[Partition[Append[#, First[#]], 2, 1]& /@ Faces[plato], 1]];
(* neighbors of the vertex k *)
neighbors[k_] := 
Union[Flatten[DeleteCases[Select[edges, MemberQ[#, k]&], k, Infinity]]];
(* resulting force on a vertex *)
ℱ[k_] := Plus @@ (force[{k, #}]& /@ neighbors[k]);
(* force on vertex i due to vertex j *)
force[{i_, j_}] := 
Module[{p0 = N[Vertices[plato][[#]], 22]&, p},
        p = (p0[#] + {x[#], y[#], z[#]})&; 
        #/Sqrt[#.#]&[p[j] - p[i]]*
        (Sqrt[#.#]&[p[j] - p[i]] - Sqrt[#.#]&[p0[j] - p0[i]])];
(* force for small elongations *)
ℱLinearized[k_] := Expand[Normal[(* keep linear terms only *)
   Series[ℱ[k] /. xyz:(_x | _y | _z) :> ε xyz, {ε, 0, 1}]]/ε];
(* make rules of all nonvanishing matrix elements *)
coefficientRules = Module[{υ, xC, yC, zC},  υ[0] := {};
 υ[p_Plus] := υ /@ (List @@ p); υ[l_List] := υ /@ l;
 υ[f_. x[j_]] := {j, f}; 
 υ[f_. y[j_]] := {dim + j, f}; υ[f_. z[j_]] := {2dim + j, f};
(* nonvanishing matrix elements *)
 Flatten[Table[{xC, yC, zC} = Chop[ℱLinearized[k]];
               {({k, #1} -> #2)& @@@ υ[xC],
               ({dim + k, #1} -> #2)& @@@ υ[yC],
               ({2dim + k, #1} -> #2)& @@@ υ[zC]}, {k, dim}]]];
 (* form matrix *)
 M = Module[{m = Table[0, {3dim}, {3dim}], 
            cR = coefficientRules},
           Do[m[[cR[[j, 1, 1]], cR[[j, 1, 2]]]] = 
              m[[cR[[j, 1, 1]], cR[[j, 1, 2]]]] + cR[[j, 2]],
             {j, Length[coefficientRules]}]; m];
(* eigenvalues and eigenvectors *)
{evals, evecs} = Eigensystem[M];
(* count eigenvalues *)
allEigenvalues = {SetPrecision[First[#], 5], Length[#]}& /@ 
Split[Sort[Chop[SetAccuracy[SetPrecision[
                  evals, 11], 11], 10^-10]]];
(* eigenvalues forming the breathing mode *)
iVec = Flatten[Transpose[N[Vertices[plato], 22]]];
iCoeffs = Chop[iVec.#& /@ evecs, 10^-10];
breatingModeEigenvalue = {First[#], Length[#]}& /@
Split[Sort[SetPrecision[evals[[Flatten[
             Position[iCoeffs, _?(# != 0&)]]]], 5]]];
(* return all and breathing eigenvalues *)             
Apply[{Sqrt[Abs[#1]], #2}&, 
      {allEigenvalues, breatingModeEigenvalue}, {-2}]]

For the tetrahedron and the octahedron the “breathing mode” is the highest mode.

breathingData[Tetrahedron]

breathingData[Octahedron]

Due to the orthogonality of the faces of the cube, linear coupling terms are largely missing and 12 modes contribute to the “breathing mode”.

breathingData[Hexahedron]

For the dodecahedron and the icosahedron, the “breathing mode” is again unique, but it is not the highest frequency mode.

breathingData[Dodecahedron]

breathingData[Icosahedron]

For a group-theoretical discussion of the eigenmodes, see [1017✶], [495✶].

We begin with the computation of ν(ξ). We implement the left side of the differential equation and insert the given transformation of the dependent variables.

ODE[y_, x_] := f2[x] D[y, {x, 2}] + f1[x] D[y, x] + (f0[x] + λ g[x]) y

aux1 = ODE[η[ξ[x]]/Φ[x], x] // Together // (# Φ[x]^3)&

The quantities ξ[x], η[ξ] and their derivatives can now be given explicitly.

ξv[x_] = Integrate[Sqrt[g[x]/f2[x]], x];
ξvs = D[ξv[x], x];
ξvss = D[ξv[x], {x, 2}] // Together;

Φv[x_] = (g[x]/f2[x])^(1/4) Exp[1/2 Integrate[f1[x]/f2[x], x]];
Φvs = D[Φv[x], x] // Together;
Φvss = D[Φv[x], {x, 2}] // Together;

We insert this in aux1, simplify the resulting expression, and “backsubstitute” (the backsubstituted quantities carry an additional v in their names).

Numerator[(* carry out all backsubstitutions *)
aux1 //. {ξ[x] -> ξv[x], ξ'[x] -> ξvs, ξ''[x] -> ξvss,
          Φ[x] -> Φv[x], Φ'[x] -> Φvs,
          Φ''[x] -> Φvss} // Together] //.
           {Integrate[(g[x]/f2[x])^(1/2), x] -> ξ,
            Exp[Integrate[f1[x]/f2[x], x]] -> Φ^2 Sqrt[f2[x]/g[x]]}

We now cancel common factors.

Factor[%]/(Φ^2 Sqrt[f2[x]/g[x]])

We rearrange the result in an appropriate form.

Collect[%, {η[ξ], η''[ξ]}]

Now we divide through by the coefficient of η''(ξ).

#/(16 f2[x] g[x]^3)& /@ %

This leads to the following result for ν(ξ).

Expand[%[[1]]/η[ξ]] - λ

The following formula can be found in the references given above:

(((Subscript[f, 0])(x))/(g(x)))+(1/2)((((g(x))/((Subscript[f, 2])(x)))))'((((((Subscript[f, 2])(x))/(g(x)))))^2)((Φ'(x))/(Φ(x)))-(((Subscript[f, 2])(x))/(g(x)))((Φ''(x))/(Φ(x))).

This is identical to the one above.

f0[x]/g[x] + 1/2D[g[x]/f2[x], x] (f2[x]/g[x])^2 *
D[Φv[x], x]/Φv[x] - f2[x]/g[x] D[Φv[x], {x, 2}]/Φv[x];

Expand[MapAll[Cancel, %]] === %%

Now we implement the transformation to normal form. Most error messages implemented in the following deal with the case when the differential equations are nonlinear, homogeneous, and of second order. We try to analyze the input carefully to generate helpful warning messages. This is the reason for the test of these properties in the ODE. In addition, it may not be possible to compute ξ(x) explicitly (for example, we cannot integrate explicitly, or afterwards, we cannot solve for x). In the case in which we get several solutions for x (as a default), we look only at the first solution. 
The application of Solve permits only generic transformations. Using Eliminate, we can sometimes do more. We prefer to use Solve to avoid too many solutions. The optional function func serves to help with the integration; PowerExpand is often useful here. Now we give the implementation. If the argument is inappropriate or Mathematica cannot do the necessary integration, ToNormalForm[arguments] remains unevaluated. We achieve this with a construction of the form With[{res = allCalculations}, res /; Return[$Failed]]. If any problems are found in allCalculations, then $Failed is returned. This is tested in the outer With, and only in the case in which $Failed was not returned is the result of allCalculations returned.

(* various error messages *)
(* _..._ points out the problem at hand *)
ToNormalForm::cantint    = "Cannot explicitly integrate.";
ToNormalForm::cantsolve  = "Cannot solve the equation.";
ToNormalForm::notlinode2 = "ODE is not a linear ODE of _second_ order.";
ToNormalForm::notLINode2 = "ODE is not a _linear_ ODE 2. order.";
ToNormalForm::nothomode2 = "ODE is not a _homogeneous_ ODE 2. order.";
ToNormalForm::notevpode2 = "ODE is not an _eigenvalue_ problem.";
ToNormalForm::multisol   = "Solution for the new variable is not unique.";

ToNormalForm[ode_Equal, y_, x_, λ_,
             yNew_, xNew_, func_:Identity, i_Integer:1] :=
With[{res =
Module[{right, f2, f1, f0, g, ξ1, pot, η, ξ},
Check[(* is it a linear ODE of degree 2? *)
     If[Max[#[[0, 0, 1]]& /@
       Cases[ode, Derivative[_][y][x], {0, Infinity}]] > 2,
       Message[ToNormalForm::notlinode2]], Return[$Failed]];
 right = Expand[ode[[1]] - ode[[2]]];
 Check[(* is it not an eigenvalue problem? *)
      If[FreeQ[Expand[right], λ],
   Message[ToNormalForm::notevpode2]], Return[$Failed]];
 f2 = Coefficient[right, y''[x]];
 Check[ (* it is not of second order? *)
       If[f2 === 0, Message[ToNormalForm::notlinode2]],
      Return[$Failed]];
 f1 = Coefficient[right, y'[x]]; g = Coefficient[right, λ]/y[x];
 f0 = Coefficient[right, y[x]] - λ g;
 {f2, f1, f0, g} = If[# === {}, 0, #]& /@ {f2, f1, f0, g};
 Check[(* is it linear? *)
  If[MemberQ[#, y''[x] | y'[x] | y[x], {0, Infinity}],
     Message[ToNormalForm::notLINode2]]& /@ {f2, f1, f0, g},
      Return[$Failed]];
Check[(* is it homogeneous? *)
      If[Simplify[Expand[right -
             (f2 y''[x] + f1 y'[x] + (f0 + λ g)y[x])]] =!= 0,
   Message[ToNormalForm::nothomode2]], Return[$Failed]];
 ξ1 = Integrate[func[Sqrt[g/f2]], x];
 Check[(* can it explicitly integrated? *)
 If[FreeQ[ξ1, Integrate],
    Check[sol = Solve[ξ1 == ξ, x],
          Message[ToNormalForm::cantsolve]; Return[$Failed]],
    Message[ToNormalForm::cantint]], Return[$Failed]];
 If[Length[sol] > 1, Message[ToNormalForm::multisol]];
 (* write the result in a nice form *)
 pot = Together[f0/g - f1^2/(4 f2 g) - D[f1, x]/(2 g) +
                (f1 D[f2, x])/(2 f2 g) - (3 D[f2, x]^2)/(16 f2 g) -
                (D[f2, x] D[g, x])/(8 g^2) + (5 f2 D[g, x]^2)/(16 g^3) +
                D[f2, x]/(4 g) - (f2 D[g, {x, 2}])/(4 g^2)];
(* form new equation *)
((η''[ξ] + λ η[ξ] + # η[ξ] == 0 & /@ (* go to new variables *)
         (pot /. sol // Simplify))[[i]]) //.
         {η -> yNew, ξ -> xNew}]}, res /; res =!= Return[$Failed]]

Here are a few examples. First, we look at a differential equation of third order, an inhomogeneous differential equation, a nonlinear differential equation, and a differential equation not containing an eigenvalue. These are all unsuitable inputs.

ToNormalForm[c'''[r] + la c'[r] == 0, c, r, la, y, x]

ToNormalForm[c''[r] + 34 c'[r] == e c[r] + 56, c, r, e, y, x]

ToNormalForm[c'[r] + la c[r] c'[r] == 0, c, r, la, y, x]

ToNormalForm[c'[r] + la c[r] c'[r] == 0, c, r, al, y, x]

If the differential equation is already in normal form, the most that happens is that the variables are renamed.

ToNormalForm[z''[s] + a s z[s] + ϵ z[s] == 0, z, s, ϵ, z, s]

ToNormalForm[z''[s] + a s z[s] + ϵ z[s] == 0, z, s, ϵ, ψ, t]

Now we give a few nontrivial examples.

ToNormalForm[D[(a s + b) z'[s], s] + a s z[s] + ϵ z[s] == 0,
             z, s, ϵ, ψ, t]

ToNormalForm[D[D[ψ[r]/r, r] r^2, r]/r^2 + v0/r ψ[r]/r +
             l^2/r^2 ψ[r]/r + ϵ ψ[r]/r == 0, ψ, r, ϵ, φ, x]

ToNormalForm[D[D[ψ[r]/r, r] r^2, r]/r^2 + v0/r ψ[r]/r +
             eF r ψ[r]/r + l^2/r^2 ψ[r]/r + ϵ ψ[r]/r == 0, ψ, r, ϵ, φ, x]

In the following example, multiple choices for the new variable exist.

ToNormalForm[D[1/(a z + b) p'[z], z] + (a z + b1) p[z] + ϵ p[z] == 0,
             p, z, ϵ, ψ, z]

The next input fails because the resulting equation cannot be solved.

ToNormalForm[x^2 y''[x] + x y'[x] + (x^2 - n^2) y[x] == 0,
             y, x, n^2, y, x]

Next, we use ToNormalForm with a nontrivial seventh argument on the differential equation from the last input.

ToNormalForm[x^2 y''[x] + x y'[x] + (x^2 - n^2) y[x] == 0,
             y, x, n^2, y, x, PowerExpand]

sol = Solve[{ (* x - component of impulse *)
             m vx == m vxs + m Vxs,
              (* y - component of impulse *)
             m vy == m vys + M Vys,
             (* energy conservation *)
             m/2 (vx^2  +  vy^2) ==
             m/2 (vxs^2 + vys^2) + M/2 (Vxs^2 + Vys^2),
             (* angular momentum of the center of gravity
                with respect to (0, 0) *)
             x m vy - y m vx ==  x m vys - y m vxs},
            {vxs, vys, Vxs, Vys}] // Simplify

The first solution is the trivial one after the collision. We are interested in the second solution.

sol = #[[2]]& /@ sol[[2]]

Here is a plot [948✶]: after scaling all quantities involved, we show the positions of the two spheres before the collision, at the point of collision (twice), and after the collision. The time scale was chosen by scaling with the radius of the sphere.

collisionGraphics[m_, M_, vx_, vy_, x_, y_] :=
Module[{vxs, vys, Vxs, Vys, v, R},
(* the velocity components after the collision *)
Vxs = (2 m M x (vx x + vy y))/((m + M) (M x^2 + m y^2)) // N;
Vys = (2 m^2 y (vx x + vy y))/((m + M) (M x^2 + m y^2)) // N;
vxs = (-(m M vx x^2) + M^2 vx x^2 -
       2 m M vy x y + m^2 vx y^2 + m M vx y^2)/
      ((m + M) (M x^2 + m y^2)) // N;
vys = (m M vy x^2 + M^2 vy x^2 -
       2 m M vx x y +  m^2 vy y^2 - m M vy y^2)/
      ((m + M) (M x^2 + m y^2)) // N;
(* scaled time *)
R = Sqrt[x^2 + y^2]/2 // N;
tm = 3 R/Max[Sqrt[vx^2 + vy^2], Sqrt[vxs^2 + vys^2],
             Sqrt[Vxs^2 + Vys^2]] // N;
(* make array of graphics *)
Show[GraphicsArray[#]]& /@ Join[ (* before the collision *)
Partition[Table[(* make a couple of pictures at various times *)
Graphics[{Line[{{-2, 0}, {2, 0}}], Line[{{0, -2}, {0, 2}}],
          {GrayLevel[0], Disk[{0, 0}, R]},
          {GrayLevel[1/2], Disk[{x, y} + t {vx, vy}, R]}},
          AspectRatio -> Automatic, PlotRange -> {{-3, 3}, {-3, 3}},
          PlotLabel -> "t = " <> ToString[Chop[t]]],
        {t, -tm, 0, tm/7}], 4],
                                 (* after the collision *)
Partition[Table[(* make a couple of pictures at various times *)
Graphics[{Line[{{-2, 0}, {2, 0}}], Line[{{0, -2}, {0, 2}}],
          {GrayLevel[0], Disk[{0, 0} + t {Vxs, Vys}, R]},
          {GrayLevel[1/2], Disk[{x, y} + t {vxs, vys}, R]}},
          AspectRatio -> Automatic, PlotRange -> {{-3, 3}, {-3, 3}},
          PlotLabel -> StyleForm["t = " <> ToString[Chop[t]]]],
       {t, 0, tm, tm/7}], 4]]]

Here is the result of a central collision (|x/y|=|(Subscript[v, x])/(Subscript[v, y])|) of two spheres with the same masses.

collisionGraphics[1, 1, -1, 0, 1, 0]

Here is a noncentral collision (|x/y|≠|(Subscript[v, x])/(Subscript[v, y])|) for two different masses.

collisionGraphics[1, 2, -1, -1, 1, 1/2]

Collision can still be refined somewhat by checking whether the input arguments would result in a collision at all, and the plot could be animated. For a detailed discussion of noncentral collisions, also with friction, see [665✶], [886✶], [211✶], [914✶], and [447✶].

b[n_, k_, x_] := Binomial[n, k] x^k (1 - x)^(n - k)

Their maximum occurs at (Subscript[x, m])=k/n.

Solve[Together[D[x^k (1 - x)^(n - k), x]] == 0, x]

The following graphic shows the 33 Bernstein polynomials for n=32 and marks their maxima.

With[{n = 32},
     Plot[Evaluate[Table[b[n, k, x], {k, 0, n}]], {x, 0, 1},
          PlotRange -> {0, 0.4}, Epilog -> {Hue[0], PointSize[0.01], 
                    Table[Point[{k/n, b[n, k, k/n]}], 
                          {k, 1, n - 1}]}]]

In the limit of large n, we get the following expression for the scaled maxima.

Sqrt[n] b[n, x n, x] /. Binomial[n_, k_] :> n!/((n - k)! k!) /. 
                  (* expand factorials at infinity *)
                  y_! -> (Normal[Series[y!, {y, Infinity, 1}]])

In the limit n->∞, this expression is (((2π x(1-x)))^(-1/2)).

θ[x_] = Limit[%, n -> Infinity]

The next graphic shows the limit curve of the scaled maxima together with the scaled maxima for n=256.

Plot[θ[x], {x, 0, 1}, PlotStyle -> Hue[0], PlotRange -> {0, 3},
     Prolog -> With[{n = 256}, {PointSize[0.006], 
                    Table[Point[{k/n, Sqrt[n] b[n, k, k/n]}], 
                          {k, 1, n - 1}]}]]

BernsteinB[n_, f_, x_] := Sum[Binomial[n, k] x^k (1 - x)^(n - k) *
                              (f /. x -> k/n), {k, 0, n}]

To obtain the eigenfunctions of (Subscript[(OverHat[B]), n]), we make the ansatz (Subscript[f, k])(x)=(∑_(j=0)^n)(Subscript[c, j]^((k)))(x^j). Calculating (Subscript[(OverHat[B]), n])((Subscript[f, k])(x)) and extracting the coefficients of the (x^j) yields a matrix M, whose eigensystem yields the (Subscript[f, k])(x).

n = 12; f = Sum[c[k] x^k, {k, 0, n}];
bs = BernsteinB[n, f, x];

(* coefficients of the x^j *)
cl = CoefficientList[bs, x] // Expand;
(* c[k] coefficients inside the coefficients of the x^j *)
M = Table[Coefficient[cl[[k]], c[j]], {k, n + 1}, {j, 0, n}];

Interestingly, all eigenvalues are rational and no algebraic numbers appear.

Take[evals = Eigenvalues[M], -5]

Union[Head /@ evals]

The eigenvalues can actually be expressed in closed form.

Eigenvalues[M] == Table[n!/(n - k)!/n^k, {k, n, 0, - 1}]

Now we calculate the eigenvectors of M.

evecs = Eigenvectors[M];
xPowers = Array[x^#&, n + 1, 0];
evecsx = xPowers.#& /@ evecs;

The resulting eigenvectors have rational x-coefficients with hundreds of digits in the numerators and denominators.

Round[Log[10, #]]& @ 
{Max[Numerator[#]], Max[Denominator[#]]}&[
        Abs[Cases[evecs, _Rational, Infinity]]]

To visualize the eigenvectors, we scale them to the same maximal height over the x-interval [0,1]. In addition, to avoid numerical errors when calculating the eigenfunctions, we define a function evecsxHP that uses high-precision arithmetic for their numerical evaluation.

scale[k_] := 1/Max[Abs[evecsx[[k]] /. 
                       {ToRules[NRoots[D[evecsx[[k]], x] == 0, x]]}]]
evecsxHP[k_, ξ_?NumberQ] := evecsx[[k]] /. x -> SetPrecision[ξ, 200]

Here are the 36 eigenfunctions. For a nicer picture, we use the same overall sign for the linear coefficient of the polynomials.

Plot[Evaluate[Table[Sign[Coefficient[evecsx[[k]], x, 1]] scale[k]*
                    evecsxHP[k, x], {k, n + 1}]], {x, 0, 1}, 
                    PlotRange -> All, Frame -> True, 
                    PlotStyle -> {Thickness[0.002]}, 
                    Axes -> False, PlotRange -> All]

For closed form expressions of the eigenvalues and eigenvectors, see [1624✶], [370✶].

ℳ = {{-367296,  -43199, +0519436, -0954302},
      {+259718, -477151, -0367295, -1043199},
      {+886731, +088897, -1254026, -1132096},
      {+627013, +566048, -0886732, +0911103}};

Max[#]/Min[#]&[Abs[Eigenvalues[N[ℳ]]]]

Here are the equations and the exact solution of the system.

eqs = Thread[ℳ.{t, u, v, w} == {1, 1, 1, 0}]

Solve[eqs, {t, u, v, w}]

N[%]

exactSolution = ({t, u, v, w} /. %%)[[1]];

An attempt to find a numerical solution with machine accuracy fails completely.

Solve[N[eqs], {t, u, v, w}]

If we increase the number of digits used in the calculation step by step and monitor the accuracy of the results obtained, we can get the at least one certified digit. We have to work with the following number of digits.

prec = 10;
While[sol = Check[Solve[SetPrecision[eqs, prec], {t, u, v, w}],
            $Failed];
     sol === {} || sol === $Failed || Precision[sol] < 2, 
     prec = prec + 1]

We had to use 27 digits to get a certified solution.

prec

Even with 27 digits the solution is correct to only two digits.

Solve[SetPrecision[eqs, prec], {t, u, v, w}]

To find the sensitivity of the solution to small changes, we find the Taylor expansion for small a[i,j] for the solutions of the following generalization of the above system of equations.

eqn1 = Thread[(ℳ (1 + Array[a, {4, 4}])).{t, u, v, w} == {1, 1, 1, 0}]

coeff = Flatten[Table[a[i, j], {i, 4}, {j, 4}]];
coeffRules = Flatten[Table[a[i, j] -> 0, {i, 4}, {j, 4}]];

We now compute the sensitivity. The quantities being computed below are the following:

(((∂/(∂ a[i,j]))"exact solution with \!\(\*StyleBox[\"\\\"a[\\\"\", \"MR\"]\)"i"\!\(\*StyleBox[\"\\\", \\\"\", \"MR\"]\)"j"\!\(\*StyleBox[\"\\\"]\\\"\", \"MR\"]\)")/("exact solution with \!\(\*StyleBox[\"\\\"a[\\\"\", \"MR\"]\)"i"\!\(\*StyleBox[\"\\\", \\\"\", \"MR\"]\)"j"\!\(\*StyleBox[\"\\\"]\\\"\", \"MR\"]\)"))(Subscript[|, (Underscript[ (Underscript[ ,  ]), a[i,j]=0])]).

To find these values, we compute the exact solution, develop it in a series, and extract the desired relation using (N[Divide @@ #[[3]]])&.

tab = Table[
(* the exact solutions *)
soltemp = Solve[eqn1 /. Delete[coeffRules, i], {t, u, v, w}];
(* calculate relative change *)
res = (N[Divide @@ Reverse[#[[3]]]])& /@
      (* make series of exact solution wrt a[i, j] *)
      (Series[#, {coeff[[i]], 0, 1}]& /@ (({t, u, v, w} /. soltemp)[[1]]));
NumberForm[#, 2, NumberSigns -> {"-", "+"}]& /@ res, {i, 16}] // 
    (* format as a table *)
   TableForm[#, TableHeadings -> {coeff, {"t", "u", "v", "w"}}]&

Thus, a relative change of the first coefficient of size 2×(10^(-23))=4×(10^(-24)) already leads to a change in the first digit of the result!

With[{ϵ = 4 10^-24}, 
Solve[{-367296 t (1 + ϵ) -  43199 u +  519436 v -  954302 w == 1,
        259718 t -         477151 u -  367295 v - 1043199 w == 1,
        886731 t +          88897 u - 1254026 v - 1132096 w == 1,
        627013 t +         566048 u -  886732 v +  911103 w == 0}, 
      {t, u, v, w}] // N]

For comparison, this was the exact result without perturbation:
{{t -> 8.867×(10^17), u -> 8.867×(10^11), v -> 6.270×(10^17), w -> 6.270×(10^12)}}.

Another way to look at the sensitivity is the following [1571✶] (now all perturbations enter with the same parameter t): Let the original linear system be A.x=b. Now we change A to A+t δA and b to b+t δb. Then, for (OverDot[x])(t) we get

x(t)≈x(0)+t (OverDot[x])(0)= x(0) + t (A^(-1))(δb-δA .x(0))

with x(0)= (A^(-1)).b .
Here, the term (OverDot[x])(0) describes the sensitivity of the system to small perturbations. For our example, we get the following by taking into account only changes in the matrix A. (The following are a different measure of sensitivity than is the above one; so we get different numbers now.)

(* avoid numericalization the the arguments of δa *)
SetAttributes[δa, NHoldAll]

-Inverse[ℳ].Array[δa, {4, 4}].
             LinearSolve[ℳ, {1, 1, 1, 0}] // Expand // N[#, 2]&

We could also use Intervals to measure the sensitivity of the system. In the next input, we use an Interval-object for one of the integer coefficients of the first equation. We calculate the relative uncertainty of the result.

Table[{n, 
X = Interval[43199 + {-10^-n, 10^-n}];
(* second coefficient of first equation is now an interval *)
eqn = {-367296 t -      X u +  519436 v -  954302 w  == 1,
        259718 t - 477151 u -  367295 v - 1043199 w  == 1,
        886731 t +  88897 u - 1254026 v - 1132096 w  == 1,
        627013 t + 566048 u -  886732 v +  911103 w  == 0};
(* (length of the resulting solution interval)/ 
   (average of the resulting solution interval) *)        
Abs[(Subtract @@ #[[1]]/(Plus @@ #[[1]]/2))& /@ 
     ({t, u, v, w} /. Solve[eqn, {t, u, v, w}][[1]] /. 
     Interval[{0, 0}] -> 0)] // N}, {n, 15, 30}]

torus[φ1_, φ2_, r1_, r2_] = {r1 Cos[φ1] + r2 Cos[φ1] Cos[φ2],
                             r1 Sin[φ1] + r2 Sin[φ1] Cos[φ2],
                                          r2         Sin[φ2]};

Let the point be at {ξ,η,ζ}. The bisector surface has coordinates {X, Y, Z}.

𝒯 = torus[φ1, φ2, r1, r2];
eqs = {({X, Y, Z} - 𝒯).D[𝒯, φ1], ({X, Y, Z} - 𝒯).D[𝒯, φ2],
       #.#&[{ξ, η, ζ} - {X, Y, Z}] - #.#&[{X, Y, Z} - 𝒯]} // Factor

To obtain an implicit representation of the bisector surface, we use GroebnerBasis to eliminate the parametric variables φ1 and φ2.

gb = GroebnerBasis[
  Join[Cancel[eqs/{-r1 - r2 Cos[φ2], r2, 1}], 
       {Cos[φ1]^2 + Sin[φ1]^2 - 1, Cos[φ2]^2 + Sin[φ2]^2 - 1}],
       {}, {Cos[φ1], Sin[φ1], Cos[φ2], Sin[φ2]},
                   MonomialOrder -> EliminationOrder];

The resulting basis is large. It has 470 terms and total degree 4.

{Length[gb[[1]]], Max[(Plus @@ Exponent[#, {X, Y, Z}])& /@ 
((List @@ gb[[1]]) /. {r1 -> 1, r2 -> 1, ξ -> 1, η -> 1, ζ -> 1})]}

Writing for brevity (R^2) for (ξ^(2+))(η^2)+(ζ^2) and collecting with respect to X, Y, and Z, the implicit equation for the bisector takes the following form.

Plus @@ Flatten[
MapIndexed[(Times @@ (#1 {X, Y, Z}^(#2 - 1)))&, 
  Factor[CoefficientList[gb[[1]], {X, Y, Z}] /. ξ^n_ :> 
              (R^2 - η^2 - ζ^2)^Floor[n/2] ξ^Mod[n, 2]], {3}]]

Now let us visualize the bisector surface for the case {ξ,η,ζ}={0,0,0}. Obviously, the bisector surface has rotational symmetry around the z-axis.

bisector1 = gb[[1]] /. {r1 -> 3, r2 -> 1, ξ -> 0, η -> 0, ζ -> 0}

The bisector surface splits into two disconnected parts. We use the representation z=z(x).

Factor[bisector1 /. Y -> 0]

X[1][Z_] = Abs[6 - Sqrt[2] Sqrt[2 + Z^2]]/4;
X[2][Z_] = (6 + Sqrt[2] Sqrt[2 + Z^2])/4;

Now we have everything together and can create the polygons of the torus and the bisector surface.

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

(* the polygons of the original torus *)
torusPolys = makeHole[#, 0.7]& /@ Cases[
ParametricPlot3D[Evaluate[torus[φ1, φ2, 3, 1]], 
                 {φ1, 0, 2Pi}, {φ2, 0, 2Pi},
                 PlotPoints -> {60, 16}, DisplayFunction -> Identity],
                                       _Polygon, Infinity];

For the bisector surface, we rotate the line forming the cross section around the z-axis.

(* bisector surface *)
bisectorPolys = makeHole[#, 0.9]& /@ Cases[
Table[ParametricPlot3D[Evaluate[{X[j][Z] Cos[φ], X[j][Z] Sin[φ], Z}], 
                {φ, 0, 2Pi}, {Z, -6, 6},
      PlotPoints -> {60, 49}, DisplayFunction -> Identity], {j, 2}],
                   _Polygon, Infinity];

The torus is shown in red and the bisector surface in green.

Show[Graphics3D[{EdgeForm[],
      {SurfaceColor[Hue[0], Hue[0], 2.8], torusPolys},
      {SurfaceColor[Hue[0.22], Hue[0.22], 2.9], bisectorPolys}}],
     PlotRange -> All]

poly[x_, y_, z_] = Sum[c[i, j, k] x^i y^j z^k,
                       {i, 0, 4}, {j, 0, 4 - i}, {k, 0, 4 - i - j}]

Due to the symmetry of the three cylinders, the polynomial p(x,y,z) should have a threefold rotational symmetry, along the direction {1,1,1}. By applying this symmetry, some coefficients can be eliminated. (The message in the following input is generated because it is not possible to solve for all of the coefficients.)

poly1[x_, y_, z_] = poly[x, y, z] /. Solve[
Flatten[ (* equations from applying rotational symmetry *)
{# == 0& /@ Flatten[
 CoefficientList[poly[x, y, z] - poly[y, z, x], {x, y, z}]],
 # == 0& /@ Flatten[
 CoefficientList[poly[y, z, x] - poly[z, x, y], {x, y, z}]]}],
             (* all coefficients *)
             Cases[poly[x, y, z], _c, {0, Infinity}]][[1]]

Next, we demand that (at least) eight points from each of the three cylinders should lie on the surface defined implicitly by the polynomial at x=l, y=l, and z=l (later we set l equal to 3). This again eliminates some coefficients.

sol1 = Map[Together, Solve[Flatten[{
 (* eight points on every cylinder *)
  Table[poly1[Cos[φ], Sin[φ], l] == 0, {φ, 0, 2Pi, 2Pi/8}],
  Table[poly1[Cos[φ], l, Sin[φ]] == 0, {φ, 0, 2Pi, 2Pi/8}],
  Table[poly1[l, Cos[φ], Sin[φ]] == 0, {φ, 0, 2Pi, 2Pi/8}]}],
  Cases[poly1[x, y, z], _c, {0, Infinity}] // Union], {3}];

poly2[x_, y_, z_] = Numerator[Factor[(poly1[x, y, z] /. sol1)[[1]]]]

To have a smooth transition between the cylinders and the surface to be determined, we also demand that the normals of the cylinders are parallel to the normals of our surface at x=l, y=l, and z=l. Due to the rotational symmetry of each cylinder, this means that the normal should have no component in the direction of the cylinder axes at this cross section. This constraint fixes some more of the c[i, j, k].

sol2 = Map[Together, Solve[Flatten[{
(* parallel components of eight normals on every cylinder *)
Table[Evaluate[D[poly2[x, y, z], z] == 0 /. 
                        {x -> Cos[φ], y -> Sin[φ], z -> l}],
      {φ, 0, 2Pi, 2Pi/8}],
Table[Evaluate[D[poly2[x, y, z], y] == 0 /.
                        {x -> Cos[φ], y -> l, z -> Sin[φ]}],
      {φ, 0, 2Pi, 2Pi/8}],
Table[Evaluate[D[poly2[x, y, z], x] == 0 /.
                        {x -> l, y -> Cos[φ], z -> Sin[φ]}],
      {φ, 0, 2Pi, 2Pi/8}]}],
      Cases[poly2[x, y, z], _c, {0, Infinity}] // Union], {3}]

poly3[x_, y_, z_] = Numerator[Factor[poly2[x, y, z] /. sol2[[1]]]]

Now let us see what we have so far. poly3[x, y, z] still contains two parameters.

cs = Cases[poly3[x, y, z], _c, {0, Infinity}] // Union

But all properties we wanted are already satisfied for all points of the boundary of the three cylinders and not only at the eight points used above. Let us check this explicitly. This shows that the boundaries of the three cylinders agree with the surface at x=l, y=l, and z=l.

{poly3[l, Cos[φ], Sin[φ]], poly3[Cos[φ], l, Sin[φ]],
 poly3[Cos[φ], Sin[φ], l]} // Simplify

Here, we show that the parallel components of the normals vanish along the cylinder boundaries at x=l, y=l, and z=l.

(Simplify /@ Flatten[CoefficientList[D[poly3[x, y, z], x] /.
             {x -> l, y -> Cos[φ], z -> Sin[φ]}, cs]])& /@ {x, y, z}

We fix the two free parameters by looking for values such that the surface of our polynomial is simply connected and looks nice. Here are some cross sections of p(x,y,z)=0 in the y,z- plane. 
After renaming the undetermined coefficients, we have the following polynomial surface connecting the three cylinders.

finalPoly[x_, y_, z_, {l_, α_, β_}] =
α (-3 l^2 - l^4 + 2 l x + 3 l^2 x^2 - 2 l x^3 + 2 l y - x y + 
   l^2 x y - 2 l x^2 y + x^3 y + 3 l^2 y^2 - 2 l x y^2 - 2 l y^3 + 
   x y^3 + 2 l z - x z + l^2 x z - 2 l x^2 z + x^3 z - y z + 
   l^2 y z - 2 l x y z + x^2 y z - 2 l y^2 z + x y^2 z + y^3 z + 
   3 l^2 z^2 - 2 l x z^2 - 2 l y z^2 + x y z^2 - 2 l z^3 + 
   x z^3 + y z^3) - β 2 l (-l^2 + x^2 + y^2 + z^2 - 1)^2;

We look at some of the possible shapes for the connector by using various values for α and β.

Show[Flatten[Table[
ContourPlot[Evaluate[finalPoly[0, y, z, {3, α, β}]],
            {y, -2, 6}, {z, -2, 6}, 
            Contours -> {0}, ContourShading -> False, 
            DisplayFunction -> Identity, PlotPoints -> 60, 
            ContourStyle -> {Hue[Random[]], Thickness[0.002]}],
      {α, 50, 60, 1}, {β, -6, -12, -1}]],
     DisplayFunction -> $DisplayFunction]

Choosing the parameters β->-7, α->55, we can make a picture of our polynomial.

Needs["Graphics`ContourPlot3D`"]

ContourPlot3D[Evaluate[finalPoly[x, y, z, {3, 55, -7}]],
              {x, -2, 5}, {y, -2, 5}, {z, -2, 5},
              MaxRecursion -> 1, PlotPoints -> {15, 3},
              PlotRange -> All, Axes -> True]

This sorts out the polygons needed to connect the three cylinders.

Show[Graphics3D[connector = 
                Select[%[[1]], Max[Flatten[#[[1]]]] <= 3&]]]

We add the three cylinders to the end. To get a pleasing picture, we arrange the mesh lines of the cylinders to fit the mesh lines of connector. We use ListSurfacePlot3D from the package Graphics`Graphics3D` to generate the cylinders.

Needs["Graphics`Graphics3D`"]

(* along the x-axis *)
(* boundary polygons of the polynomial part *)
tubePolysx = Select[connector, MemberQ[#[[1]]& /@ #[[1]], 3.] &&
                               Max[#[[1]]& /@ #[[1]]] <= 3&];
(* list of angles of points along the circular boundary *)
pxList = Append[#, First[#]]&[Sort[Apply[ArcTan,
          Delete[#, 1]& /@ Union[Cases[Flatten[Last /@ tubePolysx, 1],
                                       {3., _, _}]], {1}]]];
(* points of the cylinder *)
tabx = Table[{x, 0, 0} + {0, Cos[#], Sin[#]}& /@ pxList,
             {x, 3 + 1/4, 5, 1/4}];
(* boundary points of polynomial *)
lastPointsx = Append[#, First[#]]&[
Sort[Union[Cases[Flatten[Last /@ tubePolysx, 1], {3., _, _}]],
     ArcTan @@ Delete[#1, 1] < ArcTan @@ Delete[#2, 1]&]];
(* the cylinder along the x - axis *)
tubex = ListSurfacePlot3D[Prepend[tabx, lastPointsx],
                          DisplayFunction -> Identity][[1]];

(* along the y-axis *)
(* boundary polygons of the polynomial part *)
tubePolysy = Select[connector, MemberQ[#[[2]]& /@ #[[1]], 3.] &&
       Max[#[[2]]& /@ #[[1]]] <= 3&];
(* list of angles of points along the circular boundary *)
pyList = Append[#, First[#]]&[Sort[Apply[ArcTan,
         Delete[#, 2]& /@ Union[Cases[Flatten[Last /@ tubePolysy, 1],
                                      {_, 3., _}]], {1}]]];
(* points of the cylinder *)
taby = Table[{0, y, 0} + {Cos[#], 0, Sin[#]}& /@ pyList,
             {y, 3 + 1/4, 5, 1/4}];
(* boundary points of polynomial *)
lastPointsy = Append[#, First[#]]&[
Sort[Union[Cases[Flatten[Last /@ tubePolysy, 1], {_, 3., _}]],
     ArcTan @@ Delete[#1, 2] < ArcTan @@ Delete[#2, 2]&]];
(* the cylinder along the x - axis *)
tubey = ListSurfacePlot3D[Prepend[taby, lastPointsy],
                          DisplayFunction -> Identity][[1]];

(* along the z-axis *)
(* boundary polygons of the polynomial part *)
tubePolysz = Select[connector, MemberQ[#[[3]]& /@ #[[1]], 3.] &&
       Max[#[[3]]& /@ #[[1]]] <= 3&];
(* list of angles of points along the circular boundary *)
pzList = Append[#, First[#]]&[Sort[Apply[ArcTan,
         Delete[#, 3]& /@ Union[Cases[Flatten[Last /@ tubePolysz, 1],
                                      {_, _, 3.}]], {1}]]];
(* points of the cylinder *)
tabz = Table[{0, 0, z} + {Cos[#], Sin[#], 0}& /@ pzList,
             {z, 3 + 1/4, 5, 1/4}];
(* boundary points of polynomial *)
lastPointsz = Append[#, First[#]]&[
Sort[Union[Cases[Flatten[Last /@ tubePolysz, 1], {_, _, 3.}]],
     ArcTan @@ Delete[#1, 3] < ArcTan @@ Delete[#2, 3]&]];
(* the cylinder along the x - axis *)
tubez = ListSurfacePlot3D[Prepend[tabz, lastPointsz],
                          DisplayFunction -> Identity][[1]];

Here the three cylinder and the inner part of the polynomial are shown.

Show[Graphics3D[{EdgeForm[Thickness[0.002]],
                 (* the three tube pieces and the connecting quartic *)
                 connector, tubex, tubey, tubez}],
     PlotRange -> All, Boxed -> False]

degree = 6;

ansatz[x_, y_, z_] = 
Sum[If[i + j + k > degree, 0, c[i, j, k] x^i y^j z^k], 
    {i, 0, degree, 2}, {j, 0, degree, 2}, {k, 0, degree, 2}];

These are the to-be-determined coefficients.

cs = Cases[ansatz[x, y, z], _c, Infinity]

To determine some of the coefficients cs, we require the double torus to touch the torus at 12 points at each of its holes. We also require the double torus’s “middle bridge” to fit exactly into the torus’s hole. In addition, we make the cross section of the left-most and right-most arm of the double torus also circles of radius r. All of these conditions we enforce at 12 equidistant points on the circles. This leads to the following set of equations. (We take the original torus in the x,z-plane.)

n = 12;
eqs1 = Flatten[{(* right hole of the double torus *)
                Table[ansatz[+R + r Cos[φ], r Sin[φ], 0], 
                      {φ, 0, 2Pi, 2Pi/n}],
                (* middle bridge of the double torus *)
                Table[ansatz[(R - r) Cos[φ], 0, (R - r) Sin[φ]], 
                      {φ, 0, 2Pi, 2Pi/n}],
                (* outer arm of the double torus *)
                Table[ansatz[+R + 2r + r Cos[φ], 0, r Sin[φ]], 
                      {φ, 0, 2Pi, 2Pi/n}],
                (* extension of the double torus in y-direction *)
                ansatz[0, 3r, 0]}];

The solution is a large expression. We fix the coefficient c[6, 0, 0] to be 1.

sol = Solve[# == 0& /@ eqs1, cs] /. c[6, 0, 0] -> 1;

ByteCount[sol]

Fortunately, the expression can be simplified considerably by writing it over common denominators.

sol1 = {MapAt[Together, #, 2]& /@ sol[[1]]};
ByteCount[sol1]

The coefficients are all rational functions in R and r.

sol1

We substitute the solution sol1 and obtain the following polynomial.

ansatz1[x_, y_, z_] = Numerator[(ansatz[x, y, z] /. sol1[[1]] /. 
                                c[6, 0, 0] -> 1) // Together // Factor]

The following coefficients are still undetermined.

cs = Cases[ansatz1[x, y, z], _c, Infinity] // Union

We will try the simplest possible choice for them—we set them all to 0. This results in the following homogeneous polynomial.

doubleTorus[x_, y_, z_, {R_, r_}] = Factor[ansatz1[x, y, z] /. _c -> 0]

The polynomial doubleTorus really describes a closed surface. This can be seen from the asymptotic behavior far away from the origin. In every direction {x, y, z}, the polynomial doubleTorus[x, y, z, {R, r}] is positive definite.

Series[doubleTorus[t x, t y, t z, {R, r}], {t, Infinity, 1}]

For z=0, the polynomial doubleTorus contains the two factors ((r^2)-(R^2)-2 R x-(x^2)-(y^2))  and ((r^2)-(R^2)+2 R x-(x^2)-(y^2))  that represent the circles from the torus’s cross section. And for y=0, doubleTorus contains the factor ((r^2)-2 r R+(R^2)-(x^2)-(z^2)) that represents the middle hole of the torus, and the factors (3 (r^2)+4 r R+(R^2)-4 r x-2 R x+(x^2)+(z^2)) and (3 (r^2)+4 r R+(R^2)+4 r x+2 R x+(x^2)+(z^2)) represent the left-most and right-most arms of the double torus. This means that not only the 12 points, but also all points from the cross section fulfill the required conditions.

Factor[doubleTorus[x, y, 0, {R, r}]]

For y=0, ansatz1 contains the factor ((r^2)-2 r R+(R^2)-(x^2)-(z^2)) that represents the middle hole of thee torus and the factors (3 (r^2)+4 r R+(R^2)-4 r x-2 R x+(x^2)+(z^2)) and (3 (r^2)+4 r R+(R^2)+4 r x+2 R x+(x^2)+(z^2)) that represent the left and rightmost arm of the double torus. This means that the polynomial doubleTorus fulfills the required conditions.

Factor[doubleTorus[x, 0, z, {R, r}]]

Here is a cross section of the family of double tori for various R (we fix r to be 1). We see that for the R-values displayed, doubleTorus has the intended shape.

Show[Table[
ContourPlot[Evaluate[doubleTorus[x, y, 0, {R, 1}]],
            {x, -R - 4, R + 4}, {y, -4, 4},
            Contours -> {0}, ContourShading -> False,
            AspectRatio -> Automatic, PlotPoints -> 200,
            ContourStyle -> {Hue[0.8 (R - 1)/2], Thickness[0.002]},
            DisplayFunction -> Identity], (* use 20 R *)
       {R, 1, 3, 1/10}], DisplayFunction -> $DisplayFunction]

We see that for the R values displayed doubleTorus has the intended shape. 
For too large values of R our sextic ansatz breaks down. The following contour plot demonstrates this.

With[{R = 100},
ContourPlot[Evaluate @ doubleTorus[x, y, 0, {R, 1}],
            {x, - R - 2, - R + 2}, {y, -2, 2},
            PlotPoints -> 100, Contours -> {0}]]

Now we will visualize the resulting double torus. This is a parametric representation of the torus.

torus[φ1_, φ2_, {R_, r_}] :=  {R Cos[φ1] + r Cos[φ1] Cos[φ2], Sin[φ2],
                               R Sin[φ1] + r Sin[φ1] Cos[φ2]};

Here is the corresponding implicit representation.

torusPoly[x_, y_, z_, {R_, r_}] = Factor @ 
GroebnerBasis[Flatten[{{x, y, z} - torus[φ1, φ2, {R, r}],
                       (* algebraic relation between Cos and Sin *)
                       Sin[φ1]^2 + Cos[φ1]^2 - 1, 
                       Sin[φ2]^2 + Cos[φ2]^2 - 1}], {x, y, z}, 
                      {Sin[φ1], Cos[φ1], Sin[φ2], Cos[φ2]}][[1]]

The two polynomials torusPoly and doubleTorusPoly assume negative values inside the corresponding bodies. (For the torus only, values R>r are sensible.)

torusPoly[R, 0, 0, {R, r}] // Factor

doubleTorus[0, 0, 0, {R, r}] // Factor

After having constructed the double torus, let us visualize it and see how it fits together with the original torus. For the graphic of the double torus, we use ContourPlot3D. Because of the symmetry of doubleTorusPoly we construct only one-eight of its surface. We will choose the parameter values R=3 and r=1. (As mentioned, not for all r,R do we get a sensible solution.)

Needs["Graphics`ContourPlot3D`"]

cp = ContourPlot3D[Evaluate[doubleTorus[x, y, z, {3, 1}]],
                   {x, 0, 7}, {y, 0, 4}, {z, 0, 4},
                   MaxRecursion -> 1, PlotPoints -> {15, 4},
                   DisplayFunction -> Identity];

doubleTorusPolys = (* reflect on coordinate planes *)
                   {#, Map[# {1, 1, -1}&, #, {-2}]}&[
                    {#, Map[# {1, -1, 1}&, #, {-2}]}&[
                     {#, Map[# {-1, 1, 1}&, #, {-2}]}&[
                      Cases[cp, _Polygon, Infinity]]]];

Show[Graphics3D[{EdgeForm[], SurfaceColor[Hue[0], Hue[0], 2.2], 
                  doubleTorusPolys}], ViewPoint -> {2, -1, 2.5}]

For the torus, we use its parametric representation to graph it.

torusPolys = 
Cases[ParametricPlot3D[Evaluate[torus[φ1, φ2, {3, 1}]],
      {φ1, 0, 2Pi}, {φ2, 0, 2Pi}, PlotPoints -> {120, 24},
      DisplayFunction -> Identity], _Polygon, Infinity];

Here are the torus and the double torus shown together.

Show[Graphics3D[{EdgeForm[],
{SurfaceColor[Hue[0.00], Hue[0.00], 2.2], doubleTorusPolys},
{SurfaceColor[Hue[0.12], Hue[0.12], 2.2], torusPolys}}]]

The following two cross sections show nicely that the two bodies fit perfectly together and penetrate each other in a symmetrical way.

Show[GraphicsArray[Show[%, PlotRange -> #,
           DisplayFunction -> Identity]& /@ 
      {{All, {0, 4}, All}, {All, All, {-4, 0}}}]]

Here is a short symbolic proof that the two surfaces have no interior points in common. The function Resolve allows us to prove this as a one-liner.

AppendTo[$ContextPath, "Experimental`"]

Resolve[
Exists[{x, y, z}, Element[{x, y, z}, Reals],
       (* because of symmetry, use one-eight *)
       x > 0 && y > 0 && z > 0 && torusPoly[x, y, z, {3, 1}] < 0 && 
       doubleTorus[x, y, z, {3, 1}] < 0]]

If the reader liked this exercise, he can continue and construct a triple torus that perfectly fits around the just constructed double torus and then ….

(∂/(∂(Subscript[x, (Subscript[old, 1])])))=((∂(Subscript[x, (Subscript[new, 1])]))/(∂(Subscript[x, (Subscript[old, 1])])))(∂/(∂(Subscript[x, (Subscript[new, 1])])))+⋯+((∂(Subscript[x, (Subscript[new, n])]))/(∂(Subscript[x, (Subscript[old, 1])])))(∂/(∂(Subscript[x, (Subscript[new, n])]))).

Here, the corresponding Jacobian matrix is obtained by inverting the inverse Jacobian matrix ∂(Subscript[x, "oldi"])/∂(Subscript[x, "newj"]) one time, which is immediately accessible. The new derivatives are computed in the form of pure functions d[oldVariable] by applying them to the not-renamed (original) dependent functions. The number of derivatives with respect to the old variables determines how often d[oldVariable] is applied. The result is written as a polynomial in the derived functions. The optional function simp carries out additional simplifications on the resulting expression. 
If we are interested in transforming higher derivatives, we should further optimize the code; in particular, we should try to factor the differential expression before the change of variables. Further on, we should check that the transformation is nonsingular, …. (In the following routine DerivativeVariablesTransformation, we built a few expressions in the following by joining strings together to avoid the evaluation of such expressions as {D[#1, var1], D[#1, var3], D[#1, var3], …" "}; we could have done this also by using appropriate stringfree constructions, which avoid evaluation.)

DerivativeVariablesTransformation[expression_, 
           oldVarsOfNewVars:{__Equal}, newVars_, simp_:Identity] :=
Module[{oldVars, allDerivatives, allVars, remainingVars, jacobi, 
        dRules, remainingRules, operators, variableReplacements, 
        rules, d, auxTab, allNewDerivatives, exprNew, aux, 
        exprTemp1, exprTemp2, exprTemp3, 𝒟, dot},
  (* the old independent involved variables *)
  oldVars = First /@ oldVarsOfNewVars;
  (* all derivatives *)
  allDerivatives = Cases[expression, Derivative[___][_][___],
                         {0, Infinity}] // Union;
  (* local renaming *)
  auxTab = MapIndexed[(#1 -> aux[#2[[1]]])&, allDerivatives];
  exprTemp1 = expression //. auxTab;
  exprTemp2 = exprTemp1 //. ((Rule @@ #)& /@ oldVarsOfNewVars);
  exprTemp3 = exprTemp2 //. (Reverse /@ auxTab);
  (* variables with respect to which is differentiated *)
  allVars = Union[Flatten[List @@ # & /@ allDerivatives]];
  (* remaining variables *)
  remainingVars = Complement[allVars, oldVars];
  (* the Jacobi matrix; simplified - takes time !! *)
  jacobi = Transpose @ Simplify @ Inverse @
         Outer[D, #[[2]]& /@ oldVarsOfNewVars, newVars];
  (* how to transform the derivatives in form of applying 
     pure Functions; the d's are differential operators *)
  dRules = Table[d[oldVars[[i]]] = Function @@ {
      dot[jacobi[[i]], Function[nV, 𝒟[#, nV]] /@ newVars]} //.
                      {𝒟 -> D, dot -> Dot}, {i, Length[oldVars]}];
  (* not to change *)
  remainingRules = Function[rV, d[rV] = ((Function @@ {𝒟[#, rV]}) /.
                                        {𝒟 -> D})] /@ remainingVars;
  (* the pure functions *)
  operators = Function[expr, Composition @@ Flatten[
     Function[p, Table[d[p], {expr[[0, 0, Position[
              expr, p][[1, 1]]]]}]] /@ (List @@ expr)]];
  (* replace variables *)
  variableReplacements = MapThread[Rule, {oldVars, newVars}];
  rules = (# -> operators[#][#[[0, 1]] @@
       ((List @@ #) /. variableReplacements)])& /@ allDerivatives;
  (* variables not changed, but which are involved in D *)
  allNewDerivatives = Union @ Cases[#[[2]]& /@ rules,
          Derivative[___][_?(MemberQ[#, oldVars]&)][___],
                          {0, Infinity}];
  exprNew = exprTemp3 /. rules;
  (* apply a little bit of make up *)
  simp[Which[Head[expression] === Plus,
             Collect[exprNew, allNewDerivatives],
             Head[expression] === Equal,
             Collect[#, allNewDerivatives]& /@ exprNew,
             True, exprNew]]]

As a first application of DerivativeVariablesTransformation, we transform the three-dimensional wave equation from the Cartesian to the cylindrical coordinate system. The derivatives with respect to t remain unchanged. (We set z==Z to clearly differentiate between the old and the new coordinates.)

DerivativeVariablesTransformation[
D[u[x, y, z, t], {x, 2}] + D[u[x, y, z, t], {y, 2}] +
D[u[x, y, z, t], {z, 2}] -
(* this differentiation is not to be touched *)
1/c^2  D[u[x, y, z, t], {t, 2}] == 0,
               {x == r Cos[φ], y == r Sin[φ], z == Z}, {r, φ, Z}]

Simplified, we get the well-known result.

Simplify[%]

Next we express the 4D Laplace operator in hyperspherical coordinates [91✶], [1172✶], [1252✶].

(DerivativeVariablesTransformation[
   (D[#, {x, 2}] + D[#, {y, 2}] + D[#, {z, 2}] + D[#, {w, 2}])&[
                                                   u[x, y, z, w]],
   (* 4D Cartesian ⟹ 4D spherical coordinates *)
   {x == r Cos[ϑ[1]], 
    y == r Cos[ϑ[2]] Sin[ϑ[1]], 
    z == r Cos[ϑ[3]] Sin[ϑ[1]] Sin[ϑ[2]], 
    w == r Sin[ϑ[1]] Sin[ϑ[2]] Sin[ϑ[3]]},  
   {r, ϑ[1], ϑ[2], ϑ[3]}, (* could use more specific simplifyer here *)
     (Simplify /@ #)&] // Expand //
       Collect[#, Derivative[__][u][__], Simplify]&) /. 
               (* shorten output *) ϑ[k_] :> Subscript[ϑ, k]

In quantum mechanics, the operator x∂/∂y-y∂/∂x turns out to be essentially the angular momentum in the z-direction. Here, we transform the variables of this differential operator, applied to u(x,y), to polar coordinates.

DerivativeVariablesTransformation[
  y D[u[x, y], x] - D[u[x, y], y] x,
 {x == r Cos[φ], y == r Sin[φ]}, {r, φ}, Simplify]

Here is the Laplace operator in spherical coordinates [1278✶].

DerivativeVariablesTransformation[
   (D[#, {x, 2}] + D[#, {y, 2}] + D[#, {z, 2}])&[u[x, y, z, t]],
  {x == r Cos[φ] Sin[ϑ], y == r Sin[φ] Sin[ϑ], z == r Cos[ϑ]}, 
  {r, φ, ϑ}, (* could use more specific simplifier here *)
                      (Simplify /@ #)&] // Expand //
                       Collect[#, Derivative[__][u][__], Simplify]&

The Levi–Civita transformation that transforms a 2D Kepler problem to a harmonic oscillator problem [1033✶], [1002✶].

DerivativeVariablesTransformation[
   D[u[x, y], x, x] + D[u[x, y], y, y],
  {x == u1^2 - u2^2, y == 2 u1 u2}, {u1, u2}, Simplify]

We can also treat purely symbolic relations.

DerivativeVariablesTransformation[D[u[x, y], x] - D[v[x, y], y],
  {x == x[ξ, η], y == y[ξ, η]}, {ξ, η}, Simplify]

For another implementation see [3✶].

𝔸 = Array[𝕒, {3, 3}];
det = Det[MatrixExp[𝔸]];

det is a relatively large symbolic expression.

{ByteCount[det], LeafCount[det]}

A direct call to Simplify will take a long time and not give the desired result.

TimeConstrained[Simplify[det - Tr[𝔸]], 100] === 0

Here is the matrix exponential of 𝔸 written in a concise form.

Exp𝔸 = With[{𝒶11 = 𝕒[1, 1], 𝒶12 = 𝕒[1, 2], 𝒶13 = 𝕒[1, 3],
              𝒶21 = 𝕒[2, 1], 𝒶22 = 𝕒[2, 2], 𝒶23 = 𝕒[2, 3],
              𝒶31 = 𝕒[3, 1], 𝒶32 = 𝕒[3, 2], 𝒶33 = 𝕒[3, 3], ℯ = Exp[#]}, 
Map[Function[r,
RootSum[#^3 - #^2 𝕒[1, 1] - # 𝒶12 𝒶21 - #^2 𝒶22 + # 𝒶11 𝒶22 - # 𝒶13 𝒶31 + 
        𝒶13 𝒶22 𝒶31 - 𝒶12 𝒶23 𝒶31 - 𝒶13 𝒶21 𝒶32 - # 𝒶23 𝒶32 + 𝒶11 𝒶23 𝒶32 - 
        #^2 𝒶33 + # 𝒶11 𝒶33 + 𝒶12 𝒶21 𝒶33 + # 𝒶22 𝒶33 - 𝒶11 𝒶22 𝒶33 & , 
        Function[r]]],
      {{ℯ #^2 - ℯ # 𝒶22 - ℯ 𝒶23 𝒶32 - ℯ # 𝒶33 + ℯ 𝒶22 𝒶33, 
        ℯ # 𝒶12 + ℯ 𝒶13 𝒶32 - ℯ 𝒶12 𝒶33, ℯ # 𝒶13 - ℯ 𝒶13 𝒶22 + ℯ 𝒶12 𝒶23}, 
       {ℯ # 𝒶21 + ℯ 𝒶23 𝒶31 - ℯ 𝒶21 𝒶33, ℯ #^2 - ℯ # 𝒶11 - ℯ 𝒶13 𝒶31 - 
        ℯ # 𝒶33 + ℯ 𝒶11 𝒶33, -ℯ 𝒶13 𝒶21 - ℯ # 𝒶23 + ℯ 𝒶11 𝒶23}, 
       {ℯ # 𝒶31 - ℯ 𝒶22 𝒶31 + ℯ 𝒶21 𝒶32, -ℯ 𝒶12 𝒶31 - ℯ # 𝒶32 + ℯ 𝒶11 𝒶32, 
        ℯ #^2 - ℯ # 𝒶11 - ℯ 𝒶12 𝒶21 - ℯ # 𝒶22 + ℯ 𝒶11 𝒶22}}/
  (3 #^2 - 2 # 𝒶11 - 𝒶12 𝒶21 - 2 # 𝒶22 + 𝒶11 𝒶22 - 𝒶13 𝒶31 - 𝒶23 𝒶32 - 
  2 # 𝒶33 + 𝒶11 𝒶33 + 𝒶22 𝒶33), {2}] {{1, 1, 1}, {1, 1, -1}, {1, -1, 1}}];

det = Det[Exp𝔸];

So we will carry out various transformations “by hand”. det is a sum of six terms, each being a RootSum.

Module[{c = 0}, det /. _RootSum :> RS[c++]]

We start by rewriting the RootSums as Roots and factor the resulting polynomials. For brevity we denote the three roots by R[1], R[2], and R[3].

det1 = Map[Factor, #, {2}]& /@ (* RootSum ⟶ sum of Root\[Hyphen]objects *)
               (Normal[det] /. Root[_, k_, ___] :> R[k]);

These are the three Root-objects that appear in the determinant.

(Cases[Normal[det], _Root, Infinity] // Union) /. 
                                   𝕒[ij__] :> Subscript[𝕒, ij]

The whole determinant is formed by the following 10 polynomials (with different arguments). Here we identify all Root-objects.

allPolys = Cases[det1, _Plus?(FreeQ[#, _Plus, {1, Infinity}]&),
                 Infinity] /. _R -> ℝ // Union

collapsePolyRules and expandPolyRules are list of rules that rewrite the polynomials of det1.

collapsePolyRules = Flatten[Table[
      MapIndexed[((# /. ℝ -> R[j]) -> P[#2[[1]], j])&, allPolys], {j, 3}]];
expandPolyRules = Reverse /@ collapsePolyRules;

In abbreviated form the first term of the determinant is the following.

det2 = det1 //. collapsePolyRules;

det2[[1]]

By Schanuel’s conjecture [325✶], [1335✶] we assume the exponents of the various sums of the roots are independent quantities. So we collect with respect to these exponents and simplify their coefficients.

det3 = Expand[det2];

exps = Cases[det3, Power[E, _], Infinity] // Union

For the first exponent Exp[3 R[1]] it is easily shown that its prefactor vanishes. This is the expression.

fac[1] = Factor[Together[Plus @@ 
                Cases[det3, exps[[1]] _, Infinity]]]

fac1[1] = Expand[Cases[fac[1], _Plus][[1]] /. expandPolyRules];

Its factored form resembles the defining polynomial for the three roots R[1], R[2], and R[3].

fac1[1] // Factor

(* the polynomial fulfilled by the roots *)
rootPoly = (Cases[Normal[det], _Root, Infinity] // Union)[[1, 1]]

PolynomialReduce[fac1[1], rootPoly[R[1]]][[2]]

We automate the process of showing that the prefactors of all the other eight exponents of exps1 vanish too.

exps1 = DeleteCases[exps, Exp[R[1] + R[2] + R[3]]]

gb = GroebnerBasis[
(* R[1], R[2], and R[3] are the three roots of rootPoly *)
CoefficientList[rootPoly[ξ] -  (ξ - R[1])(ξ - R[2])(ξ - R[3]), ξ],
                    {R[1], R[2], R[3]}];

Table[fac[j] = Factor[Together[Plus @@ 
                Cases[det3, exps1[[1]] _, Infinity]]];
      fac1[j] = Expand[Cases[fac[j], _Plus][[1]] /. expandPolyRules];
      (* reduce the factors *)
      PolynomialReduce[fac1[j], gb, {R[1], R[2], R[3]}][[2]],
      {j, Length[exps1]}]

The prefactor of the remaining exponent Exp[R[1] + R[2] + R[3]] simplifies to 1.

fac[10] = 1/Exp[R[1] + R[2] + R[3]] Factor[Together[Plus @@ 
       Cases[det3, Exp[R[1] + R[2] + R[3]] _, Infinity]]]

PolynomialReduce[Numerator[Together[fac[10] - (* the 1 *) 1]] /. 
                 expandPolyRules, gb, {R[1], R[2], R[3]}][[2]]

It remains to simplify the argument of Exp, namely R[1] + R[2] + R[3] to 𝕒[1,1]+𝕒[2,2]+𝕒[3,3].

gb[[-1]]

PolynomialReduce[R[1] + R[2] + R[3], gb, {R[1], R[2], R[3]}][[2]]

𝔸 = {{a11, a12, a13}, {a21, a22, a23}, {a31, a32, a33}};

The implementation of the identity is straightforward by using the functions Inverse, MatrixPower, and Sum. To speed up the calculation we sprinkle Together and Simplify throughout the code.

Inverse[IdentityMatrix[3] - λ 𝔸] ==
     Map[Simplify[Together[Sum[λ^k #, {k, 0, Infinity}]]]&, 
         Together[MatrixPower[𝔸, k]], {2}] // Simplify

For some more complicated matrix identities, see [1273✶].

n = 2;
𝔸 = Table[Subscript[a, i, j], {i, n}, {j, n}];
ℍ = Table[Subscript[h, i, j], {i, n}, {j, n}];

𝕕1 and 𝕕2 are the two expressions for the matrix differential quotients. 𝕕1Pre is the argument of the limit definition.

𝕕1Pre = (MatrixExp[t (𝔸 + ε ℍ)] - MatrixExp[t 𝔸])/ε;

𝕕2 = Map[Integrate[#, {τ, 0, t}, GenerateConditions -> False]&,
         MatrixExp[(t - τ) 𝔸].ℍ.MatrixExp[τ 𝔸], {2}];

𝕕1Pre and 𝕕2 are relatively large expressions.

{LeafCount[𝕕1Pre], LeafCount[𝕕2]}

To calculate 𝕕1 from 𝕕1Pre we have to carry out the limit. A direct call to Limit does not give a useful result.

Limit[𝕕1Pre[[1, 1]], ε -> 0] // Head

The reason for the failure of Limit is not completely unexpected. To calculate the limit a series expansion will often be carried out. But formally there is a nonvanishing term of (ε^(-1)).

(ser = Series[𝕕1Pre[[1, 1]], {ε, 0, 0}])[[4]]

Automatic internal simplification cannot always reduce terms to zero. For this case it is obvious that the coefficient of (ε^(-1)) is zero. Together, applied to all levels, is powerful enough to show this.

Together //@ ser[[3]][[1]]

𝕕1 is the simplified limit version of 𝕕1Pre. No ε is present anymore.

𝕕1 = Map[Normal[Together //@ Series[#, {ε, 0, 0}]]&, 𝕕1Pre, {2}];

Position[𝕕1, ε]

Now it remains to show that diff is zero.

diff = 𝕕1 - 𝕕2;

To show that an expression is identically zero, it is always a good idea to transform the problem to a rational function. This means we have to replace the following square roots.

Cases[diff, Power[_, _Rational], Infinity] // Union

aux = With[{𝓈 = Subscript},
           𝓈[a, 1, 1]^2 + 𝓈[a, 2, 2]^2 + 4 𝓈[a, 1, 2] 𝓈[a, 2, 1] - 
           2 𝓈[a, 1, 1] 𝓈[a, 2, 2]];

Replacing the square roots by functions of ℛ, “togethering” and factoring the expression, and finally using the definition for ℛ gives the result {{0,0},{0,0}} we were looking for.

diff1 = diff //. {1/aux^(3/2) :> 1/(aux ℛ), 
                  1/aux^(1/2) :> 1/ℛ, aux^(1/2) :> ℛ};

Factor[ExpandAll[Numerator[Together[diff1]]]] /. ℛ^2 -> aux

For details of the derivative with respect to a symmetric matrix, see [823✶]; for derivatives with respect to infinite matrices, see [1516✶].

d = 3;
A[] = Table[a[i, j], {i, d}, {j, d}];
A[rows_, colums_] := #[[colums]]& /@ A[][[rows]];

(* generate all equations *)
eqs = (𝒜[##] - Det[A[##]])& @@@ 
 Join[{{}}, Flatten[Table[{{i}, {j}}, {i, d}, {j, d}], 1],
            Flatten[Table[{{i1, i2}, {j1, j2}}, {i1, d}, {i2, d}, 
                           {j1, d}, {j2, d}], 3]];

Using GroebnerBasis to eliminate the variables a[i, j] gives us a set of 124 polynomials that have to vanish.

(gb = GroebnerBasis[eqs, Union[Cases[eqs, _𝒜, Infinity]], 
                               Flatten[A[]]]) // Length

These 124 polynomials can be naturally grouped according to the number of monomials in them. We have four different groups.

groups = Map[Last, #, {2}]& @ Split[Sort[{Union[Cases[#, _𝒜, Infinity] /. 
           {𝒜[l_, _] :> Length[l]}], #}& /@ gb], #1[[1]] === #2[[1]]&];

Length /@ groups

To represent the results in a concise form, we introduce the notation (Subscript[𝒜, rows]^columns) to denote the determinant of the matrix that was formed by using the rows rows and the columns columns from 𝒜.

MakeBoxes[𝒜[rs_, cs_], fmt_] := 
 SubsuperscriptBox["𝒜", #[rs], #[cs]]&[StringJoin[ToString /@ #]&]
 
MakeBoxes[𝒜[], fmt_] := "𝒜"

The first group contains the identities of determinants that arise from 2×2 matrices with identical rows and/or columns.

groups[[1]]

The second group contains again trivial identities, namely the ones arising from exchanging rows and columns in the 2×2 matrices.

Partition[groups[[2]], 3] // TableForm

The third group finally contains some more interesting identities. We sort the identities from this group according to the number of determinants appearing in the polynomials. 𝒜Count counts the number of determinants in an expression.

(* count 𝒜's in a polynomial recursively *)
𝒜Count[expr_Plus] := Plus @@ (𝒜Count /@ expr)
𝒜Count[expr_Times] := Plus @@ (𝒜Count /@ (List @@ expr))
𝒜Count[expr_] := 0 /; FreeQ[expr, _𝒜, {0, Infinity}]
𝒜Count[Power[_𝒜, e_]] := e
𝒜Count[_𝒜] := 1

The third group splits naturally into ten subgroups. The first subgroup contains the expansion of 2×2 formulas. The second subgroup contains the symmetric Laplace expansion-like identities.

subGroups3 = Split[Sort[groups[[3]], 𝒜Count[#1] < 𝒜Count[#2]&],
                        𝒜Count[#1] === 𝒜Count[#2]&];
                        
(* number of groups and their length *)
{𝒜Count[#[[1]]], Length[#]}& /@ subGroups3

Print[TableForm[#]]& /@ Take[subGroups3, {1, 2}];

The third to ninths subgroups contains a variety of symmetry-based identities.

The tenth subgroup contains a relatively complicated identity that has nine summands.

subGroups3[[-1, 1]]

The fourth and last group contains the Laplace-expansion of the 3×3 determinant through three 2×2 determinants.

groups[[4]]

We could now continue to generate more identities. If we eliminate all determinants of the 2×2 matrices, we get the expansion of the 3×3 determinant through the nine matrix elements.

GroebnerBasis[gb, {}, Union[Cases[gb, 𝒜[{_, _}, {_, _}], Infinity]]]

If we eliminate all determinants of the 1×1 matrices (meaning the matrix elements themselves), we get an expansion of the 3×3 determinant through then determinants of 2×2 matrices.

GroebnerBasis[gb, {}, Union[Cases[gb, 𝒜[{_}, {_}], Infinity]]] //
                   Select[#, (Head[#] === Plus && Length[#] > 2)&]&

By selecting various 1×1and 2×2 matrices, we can generate many more identities. Here is a Lewis–Carroll identity [821✶].

all𝒜s = Cases[eqs, _𝒜, Infinity] // Union;

GroebnerBasis[gb, #, Complement[all𝒜s, #]]& @
{𝒜[{1, 3}, {1, 3}], 𝒜[{1, 2}, {1, 2}], 
 𝒜[{1, 3}, {1, 2}], 𝒜[{1, 2}, {1, 3}], 𝒜[{1}, {1}], 𝒜[]}

By selecting a random combination of determinants we obtain a variety of representations for the 3×3 determinant.

selectGoodIdentity[l_List] := 
    Select[l, (Head[#] === Plus && MemberQ[#, 𝒜[], Infinity])&]

SeedRandom[111];
Table[While[(gI = selectGoodIdentity[
       GroebnerBasis[gb, #, Complement[all𝒜s, #]]& @ 
          all𝒜s[[Join[{1}, Table[Random[Integer, {2, 91}], 
           {12}]]]]]) === {}]; gI, {5}]

Sum[k x^k, {k, Infinity}]

b[n_] = Sum[k, {k, n}];
Sum[b[k], {k, n}]/(n + 1)

A standard way to deal with divergent sums and integrals is to add exponential terms that give rise to convergence.

Sum[k Exp[-ε k], {k, Infinity}]

Letting now ε go to 0, we have the following behavior.

Series[%, {ε, 0, 2}]

We subtract the integer order quadratic divergence and obtain -1/12, a result first obtained by Euler [888✶]. Another way to obtain this result is to get convergence by summing (n^(-s)) and then letting s->-1 [1397✶]. Again we obtain the result -1/12 [937✶], [538✶].

Sum[k^-s, {k, Infinity}] /. s -> -1

For a detailed discussion why the last two approaches yield the same result, see [1520✶], [1521✶], [1522✶]. For corresponding multidimensional sums, see [500✶]. For Ramanujan’s derivation of this result, see [142✶], [415✶].
Unfortunately, Mathematica’s Sum function does not carry out this removal of infinities automatically, and currently there is also no option to allow for this.

sum = Sum[n^3 Exp[-λ n], {n, 0, m}]

integral = Integrate[n^3 Exp[-λ n], {n, 0, m}]

We simplify the result.

Short[difference = sum - integral // Together // PowerExpand, 6]

All we now have to do is apply taking limit twice, and we are done (the order matters in this example). The first limit is trivial to do by hand (the terms (e^(-m l)) vanish faster than does any power of m for m->∞ ).

(Expand[difference (-1 + E^λ)^4 λ^4] /. 
        Exp[_?(MemberQ[#, m, Infinity]&)] -> 0)/
                    ((-1 + E^λ)^4 λ^4) // Factor

And the second limit yields the result we are looking for: 1/120.

Series[%, {λ, 0, 2}]

Taking the limits in the opposite order would have resulted in a nonconvergent result.

Series[difference, {λ, 0, 0}] // Simplify

Another possibility would have been to use the Abel–Plana formula [1385✶], [1358✶], [811✶] for the first summation/integration step.

(∑_(n=0)^∞)f(n)-(∫_0^∞)f(x)dx=((f(0))/2)+i (∫_0^∞)((f(i t)-f(-i t))/((e^(2 π t))-1))dt

f[ξ_] := ξ^3 Exp[-λ ξ]
1/2 f[0] + I Integrate[(f[I t] - f[-I t])/(Exp[2 Pi t] - 1), 
                       {t, 0, Infinity},
                       Assumptions -> (Im[λ] == 0)] // Simplify

Series[%, {λ, 0, 3}]

Still another possibility is the use of the extended Poisson summation formula [491✶]. (Here (Subscript[ℱ, n])[f(n)](ν) denotes the Fourier transform of f(n))

(∑_(n=-∞)^∞)f(n)-(∫_(-∞)^∞)f(x)dx=-(Sqrt[2π])(Subscript[ℱ, n])[f(n)](0)+(∑_(ν=-∞)^∞)(Sqrt[2π])(Subscript[ℱ, n])[f(n)](ν).

To obtain a sum running from -∞ to ∞, we extend the summands symmetrically for negative n. Proceeding in a similar way for the integral, we obtain the following function f.

f[ξ_] := 1/2 Sqrt[ξ^2]^3 Exp[-λ Sqrt[ξ^2]]

It is straightforward to implement the above Poisson formula.

F[ν_] = Sqrt[2 Pi] FourierTransform[f[n], n, ν]

Sum[F[2 Pi ν], {ν, -Infinity, Infinity}] - F[0]

In the limit λ ->0, we again obtain the value 1/120.

Series[%, {λ, 0, 1}]

For a Zeta function approach to calculate such differences, see [521✶]. For a review of methods to calculate (∫_0^∞)f(x)dx-(∑_(k=0)^∞)f(n), see [111✶]; for multidimensional examples, see [1439✶], [1440✶];

Note that the above-calculated difference between the sum and the integral plays an important role in the quantum electrodynamical explanation of the Casimir effect; see, for instance, [1011✶], [425✶], [186✶], [752✶], [1083✶], [1277✶], [1146✶], [548✶], [462✶], [1521✶], [520✶], [1139✶], [1020✶], [185✶], [1000✶], and [1170✶].

Σ = Log[Sqrt[Pi^2 n^2/l^2       + kx^2 + ky^2]/
        Sqrt[Pi^2 n^2/(L/2)^2   + kx^2 + ky^2]] + 
    Log[Sqrt[Pi^2 n^2/(L - l)^2 + kx^2 + ky^2]/
        Sqrt[Pi^2 n^2/(L/2)^2   + kx^2 + ky^2]];

Not unexpectedly, Mathematica cannot evaluate the sum and the double integrals directly.

Integrate[Sum[Evaluate[Σ], {n, -Infinity, Infinity}],
          {kx, -Infinity, Infinity}, {kx, -Infinity, Infinity},
          GenerateConditions -> False]

Because we are dealing with divergent integrals we take the liberty to exchange the integrals and the sum. To simplify the integrand we first simplify the arguments of the logarithms taking into account they are always positive. Performing the resulting integration over the (Subscript[k, x]),(Subscript[k, y])-plane in polar coordinates using the GenerateConditions -> False option setting to get regularized results for divergent integrals gives a nice result containing only integer powers and logarithms of n. (We could also use an convergence generating factor such as exp(-ε κ), then make a series expansion around κ=0 and ignore terms of the form (κ^(-m)),m∈(SuperPlus[ℕ]).)

int = Integrate[Pi (PowerExpand[Σ] /. kx^2 + ky^2 -> κ), 
                {κ, 0, Infinity}, GenerateConditions -> False]

Using the last result in the sum over n yields a divergent sum. Using now the GenerateConditions -> False option setting in SymbolicSum`SymbolicSum yields a finite result. We change the double infinite sum to a single infinite sum by observing that int depends only on (n^2) and the n=0 term does not contribute to the finite result.

Series[PowerExpand[int], {n, 0, 1}]

res = SymbolicSum`SymbolicSum[Evaluate[int], {n, 1, Infinity},
                              GenerateConditions -> False]

We end by writing the last result in a symmetric form.

-4 Pi Zeta[3] Apart[-1 /(Pi Zeta[3]/4) Factor[res], l]

As a quick explanation for the result of Sum, let us look at the sums of the individual terms. We have two types of sums: (∑_(n=1)^∞)(n^2) and (∑_(n=1)^∞)ln(n) (n^2).

int1 = Expand[PowerExpand[int]]

Proceeding in a similar way to in part a) of this exercise, we see that the first sum vanishes and the second has the value (Subscript[Li, 2]^((1,0)))(-1).

Series[Sum[n^2 Exp[-ε n], {n, Infinity}], {ε, 0, 1}]

Series[Sum[n^2 Log[n] Exp[-ε n], {n, Infinity}], {ε, 0, 1}]

Taking into account that ∂(n^α)/∂α=ln(n)(n^α), we can rewrite (Subscript[Li, 2]^((1,0)))(-1) in a derivative-free way. (We discuss the function FunctionExpand in Chapter 3).

{#, FunctionExpand[#]}&[D[Sum[n^α, {n, Infinity}], α] /. α -> 2]

This again yields the result from above.

int1 //. n^2 Log[n] :> Zeta[3]/(4 Pi^2) /. n^2 -> 0

We now give a possible implementation: the functions involved can have several arguments. Here, we restrict ourselves to functions with one, two, or three arguments. The lists are arbitrarily extendable in number and size (in particular, for more than three arguments, Times and Plus are appropriate). Here, we avoid special functions and instead just use elementary functions.

functionWithiArguments[1] := #[[Random[Integer, {1, Length[#]}]]]&[
              (* we use only elementary functions here *)
              {Sin, Cos, Tan, Cot, ArcSin, ArcCos, Exp, Log,
               Sqrt, Log, Minus, Sinh, Tanh, Power[#, 1/3]& (* … *)}]

functionWithiArguments[2] := #[[Random[Integer, {1, Length[#]}]]]&[
            {Power, Plus, Times, Log, Divide
              (* plus many special functions *)}]

functionWithiArguments[3] :=
 #[[Random[Integer, {1, Length[#]}]]]&[{Plus, Times}]

(* expandable:
   functionWithiArguments[4] := ... *)

The list of random functions should also include constants. To be able to combine these more easily later, we do not use the built-in command Unique directly, but instead employ the following modified version.

myUnique := c[Unique[my]]

myUnique produces the previously unused constant of the form c[my$number]. Here are some examples.

Table[myUnique, {20}]

In order to get an arbitrary ordering of the arguments of the various types and x, we permute all possible arguments. Because we only need one permutation, we implement aPermutation instead of the (for many arguments much, much slower) built-in Permutations.

aPermutation[l_List] :=
(* take random elements from a list until this list is empty *)
Nest[Function[a, {Append[a[[1]], a[[2, #]]],
Drop[a[[2]], {#}]}&[Random[Integer, {1, Length[a[[2]]]}]]],
                         {{}, l}, Length[l]][[1]]

Here are two examples.

aPermutation[{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}]

aPermutation[{x, x, x, x, c[1], c[2], c[3], c[4]}]

We now proceed to the actual implementation: a random function of depth 2 is just one of the above functions in functionWithiArguments with appropriate arguments. We must be careful to make sure that at least one x appears in the random function.

randomFunction[2] :=
Function[m, functionWithiArguments[m][
Sequence @@ (* mix *) aPermutation[Flatten[(* the elements *)
{Table[x, {#}], Table[myUnique, {m - #}]}]]&[
            Random[Integer, {1, m}]]]][Random[Integer, {1, 3}]]

Here is again an example.

Table[randomFunction[2], {12}]

We define a random function of depth n recursively as a random function that has at least one argument of depth n-1.

randomFunction[n_Integer?(# >= 3&)] :=
Function[m, functionWithiArguments[m][
Sequence @@ (* mix *) aPermutation[Flatten[
(* the elements *)
{Table[(* call _one_ level lower *)
       randomFunction[n - 1], {#}],
 Table[(* call _any_ lower level *)
       randomFunction[Random[Integer, {2, n - 1}]],
         {m - #}]}]]&[Random[Integer, {1, m}]]]][
                         Random[Integer, {1, 3}]]

In principle, this definition should already work.

Table[randomFunction[3], {6}]

We now refine it somewhat. First, functions of constants are again constants (here, we make use of the structure of constants generated by the above myUnique function). The following simplification rules for x independent parts cover most but not all cases. On the other hand, we do not want to wait too long for a result.

(* f[constants] -> newConstant *)
simpRule = {f_[__c] :> myUnique, _?NumericQ*(_c)^_. :> myUnique};

Secondly, in this form, the constants do not look especially nice; c1, c2,… , looks better than c[my$number]. So we can implement the function randomFunctionPre.

randomFunctionPre[n_] :=
Function[p, p //. ((Rule @@ #)& /@ Transpose[
(* replace c[...] by ci for shortness *)
  {#, Table[ToExpression["c" <> ToString[i]],
        {i, Length[#]}]}]&[Cases[p, c[_], {-2}]])][
         randomFunction[n] //. simpRule]

Table[randomFunctionPre[3], {6}]

Complications can and still do arise. Because of the completely independent choice of functions, the result can turn out to be x-independent, we could be dividing by 0, and so on. We check for the most common of these problems, and keep calling RandomFunctionH until a satisfactory result is obtained. We do not insist on an exact depth of n, because not all functions collected in functionWithiArguments have the same depth because some of them are composite. This leads us finally the following definition.

RandomFunction[n_Integer?(# >= 2&)] :=
Module[{aux, test1, test2, test3, test4},
       While[Check[ (* until we have a "good" result *)
             aux = TimeConstrained[randomFunctionPre[n],
              (* possibly increase for large n *) 10 n], " error "];
            test1 = !(And @@ (* might be 0/0 or related
                              objects were generated *)
              (FreeQ[aux, #, {0, Infinity}]& /@
               {Indeterminate, DirectedInfinity}));
              (* the variable x should be present *)
            test2 = !MemberQ[aux, x, {0, Infinity}];
              (* may be do here: test3 = Depth[aux] =!= n; *)
            test4 = aux === $Aborted;
            test5 = aux === " error ";
            !(test1 == False && test2 == False &&
              (* test3 == False && *)  test4 == False &&
              test5 == False), Null];
            aux]

We now look at a few examples of random functions of various depths.

Table[RandomFunction[2], {12}]

Table[RandomFunction[3], {12}]

Table[RandomFunction[4], {12}]

Table[RandomFunction[5], {6}]

RandomFunction[6]

We can use RandomFunction to test Mathematica’s integration capabilities by first integrating the random functions, and then differentiating them and comparing with the originals.

IntegrateTest[n_] :=
Module[{v = RandomFunction[n], int},
       int = Integrate[v, x];
       If[FreeQ[int, Integrate, {0, Infinity}, Heads -> True],
          If[(* hopefully, Simplify can do it *)
          Simplify[D[int, x] - v] =!= 0, v, Null], Null]]

SeedRandom[111];
Do[If[# =!= Null, Print[#]]&[IntegrateTest[3]], {10}] // Timing

Of course, we could first differentiate the random functions and then integrate. (Here, additive constants may be lost, as, for instance, in the case Integrate[D[Log[2x], x], x] - Log[2x].)

IntegrateTest2[n_] :=
Module[{v = RandomFunction[n], d, int},
       d = D[v, x];
       int = Integrate[d, x];
       If[MemberQ[int, Integrate, {0, Infinity}, Heads -> True],
          (* Risch should do it *)
          Print["Antiderivative of the complete differential",
                d, " not found"],
          (* tricky case or a bug? *)
          If[MemberQ[Simplify[int - v], x, {0, Infinity}],
             Print["Equality cannot be established: ", v, " ⟷ ", int],
             Null]]]

Because indefinite integration is correct modulo a differential-algebraic constant, the branch cut structure of some functions f(x) might change after carrying out (∂/(∂x))(∫^x)f(x) dx. Here, we find such an example.

SeedRandom[175068687549];
Do[IntegrateTest2[3], {1}]

To get “positive” results with these tests, we have to look at several thousand examples for n=3. (We found an example quickly because we used a “lucky” seed for the random number generator.
Now let us use n=5 to find an example for a doable integral that will not be done by Mathematica. We count the number of tries needed to find such an integrand.

SeedRandom[7777777];
Module[{counter, v, d, int},
       counter = 0;
       While[counter = counter + 1;
             v = RandomFunction[4];
             (* differentiation *)
             d = D[v, x];
             (* integration *)
             int = Integrate[d, x];
             FreeQ[int, Integrate, {0, Infinity}, Heads -> True], Null];
       {counter, v}]

Often such type integrands contain radicals.

D[%[[2]], x]

Integrate[%[[2]], x]

RandomFunction can also be used to discover functions for which Mathematica is not able to find series expansions or limit values, and so on. With an analogous implementation, we can also construct random functions of several variables. 
Such techniques are typically very useful for automatic testing for larger pieces of code that need to be robust in all cases.

Using the function randomFunction, we can easily implement the generation of random numeric expressions (say for investigating the uniformity conjecture [1337✶], [1338✶]). randomNumericExpression[n, iMax] generates a random numeric expression by (about) n-fold composition that has no integers larger than iMax (to avoid expressions with huge integers that might arise from repeatedly forming powers of smaller integers).

randomNumericExpressionPre[n_, nMax_] := 
 randomFunction[n] //. (* substitute integers for symbols *)
                       (x | _c) :> Random[Integer, {-nMax, nMax}]

randomNumericExpression[n_, iMax_] := 
Module[{rNe},
While[(* better reproducibility *) Developer`ClearCache[];
      rNe = MemoryConstrained[TimeConstrained[
                   randomNumericExpressionPre[n, iMax], 100], 10^6]; 
      (* is it a "good" expression? *)
      MatchQ[rNe, _Integer] || rNe === $Aborted || 
      rNe === Overflow[] ||  rNe === Underflow[] ||
      Max[Abs[Cases[rNe, _Integer, {-1}]]] > iMax ||
      Max[{Numerator[#], Denominator[#]}& /@ 
         Abs[Cases[rNe, _Rational, {-1}]]] > iMax ||
      Not[NumericQ[rNe]], Null]; rNe]

Here are four examples of random numeric expressions.

Off[General::dbyz]; Off[Infinity::indet]; Off[Power::infy];
Off[Power::indet]; Off[General::ovfl]; Off[General::unfl];
Off[$MaxExtraPrecision::meprec];

Table[randomNumericExpression[8, 10], {4}]

We could use Trace or On, but these functions produce large outputs and slow down calculations substantially. So we add additional rules to Real and Complex (with inexact arguments) as well as to N. In case any of these heads is used, we record this and immediately after this we remove the rule to avoid the slowdown of any further computation. The argument HoldAll is needed to avoid the evaluation of the input before Real, Complex, and N are overloaded. inexactNumberUseChecker returns a list with three elements. The first element is the result of the calculation, the second indicates if inexact numbers were used in this calculation, and the third indicates if explicit calls to N were carried out.

SetAttributes[inexactNumberUseChecker, HoldAll];

inexactNumberUseChecker[f_] := 
Module[{realsWereUsed = False, complexesWereUsed = False,
        NWasCalled = False},
 Unprotect[{N, Real, Complex}];
 (* intercept calls to N *)
 DownValues[N] = {HoldPattern[N[x__]] :> Null /; 
                     (NWasCalled = True; Clear[N]; False)};
 (* intercept calls to a function with an approximative argument *)
 Real /: _[___, _Real, ___] := Null /; 
               (realsWereUsed = True; Clear[Real]; False);
 Complex /: _?(# =!= Precision&)[___, c_Complex, ___] := Null /;
        (If[Precision[c] < Infinity,
            complexesWereUsed = True; Clear[Complex]]; False);              
 (* return result and if approximative numbers were used
    and if N was called explicitly *)
 res = {f, realsWereUsed || complexesWereUsed, NWasCalled};
 Protect[{N, Real, Complex}]; (* return result *) res]

Here are three sample inputs demonstrating that inexactNumberUseChecker works correctly.

inexactNumberUseChecker[Sin[3.]]

inexactNumberUseChecker[Sin[N @ Pi]]

inexactNumberUseChecker[Sin[1. + I]]

Not every possible input to the functions of this chapter will cause the use of inexact numbers. Expressions with “hidden zeros” will more frequently cause numericalization to make certain decisions. So we will use the zero zero in the next examples. Because “hidden zeros” will frequently trigger $MaxExtraPrecision::meprec messages, we will turn them off.

(* the hidden zero *)
zero = Sqrt[2] + Sqrt[3] - Sqrt[5 + 2 Sqrt[6]];
Off[$MaxExtraPrecision::meprec]; Off[Clear::wrsym];

Many symbolic functions are actually using numerical techniques internally. In the following we will see that at least the Solve, Integrate, Factor, Roots, Root, RootSum, Sum, Series, DSolve, FourierTransform, LaplaceTransform, CylindricalAlgebraicDecomposition are of such type.

Solve uses numerical techniques for verification.

inexactNumberUseChecker[Solve[Cos[x] + Sin[x] == Pi, {x}]]

Avoiding the verification of the solutions does not avoid the use of inexact numbers.

inexactNumberUseChecker[Solve[Cos[x] + Sin[x] == Pi, {x},
                              VerifySolutions -> False]]

For definite integrals Integrate will use numerical techniques to find singularities along the integration path.

inexactNumberUseChecker[Integrate[1/(x - zero), {x, -1, 1}]]

Also factoring over extension fields uses numerical techniques.

inexactNumberUseChecker[Factor[3 x^3 + 7 x^2 - 9, 
       Extension -> {(1501/2 - (27 Sqrt[2445])/2)^(1/3)}]] // Simplify

Most functions related to Root need numerical techniques to isolate the roots.

inexactNumberUseChecker[Roots[zero x^7 + 5 x - 1 == 0, x]]

roots = Root[#^5 + 3 # - 1&, 3] + Root[#^3 + 5 # - 3&, 1];
inexactNumberUseChecker[RootReduce[roots]]

The results of Experimental`CylindricalAlgebraicDecomposition often contain Roots. As a result it uses numerical techniques.

AppendTo[$ContextPath, "Experimental`"]

inexactNumberUseChecker[
CylindricalAlgebraicDecomposition[
                              x^2 + x^6 + y^8 == 1, {y, x}]]

In the next example numerical techniques are used to obtain the number of steps from the iterator of Sum.

inexactNumberUseChecker[Sum[1/k, {k, 2, 3 + zero}]]

Also Series might numericalize certain expressions internally.

inexactNumberUseChecker[Series[ArcSin[x + zero], {x, 1, 0}]]

DSolve heavily depends on Solve. As a result it too uses inexact numbers at some steps.

inexactNumberUseChecker[DSolve[{y''[x] - y'[x] + y[x] == 0,
                               y[0] == 1, y'[0] == 0}, y[x], x]]

Integral transforms use numerical techniques for verifying convergence.

inexactNumberUseChecker[FourierTransform[Exp[-x^2], x, k]]

inexactNumberUseChecker[LaplaceTransform[Exp[-x^2], x, k]]

allFunctions = DeleteCases[Names["*"], "allFunctions"];

We eliminate all values, meaning the commands that evaluated to something other than themselves.

allFunctions1 = Select[allFunctions, ToString[ToExpression[#]] === #&];

Because many of the following inputs would generate large amounts of messages, we shut off all messages.

Get[ToFileName[{$TopDirectory, "SystemFiles", "Kernel", 
	           "TextResources", $Language}, "Messages.m"]];

(* list of all messages *)
allMessages = Flatten[(Messages @@ #)& /@ (ToHeldExpression[#]& /@
                                     DeleteCases[allFunctions, "I"])];

(Off @@ First[#])& /@ allMessages;

Often argument-counting and -checking messages are associated with General. So we shut off all these messages too.

generalMessageNames = #[[1, 1, 2]]& /@ Messages[General];

Function[c, Function[n, Off[c::n], {HoldAll}] /@ c] /@ allFunctions2;

Further, we delete some “dangerous” (meaning they would exit the program) functions from allFunctions1.

allFunctions2  = ToExpression /@ DeleteCases[allFunctions1,
            (* "dangerous" functions *)
            "Abort" | "Break" | "Continue" | "Exit" | "Quit" |  
            "Remove" | "Goto" | "Throw" | "Install" | "On[]" |
            "ConsoleMessage" | "Interrupt" | "$Inspector" | 
            _?(Function[c, Or @@ (StringMatchQ[c, #]& /@
            {"*Link*", "*Print*", "*Write*", "*Edit*", "*File*",
             "*Input*", "*Dialog*", "*Convert*", "*Notebook*"})])];

Selecting now all functions for which Derivative[2][function] is different from function yields about 250 functions.

l1 =  Select[allFunctions2,
 ((Derivative[2][#] /. Derivative -> 𝒹) =!= 𝒹[2][#])&];

l1 // Length

About 70 of these functions are elementary and special functions like Cos and ArcTan. Calculating the second derivative of these functions yields often a different function. These functions carry the attribute NumericFunction. Or they are mathematical constants.

l2 = DeleteCases[l1, 
          _?((MemberQ[Attributes[#], NumericFunction] || 
              MemberQ[Attributes[#], Constant] ||
              NumberQ[#] || PolyGamma === # || ProductLog === #)&)];

l2 // Length

We group the remaining 180 or so functions according to their result for Derivative[2][function].

({#[[1, 1]] /. _?((LeafCount[#] > 50)&) :> 𝓉ℴℴℬ𝒾ℊ, 
 (Last /@ #) }& /@ Split[Sort[{Derivative[2][#], #}& /@ l2, 
                         OrderedQ[{#1[[1]], #2[[1]]}]&],
                              #1[[1]] === #2[[1]]&])

Most of the results of Derivative[2][function] are of the form 0& or some list version of this. The reason for these results is the sequence of evaluations carried out when evaluating Derivative[2][function]. Derivative[2][function] evaluates function[#] and differentiates the result. function[#] often evaluates to # and differentiating this twice with respect to # yields 0. Here is the sequence of evaluations for N and Decompose.

Trace[Derivative[2][N]]

Trace[Derivative[2][Decompose]]

We now iterate this several times. Here is the corresponding recursive Mathematica implementation (the Function part serves to sum up the coefficients of the powers of x). For efficiency, we do not use the built-in Integrate for the definite integrations to be carried out, but define our own integrate, which is based on the (much faster) indefinite integration capabilities of Mathematica.

seriesSol[0, x_] = f0 + fs0 x;

seriesSol[ord_, x_] := seriesSol[ord, x] =
Module[{ξ, 𝓍},
Function[res, Plus @@ (* write result in nice form *)
(Simplify[Plus @@ Cases[res, _ x^#]]& /@
 Union[{1}, #[[2]]& /@ Cases[res, x^_, {0, Infinity}]])][
 (* starting values *)
  f0 + fs0 x + (* Integrate existing series *)
    integrate[integrate[Normal[Series[ (* rename variables
                                          for definite integration *)
     (seriesSol[ord - 1, x] //. x -> 𝓍)^(3/2)/𝓍^(1/2), {𝓍, 0, ord}]],
          {𝓍, 0, ξ}], {ξ, 0, x}] // Expand] +
                            (* lost by Cases for powers of x *) f0]

(* simple definite integration *)
integrate[f_, {x_, x0_, x1_}] := 
         ((# /. x -> x1) - (# /. x -> x0))&[Integrate[f, x]]
         
integrate[f_Plus, {x_, x0_, x1_}] := integrate[#, {x, x0, x1}]& /@ f

Here is the result of the first two iterations.

seriesSol[0, x]

seriesSol[1, x]

seriesSol[2, x]

seriesSol[3, x]

Here is a later stage of the iteration.

seriesSol[10, x] // Simplify

For a Adomian decomposition-based series solution of the Thomas–Fermi equation, see [1636✶].

U = u[t] - (-(16/3)^(1/3) φ[x[t]]^(-4/3) φ'[x[t]]);
T = t - (144^(-1/6) x[t]^(1/2) φ[x[t]]^(1/6));
TF = φ''[x[t]] - φ[x[t]]^(3/2)/Sqrt[x];

Differentiating U and T with respect to t gives us two further equations. We start by clearing denominators.

eqs1 = Numerator[Together[{TF, D[U, t], U, D[T, t], T}]] /. x[t] -> x;

Next we form a polynomial system by introducing new variables for the symbolic quantities appearing in fractional powers.

eqs2 = PowerExpand[eqs1 /. φ[x] -> Φ^6 /. φ'[x] -> φ1 /. φ''[x] -> φ2 /. 
                   x'[t] -> xs/(2^(1/3) 3^(2/3)) /. x -> y^2]

Now we have five equations and we have to eliminate five variables: Φ, φ2, φ1, y, and xs. This means we cannot use Eliminate or GroebnerBasis[eqs2, {}, {Φ, φ2, φ1, y, xs}]. We eliminate one variable after another and look for a factors containing only t, u[t], and u'[t]. The function eliminate eliminates the variable var from the equations eqs and factors the result.

eliminate[eqs_, var_] := Cases[Factor[
   Resultant[First[eqs], #, var]]& /@ Rest[eqs], _Plus, Infinity]

Eliminating the variables in the order φ2, φ1, y, and finally xs yields the differential equation u'(t)->-8 (t ((u(t))^2)-1)/((t^2) u(t)-1).

eliminate[eqs2, φ2]

eliminate[%, φ1]

eliminate[%, y]

eliminate[%, xs]

Solve[First[%] == 0, u'[t]] // Simplify

uE[0][z_] = 1;
uE[n_][z_] := uE[n][z] = Expand[uE[n - 1][z] - z^(n - 1)/2 uE[n - 1][z]^2]

The direct implementation allows us easily to calculate the first ten terms of the series expansion.

Take[uE[10][z], 10]

Due to the exponentially increasing number of terms of (Subscript[u, n])(z) the direct calculation of 100 terms is impossible. Already (Subscript[u, 10])(z) is a polynomial with 1014 terms.

uE[10][z] // Length

To keep the number of needed terms reasonable, we will use a SeriesData-object instead. Making sure that we have enough series terms, we have the following implementation.

u[0, o_][z_] = 1;
u[n_, o_][z_] := u[n, o][z] = 
Normal[Series[u[n - 1, o][z] - 1/2 z^(n - 1) u[n - 1, o][z]^2, 
              {z, 0, o}]];
                                            
u[n_][z_] := Normal[u[n + 1, n + 2][z] + O[z]^(n + 1)]

Using the function u it is possible to calculate the first 100 series terms quickly.

u[100][x]; // Timing

Short[u[100][x]  /. (* nicer form of denominators *)
      Rational[p_, q_] :> (p "2"^-#&[Log[2, q]]), 12]

Doubling the number of terms multiplies the time by about a factor of 8=(2^3).

u[200][x]; // Timing

This means that the first 1000 series terms using u[1000][x] can be calculated in a few hours. The result for (Subscript[c, 1000]) is:

(Subscript[c, 1000])=-(2^(-999))×

Now let us visualize arg(u(0.999 (e^(i  φ)))). For approximative numerical values of z we can calculate u(z) by iterating the recursion relation. For an efficient calculation, we compile the function.

uN = Compile[{{x, _Complex}},
     Module[{c = 0}, FixedPoint[(# - x^(c++)/2. #^2)&, 1. + 0. I]]];

This leads to the following graphic. The graphic immediately suggest that arg(u(0.999 (e^(i  φ)))) is discontinuous at rational values of α=p/q and the discontinuity height is 2q. For comparison we also show (Subscript[u, 200])(0.999 (e^(i  α 2π))) [240✶], [277✶].

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{(* argument along the unit circle *)
 With[{ε = 10^-12},
      Plot[Arg[uN[0.999 Exp[I φ]]], {φ, ε, 2Pi - ε}, 
           Frame -> True, Axes -> False, Compiled -> False]], 
 (* real and imaginary part along the unit circle *)          
 Module[{pp = ParametricPlot[Evaluate[{Im[#], Re[#]}&[u[200][x] /. 
                                        x -> 0.999 Exp[I φ]]], 
                {φ, 0, 2Pi}, PlotPoints -> 10000, PlotRange -> All,
                AspectRatio -> Automatic, Axes -> False], λ},
       λ  = Length[pp[[1, 1, 1, 1]]];
       (* color curve from red to red *)
       Graphics[{Thickness[0.002], MapIndexed[{Hue[#2[[1]]/λ], 
                 Line[#1]}&, Partition[pp[[1, 1, 1, 1]], 2, 1]]}, 
                PlotRange -> All, AspectRatio -> Automatic]]}]]]

({{ln(x(y)), =ln(y ln(y)+"rest"(y))=ln(y ln(y)(1+(("rest"(y))/(yln(y)))))}, {, =ln(y)+ln(ln(y))+(∑_(k=1)^∞)((((-1))^(k+1))/k)((((("rest"(y))/(yln(y)))))^k).}})

Comparing equal powers of (((ln(ln(y))))^j)/(ln^i)(y) then gives the required equations for the (Subscript[a, "ij"]). 
The implementation is nearly straightforward. The only difficulty is that a direct brute force calculation of ((("rest"(y)/(yln(y))))^k) with rest containing 25 terms and k=5 generates nearly 10 million terms that are too much to handle in a reasonable time. So we implement a function rest[n, pow], which calculates only the required terms of the pow power of "rest"(y)/(yln(y)) up to order n.

rest[n_, pow_] :=
Module[{iterVars},
 (* list of iterator variables *)
 iterVars = Table[a[i], {i, pow}];
 (* list of iterator limits *)
 iterUpperLimits = Drop[n - FoldList[Plus, 0, iterVars], -1];
 (* the sum *)
 Sum[y^pow Log[y]^(-Plus @@ iterVars) Times @@ (b /@ iterVars), ##]& @@
     (* generating the iterator *)
     Thread[{iterVars, Table[0, {pow}], iterUpperLimits}] //.
    (* inner sum *) {b[i_] :> If[i === 0, Log[Log[y]],
                                 Sum[Log[Log[y]]^j a[i, j], {j, i}]]}]

rest[5, 1] just gives rest to order 5.

rest[5, 1]

These are the possible expressions of the form (((ln(ln(y))))^j)/(ln^i)(y).

scales = Flatten[Table[y Log[Log[y]]^j/Log[y]^i, {i, 0, 5}, {j, i}]]

These are the coefficients to be determined.

coeffs = Table[a[i, j], {i, 5}, {j, i}] // Flatten

So we can calculate the expression yln(x(y))-x(y), which should be 0.

order = 6;

zero = y (Log[y] + Log[Log[y]] +
      Sum[(-1)^(i + 1) (rest[order, i]/(y Log[y])^i)/i, {i, 1, order}]) -
      (y Log[y] + rest[order, 1]) // Expand;

Equating the coefficients of (((ln(ln(y))))^j)/(ln^i)(y) to zero gives the following set of equations.

Plus @@ # == 0& /@
Function[lnTerm, Cases[Cancel[Cases[zero, _. lnTerm]/lnTerm],
                       _?(FreeQ[#, y]&)]] /@ scales

These can be easily solved.

Solve[%, coeffs]

We finally use this result in rest[5, 1].

rest[5, 1] /. %

Let us look at a numerical example: (10^6)=x/ln(x). The single calculated summands of the series for x(y) have the following values.

Prepend[Apply[List, %[[1]]], (* add main term *) y Log[y]] //.
                                    {a_ b_Plus :> a List @@ b}

% /. y -> 10.^6

Here is their sum.

N[Plus @@ Flatten[%], 12]

This is the direct numerical solution. The asymptotic result agrees well with the numeric one.

N[FindRoot[10^6 == x/Log[x], {x, 10^6},
           AccuracyGoal -> 60, WorkingPrecision -> 40], 10]

The asymptotic inversion of y=x/lnx can also be obtained by iteration of (Subscript[x, k+1])(y)=yln(Subscript[x, k])(y) [410✶] and [139✶], or in a closed form, [356✶]. Here is the Mathematica implementation for this solution.

Clear[s, a, i, j, k, n];

s[0, 0] = 1; s[0, k_] = 0; s[n_, 0] = 0;
s[n_, k_] := s[n, k] = s[n - 1, k - 1] - (n - 1)s[n - 1, k]
a[i_, j_] := s[i, i - j + 1]/j!

The so-obtained coefficients (Subscript[a, "ij"]) are in agreement with the above-calculated ones.

Table[a[i, j], {i, 1, 5}, {j, 1, i}]

Still another way to tackle the problem of the series expansion of the x(y) defined by y ln(x(y))=x(y) is to solve this equation explicitly in terms of the ProductLog function W(z) (see Chapter 3). The solution is x(y)=y (Subscript[W, -1])(-1/y), and then carry out a series expansion at y=∞.

directCalculation[f_, g_, w_Symbol, z0_, ord_Integer?Positive] :=
Module[{z}, Normal[g[InverseSeries[Series[f[z], {z, z0, ord}], w]]]]

Here is an example.

f[z_] = Exp[z] + Log[z + 1];
g[w_] := Tan[w];

Short[dcs = directCalculation[f, g, w, 1, 3], 6]

Implementing the Lagrange–Bürmann formula is also straightforward. (To avoid expressions of the form 0/0, we use Normal[Series[…, z, z0, 0]] instead of the naive ξ -> z0 substitution.)

LagrangeBürmannSeries[f_, g_, w_Symbol, z0_, ord_Integer?Positive] :=
Module[{ξ},
Module[{gp = D[g[ξ], ξ], w0 = f[z0]},
       g[z0] + Sum[(1/i! Normal[Series[D[gp ((ξ - z0)/(f[ξ] - w0))^i,
                   {ξ, i - 1}], {ξ, z0, 0}]]) (w - w0)^i, {i, ord}]]]

Here is the result.

Short[lbs = LagrangeBürmannSeries[f, g, w, 1, 3], 6]

To show the equality between these two expressions, it is preferable to compare the coefficients of the powers of w - E - Log[2] to avoid slow manipulation of big expressions.

Simplify /@ Together /@ Apply[Subtract, Transpose[
{CoefficientList[lbs //. {w - E - Log[2] -> newVar}, newVar],
 CoefficientList[dcs //. {w - E - Log[2] -> newVar}, newVar]}], {1}]

For a multivariate version of the Lagrange–Bürmann formula, see [677✶], [6✶], [645✶], [750✶], [981✶], [1719✶], [1021✶], and [1676✶].

(Subscript[𝒮, α,o])(q)=(∑_(i,j,k=1)^(d(α,o)))(Subscript[c, i,j,k]^((α,o)))((P(q))^i)((Q(q))^j)((R(q))^k).

Using a truncated series representation for P(q), Q(q), and R(q) and collecting terms with respect to powers of q gives a set of equations (by carrying out the series expansion to a high order we get as many terms as needed) to determine (Subscript[c, i,j,k]^((α,o))). Next we implement the truncated series.

P𝒮[n_] := P𝒮[n] = Series[1 -  24 Sum[k   q^k/(1 - q^k), {k, n}], {q, 0, n}]
Q𝒮[n_] := Q𝒮[n] = Series[1 + 240 Sum[k^3 q^k/(1 - q^k), {k, n}], {q, 0, n}]
R𝒮[n_] := R𝒮[n] = Series[1 - 504 Sum[k^5 q^k/(1 - q^k), {k, n}], {q, 0, n}]

Correspondingly, we also use a truncated series for  (Subscript[𝒮, α,o])(q).

𝒮[α_, o_, n_] := Sum[k^α DivisorSigma[o, k] q^k, {k, n}] + O[q]^(n + 1)

PQRPoly generates all monomials of the form ((P(q))^i)((Q(q))^j)((R(q))^k) of total degree less than or equal to d.

PQRPoly[d_] := PQRPoly[d] = Sum[c[i, j, k] P^i Q^j R^k, 
           {i, 0, d}, {j, 0, d - i}, {k, 0, d - i - j}]

The function makeIdentity[α, o, d] tries to find polynomial representation of degree less than or equal to d. We take about 50% more equations than unknowns (Subscript[c, i,j,k]^((α,o))) to find unique expressions for the coefficients.

makeIdentity[α_, o_, d_] := 
Module[{ansatz = PQRPoly[d], δ, sbz, sol, id, ΣTerm},
 δ = Ceiling[3/2 Length[ansatz]];
 (* the series *)
 sbz = 𝒮[α, o, δ] - (ansatz /. {P -> P𝒮[δ], Q -> Q𝒮[δ], R -> R𝒮[δ]});
 (* solve for coefficients *)
 Off[Solve::svars];
 sol = Solve[# == 0& /@ CoefficientList[sbz, q], 
             Cases[ansatz, _c, Infinity]];
 (* simplify result *)
 If[sol === {}, {}, id = Numerator[Together[
                 Subscript[𝒮, α, o] - ansatz /. sol[[1]] /.
  (* fix undetermined coefficients *) _c -> 0]] // Expand;
 𝒮Term = Select[id, MemberQ[#, 𝒮, Infinity]&];                                  
 (* format result *)
 𝒮Term == -id + 𝒮Term]]

For odd o we can now easily find the polynomials we were looking for. (Because of relations between P(q), Q(q), and R(q) the results are not unique.)

Do[If[# =!= {}, Print[#]]&[makeIdentity[o, k, o + 2]], 
   {o, 1, 3}, {k, 9}]

makeℰDefinitions[] := 
(Clear[ℰ]; ℰ[k_, q_, o_] := ℰ[k, q, o] = 
  1 - 2k/BernoulliB[k] Sum[DivisorSigma[k - 1, j] q^j, {j, o}] + 
  O[q]^(o + 1))

The search for identities of the prescribed kind is straightforward for a given d and suppresses identities of lower order.

(* load context for integer partition functions *)
AppendTo[$ContextPath, #]& /@ 
         Union[Context /@ Names["*`*IntegerPartition*"]];

makeℰRelations[d_] := 
((* the possible indices and powers of the E's *)
 ips = Select[IntegerPartitions[d],
              (And @@ (EvenQ[First[#]]& /@ #))&];
 (* order of q-series *)
 λ = Length[ips] + 20;
 (* the q-series of the monomials *)
 prods = Times @@@ Apply[ℰ[#1, q, λ]^#2&, ips, {2}];
 (* the coefficient lists *)
 cls = If[Length[#] < λ + 1, Join[#, 
           Table[0, {λ - Length[#]}]], #]& /@ (#[[3]]& /@ prods);
 (* quick modular null space *)
 nsm = NullSpace[Transpose[cls], Modulus -> Prime[10^6]];
 (* loop over all null space spanning vectors *)
 tab = Table[posis = Flatten[Position[nsm[[k]], _?(# =!= 0&), 
                                      {1}, Heads -> False]];
 (* full null space *)
 ns = NullSpace[Transpose[cls[[posis]]]];
 If[ns =!= {}, Factor[Numerator[Together[(* extract monomials *)
             ns[[1]].(Times @@@ Apply[Subscript[ℰ, #1]^#2&, 
                   ips[[posis]], {2}])]]]], {k, Length[nsm]}];
 (* extract sums *)
 res = Union[Cases[tab, _Plus, Infinity]])

We get the first identity of the kind described for d=8.

Table[{d, makeℰDefinitions[]; makeℰRelations[d]}, {d, 2, 8, 2}]

For larger d we obtain more than one identity. To canonicalize the identities found, we use their Gröbner basis. The function reduceℰRelations does this canonicalization.

reduceℰRelations[eqs_] := 
GroebnerBasis[eqs, Union[Cases[eqs, Subscript[ℰ, _], Infinity]], 
              MonomialOrder -> DegreeReverseLexicographic]

Here are the identities for d=10, d=12, d=14, and d=16. We display only the relations containing the actual d.

Do[makeℰDefinitions[]; 
   Print @ Select[reduceℰRelations[makeℰRelations[d]], 
                  MemberQ[#, Subscript[ℰ, d], Infinity]&], 
   {d, 10, 16, 2}]

As visible in the last results, the coefficients occurring in the relations are quickly growing. Luckily these integers factor nicely. So, for d=18 we display the factored form of the coefficients.

𝔣[i_?Negative] = -𝔣[-i];
𝔣[i_?(# === 1 || PrimeQ[#]&)] = i;
𝔣[i_] := (HoldForm @@ {C @@ FactorInteger[i]}) /. {List -> Power, C -> Times}
                                
factorCoefficients[expr_] := expr /. i_Integer r_ :> 𝔣[i] r

Function[d, factorCoefficients[reduceℰRelations[Select[makeℰRelations[d],
                        MemberQ[#, Subscript[ℰ, d], Infinity]&]]]] /@ {18}

Also, the number relations increase with d.

Table[{d, Length[Select[makeℰRelations[d], MemberQ[#, 
                Subscript[ℰ, d], Infinity]&]]}, {d, 20, 26, 2}]

S[k_, x_] := Sum[(-1)^j Binomial[k + 1, j] BernoulliB[j] x^(k + 1 - j),
                 {j, 0, k}]/(k + 1)

To find relations of the given form we make a generic ansatz, compare coefficients in ξ, and solve for the (Subscript[c, j]). This is done in the following one-liner.

findQuadraticIdentity[o_, ξ_] := Subscript[S, o][ξ]^2 == 
         Sum[c[k] Subscript[S, k][ξ], {k, 0, 2o + 1}] /.
 Solve[# == 0& /@ CoefficientList[S[o, x]^2 - Sum[c[k] S[k, ξ], 
          {k, 0, 2o + 1}], ξ], Table[c[k], {k, 0, 2o + 1}]]

Here are the first 12 of these identities.

Flatten[Table[findQuadraticIdentity[o, ξ], {o, 12}]] // TraditionalForm

Using GroebnerBasis we could find many more relations between the (Subscript[S, k])(x).

GroebnerBasis[Table[Subscript[S, k][x] - S[k, x], {k, 6}], 
              {}, {x}, MonomialOrder -> EliminationOrder] //
                                            TraditionalForm

o = 100;
as = {};

Do[ser = Exp[z] - (Product[(1 - a[k] z^k)/(1 + a[k] z^k), 
                           {k, n}] /. as) + O[z]^(n + 1);
   coeff = SeriesCoefficient[ser, n];
   (* solve for last coefficient a[n] *)
   sol = Solve[coeff == 0, a[n]];
   as = AppendTo[as, sol[[1, 1]]], {n, o}]

The coefficients (Subscript[a, k]) decrease quickly.

ListPlot[N[Log[10, Abs[(Last /@ as) /. 0 -> 1]]]]

The function δ[z] is the difference between the exponential function and the truncated product.

δ[z_] = (Exp[z] - Product[(1 - a[k] z^k)/(1 + a[k] z^k), {k, 1, o}] /. as);

Taking into account the first 50 nonvanishing factors approximates e to 32 digits.

δ[1] // N[#, 22]&

Here are the first few factors explicitly. The linear term in the denominator shows that the radius of convergence is 2.

δ[z] - Exp[z] /. z^(_?(# > 12&)) -> 0

The following plot also clearly shows that the radius of convergence is 2.

(* avoid messages *) Off[Plot::plnr]; 
Plot[Log[10, Abs[δ[SetPrecision[z, 200]]]], {z, 0, 3}, Compiled -> False]

ε = 10^-3; (* avoid messages *) Off[ParametricPlot3D::pplr]; 
ParametricPlot3D[{r Cos[φ], r Sin[φ], 
                  Log[10, Abs[δ[SetPrecision[r Exp[I φ], 200]]]]}, 
                 {r, ε, 3}, {φ, 0, 2Pi},
                 Compiled -> False, BoxRatios -> {1, 1, 1}]

𝕕[expr_, newIndex_] := 
Module[{aux1, aux2, aux3, s},
 (* append temporary differentiation variable s *)
 aux1 = expr /. f[i_][derivs___] -> f[i][derivs][s];
 (* carry out differentiation *)
 aux2 = D[aux1, s];
 (* reformat partial derivatives *)
 aux3 = aux2 /. {Derivative[1][f[i_][derivs___]][s] :>
                                 f[i][derivs, newIndex],
                 f[i_][derivs___][s] :> f[i][derivs]};
 (* multiply by D[f, newIndex] *) Expand[aux3 f[newIndex][]]]

Here are the first few derivatives. We use j, k, and l as the dummy summation variables.

d2 = 𝕕[f[i][], j]

d3 = 𝕕[d2, k]

d4 = 𝕕[d3, l]

The number of terms of the resulting expressions grows factorially with increasing number of differentiations.

Length /@ FoldList[𝕕, f[i][], Table[δ[j], {j, 8}]]

For a more readable and more concise version of the multiple-differentiated expressions, we implement a function formatNicely that uses subscripts.

formatNicely[expr_] := expr //. (* use subscripts *)
  {f[i_][derivs__] :> Subscript[f,
   StringReplace[ToString[i] <> ";" <> ToString[{derivs}], 
                    {" " -> "", "{" -> "", "}" -> ""}]],
   f[i_][] :> Subscript[f, ToString[i]]};

formatNicely[d4]

In the last expressions, the two terms (Subscript[f, "i;j,l"]) (Subscript[f, "j;k"]) (Subscript[f, "k"]) (Subscript[f, "l"]) and (Subscript[f, "i;j,k"]) (Subscript[f, "j;l"]) (Subscript[f, "k"]) (Subscript[f, "l"]) are equivalent. By renaming the dummy summations indices k↔l in the last expressions, the second expression becomes identical to the first. The function canonicalize identifies expressions which are identical with respect to the renaming of summation variables by comparing with all possible permutations. This is a straightforward brute-force approach for canonicalization.

(* pure f-term and the prefactor *)
fPair[expr_] := {#, expr/#}&[DeleteCases[expr, _Integer, Infinity]];
(* sort partial derivative variables -- their order does not matter *)
sortDerivs[expr_] := expr //. f[i_][derivs___] :>
                              f[i][Sequence @@ Sort[{derivs}]]

canonicalize[expr_] :=
Module[{vars, perms, rules, newList, oldList, newPair, permElems, pos},
 (* all permutations of the variables *)
 vars = DeleteCases[Union[Level[expr, {-1}]], i | _Integer];
 perms  = Permutations[vars];
 rules = Apply[Rule, Transpose[{vars, #}], {1}]& /@ perms;
 newList = {};
 (* list of f-terms and how many of them *)
 oldList = sortDerivs[fPair /@ (List @@ expr)];
(* check if elements are equivalent *)
While[oldList =!= {},
      newPair = oldList[[1]];
      oldList = Rest[oldList];
      permElems = Union[sortDerivs[newPair[[1]] /. rules]];
      pos = Position[First /@ newList, 
                     _?(MemberQ[permElems, #, Infinity]&), {1}, 1]; 
      If[pos === {}, (* new term *) AppendTo[newList, newPair],
         (* increase counter *) pos = pos[[1, 1]];
         newList[[pos, 2]] = newList[[pos, 2]] + newPair[[2]]]];
(* return simplified result *) Plus @@  Apply[Times, newList, {1}]]

Using the function canonicalize three terms in d4 turn out to be identical.

formatNicely[canonicalize[d4]]

Now it is straightforward to calculate the fifth and sixth derivative. We use m, n, and o as the dummy summation variables.

formatNicely[d5 = canonicalize[𝕕[d4, m]]]

Short[formatNicely[d6 = canonicalize[𝕕[d5, n]]], 12]

The seventh derivative has 48 terms and takes a little while to canonicalize.

Length[d7 = canonicalize[𝕕[d6, o]]] // Timing

formatNicely[d7]

Although canonicalize worked, it is of course a very slow function with a worst case complexity n!. In general the algorithmic simplification of tensor-like expressions is a very difficult problem [737✶], [1286✶], [1287✶], [1288✶]. For the simple case under consideration it is relatively straightforward to implement a more efficient way to canonicalize the derivatives. As a first step towards canonicalization we sort the products of f terms in such a way that the highest derivatives come first. Equal orders of differentiation are sorted lexicographically. To avoid automatic reordering inside the products, we change the head Times to List.

productList[dk_] := 
 Apply[List, (List @@ Expand[dk]) //. i_Integer r__ :> r, {1}]

factorList[dk_] := 
 (List @@ Expand[dk])/Apply[Times, productList[dk], {1}]

sortFProducts[fProductList_] := 
 Last /@ Sort[R = {Length[#], #}& /@ fProductList, 
        Which[#1[[1]] > #2[[1]], True,
              #1[[1]] < #2[[1]], False,
             (* lex *) #1[[1]] == #2[[1]], 
                OrderedQ[{#1[[2]], #2[[2]]}]]&]

Here are the sorted terms of d4.

sortFProducts /@ productList[d4]

As a next step we reindex the expressions in such a way that the indices are lexicograhically increasing. As a subsidiary function we need UnsortedUnion. Given a list l with multiple elements, UnsortedUnion[l] returns a list where the multiple elements are dropped, but the order of the elements is not changed.

UnsortedUnion[l_] := 
Module[{alreadyFound, bag = {}},
       (* step through and collect elements that are new *)
       If[Head[alreadyFound[#]] === alreadyFound,
               alreadyFound[#] = True; bag = {bag, #}]& /@ l;
       (* return elements as they were found *)        
       Flatten[bag]]

reindex[fProductList_] := 
Module[{sortedIndices, indicesInOrder},
 (* sorted list of all indices *)
 sortedIndices = fProductList /. f[i_][jk___] :> {i, jk};
 (* remove doubles *)
 indicesInOrder = UnsortedUnion[DeleteCases[Flatten[sortedIndices], i]];
 (* replace by sorted list of indices *)
 reindexRules = Rule @@@ Transpose[{indicesInOrder, Sort[indicesInOrder]}];
 fProductList /. reindexRules]

For our simplest nontrivial expression, d4 we get now the following.

sortFProducts /@ reindex /@ sortFProducts /@ productList[d4]

Now comes the main step: reindexing the dummy variables such that the expressions become canonical. To do this we sequentially go through the product list and deal with each group of "identical" indices. The first time a dummy index is needed we use the first (in lexicographic order) one that is still available from the indices that are in the same group as the original index. Here is an example of how this works. Say we have the product f[i][j, k, l, m] f[m][l], and we encounter, say, index m. If m has not been seen so far, then make an assignment of the form indicesGroup[m]. If we encounter the index m the second time (meaning in f[m][l]), then evaluate indicesGroup[m]. Take the first element of the returned result and use it as the new dummy variable (here j). Remove assignments of the form indicesGroup[m] and update other assignments for dummies from the same group as m. Add j->m and m->j to the renameList of rules collected. Then go to the next index. At the end apply renameRules in a recursive way.

canonicalizeFProduct[fProductList_] := 
Module[{indicesGroup, renameRules = {}, reIndex, activeIndicesGroup, 
        indicesUsedWithinGroup, activeIndex, usableIndices, indexToBeUsed},
 (* recursively reindex *)
 reIndex[l_] := Fold[(# /. #2)&, l, Partition[renameRules, 2]];
 (* loop over all groups of variables *)
 Do[activeIndicesGroup = reIndex[fProductList[[k1]] /. 
       f -> List /. List[ii_][jk___] :> DeleteCases[{ii, jk}, i]];
    indicesUsedWithinGroup = {};
    (* loop over all variables from one group *)
    Do[activeIndex = activeIndicesGroup[[k2]];
       If[(* index appears for the first time *)
         Head[indicesGroup[activeIndex]] === indicesGroup,
            indicesGroup[activeIndex] =  
              DeleteCases[activeIndicesGroup, 
                          Alternatives @@ indicesUsedWithinGroup],
         (* use the earliest available index *)
         usableIndices = indicesGroup[activeIndex];
         indexToBeUsed = First[usableIndices];
         AppendTo[indicesUsedWithinGroup, activeIndex];                        
         (* update the reindex rules *)
         renameRules = Flatten[{renameRules, 
                                activeIndex -> indexToBeUsed, 
                                indexToBeUsed -> activeIndex}];
          indicesGroup[indexToBeUsed] =. ;
        (* update definitions for indicesGroup *)
         DownValues[indicesGroup] = (RuleDelayed @@ {#[[1]], 
         DeleteCases[Union[#[[2]]], indexToBeUsed, {-1}]})& /@ 
            (DownValues[indicesGroup] /. indexToBeUsed -> activeIndex)],
            {k2, Length[activeIndicesGroup]}],
         {k1, Length[fProductList]}]; 
(* the reindexed result *)
 reIndex[fProductList] /. f[i_][l__] :> f[i] @@ Sort[{l}]]

Here are some examples demonstrating canonicalizeFProducs action.

canonicalizeFProduct[{f[i][j, k, l, m], f[m][l], f[k][]}]

canonicalizeFProduct[{f[i][j, k], f[k][l], f[j][], f[l][]}]

canonicalizeFProduct[{f[i][j, k, l], f[l][m], f[j][], f[k][], f[m][]}]

canonicalize2[expr_] := 
Module[{factors = factorList[expr],
        fTerms = canonicalizeFProduct /@ sortFProducts /@ 
            reindex /@ sortFProducts /@ productList[expr]},
factors.(Times @@@ fTerms)]

canonicalize2 works much faster than canonicalize and produces equivalent results (with differently ordered dummy indices).

canonicalize2[d4] // formatNicely

canonicalize2[d5 = 𝕕[d4, m]] // formatNicely

canonicalize2[d6 = 𝕕[d5, n]] // formatNicely

Now the canonicalization of d7 is much faster. Canonicalization of all 5040 terms using canonicalize2 is about ten times faster then the above canonicalization of the 120 terms of the differentiated precanonicalized d6 from above using canonicalize.

canonicalize2[d7 = 𝕕[d6, o]]; // Timing

For a tree-oriented approach to calculate such expressions, see [253✶], [1497✶], [1213✶], [224✶], [252✶], [190✶], [296✶], [819✶], [820✶], [817✶], [1461✶], [1364✶], [429✶], [165✶], and [818✶]. For a Faà di Bruno-like formula for vector arguments, see [1148✶], [524✶], [582✶], [5✶]. For expressions through Bell polynomials, see [1210✶].

Because Solve produces several solutions, we subsequently have to pick out the relevant one. We do this using numerical techniques. (We could also only look for a primitive root and generate other ones by exponentiation of this one.)

SinCosExact[arg_?((Head[Simplify[#/Pi]] === Rational &&
                   0 < N[#] < N[Pi/2])&)] :=
Module[{denominator, numerator, exponentDenominator, re, im, poly, 
        sol, equations, exSol, nSol, dirSol, pre, pos, c, s},
If[FreeQ[Cos[arg], Cos, {0, Infinity}], {Cos[arg], Sin[arg]},
    {denominator, numerator} = {Denominator[#],
                      Numerator[#]}&[Simplify[arg/Pi]];
    exponentDenominator = If[EvenQ[denominator], denominator/2, denominator];
    (* make two coupled polynomial equations for 
        Cos[arg] and for Sin[arg] *)
    poly = Expand[(c + I s)^exponentDenominator];
    im = Plus @@ Cases[poly, Complex[_, _] _];
    re = poly - im;
    equations = {re == Re[Exp[I arg exponentDenominator]],
                  Cancel[im/I] == Im[Exp[I arg exponentDenominator]]};
    (* solve the two equations *)
    sol = Solve[equations, {c, s}];
    (* analyze solution if they are all _solved _ *)
    If[sol == {{}} ||
       MemberQ[sol, Roots, {0, Infinity}, Heads -> True],
       Print["No analytic solution computable"],
       exSol = {c, s} /. sol; nSol = N[exSol];
    (* compare with numerical value to choose the correct root *)
       dirSol = {Cos[arg], Sin[arg]} // N;
       pre = (Plus @@ #)& /@ Map[Abs, (# - dirSol& /@ nSol), {2}];
       pos = Position[pre, Min[pre]];
       Simplify[{c, s} /. sol[[pos[[1, 1]]]]]]]];

Here are a few examples (and a comparison with the numerical results).

arg = Pi/4; SinCosExact[arg]

% == {Cos[arg], Sin[arg]}

arg = Pi/5; SinCosExact[arg]

% == {Cos[arg], Sin[arg]}

arg = 3Pi/8; SinCosExact[arg]

N[%] == {Cos[arg], Sin[arg]}

Unfortunately, the result of Solve frequently contains an explicit I (by Hölder’s theorem, this is unavoidable [785✶]), and Chop only gives a real numerical solution. Further on, the following result contains more than square and cube roots.

arg = Pi/7; SinCosExact[arg]

N[%] == {Cos[arg], Sin[arg]}

Due to space limitations, we do not carry out the computation of all sin and cos of possible numerator–denominator arrangements, as suggested in the exercise.

Sort @ Union @ Flatten[Range[1, # - 1]/#& /@ Range[1, 10]]

We can also find exact solutions for larger denominators. Here is an example.

arg = 5 Pi/14; SinCosExact[arg]

{%, {Cos[arg], Sin[arg]}} // N

In some sense, the solution of this exercise could be written straightforwardly, without using Mathematica at all. It depends on which roots one allows in the result [338✶], [1642✶]. If we also allow any order, then we can immediately write the following expressions for cos(j2π/n) and sin(j2π/n):.

cos(j 2 π/n)=(1/2)((((-1))^(2j/n))+(((-1))^(-2j/n)))
sin(j 2 π/n)=(1/(2i))((((-1))^(2j/n))-(((-1))^(-2j/n))).

Last, but not least, we could use the function FunctionExpand (to be discussed in Chapter 3) to express cos(j2(π/n)) in radicals. Here are two examples.

FunctionExpand[Cos[Pi/9]]

FunctionExpand[Sin[Pi/14]]

Because we know explicit expressions involving only square roots for the fractions (Subscript[p, 3])/3, (Subscript[p, 5])/5, and (Subscript[p, 17])/17, and because by using half-angle formulas and multiple-angle formulas we can produce expressions involving only square roots for arguments of the form (OverTilde[p])/(2^n)π, the first step is to express p/q in the following form (where the denominators actually present are given by the prime factorization of q=(2^i)(3^(0Or1))(5^(0Or1))(17^(0Or1))): p/q=(Subscript[p, 2])/(2^i)+(Subscript[p, 3])/3+(Subscript[p, 5])/5+(Subscript[p, 17])/17.

Due to the size of the expressions calculated in Section 1.8.2 for cos(2π/257), here and in the following, we assume that no larger Fermat prime than 17 is present in the denominator; the inclusion of the case that larger ones are present is straightforward.

Multiplying the above equation by q, we get a linear Diophantine equation in several unknowns ((Subscript[p, 2]), (Subscript[p, 3]), (Subscript[p, 5]), and (Subscript[p, 17])). There is a straightforward way to solve a Diophantine equation of the following form: (Subscript[a, 1])(Subscript[x, 1])+(Subscript[a, 2])(Subscript[x, 2])+⋯+(Subscript[a, n])(Subscript[x, n])=d.

Here, the (Subscript[a, i]) and d are given integer coefficients and the (Subscript[x, i]) are the unknowns. We search for the smallest coefficient (Subscript[a, j]) among the (Subscript[a, i]), and solve for the corresponding (Subscript[x, j]). In the resulting expression (Subscript[x, j])=(∑_((k=1)/(k≠j))^n)(Subscript[a, k])/(Subscript[a, j])(Subscript[x, k]) the integer part of the (Subscript[a, k])/(Subscript[a, j]) is explicitly separated (because (Subscript[a, j]) is the smallest coefficient, there is always a nonzero integer part)

(Subscript[x, j])=(∑_((k=1)/(k≠j))^n)(Subscript[(((Subscript[a, k])/(Subscript[a, j]))), ("int")])(Subscript[x, k])+(∑_((k=1)/(k≠j))^n)(Subscript[(((Subscript[a, k])/(Subscript[a, j]))), ("fract")])(Subscript[x, k]).

Because we look for integer solutions (Subscript[x, j]) only, the second sum again must be an (still undetermined) integer (Subscript[b, j]). So we have a new equation of a form similar to the starting equation with one less unknown variable (∑_((k=1)/(k≠j))^n)(Subscript[((Subscript[a, k])/(Subscript[a, j])), ("fract")])(Subscript[x, k])=(Subscript[b, j]).

Now selecting again the smallest coefficient among the coefficients of this sum, the above process is repeated until it ends with one equation connecting the last two coefficients. Then the calculated values for the parameters (Subscript[b, j]),… are substituted back. Here, this algorithm is implemented. We use C[i] as the undetermined parameters of the solution. (There are of course more efficient, number-theory-based algorithms to solve linear Diophantine equations. But because of the obvious working principle of the algorithm described above, we use this one.)

eliminateSmallestPart[eq_, i_, vars_] :=
Module[{coeffTimesVarList, coeffList, positionSmallestCoeff,
        varToSolveFor, eqSolved, integerPart, fractionalPart},
 (* find smallest coefficient *)
 coeffTimesVarList = 
      Cases[eq, Alternatives @@ Join[_ #& /@ vars, {_ _C}]];
 coeffList = coeffTimesVarList //. Join[# -> 1& /@ vars, {_C -> 1}];
 positionSmallestCoeff = If[Length[coeffTimesVarList] > 1,
            Position[Abs[coeffList], Min[Abs[coeffList]]][[1, 1]], 1];
 (* variable corresponding to smallest coefficient *)
 varToSolveFor = Cases[coeffTimesVarList[[positionSmallestCoeff]],
              Alternatives @@ Join[#& /@ vars, {_C}] ];
 (* solve for this variable *)
 eqSolved = Solve[eq == 0, varToSolveFor][[1, 1, 2]] // Expand;
 (* write all fractions in the form (integerPart + fractionalPart) *)
 integerPart = eqSolved //. r_Rational :> Round[r];
 fractionalPart = eqSolved - integerPart;
 {varToSolveFor[[1]] -> integerPart + C[i], C[i] - fractionalPart}]

linearDiophantineSolve[equation_Equal, varList_] :=
Module[{equation1, coeffs, rhs, currentEquation, aux, integerPartBag, 
        n, substitutedSolutions, substitutedSolutionswithOutTempVars,
        rhss, remainingFreeVars, additionalParameterVars, rules,
        expandAll = If[Head[#] === Rule, ExpandAll /@ #, ExpandAll @ #]&},
 (* write equation in form Sum[coeff[i] var[i], {i, m}] = integer *)
 equation1  = Subtract @@ equation;
 coeffs = Coefficient[equation1, #]& /@ varList;
 rhs = Expand[coeffs.varList - equation1];
 (* solvability condition *)
 If[Mod[rhs, GCD @@ coeffs] =!= 0, {},
 (* recursively solve for var with smallest
    coefficient until process terminates *)
   integerPartBag = {};
   currentEquation = equation1; i = 0; 
   While[i = i + 1; aux = eliminateSmallestPart[
                                    currentEquation, i, varList]; 
         currentEquation = aux[[2]];
         If[i > 1,
            (* termination conditions *)
            currentEquation =!= C[i] &&
            (MemberQ[currentEquation,
                     Alternatives @@ varList, {0, Infinity}] ||
            MemberQ[Solve[currentEquation == 0, C[i - 1]][[1, 1, 2]],
                    _Rational, {0, Infinity}]), True],
        AppendTo[integerPartBag, aux]]; 
  AppendTo[integerPartBag, aux];
  n = Length[integerPartBag];
   sol = If[MemberQ[integerPartBag[[-1, 2]], C[n - 1], {0, Infinity}],
            Solve[integerPartBag[[-1, 2]] == 0, C[n - 1]], {{C[n] -> 0}}];
   (* substitute solutions back *)
   substitutedSolutions = 
     Fold[{Flatten[{expandAll[#2 //. Flatten[#1]], #1}]}&,
        {expandAll[integerPartBag[[-1, 1]] //. sol[[1, 1]]]},
              Flatten[(First /@ Rest[Reverse[integerPartBag]]) //. sol]];
   substitutedSolutionswithOutTempVars =
            DeleteCases[Flatten[substitutedSolutions], _C -> _];
   rhss = Last /@ substitutedSolutionswithOutTempVars;
  (* introduce parameter variables in
     case a variable from varList is used *)
   remainingFreeVars = Union[Cases[rhss, Alternatives @@ varList,
                                   {0, Infinity}]];
   additionalParameterVars =
         Table[C[j], {j, i + 1, i + 1 + Length[remainingFreeVars] - 1}];
   (* make rules for the result *)
   rules = Apply[Rule, Transpose[{remainingFreeVars,
                                   additionalParameterVars}], {1}];
   (* return result, recursively backsubstituted *)
   Flatten[{substitutedSolutionswithOutTempVars //. rules, rules}]]] /;
   (* test if equation is a linear diophantine equation *)
   Function[eq1, Function[coeffs, Not[And @@ (NumberQ /@ N[varList])] &&
     Union[Exponent[eq1, varList]] === {1} && And @@ (IntegerQ /@ coeffs) &&
     IntegerQ[Expand[eq1 - coeffs.varList]]][
            Coefficient[eq1, #]& /@ varList]][Subtract @@ equation]

Let us test linearDiophanticneSolve using a few examples.

linearDiophantineSolve[16 x[1] + 17 x[2] == 2, {x[1], x[2]}]

16 x[1] + 17 x[2] == 2 //. % // ExpandAll

linearDiophantineSolve[17 x[1] + 5 x[2] == 15, {x[1], x[2]}]

17 x[1] + 5 x[2] == 15 //. % // ExpandAll

linearDiophantineSolve[17 x + 5 y + 8 z == 7, {x, y, z}]

17 x + 5 y + 8 z == 7 //. % // ExpandAll

Now we use the routine linearDiophantineSolve for determining the numerators in the above decomposition of p/q. Actually, we do not need the full parametrized solution, but only one special one. Because we do not need explicit variable names for the unknowns later, the following function lDS takes as its arguments a list of the coefficients (Subscript[a, i]) and the right-hand side d, and it returns a list of a special solution set (Subscript[x, i]). (One special solution can be obtained in a shorter way; see [243✶], [1359✶], and [1220✶].)

lDS[abList_, d_] :=
Module[{vars, sol, res, paramVars},
  vars = Table[Unique[x], {Length[abList]}];
  sol = linearDiophantineSolve[vars.abList == d, vars];
  res = vars /. sol;
  paramVars = Union[Cases[res, _C, {0, Infinity}]];
  res /. Apply[Rule, (* just take all parameters equal to 0 *)
         Transpose[{paramVars, Table[0, {Length[paramVars]}]}], {1}]]

Let us test lDS again using a few examples.

lDS[{123, 73, 90}, 3]

%.{123, 73, 90}

lDS[{15, 40, 24}, 1]

%.{15, 40, 24}

lDS[{11, -29, 17}, -3]

%.{11, -29, 17}

Now we can implement a function sumOfFractions that gives the summands of the partial fraction decomposition of a fraction p/q with the denominators being given by the prime factorization of q.

sumOfFractions[frac:Rational[p_, q_]] :=
Module[{fa0 = FactorInteger[q], fa, lds},
   If[Length[fa0] > 1,
      fa = Apply[Power, fa0, {1}];
      lds = lDS @@ {1/fa q, Numerator[frac]};
      tmp = lds/fa; If[(Plus @@ tmp) > 1, Append[tmp, -1], tmp], frac]]

Here are two examples.

sumOfFractions[1/120]

Plus @@ %

sumOfFractions[13/(2^3 5 17)]

Plus @@ %

To test if a given fraction belongs to the class that represents arguments so that the corresponding trigonometric expressions can be expressed in square roots, we implement a function squareRootableQ[p/q] that returns True or False depending on whether it is possible to express trigonometric functions of p/qπ by using only addition, subtraction, multiplication, division, and square rooting.

squareRootableQ[frac:Rational[p_, q_]] := squareRootableQ[frac] =
Module[{fa0 = FactorInteger[q], oddPrimeParts},
 If[(* are the only primes 2 and/or 3 and/or 5 and/or 17? *)
    Complement[First /@ fa0, {2, 3, 5, 17}] === {},
    (* are the primes and/or 3 and/or 5 and/or 17 with power 0 or 1? *)
    oddPrimeParts = Cases[fa0, {3, _} | {5, _} | {17, _}];
     If[Length[oddPrimeParts] > 0,
        If[Union[Last /@ oddPrimeParts] =!= {1}, False, True], True],
    False]]

Taking into account the above-stated conditions when this can be done, we easily verify the following examples.

squareRootableQ[1/(2^3 5^3)]

squareRootableQ[1/(2^4 3 5 17)]

squareRootableQ[131/(2^12 17)]

To actually express a trigonometric function of p/qπ we need explicit expressions for basic fractions of the form (Subscript[p, 2])/(2^n)π, (Subscript[p, 3])/3π, (Subscript[p, 5])/5π, (Subscript[p, 17])/17π. For fractions less than 1/2, we implement these here. We use our own functions sin and cos here, to avoid any autosimplification of built-in functions. (The other trigonometric functions we express later through sin and cos.)

sin[0] = 0;
cos[0] = 1;

sin[Pi/3] = Sqrt[3]/2;
cos[Pi/3] = 1/2;

sin[Pi/5] = Sqrt[(5 - Sqrt[5])/2]/2;
cos[Pi/5] = (1 + Sqrt[5])/4;

sin[2 Pi/5] = Sqrt[(5 + Sqrt[5])/2]/2;
cos[2 Pi/5] = (-1 + Sqrt[5])/4;

(* use some abbreviations to shorten definitions *)
With[{𝓈 = Sqrt}, Module[{α = 𝓈[17 - 𝓈[17]], β = 𝓈[17 + 𝓈[17]]}, 
cos[1 Pi/17] = 𝓈[15 + 𝓈[17] + 𝓈[2] α +  𝓈[2] 𝓈[34 + 6 𝓈[17] - 𝓈[2] α +
                 𝓈[34] α - 8 𝓈[2] β]]/(4 𝓈[2]);
sin[1 Pi/17] = 𝓈[8 - 𝓈[2] 𝓈[15 + 𝓈[17] - 𝓈[2] α +
                 𝓈[2] 𝓈[34 + 6 𝓈[17] + 𝓈[2] α - 𝓈[34] α + 8 𝓈[2] β]]]/4;
cos[2 Pi/17] = 𝓈[15 + 𝓈[17] - 𝓈[2] α + 𝓈[2] 𝓈[34 + 6 𝓈[17] + 𝓈[2] α -
                 𝓈[34] α + 8 𝓈[2] β]]/(4 𝓈[2]);
sin[2 Pi/17] = 𝓈[8 - 𝓈[2] 𝓈[15 + 𝓈[17] + 𝓈[2] α - 𝓈[2] 𝓈[34 + 6 𝓈[17] - 
                 𝓈[2] α + 𝓈[34] α - 8 𝓈[2] β]]]/4;
cos[3 Pi/17] = 𝓈[15 - 𝓈[17] + 𝓈[2] β + 𝓈[2] 𝓈[34 - 6 𝓈[17] + 8 𝓈[2] α -
                 𝓈[2] β - 𝓈[34] β]]/(4 𝓈[2]);
sin[3 Pi/17] = 𝓈[8 - 𝓈[2] 𝓈[15 - 𝓈[17] - 𝓈[2] β + 𝓈[2] 𝓈[34 - 6 𝓈[17] - 
                 8 𝓈[2] α + 𝓈[2] β + 𝓈[34] β]]]/4;
cos[4 Pi/17] = 𝓈[15 + 𝓈[17] + 𝓈[2] α - 𝓈[2] 𝓈[34 + 6 𝓈[17] - 𝓈[2] α +
                 𝓈[34] α - 8 𝓈[2] β]]/(4 𝓈[2]);
sin[4 Pi/17] = 𝓈[8 - 𝓈[2] 𝓈[15 + 𝓈[17] - 𝓈[2] α - 𝓈[2] 𝓈[34 + 6 𝓈[17] + 
                 𝓈[2] α - 𝓈[34] α + 8 𝓈[2] β]]]/4;
cos[5 Pi/17] = 𝓈[15 - 𝓈[17] + 𝓈[2] β - 𝓈[2] 𝓈[34 - 6 𝓈[17] + 8 𝓈[2] α -
                 𝓈[2] β - 𝓈[34] β]]/(4 𝓈[2]);
sin[5 Pi/17] = 𝓈[17 + 𝓈[17] - 𝓈[2] β + 𝓈[2] 𝓈[34 - 6 𝓈[17] + 8 𝓈[2] α -
                 𝓈[2] β - 𝓈[34] β]]/(4 𝓈[2]);
cos[6 Pi/17] = 𝓈[15 - 𝓈[17] - 𝓈[2] β + 𝓈[2] 𝓈[34 - 6 𝓈[17] - 8 𝓈[2] α +
                 𝓈[2] β + 𝓈[34] β]]/(4 𝓈[2]);
sin[6 Pi/17] = 𝓈[17 + 𝓈[17] + 𝓈[2] β - 𝓈[2] 𝓈[34 - 6 𝓈[17] - 8 𝓈[2] α +
                 𝓈[2] β + 𝓈[34] β]]/(4 𝓈[2]);
cos[7 Pi/17] = 𝓈[15 - 𝓈[17] - 𝓈[2] β - 𝓈[2] 𝓈[34 - 6 𝓈[17] - 8 𝓈[2] α +
                 𝓈[2] β + 𝓈[34] β]]/(4 𝓈[2]);
sin[7 Pi/17] = 𝓈[17 + 𝓈[17] + 𝓈[2] β + 𝓈[2] 𝓈[34 - 6 𝓈[17] - 8 𝓈[2] α +
                 𝓈[2] β + 𝓈[34] β]]/(4 𝓈[2]);
cos[8 Pi/17] = 𝓈[15 + 𝓈[17] - 𝓈[2] α - 𝓈[2] 𝓈[34 + 6 𝓈[17] + 𝓈[2] α -
                 𝓈[34] α + 8 𝓈[2] β]]/(4 𝓈[2]);
sin[8 Pi/17] = 𝓈[17 - 𝓈[17] + 𝓈[2] α +  𝓈[2] 𝓈[34 + 6 𝓈[17] + 𝓈[2] α -
                 𝓈[34] α + 8 𝓈[2] β]]/(4 𝓈[2])]];

Now remaining is the implementation of the reduction of every “square rootable” trigonometric function to the previously-defined cases. 
All trigonometric functions are periodic with period 2π.

cos[(fract_Rational | fract_Integer) Pi] :=
       (cos[fract Pi] = cos[Mod[fract, 2] Pi]) /; fract >= 2

sin[(fract_Rational | fract_Integer) Pi] :=
       (sin[fract Pi] = sin[Mod[fract, 2] Pi]) /; fract >= 2

Trigonometric functions with arguments π<p/qπ<2π can be reduced to arguments in the range (0,π).

cos[(fract_Rational | fract_Integer) Pi] :=
       (cos[fract Pi] = +cos[(2 - fract) Pi]) /; fract >= 1

sin[(fract_Rational | fract_Integer) Pi] :=
       (sin[fract Pi] = -sin[(2 - fract) Pi]) /; fract >= 1

We can actually go one step further: trigonometric functions with arguments π/2<p/qπ<π can be reduced to arguments in the range (0,π/2).

cos[fract_Rational Pi] :=
       (cos[fract Pi] = -cos[(1 - fract) Pi]) /; fract > 1/2

sin[fract_Rational Pi] :=
       (sin[fract Pi] = +sin[(1 - fract) Pi]) /; fract > 1/2

And in the case q=(2^n), we can go still one step further and reduce all arguments to the range (0,π/4).

cos[fract_Rational Pi] :=
       (cos[fract Pi] = sin[(1/2 - fract) Pi]) /; fract > 1/4

sin[fract_Rational Pi] :=
       (sin[fract Pi] = cos[(1/2 - fract) Pi]) /; fract > 1/4

Taking again into account the periodicity of trigonometric functions, negative arguments can always be transformed to positive ones.

cos[fract_Rational Pi] :=
       (cos[fract Pi] = +cos[-fract Pi]) /; fract < 0

sin[fract_Rational Pi] :=
       (sin[fract Pi] = -sin[-fract Pi]) /; fract < 0

The next rule governs the case when the numerator is 1 and the denominator is a power of 2 by recursively using half-angle formulas.

cos[fract_Rational Pi] :=
(cos[fract Pi] = Sqrt[Together[(1 + cos[2 fract Pi])/2]]) /;
     fract > 0 && MatchQ[FactorInteger[1/fract], {{2, _?(# > 1&)}}] &&
     Numerator[fract] === 1

sin[fract_Rational Pi] :=
(sin[fract Pi] = Sqrt[Together[(1 - cos[2 fract Pi])/2]]) /;
     fract > 0 && MatchQ[FactorInteger[1/fract], {{2, _?(# > 1&)}}] &&
     Numerator[fract] === 1

Using multiple-angle formulas, arguments p/qπ can be reduced to a sum of products of trigonometric functions with argument 1/qπ.

cos[fract_Rational Pi] := (cos[fract Pi]  =
With[{z = 1/Denominator[fract] Pi, n = Numerator[fract]},
 Factor @ Together @
 (* this might be a bit dangerous from a timing point of view
    for large n *)
 Sum[(-1)^k Binomial[n, 2k] cos[z]^(n - 2k) (1 - cos[z]^2)^k,
     {k, 0, n/2}]]) /;
       Numerator[fract] > 1 && IntegerQ[Log[2, Denominator[fract]]]

sin[fract_Rational Pi] := (sin[fract Pi]  =
With[{z = 1/Denominator[fract] Pi, n = Numerator[fract]},
 Factor @ Together @
 (* this might be a bit dangerous from a timing point of view *)
 Sum[(-1)^(k) Binomial[n, 2k + 1] sin[z]^(2k + 1) cos[z]^(n - 2k - 1),
     {k, 0, (n - 1)/2}]]) /;
  Numerator[fract] > 1 && IntegerQ[Log[2, Denominator[fract]]]

The last rules govern the generic case p/qπ. If the argument is such that the trigonometric function can be expressed in square roots, the decomposition of p/q is actually carried out and the resulting sum of products of trigonometric functions contains the already implemented cases.

cos[fract_Rational Pi] := (cos[fract Pi]  =
Module[{singles, auxVars, expa},
 (* write fract as a sum of fractions with
    denominators 3 or 5 or 17 or powers of 2 *)
 singles = sumOfFractions[fract];
 (* introduce dummy variable for expanding the sum of fractions *)
 auxVars = Table[cc[i], {i, Length[singles]}];
 expa = cos[Plus @@ auxVars]  //.
           {sin[x_ + y_] :> sin[x] cos[y] + cos[x] sin[y],
            cos[x_ + y_] :> cos[x] cos[y] - sin[x] sin[y]};
 (* substitute fractions for dummy variables *)
 expa //. Apply[Rule, Transpose[{auxVars, singles Pi}], {1}]]) /;
 squareRootableQ[fract]

sin[fract_Rational Pi] := (sin[fract Pi]  =
Module[{singles, auxVars, expa},
 (* write fract as a sum of fractions with
    denominators 3 or 5 or 17 or powers of 2 *)
 singles = sumOfFractions[fract];
  (* introduce dummy variable for expanding the sum of fractions *)
 auxVars = Table[cc[i], {i, Length[singles]}];
 expa = sin[Plus @@ auxVars]  //.
           {sin[x_ + y_] :> sin[x] cos[y] + cos[x] sin[y],
            cos[x_ + y_] :> cos[x] cos[y] - sin[x] sin[y]};
 (* substitute fractions for dummy variables *)
 expa //. Apply[Rule, Transpose[{auxVars, singles Pi}], {1}]]) /;
 squareRootableQ[fract]

We reduce the trigonometric functions tan, cot, sec, and csc to rational functions of sin and cos with the same arguments.

tan[z:(fract_Rational Pi)] := (tan[z] = sin[z]/cos[z]) /;
                                          squareRootableQ[fract]

cot[z:(fract_Rational Pi)] := (cot[z] = cos[z]/sin[z]) /;
                                          squareRootableQ[fract]

sec[z:(fract_Rational Pi)] := (sec[z] = 1/cos[z]) /;
                                          squareRootableQ[fract]

csc[z:(fract_Rational Pi)] := (csc[z] = 1/sin[z]) /;
                                          squareRootableQ[fract]

Now we have everything together to define a function TrigToSquareRoots[expr] that expresses every trigonometric function in expr, which can be expressed in square roots.

TrigToSquareRoots[expr_] :=
(expr //. {Sin -> sin, Cos -> cos, Tan -> tan, Cot -> cot,
           Sec -> sec, Csc -> csc}) //.
    (* restore nontransformed expressions *)
          {sin -> Sin, cos -> Cos, tan -> Tan, cot -> Cot,
           sec -> Sec, csc -> Csc}

Here are a few examples. First are some fractions with denominators being fractions of 2.

sin[1/16Pi]

sin[Pi/256]

Here are two compound denominators.

cos[1/(2 3 5) Pi]

cos[1/272 Pi]

These are all fractions 1/q with numerator 1, which allow the corresponding trigonometric functions with argument π/q to be expressed in square roots.

Select[1/Range[1000], squareRootableQ]

We test all of these fractions using the Cos function.

Chop[N[TrigToSquareRoots[Cos[# Pi]] - Cos[# Pi]]& /@ %]

Here is a more complicated expression, which contains various trigonometric functions and arguments.

largeExpr = Sin[Pi/15] + Cos[Pi/544] + Tan[Pi/17] + Sec[5 Pi/256] //
                                                  TrigToSquareRoots;

This expression contains quite a few square roots.

Count[largeExpr, Power[_, 1/2] | Power[_, -1/2]]

This is a quick numerical test using 100 digits that the applied transformation was correct.

Off[$MaxExtraPrecision::meprec];
N[Sin[Pi/15] + Cos[Pi/544] + Tan[Pi/17] + Sec[5 Pi/256] - 
  largeExpr, 1000]

The resulting square roots can be sometimes simplified; see [191✶] and [1014✶].

All of the above was an interesting exercise for programming. If one is just interested in the result, the built-in function FunctionExpand (to be discussed in Chapter 3) will rewrite trigonometric functions of arguments of the form rational π in radicals, if possible in square roots.

FunctionExpand[Sin[Pi/(2^4 5)]]

FunctionExpand can also express sec(π/25) in radicals, although not in square roots.

FunctionExpand[Sec[Pi/25]]

From part a) of this exercise, we have the following two equations for c1=cos(π/7) and s1=sin(π/7).

{TrigExpand[Cos[7 V]] == -1, TrigExpand[Sin[7 V]] == 0} /. 
                             {Cos[V] -> c1, Sin[V] -> s1}

Elimination of s1 yields the following.

d1 = Eliminate[%, s1]

This equation factors into simpler pieces, which we will use later.

Factor[Subtract @@ d1]

All roots of d1 are well separated.

Min[Flatten[MapIndexed[Drop[#1, #2]&,
              Outer[Abs[Sqrt[#1^2 - #2^2]]&, #, #]&[
                              c1 /. NSolve[d1, c1]]]]]

Therefore, we are sure to have Cos[Pi/7] as a solution of 1 - 4c1 - 4c1^2 + 8c1^3 == 0.

{NRoots[1 - 4 c1 - 4 c1^2 + 8 c1^3 == 0, c1], Cos[Pi/7] // N}

Now let us simplify the three given identities. First we rewrite in terms of Sin[2Pi/7] and Sin[3Pi/7] in Sin[Pi/7] and Cos[Pi/7].

TrigExpand[{Sin[2 a], Sin[3 a]}]

repRules = {s2 -> 2 c1 s1, s3 -> 3 s1 - 4 s1^3};

So we have the first identity.

id1 = s2/s3^2 - s1/s2^2 + s3/s1^2 == 2 Sqrt[7]

This gives the following equation.

(Numerator[#]^2 - (id1[[2]] Denominator[#])^2)&[Together[id1[[1]]]]

Elimination of s1 results in a polynomial.

Eliminate[{(% /. repRules) == 0, c1^2 + s1^2 == 1}, s1]

This has solutions similar to the equation d1.

PolynomialGCD[Subtract @@ %, Subtract @@ d1] // Factor

Here is the same calculation (in an abbreviated form) for the second identity.

id2 = s2^2/s3^4 + s1^2/s2^4 + s3^2/s1^4 == 28;

PolynomialGCD[Subtract @@ Eliminate[{(
     (Numerator[#] - id2[[2]] Denominator[#])&[
         Together[id2[[1]]]] /. repRules) == 0,
           c1^2 + s1^2 == 1}, s1], Subtract @@ d1] // Factor

Here it is for the third identity.

id3 = s3^2/s1^4 ( 2 s2/s3 + 4 s3/s1) +
      s1^2/s2^4 (-2 s3/s1 + 4 s1/s2) -
      s2^2/s3^4 ( 2 s1/s2 + 4 s2/s3) == 280;

PolynomialGCD[Subtract @@ Eliminate[{(
     (Numerator[#] - id3[[2]] Denominator[#])&[
         Together[id3[[1]]]] /. repRules) == 0,
           c1^2 + s1^2 == 1}, s1], Subtract @@ d1] // Factor

This gives the same result. Because we have done all calculations so far for cos(nπ/7), we must determine which of the possible ±sin(nπ/7)=sin(±nπ/7) do not fulfill the identities. This is easily done by plugging in the numerical values in all possible combinations. (We exclude the solution n=0 because this would give zeros in the denominators.) The testing must of course give $MaxExtraPrecision::meprec messages.

Off[$MaxExtraPrecision::"meprec"];
TableForm[
Outer[N[#1 //. {s1 -> Sin[1 #2 Pi/7], s2 -> Sin[2 #2 Pi/7],
                s3 -> Sin[3 #2 Pi/7]}]&,
     {id1, id2, id3}, Range[6]],
     TableHeadings -> {{"id1", "id2", "id3"},
                       {" 1\n", " 2", " 3", " 4", " 5", " 6"}}]

This also answers the question for which integers n there are similar identities. 
Now we will give a straightforward solution using RootReduce. We first transform the trigonometric functions into exponentials using TrigToExp. Then we transform the exponentials into explicit algebraic numbers of the form (((-1))^rational) using Together, and finally we use RootReduce to canonicalize the resulting algebraic number. These three operations are put together in the function simplify.

simplify[expr_] :=
RootReduce[RootReduce[Together[TrigToExp[#]]]& /@ expr]

Here are the three identities checked.

simplify @ (Sin[2Pi/7]/Sin[3Pi/7]^2 - Sin[1Pi/7]/Sin[2Pi/7]^2 +
            Sin[3Pi/7]/Sin[1Pi/7]^2)

simplify @ (Sin[2Pi/7]^2/Sin[3Pi/7]^4 + Sin[1Pi/7]^2/Sin[2Pi/7]^4 +
            Sin[3Pi/7]^2/Sin[1Pi/7]^4)

simplify @ 
(Sin[3Pi/7]^2/Sin[1Pi/7]^4 *
         ( 2 Sin[2Pi/7]/Sin[3Pi/7] + 4 Sin[3Pi/7]/Sin[1Pi/7]) +
 Sin[1Pi/7]^2/Sin[2Pi/7]^4 *
         (-2 Sin[3Pi/7]/Sin[1Pi/7] + 4 Sin[1Pi/7]/Sin[2Pi/7]) -
 Sin[2Pi/7]^2/Sin[3Pi/7]^4 *
         ( 2 Sin[1Pi/7]/Sin[2Pi/7] + 4 Sin[2Pi/7]/Sin[3Pi/7]))

In a similar way, we can now check the sin(expr)⟶sin(n expr) part of the exercise.

Table[{k, simplify @ (Sin[k 2Pi/7]/Sin[k 3Pi/7]^2 -
                      Sin[k 1Pi/7]/Sin[k 2Pi/7]^2 +
                      Sin[k 3Pi/7]/Sin[k 1Pi/7]^2)}, {k, 1, 6}]

Table[{k, simplify @ (Sin[k 2Pi/7]^2/Sin[k 3Pi/7]^4 +
                      Sin[k 1Pi/7]^2/Sin[k 2Pi/7]^4 +
                      Sin[k 3Pi/7]^2/Sin[k 1Pi/7]^4)}, {k, 1, 6}]

Table[{k, simplify @ 
(Sin[k 3Pi/7]^2/Sin[k 1Pi/7]^4 *
    ( 2 Sin[k 2Pi/7]/Sin[k 3Pi/7] + 4 Sin[k 3Pi/7]/Sin[k 1Pi/7]) +
 Sin[k 1Pi/7]^2/Sin[k 2Pi/7]^4 *
    (-2 Sin[k 3Pi/7]/Sin[k 1Pi/7] + 4 Sin[k 1Pi/7]/Sin[k 2Pi/7]) -
 Sin[k 2Pi/7]^2/Sin[k 3Pi/7]^4 *
    ( 2 Sin[k 1Pi/7]/Sin[k 2Pi/7] + 4 Sin[k 2Pi/7]/Sin[k 3Pi/7]))},
      {k, 1, 6}]

Additional interesting trigonometric identities can be derived, for example, [1272✶], [331✶], [117✶], [644✶], [437✶], [832✶], and [1631✶]. For instance, the following identities hold [118✶]:

DedekindCotIdentity[a_Integer?Positive, c_Integer?Positive] :=
4c Sum[#[n/c] #[a n/c], {n, 1, c - 1}]&[# - Floor[#] - 1/2&] ==
   Sum[Cot[Pi n/c] Cot[Pi a n/c], {n, 1, c - 1}] /; GCD[a, c] === 1

BenczeCotIdentity[m_Integer?Positive][n_Integer?Positive] := 
Module[{k}, Sum[Product[Cot[k[r] Pi/(2n + 1)]^2, {r, m}], ##]& @@
            Table[{k[j], If[j === 1, 1, k[j - 1] + 1], n}, {j, m}]] == 
            (2n)!/((2m + 1)!(2n - 2m)!)

y = (α + β x)/(αs + βs x)

We can express the value of M(k) in terms of α(k),β(k),α'(k),β'(k) by substituting the value x=0 in the given equation.

M = ((1 - y^2) (1 - l^4 y^2)/((1 - x^2) (1 - k^4 x^2))/D[y, x]^2 /.
      x -> 0) // Together

One could think that a possibility to solve the problem would be to construct

((y'(x))^2)M(k)(1-(x^2))(1-(k^4)(x^2))-(1-((y(x,k))^2))(1-((l(k))^4)((y(x,k))^2))=0

and equate all coefficients of the various powers of x to zero and solve the resulting system of equations.

Solve[# == 0& /@ CoefficientList[Numerator[Together[
         D[y, x]^2 M (1 - x^2)(1 - k^4 x^2) - (1 - y^2)(1 - l^4 y^2)]], x],
      {α, αs, β, βs, l}]

Unfortunately, Solve will never return a solution of the last code. So we must help a bit manually. In the first step, we rewrite the part (1-(x^2))(1-(k^4)(x^2)) as follows.

yPart = (1 - y^2)(1 - l^4 y^2) 1/D[y, x]^2 1/ M // Together // Factor

We apply some cosmetic manipulations to this expression.

yPartFactored = Times @@ ({1, x}.#& /@
   ((((CoefficientList[#, x]& /@ (List @@
       Numerator[yPart]))/(List @@ Denominator[yPart]) //
                                      Cancel)) // Cancel))

If the product of these four factors (Subscript[f, 1])(Subscript[f, 2])(Subscript[f, 3])(Subscript[f, 4]) with (Subscript[f, 1])=1+(β-β')x/(α-α'), (Subscript[f, 2])=1+(β+β')x/(α+α'), (Subscript[f, 3])=1+(β'-β(l^2))x/(α'-α(l^2)), and (Subscript[f, 4])=1+(β'+β(l^2))x/(α'+α(l^2)) is equal to (1-(x^2))(1-(k^4)(x^2)), this means that either

({{(Subscript[f, 1])(Subscript[f, 2])=(1-(x^2)), " and "(Subscript[f, 3])(Subscript[f, 4])=(1-(k^4)(x^2))" or "}, {(Subscript[f, 1])(Subscript[f, 3])=(1-(x^2)), " and "(Subscript[f, 2])(Subscript[f, 4])=(1-(k^4)(x^2))" or "}, {(Subscript[f, 1])(Subscript[f, 4])=(1-(x^2)), " and "(Subscript[f, 2])(Subscript[f, 3])=(1-(k^4)(x^2))" or "}, {…, }})

Here, the six possible combinations of two factors from yPartFactored are calculated.

yPartFactoredList =
 Flatten[Table[{yPartFactored[[i]] yPartFactored[[j]],
 yPartFactored/(yPartFactored[[i]] yPartFactored[[j]])},
               {i, 4}, {j, i + 1, 4}], 1];

We now generate all possible equations listed above and extract the coefficients of the powers of x.

allEquations = DeleteCases[Join[
 Apply[Join, Map[CoefficientList[#, x]&,
       # - {1 - x^2, 1 - k^4 x^2}& /@ yPartFactoredList, {2}], {1}],
 Apply[Join, Map[CoefficientList[#, x]&,
       # - {1 - k^4 x^2, 1 - x^2}& /@ yPartFactoredList, {2}], {1}]], 
                           0, {2}];

Short[allEquations, 8]

Mathematica still cannot solve the resulting equations. Looking at the left-hand sides of the equations, contained in allEquations, we see that the variables α(k), β(k), α'(k), β'(k), and l(k) appear only in certain combinations. So we introduce some auxiliary variables, solve the resulting equations, and finally solve for the variables α(k), β(k), α'(k), β'(k), and l(k). The solutions so obtained are sometimes of the form Sqrt[someExpression^2]. They can be somewhat simplified. Because the result could be ±"something", we generate both possibilities with the help of the following function.

getRidOfSquareRoots[sol_] :=
Module[{aux1, squareRoots, powerExpandedSquareRoots,
        allPowerExpandedSquareRoots, repRules},
If[(* no square root present *)
   FreeQ[sol, Power[_, 1/2] | Power[_, -1/2]],
   Factor //@ Together //@ sol,
   (* square roots present *)
   (* eliminate all square roots by using PowerExpand
      and generate all possible solutions *)
For[aux1 = (Factor //@ Together //@ sol) /. 
               Power[b_, 1/2] :> Power[Factor[b], 1/2],
    aux1 = (Factor //@ Together //@ aux1) /. 
               Power[b_, 1/2] :> Power[Factor[b], 1/2];
(* all square roots on lowest levels *)
squareRoots =
Union[Cases[aux1, Power[_?(FreeQ[#, Power[_,  1/2] |
                                    Power[_, -1/2]]&),  1/2] |
                  Power[_?(FreeQ[#, Power[_,  1/2] |
                                    Power[_, -1/2]]&), -1/2],
                {0, Infinity}]];
squareRoots =!= {}, Null,
(* the list of square roots after applying PowerExpand *)
powerExpandedSquareRoots = PowerExpand[squareRoots];
(* all possible combinations of +1, -1 of all square roots *)
factorList = If[Length[squareRoots] === 1, {{-1}, {1}},
       Flatten[Outer[(-1)^{##}&, ##]& @@ Table[{0, 1},
          {Length[squareRoots]}], Length[squareRoots] - 1]];
allPowerExpandedSquareRoots =
       powerExpandedSquareRoots # & /@ factorList;
(* replacement rules for replacing the square roots *)
repRules = MapThread[Rule, {Table[squareRoots,
      {Length[allPowerExpandedSquareRoots]}],
              allPowerExpandedSquareRoots}, 2];
(* all possible combinations generated *)
aux1 = aux1 //. repRules]; Sequence @@ aux1]]

Here, the solution process is implemented and carried out for all 12 sets of equations.

Off[Solve::svars];

possibleSolutions = Union[Flatten[Table[
(* introduce "obvious" auxiliary variables *)
eqn1 = allEquations[[i]] //.
        {β - βs -> βm, -β + βs -> -βm,
         α - αs -> αm, -α + αs -> -αm,
         β + βs -> βp,  α + αs ->  αp,
         βs - β l^2 -> βlm, -βs + β l^2 -> -βlm,
         αs - α l^2 -> αlm, -αs + α l^2 -> -αlm,
         βs + β l^2 -> βlp,  αs + α l^2 ->  αlp};
(* eliminate a few of the auxiliary variables *)
sol1 = Solve[# == 0& /@ eqn1, {αm, αp, βm, βp, αlm, αlp, βlm, βlp}];
(* the so simplified equations *)
eqn2 = {β - βs - βm, α - αs - αm, β + βs - βp, α + αs - αp,
        βs - β l^2 - βlm, αs - α l^2 - αlm,
        βs + β l^2 - βlp, αs + α l^2 - αlp} //. sol1;
(* eliminate all still-present auxiliary variables
   and solve for a, as, b, bs, l *)
preSolution0 = Flatten[
Solve[Eliminate[# == 0& /@ #, {αm, αp, βm, βp, αlm, αlp, βlm, βlp}],
      {α, αs, β, βs, l}]& /@ eqn2, 1];
      (* get rid of square roots if present *)
preSolution1 = Union[getRidOfSquareRoots /@ preSolution0];
(* get rid of trivial solution *)
preSolution2 = DeleteCases[Sort[#, OrderedQ[{#1[[1]], #2[[1]]}]&]& /@
                               MapAll[Together, preSolution1],
                        {α -> 0, αs -> 0, β -> 0, βs -> 0, ___}];
(* y[x], M and l^4 *)
Union[Factor //@ Together //@ ({(α + β x)/(αs + βs x),
       (αs^2 - α^2)(αs^2 - α^2 l^4)/(αs β - α βs)^2, l^4} //.
                               preSolution2)], {i, 12}], 1]];

Short[possibleSolutions, 8]

Because of the use of PowerExpand, it might be that we have generated some fictitious solutions that do not satisfy the original equation. So we test the solutions possibleSolutions and keep only the correct ones.

Clear[y, M];

test[sol_] :=
If[Factor[Together[D[sol[[1]], x]^2 sol[[2]] (1 - x^2) (1 - k^4 x^2) -
            (1 - sol[[1]]^2) (1 - sol[[3]] sol[[1]]^2)]] === 0, sol,
   Sequence @@ {}]

testedSolutions = test /@ possibleSolutions;

So we finally arrive at the following 24 solutions.

TableForm[testedSolutions, TableHeadings -> {None, {"y[x] \n \n",
           "M[k] \n \n", "l[k]^4 \n"}}, TableAlignments -> Center]

These solutions play an important role in the so-called modular transformation of first-order of elliptic functions; see [526✶], [198✶], and [493✶].

Now we recommend to restart Mathematica here. Here is another (more complicated, but at the same time more straightforward) way to calculate all solutions. The following calculation will take around 6 minutes on a 2 GHz computer. This is the system of equations under consideration.

eqs = {2 a as^2 b + 2 a^2 as bs - 4 as^3 bs - 4 a^3 b l^4 +
        2 a as^2 b l^4 + 2 a^2 as bs l^4, 
       a^2 as^2 - as^4 + as^2 b^2 + 4 a as b bs + a^2 bs^2 - 
        6 as^2 bs^2 + a^2 as^2 k^4 - as^4 k^4 - a^4 l^4 + 
        a^2 as^2 l^4 - 6 a^2 b^2 l^4 + as^2 b^2 l^4 +  
        4 a as b bs l^4 + a^2 bs^2 l^4 - 
        a^4 k^4 l^4 + a^2 as^2 k^4 l^4, 
      2 as b^2 bs + 2 a b bs^2 - 4 as bs^3 - 4 a b^3 l^4 +  
        2 as b^2 bs l^4 + 2 a b bs^2 l^4, 
      b^2 bs^2 - bs^4 - a^2 as^2 k^4 + as^4 k^4 - b^4 l^4 + 
        b^2 bs^2 l^4 + a^4 k^4 l^4 - a^2 as^2 k^4 l^4};

We have five equations in four variables.

Exponent[#, {k, l, a, as, b, bs}]& /@ eqs

Unfortunately, it is not possible to eliminate a, b, as, and bs from the equations to get one equation in just l and k.

GroebnerBasis[eqs, {l, k}, {a, as, b, bs}, 
              MonomialOrder -> EliminationOrder] // Timing

So we will split the problem. In the first part, we will calculate all possible  l=l(k) values. Because we are looking for rational functions a(k), a'(k), b(k), b'(k), and l(k) we need the resulting equations to be linear (over the Gaussian integers) in l. We find all such factors by calculating a GroebnerBasis with l as the highest variable.

(gb = GroebnerBasis[eqs, {a, as, b, bs, l}, ParameterVariables -> {k}, 
                    CoefficientDomain -> RationalFunctions]); // Timing

Length[gb]

Now we first factor this GroebnerBasis over the integers.

gb1 = Factor /@  gb;

We split the equations into their factors and keep (in case of powers) only the bases.

allFactors1 = Union[Flatten[If[Head[#] === Times, 
                               List @@ #, {#}]& /@ gb1]];
allFactors2 = If[Head[#] === Power, #[[1]], #]& /@ allFactors1;

Now we factor gain, this time over the Gaussian integers.

allFactors3 = Factor[#, GaussianIntegers -> True]& /@ allFactors2;
allFactors4 = Union[Flatten[If[Head[#] === Times, 
                               List @@ #, {#}]& /@ allFactors3]];

allFactors5 = If[Head[#] === Power, #[[1]], #]& /@ allFactors4;

We now have 107 factors.

Length[allFactors5]

Twenty-eight of them contain the variable l linearly.

s1 = Select[allFactors5, 
            Variables[#] === {k, l} || Variables[#] === {l}&]

So we have the following potential values for l.

s2 = Union[Flatten[(l /. Solve[# == 0, l])& /@ s1]]

Length[s2]

Concerning the variables a, as and b, bs, we go on in a similar way: We calculate Gröbner bases with a and as (b and bs, respectively) as the highest variables, factor them over the Gaussian integers, and take out the factors that are linear.
Here the variables b and bs are eliminated.

(gbA = GroebnerBasis[eqs, {a, as, l}, {b, bs},
                     ParameterVariables -> {k}, 
                     CoefficientDomain -> RationalFunctions]); // Timing

Exponent[#, {a, as, b, bs, l}]& /@ gbA

gbA1 = Factor /@ gbA;

These are the linear occurrences of as and a.

gbA2 = If[Head[#] === Times,
 Factor[#, GaussianIntegers -> True]& /@ #,
              Factor[#, GaussianIntegers -> True]]& /@ gbA1;

(gbA3 = gbA2 /. p_Plus?(Variables[#] === {k, l}&) :> 1);

resAS = Select[Union[DeleteCases[
 If[Head[#] === Power, #[[1]], #]& /@
   Flatten[If[Head[#] === Times,
              List @@ #, {#}]& /@ gbA3], _?NumberQ, {1}]], 
 Exponent[#, as] === 1 || Exponent[#, a] === 1&]

Here, the variables a and as are eliminated.

(gbB = GroebnerBasis[eqs, {b, bs, l}, {a, as},
                     ParameterVariables -> {k}, 
                     CoefficientDomain -> RationalFunctions]); // Timing

The polynomials we now get have still a high degree.

Exponent[#, {a, as, b, bs, l}]& /@ gbB

gbB1 = Factor /@ gbB;

These are the linear occurrences of bs and b.

gbB2 = If[Head[#] === Times,
  Factor[#, GaussianIntegers -> True]& /@ #,
              Factor[#, GaussianIntegers -> True]]& /@ gbB1;

(gbB3 = gbB2 /. p_Plus?(Variables[#] === {k, l}&) :> 1);

resBS = Select[Union[DeleteCases[
               If[Head[#] === Power, #[[1]], #]& /@
                 Flatten[If[Head[#] === Times, List @@ #, {#}]& /@ gbB3],
                   _?NumberQ, {1}]], Exponent[#, bs] === 1 || 
                    Exponent[#, b] === 1&]

prep preprocesses expressions for Solve. Basically, it removes all multiplicities, because we are not interested in them and so can speed up things considerably.

prep[p_Plus] = p;
prep[p_Power] := p[[1]];
prep[p_Times] := If[Head[#] === Power, #[[1]], #]& /@ p;

test[bruch] tests if a, as, b, bs, l fulfill the original equations.

test[rational_, i_] :=
((* numerator and denominator *)
 {num, den} = {Numerator[#], Denominator[#]}&[Together[rational]];
 (* a, b, as, and bs *)
 {{a1, b1}, {as1, bs1}} = If[FreeQ[#, x, {0, Infinity}], {#, 0},
                             CoefficientList[#, x]]& /@ {num, den};                
 (* the check *)
 Together[eqs //. {l -> s2[[i]], 
          a -> a1, b -> b1, as -> as1, bs -> bs1}])

For every value of l(k), we now calculate all possible values of a, as and b, bs. 
We do this by solving (when possible) for as and bs and substitute the solutions into the original equations.
Then we calculate a GroebnerBasis with respect to the renamed variables and solve for them. Finally, we substitute all results in the original equations and test if they are fulfilled.

(* avoid messages from infinite expressions *)
Off[Solve::svars]; Off[Power::infy]; Off[Infinity::indet]

Do[bag = {};
   Do[(* solve for as or a *)
      vara = DeleteCases[Variables[resAS[[i]]], l]; 
      sola = Solve[resAS[[i]] == 0, vara[[-1]]];
      (* solve for bs or b *)
      varb = DeleteCases[Variables[resBS[[j]]], l]; 
      solb = Solve[resBS[[j]] == 0, varb[[-1]]];
      (* generate reduced equation for only two variables *)
      eqs1 = Numerator[Together[#]]& /@ 
              Flatten[(eqs //. sola //. solb) //. l -> s2[[h]]];
      (* still present variables in the equations *)
      remVars = DeleteCases[Variables[eqs1], k];
      (* groebnerize remaining variables *)
      fgb = Factor /@ GroebnerBasis[eqs1, remVars,
                                    ParameterVariables -> {k}];
      fgb2 = Union[prep /@ fgb];
      (* solve for remaining variables *)
      sol = Union[Solve[# == 0& /@ fgb2, remVars]];
      res = Cancel[Flatten[((a + b x)/(as + bs x)  //.
                   sola //. solb //. sol) //. l -> s2[[h]]]];
      (* test if solutions fulfill original equations *)
      If[MemberQ[#, x, {0, Infinity}],
         If[test[#, h] === {0, 0, 0, 0}, AppendTo[bag, Factor //@ #]];
            (* printing some results while one is waiting 
               in case waiting is too boring:
               Print[test[#, i]; InputForm[#]] *)]& /@ res,
      {i, Length[resAS]}, {j, Length[resBS]}];
   union = Union[bag];
   (* keep the good solutions *)
   result[h] = {s2[[h]], union}, {h, 1, Length[s2]}]

And here are the 24 different transformations.

Flatten[Last /@ Table[result[i], {i, 1, 28}]] // Union

We could have also started by determining relations between the functions a(k), a'(k), b(k), b'(k). The first polynomial of the following Gröbner basis gives such relations.

GroebnerBasis[eqs, {l, k, a, as, b, bs}] // First // Factor

(sol = DSolve[m x''[t] + γ x'[t] + k x[t] ==
              F0 Cos[ω t], x[t], t]) // Short[#, 12]&

Here is the long-time behavior (t->∞).

((x[t] /. sol) /. {C[1] -> 0, C[2] -> 0}) // Simplify

Collect[%[[1]], {Cos[ω t], Sin[ω t]}]

Together /@ %

We make a comparison with the following.

TrigExpand[x0 Cos[ω t - φ]]

We get the following for the square of the amplitude x0.

((F0 k - F0 m ω^2)/(k^2 + γ^2 ω^2 - 2 k m ω^2 + m^2 ω^4))^2 +
((F0 γ ω)/(k^2 + γ^2 ω^2 - 2 k m ω^2 + m^2 ω^4))^2 // Simplify

For convenience, we introduce the notation ({{(Subscript[ω, 0]^2), =k/m}}) and ({{g, =γ/m}}). Thus, the solution for t->∞ (forcing condition) can be written as x(t)=(Subscript[x, 0])cos(ω t+φ) where (Subscript[x, 0])=(Subscript[F, 0]) /m (((((((Subscript[ω, 0]^2)-(ω^2)))^2)+(g^2)(ω^2)))^(-1/2)).

The amplitude of the nth derivative is then max((x^((n)))(t))=(ω^n)(Subscript[F, 0])/m (((((((Subscript[ω, 0]^2)-(ω^2)))^2)+(g^2)(ω^2)))^(-1/2)).

Now we find the relevant minimum, simplify the result somewhat, develop everything in a series about γ=0, and simplify again.

ω0 Map[ (* mainly cosmetics *)
       #/ω0&, Map[Together, Collect[Expand[
          MapAll[PowerExpand, Simplify[MapAll[PowerExpand,
                 (* make series around g = 0 *)
      Normal[Series[#[[1]][[Position[#[[2]],
                     {ω -> ω0}][[1, 1]], 1, 2]], {γ, 0, 6}]&[
     (* all is positive here so we use PowerExpand *)
         {#, MapAll[PowerExpand, # /. {γ -> 0, n -> 0}]}&[
  Solve[(* prepare equations for Solve *)
        (Factor[Numerator[Together[
            D[ω^n/Sqrt[(ω0^2 - ω^2)^2 + γ^2 ω^2], ω]]]]/ω^n) == 0,
        ω]]]]]]]], γ]]]

Here is a plot of the results (the deviation of (Subscript[ω, 0])): the maximum of the amplitude (as a function of g) moves to smaller frequencies (in comparison to (Subscript[ω, 0])), the maximum of the velocity remains at the same place as that of g=0, and the maximum of the acceleration moves toward larger frequencies.

Needs["Graphics`Legend`"]

Plot[Evaluate[Table[
((γ^6 (-1 + 9n - 25n^2 + 31n^3 - 18n^4 + 4n^5))/(128) +
 (γ^4(-1 + 4n - 5n^2 + 2n^3))/(32) + (γ^2(-1 + n))/(4)),
               {n, 0, 3}]], {γ, 0, 0.14},
    (* color curves differently *)
    PlotStyle -> {{AbsoluteThickness[1], GrayLevel[0]},
                  {AbsoluteThickness[1], RGBColor[0, 1, 0]},
                  {AbsoluteThickness[1], RGBColor[0, 0, 1]},
                  {AbsoluteThickness[1], RGBColor[1, 0, 0]}},
    PlotRange -> {{0, 0.22}, {-0.005, 0.01}}, AxesOrigin -> {0, -0.005},
    AxesLabel -> {StyleForm[HoldForm[γ], "Input"], None},
    PlotLegend -> {"x0", "v0", "a0", "x0'''"},
    LegendPosition -> {0.44, -0.36}, LegendSize -> {0.42, 0.9}]

For the relativistic case, see [1151✶].

Series[(1 + z/n)^n, {n, Infinity, 3}]

Using (((1+z/n))^n)=exp(ln((((1+z/n))^n)))=exp(n ln((1+z/n))) it is straightforward to calculate the first 10 terms of the series.

Factor //@ Exp[n Series[Log[1 + z/n], {n, Infinity, 10}]]

For a similar series, see [717✶].

This allows for a direct calculation of the (Subscript[α, k]) using Series. Here are the first 11 (Subscript[α, k]).

1/Series[Log[1 + 1/n], {n, Infinity, 10}]

The first 100 terms can be calculated in less than a second and yield an approximation for n=1 correct to about 0.01%.

(ser = 1/Series[Log[1 + 1/n], {n, Infinity, 101}]); // Timing

{ser[[5]], ser[[3, -1]]} // Short[#, 3]&

N[E - ((1 + 1/n)^Normal[ser] /. n -> 1), $MachinePrecision + 1]

Now let us deal with the case where the base and the exponent have more than one term. Proceeding as above, we get the following system of equations.

ansatz = (1 + 1/n + β[2]/n^2 + β[3]/n^3)^(n + α[0] + α[1]/n)

ser = Exp[Series[Log[ansatz] // 
         PowerExpand, {n, Infinity, 5}]] // Simplify;

eqs = Table[SeriesCoefficient[ser, k], {k, 1, 4}];

We solve the resulting polynomial system and select the best solution.

sol = Solve[# == 0& /@ eqs, {α[0], α[1], β[2], β[3]}];
Length[sol]

fsol = sol[[Position[#, Min[#]]&[Abs[N[E - 
     (ansatz /. sol /. n -> 1), 22]]][[1, 1]]]] // RootReduce

For n=1, we obtain the following approximation for e.

(ansatz /. fsol /. n -> 1) // RootReduce

It is correct to about 0.002%.

N[1 - E/%]

rhs[q_, x_, n_] := Log𝓆[q, Product[x[i], {i, n}]]

lhs[q_, x_, n_] := Sum[(1 - q)^(k - 1)*
(Sum[Product[Log𝓆[q, x[i[j]]], {j, k}], ##]& @@
      Table[{i[j], If[j == 1, 0, i[j - 1]] + 1, n}, {j, k}]),
            {k, n}]

Here is the definition of the q-logarithm (Subscript[ln, q])(x).

Log𝓆[q_, x_] := (x^(1 - q) - 1)/(1 - q)

Here are the left and right sides for the simplest nontrivial case, n=2.

{rhs[q, x, 2], lhs[q, x, 2]}

By using Simplify with the assumptions about positivity of the (Subscript[x, i]) in the second argument, we establish the identities under consideration without problem for small n.

Table[Simplify[rhs[q, x, n] - lhs[q, x, n], 
               And @@ Table[x[j] > 0, {j, n}]],
      {n, 6}]

For larger n, we presimplify the right side using Together to speed the calculations.

Table[Simplify[rhs[q, x, n] - Together[lhs[q, x, n]], 
               And @@ Table[x[j] > 0, {j, n}]], {n, 7, 10}]

For other deformations of the logarithm, see [889✶], [187✶].

Qs[m_, n_] := Qs[m, n] = Product[q[k]^(n - m), {k, m}]*
Product[(q[i] - q[j])^2, {i, m}, {j, i + 1, m}];

Ps[m_, n_] := Sum[q[i] Log[q[i]], {i, m}] Qs[m, n]

Here are two examples.

Qs[3, 3]

Ps[4, 4]

The real problem is the computation of the multiple integrals. With the following, we have to wait “forever”: Integrate[… , {q[1], 0, Infinity}, … , {q[n], 0, Infinity}]

If we look at the resulting expressions, we note that only the following two basic types of integrals appear (with different integers n).

Integrate[Exp[-q[i]] q[i]^n, {q[i], 0, Infinity}, Assumptions -> n >= 0]

Then the second class of needed integrals (∫_0^∞)log((Subscript[q, i])) (e^(-(Subscript[q, i]))) ((Subscript[q, i])^n)d(Subscript[q, i]) follows by differentiation with respect to n.

D[%, n]

This suggests that the corresponding integrations should be programmed. For convenience, we drop the term Exp[-q[i]], which arises in every integration. We have used the two constructions myIntegrate /@ a in expressions with the head Times or Plus to avoid their slower recursive evaluation. The only remaining difficulty is in the Log terms; here, we must avoid an infinite recursive call.

(* additivity *)
myIntegrate[a_Plus] := myIntegrate /@ a;

(* integrand is a constant *)
myIntegrate[fac_?NumberQ] = fac;

(* q^n Exp[-q] *)
myIntegrate[q[_]^n_.] = n!;

(* every variable treated separately *)
myIntegrate[a_Times?(FreeQ[#, Log]&)] := myIntegrate /@ a;

(* separate variables in mixed case *)
myIntegrate[Log[q[i_]] rest_] :=
   (myIntegrate[Log[q[i]] #]*
    myIntegrate[rest/#])&[Cases[rest, q[i]^_.][[1]]] /;
        Union[Cases[rest, q[_], {0, Infinity}]] != {q[i]}

(* Log[q] q^n Exp[-q] *)
myIntegrate[Log[q[i_]] q[i_]^n_.] = n! PolyGamma[0, n + 1];

For the Digamma function, we could also use the somewhat more explicit expressions (“with storage” via a SetDelayed[Set[…]] construction) Ψ(0)=-γ, Ψ(n)=(∑_(k=1)^(n-1))1/k-γ.

We now compare the required times for a simple example.

Integrate[Expand[Exp[-q[1]] Exp[-q[2]] Qs[2, 2]],
          {q[1], 0, Infinity}, {q[2], 0, Infinity}] // Timing

myIntegrate[Expand[Qs[2, 2]]]

Do[myIntegrate[Expand[Qs[2, 2]]], {100}] // Timing

Because the application of myIntegrate can be highly recursive, we set the following.

$RecursionLimit = Infinity;

Putting all of this together, we have the following.

S[m_, n_] :=
PolyGamma[0, 1 + n m] - myIntegrate[Expand[Ps[m, n]]]/
(m n myIntegrate[Expand[Qs[m, n]]]) // Together

We now look at a few values.

Table[S[m, n], {n, 2, 4}, {m, n}]

One can actually write (Subscript[S, "mn"]) in the shorter form: (Subscript[S, "mn"])=((∑_(k=1)^("mn"))1/k)-(m-1)/(2n).

s[m_, n_] = Sum[1/k, {k, n + 1, n m}] - (m - 1)/(2n);

Table[Table[s[m, k], {m, k}], {k, 2, 4}]

For the use of this function, see [1226✶], [1435✶], and [871✶]. Qs[5, 5] cannot be computed so easily (without the use of a lot of memory).

Qs[5, 5]

After the application of Expand, it would temporarily have 3^Length[%]=59049 summands (and in the final form, it would still have 2961 terms).

In this case, it may be better not to multiply out, but to find every term in the sum by hand, and then integrate afterward. The following routine constructs the summands arising from multiplying out an expression of the form

((((Subscript[a, 11])+(Subscript[a, 12])+..))^(Subscript[e, 11]))((((Subscript[a, 21])+(Subscript[a, 22])+..))^(Subscript[e, 21]))((((Subscript[a, 31])+(Subscript[a, 32])+..))^(Subscript[e, 31]))

and then integrates them. The interesting thing about bigInt is the automatic construction of iterators and of the expressions on which these iterators operate (we suppress the error messages that are generated by Part), which we have also used in Chapter 5 of the Programming volume [1559✶] of the GuideBooks.

bigInt[arg_] :=
Module[{pluses, res, plus1, iteras, taker, a, sum},
 (* look for all powers of a sum *)
 pluses = Cases[arg, _Plus^_.];
 (* just a factor *)
 res = arg/(Times @@ pluses);
 (* analyze powers, build Lists *)
 plus1 = Flatten[If[Head[#1] === Power, Table[#[[1]], {#[[2]]}],
                    #1]& /@ pluses];
 (* build iterators *)
 iteras = MapIndexed[{a[#2[[1]]], #1}&, Length /@ plus1];
 (* call Part with nonnumeric indices gives error message *)
 Off[Part::pspec];
 taker = MapIndexed[Part[#1, a[#2[[1]]]]&, plus1];
 On[Part::pspec];
 sum = 0; (* simple Do loop over the iterators *)
 Do[sum = sum + Expand[myIntegrate[res Times @@ taker]]; Null,
    (* evaluate the iterators *)
    Evaluate[Sequence @@ iteras]]; sum]

For explicit computations, it is convenient to multiply out the squares in Qs and Ps, because by the binomial formula, we then have “only” the above 59049 elements to integrate. With a longer (but requiring less memory) calculation, we get the value 9953280.

bigInt[Expand /@ Qs[5, 5]]

We get the value for Ps[5, 5].

bigInt[Expand /@ Ps[5, 5]]

Thus, we get this for (Subscript[S, 55]).

PolyGamma[0, 1 + 25] -
(667699200 - 248832000 EulerGamma)/(25 9953280) // Together

It agrees with the direct formula for (Subscript[S, 55]).

s[5, 5]

SetAttributes[𝒞𝒯, Flat]

𝒞𝒯[e, a] = a; 𝒞𝒯[a, e] = a; 𝒞𝒯[e, b] = b; 𝒞𝒯[b, e] = b;
𝒞𝒯[e, c] = c; 𝒞𝒯[c, e] = c; 𝒞𝒯[a, b] = c; 𝒞𝒯[b, a] = c;
𝒞𝒯[a, c] = b; 𝒞𝒯[c, a] = b; 𝒞𝒯[b, c] = a; 𝒞𝒯[c, b] = a;
𝒞𝒯[a, a] = e; 𝒞𝒯[e, e] = e; 𝒞𝒯[b, b] = e; 𝒞𝒯[c, c] = e;

(* linearity *)
𝒞𝒯[𝕒___, 𝕓_ + 𝕔_, 𝕕_, 𝕖___] := 𝒞𝒯[𝕒, 𝕓, 𝕕, 𝕖] + 𝒞𝒯[𝕒, 𝕔, 𝕕, 𝕖]
𝒞𝒯[𝕒___, 𝕓_, 𝕔_ + 𝕕_, 𝕖___] := 𝒞𝒯[𝕒, 𝕓, 𝕔, 𝕖] + 𝒞𝒯[𝕒, 𝕓, 𝕕, 𝕖]
𝒞𝒯[𝕒___, (Α_α | Α_Integer) 𝕓_, 𝕔___] := Α 𝒞𝒯[𝕒, 𝕓, 𝕔]
𝒞𝒯[𝕒___, 0, 𝕓___] := 0

Next we calculate the symmetric determinant of a 4×4 matrix with generic elements of the form (Subscript[c, i,j]^((a)))a +(Subscript[c, i,j]^((b)))b +(Subscript[c, i,j]^((c)))c +(Subscript[c, i,j]^((e)))e.

o = 4;
perms = Permutations[Range[o]];

m = Table[Sum[α[i, j, k] {a, b, c, e}[[k]], {k, o}],
          {i, o}, {j, o}];

(* general definition of the symmetric determinant *)
sDet[m_] := 1/o! Sum[Signature[perms[[i]]] Signature[perms[[j]]]*
       𝒞𝒯 @@ (m[[##]]& @@@ Transpose[{perms[[i]], perms[[j]]}]),
    {i, Length[perms]}, {j, Length[perms]}];

sum = sDet[m];

In expanded form, the symmetric determinant under consideration has 6144 terms.

Length[Expand[sum]]

We extract the coefficients of a, b, c, and e and equate all of them to 1.

cs = Coefficient[Expand[sum], {a, b, c, e}];
αs = Cases[cs, _α, Infinity] // Union;

To find actual values for the αs that make the four equations cs equal to 1, we could carry out a random search. This is relatively time-consuming. Instead we choose random values for some variables, simplify the resulting equations and then try various assignments for the remaining variables.

ℴ = 56;
SeedRandom[1000];
(* random assignment until we succeed *)
While[𝕣 = Random[Integer, {1, 10^20}]; SeedRandom[𝕣];
      αsT = Take[αs, ℴ]; αsR = Take[αs, {ℴ + 1, 64}];
      ℛs = (Rule @@@ Transpose[{αsT, 
                  Table[Random[Integer, {-1, 1}], {ℴ}]}]);
      gb = GroebnerBasis[(cs - {1, 1, 1, 1}) /. ℛs, αsR,
                         MonomialOrder -> Lexicographic];
      tfs = Table[Union[gb] == {0}, Evaluate[Sequence @@ 
                        (Table[{#, -1, 1}]& /@ αsR)]] // 
                                             Flatten // Union;
FreeQ[tfs, True], Null]

We add the successful assignments to the list of rules ℛs.

cas = Cases[Flatten[Table[C[αsR, gb == Table[0, {Length[gb]}]], 
      Evaluate[Sequence @@ (Table[{#, -1, 1}]& /@ αsR)]]],
         C[_, True]]

αsRules = Join[ℛs, Rule @@@ Transpose[{αsR, cas[[1, 1]]}]];

Here is one possible form of the matrix we were looking for.

(M = m /. αsRules) // MatrixForm

sDet[M] // Expand

c1 = a22 + a12 a21 (l1 - 1) - a22 l2;
c2 = a12 (1 + a21) l1 - (a12 + a22) l2; 
c3 = (1 + a21) a22 l1 + a12 a21 (l1 - 1) l2 - 
      a22 (a21 + l1) l2;
c4 = a22 - a21 g + a12 (a22 g + a21 (n11 - 1)) - a22 n22;
c5 = (-1 - a21 + a12 (a12 + a22)) g + a12 (1 + a21) n11 - 
      (a12 + a22) n22;
c6 = a21^2 g - a22 (g (a12 + a22 + g) + n11 - n11 n22) + 
      a21 (g + a12 g^2 - a22 n11 + (a12 + a22 - a12 n11) n22); 
c7 = a22 + a12 a21 (p11 - 1) - a21 p12 + a12 a22 p21 - a22 p22; 
c8 = a12 p11 + a12 a21 p11 - p12 - a21 p12 + a12^2 p21 + 
      a12 a22 p21 - (a12 + a22) p22;
c9 = a22^2 p21 - a21 p12 (1 + a21 + a12 p21) + a12 a21 (p11 - 1) p22 +
      a22 (p11 + a21 p11 + a12 p21 + p12 p21 - (a21 + p11) p22);

𝓆1 = -c2 c6/(c3 c5); 
𝓆2 =  c2 c4/(c1 c5); 
𝓆3 =  c2 c9/(c3 c8); 
𝓆4 =  c2 c7/(c1 c8);

𝓆Toq = {q1 -> 𝓆1, q2 -> 𝓆2, q3 -> 𝓆3, q4 -> 𝓆4};

R =
-q1^2 l1 l2 (1 - p11 - p12 p21 - p22 + p11 p22) + 
 q1 q2 (l2 n11 + l1 n22) (1 - p11 - p12 p21 - p22 + p11 p22) + 
 q2^2 (g^2 - n11 n22) (1 - p11 - p12 p21 - p22 + p11 p22) + 
 q1 q3 l1 l2 (2 - n11 - n22 - p11 + n22 p11 - g p12 - g p21 - 
           p22 + n11 p22) + q2 q3 (-g^2 l1 - g^2 l2 - l2 n11 - l1 n22 + 
           l1 n11 n22 + l2 n11 n22 + g^2 l2 p11 + l2 n11 p11 - 
           l2 n11 n22 p11 + g l1 p12 + g l2 p21 + g^2 l1 p22 + 
           l1 n22 p22 - l1 n11 n22 p22) + 
 q1 q2 q3 (-l2 n11 + l1 l2 n11 - l1 n22 + l1 l2 n22 + l1 n22 p11 - 
           l1 l2 n22 p11 - g l1 p12 + g l1 l2 p12 - g l2 p21 + 
           g l1 l2 p21 + l2 n11 p22 - l1 l2 n11 p22) -
 q2^2 q3 (g^2 - n11 n22) (2 - l1 - l2 - p11 + l2 p11 - p22 + l1 p22) + 
 q3^2 l1 l2 (-1 + g^2 + n11 + n22 - n11 n22) + 
 q2 q3^2(g^2 l1 + g^2 l2 - 2 g^2 l1 l2 + l2 n11 - l1 l2 n11 + l1 n22 - 
         l1 l2 n22 - l1 n11 n22 - l2 n11 n22 + 2 l1 l2 n11 n22) + 
 q2^2 q3^2 (l1 - 1) (l2 - 1) (g^2 - n11 n22) + 
 q1 q4 (-l2 p11 + l2 n11 p11 + g l2 p12 + g l1 p21 - l1 p12 p21 - 
         l2 p12 p21 + l2 n11 p12 p21 + l1 n22 p12 p21 - l1 p22 + 
         l1 n22 p22 + l1 p11 p22 + l2 p11 p22 - l2 n11 p11 p22 - 
         l1 n22 p11 p22) + 
 q1^2 q4 (l2 p11 - l1 l2 p11 + l1 p12 p21 + l2 p12 p21 - 
          2 l1 l2 p12 p21 + l1 p22 - l1 l2 p22 - l1 p11 p22 - 
          l2 p11 p22 + 2 l1 l2 p11 p22) + 
 q2 q4 (g^2 p11 + n22 p11 - n11 n22 p11 - g p12 - g p21 + 
        2 g^2 p12 p21 + n11 p12 p21 + n22 p12 p21 - 2 n11 n22 p12 p21 + 
        g^2 p22 + n11 p22 - n11 n22 p22 - 2 g^2 p11 p22 - n11 p11 p22 - 
        n22 p11 p22 + 2 n11 n22 p11 p22) + 
 q1 q2 q4 (-n22 p11 + l1 n22 p11 + g p12 - g l2 p12 + g p21 - 
            g l1 p21 - n11 p12 p21 + l2 n11 p12 p21 - n22 p12 p21 + 
            l1 n22 p12 p21 - n11 p22 + l2 n11 p22 + n11 p11 p22 - 
            l2 n11 p11 p22 + n22 p11 p22 - l1 n22 p11 p22) - 
 q3 q4 (g^2 + n11 + n22 - n11 n22 - 1) (l2 p11 + l1 p22) + 
 q1 q3 q4 (-l2 p11 + l1 l2 p11 + l2 n22 p11 - l1 l2 n22 p11 - 
            g l2 p12 + g l1 l2 p12 - g l1 p21 + g l1 l2 p21 - 
            l1 p22 + l1 l2 p22 + l1 n11 p22 - l1 l2 n11 p22) +
 q2 q3 q4 (-g^2 p11 + g^2 l2 p11 - n22 p11 + l2 n22 p11 + 
            n11 n22 p11 - l2 n11 n22 p11 + g p12 - g l1 p12 + 
            g p21 - g l2 p21 - g^2 p22 + g^2 l1 p22 - n11 p22 + 
            l1 n11 p22 + n11 n22 p22 - l1 n11 n22 p22) + 
 q1 q2 q3 q4 (l1 - 1) (l2 - 1) (n22 p11 - g p12 - g p21 + n11 p22) - 
 q4^2 (g^2 + n11 + n22 - n11 n22 - 1) (p12 p21 - p11 p22) - 
 q1 q4^2 (2 - l1 - l2 - n11 + l2 n11 - n22 + l1 n22)*
         (p12 p21 - p11 p22) + 
 q1^2 q4^2 (l1 - 1) (l2 - 1) (p12 p21 - p11 p22);

The most direct way to show that R vanishes would be Together[R /. 𝓆Toq]. Because of the complexity of the expression under consideration this will likely not finish in a reasonable amount of time. After inspecting the form of R for a moment, one recognizes that the common denominator is (Subscript[c, 1]^2)(Subscript[c, 3]^2)(Subscript[c, 5]^2)(Subscript[c, 8]^2). Because this denominator does not identically vanish, we can reduce the problem to the expansion of a polynomial. Expand[((c1 c3 c5 c8)^2 #)& /@ (R /. 𝓆Toq)] should than give the result 0. Unfortunately also this input will likely not work, but run out of memory. To avoid sorting, Expand will first expand all products and then collapse them. If we expand one term after the other and sum the intermediate results, we can quickly show that R vanishes.

R1 = ((c1 c3 c5 c8)^2 #)& /@ (R /. 𝓆Toq);
Length[R1]

Timing[sum = 0; Do[sum = sum + Expand[R1[[k]]], {k, 21}]]

{sum, MaxMemoryUsed[]}

Because the 21 terms of the last inputs after expansion had a couple of hundred thousand terms each, the memory usage of the last input was considerable. We could reduce the memory usage by expanding R before carrying out the (Subscript[q, i])->(Subscript[𝓆, i]) substitution. This reduce the memory usage by a factor 3, but needs about three to four times as long.

R2 = ((c1 c3 c5 c8)^2 #)& /@ (Expand[R] /. 𝓆Toq);
Length[R2]

(* rerun this subexercise without evaluating the above Timing[…] *)
Timing[sum = 0; Do[sum = sum + Expand[R2[[k]]], {k, 239}]]
{sum, MaxMemoryUsed[]}

S[0] = Sqrt[ε - v[x]];

S[k_?EvenQ] := S[k] = Expand[(-1/2 D[S[k - 1], x] -
     Sum[S[m] S[k - m], {m, 1, k/2}] + 1/2 S[k/2]^2)/S[0]]

S[k_?OddQ] := S[k] = Expand[(-1/2 D[S[k - 1], x] -
     Sum[S[m] S[k - m], {m, 1, (k - 1)/2}])/S[0]]

Here is an example.

S[8]

Now we integrate the terms containing V'(x). A direct use of the built-in Integrate function does not lead to a transformation to the desired form with integrated (ε - v[x])^(⋯) and differentiated v'[x]… .

Integrate[v'[x] v''[x] (ε - v[x])^(-3/2), x]

Hence, we suggest the following program to carry out the integration. (The rules follow from a direct calculation after changing the integration variable.)

(* additivity *)
IntegrationOverV[f_. a_Plus * (ε - v[x])^n_?(# <  - 1&)] :=
      IntegrationOverV /@ Expand[f a (ε - v[x])^n]

(* integration by parts *)
IntegrationOverV[a_. v'[x]^ν_. (ε - v[x])^n_?(# <  - 1&)] :=
      Expand[D[a v'[x]^(ν - 1), x] 1/(n + 1) (ε - v[x])^(n + 1)];

(* zero case *)
IntegrationOverV[a_. v'[x] (ε - v[x])^-1] := 0

(* additivity *)
IntegrationOverV[x_Plus] := IntegrationOverV /@ x

(* nothing to do *)
IntegrationOverV[x_?(FreeQ[Numerator[#], v'[x], {0, Infinity}]&)] = x;

Now the above expression is integrated.

IntegrationOverV[v'[x] v''[x] (ε - v[x])^(-3/2)]

Taking our example S[4] expression as an example, we get the following result.

S[4]

IntegrationOverV[S[4]]

We drop the part consisting of a complete differential because it does not contribute to the integral along a closed path. 
The integration by parts is more difficult to realize. The actual integration is carried out with the function IntegrationByParts.

IntegrationByParts[x_Plus] := IntegrationByParts /@ x

IntegrationByParts[a_. (ε - v[x])^n_] :=
Module[{int, intWith, intFree, intWith1, intWith2},
  (* Integrate the factor a *)
int = Integrate[a, x];
  (* analyze the usefulness of the result *)
If[Head[int] === Plus,
   intFree = Select[int, FreeQ[#, Integrate,
                    {0, Infinity}, Heads -> True]&];
  (* still contains undone Integrate *)
     intWith = int - intFree,
   If[FreeQ[int, Integrate, {0, Infinity}, Heads -> True],
      intFree = int; intWith = 0, intFree = 0; intWith = int]];
  (* rewrite part that contains Integrate *)
 If[intWith =!= 0, intWith1 =
    If[Head[intWith] === Plus,
       Cases[intWith, HoldPattern[_. Integrate[_, _]]],
    intWith1 = {intWith}];
    (* undone *)
    intWith2 = Plus @@ (# //. {α_. Integrate[β_, x] -> α β}& /@ intWith1)];
 If[intWith =!= 0, intWith2, 0] (ε - v[x])^n +
          Expand[-intFree (-n (ε - v[x])^(n - 1) v'[x])]]

IntegrationByPartsTogether carries out the integration of the collected terms with the same denominators. myTogether collects these terms.

IntegrationByPartsTogether[y_Plus] :=
Module[{tog, tog1, max, toIntegrate, res},
      tog = myTogether[y];
       If[Head[tog] =!= Times,
          (* largest divergent power *)
          tog1 = (Denominator /@ Apply[List, tog]) //. 
                                           {n_. Power[_, m_] -> m};
           max = Max[tog1];
           toInt = Cases[tog, _. Power[ε - v[x], pot_?(# > -max&)]];
           (* integrate by parts *)
          (tog - (Plus @@ toIntegrate)) +
               Plus @@ (IntegrationByParts /@ toIntegrate),
          tog]]

IntegrationByPartsTogether[x_] = x;

myTogether[x_Plus] := (* concentrate on denominators only *)
Plus @@ ((Together[Plus @@ Cases[x, _. #^-1]])& /@
  Union[Flatten[Cases[#, Power[_, _], {0, Infinity}]& /@
                            (Denominator /@ List @@ x)]])

myTogether[x_Times] = x;

We apply IntegrationByParts to S[4].

IntegrationByParts[S[4]]

Here is the result of applying IntegrationOverV and IntegrationByParts to S[4].

IntegrationByParts[IntegrationOverV[S[4]]]

Next, we give an explicit representation for the result in the form of derivatives with respect to E of definite integrals over x. To avoid the differentiation, we apply HoldForm. We avoid higher powers in the denominators to get integrable singularities. (For another method to deal with the singularities of the form (((ε-v(x)))^(-k/2)), see [442✶].)

finalForm[y_Plus] :=
Module[{pre, lcm, u, expr, ν},
       pre = finalFormAux /@ List @@ y;
       (* pull out biggest denominator *)
       lcm = LCM @@ ((Denominator[#[[2]]] //.
                {n_. Power[ε - v[x], _] -> n})& /@ pre);
       1/lcm Plus @@ Table[u = lcm pre[[i, 2]];
       (* use HoldForm to avoid the differentiation
          to be carried out *)
       HoldForm[D[Integrate[expr, {x, x1, x2}], {ε, ν}]] /.
                   {expr -> u, ν -> pre[[i, 1]]}, {i, Length[pre]}]];

finalForm[y_Times] :=
Module[{pre = finalFormAux[y], expr, ν, denominator},
       (* pull out denominator *)
       denominator = Denominator[pre[[2, 1]]];
       1/denominator HoldForm[D[Integrate[HoldForm[expr],
                                {x, x1, x2}], {ε, ν}]] /.
            {expr -> pre[[2]] denominator, ν -> pre[[1]]}]

finalForm[0] := HoldForm[0];

(* subsidiary function for preparing output in nice form *)
finalFormAux[0] = 0;

finalFormAux[a_. (ε - v[x])^n_] :=
{-(n + 1/2), ExpandNumerator[a * (* from the differentiations wrt e *)
 Product[1/(i + 1), {i, n, -3/2}]] (ε - v[x])^(-1/2)}

Here are the correction terms of order 1 to 10. All odd terms are complete differentials, and they disappear identically. The function WKBCorrection applies both of the functions IntegrationOverV and IntegrationByPartsTogether as often as possible.

WKBCorrection[ord_Integer?Positive] :=
      finalForm[FixedPoint[IntegrationByPartsTogether,
                           FixedPoint[IntegrationOverV, S[ord]]]]

WKBCorrection[1]

WKBCorrection[2]

WKBCorrection[3]

WKBCorrection[4]

WKBCorrection[5]

WKBCorrection[6]

WKBCorrection[7]

WKBCorrection[8]

WKBCorrection[9]

WKBCorrection[10]

Here, the explicit correction terms for a quartic oscillator are calculated. The turning points are (Subscript[x, 1,2])=±(ε^(1/4)).

tab = Table[Expand[DeleteCases[WKBCorrection[i] /. 
       {x1 -> -ε^(1/4), x2 -> ε^(1/4), 
        Derivative[n_][v][x] :> D[x^4, {x, n}], v[x] -> x^4} /. 
      Integrate[f_, range_] :>  Integrate[f, range, 
        Assumptions -> ε > 0 && ε^(1/4) > 0], 
                  HoldForm, Infinity, Heads -> True]], {i, 10}]

int0 is the main term in the quantization condition.

int0 = Integrate[Sqrt[ε - x^4], {x, -ε^(1/4), ε^(1/4)}, 
                 Assumptions -> ε > 0 && ε^(1/4) > 0]

The correction terms to order m are included in quantizationCondition.

quantizationCondition[ε_, n_, ℏ_, m_] := 
        int0 + Sum[(ℏ/I)^k tab[[k]], {k, 1, m}] - (n + 1/2) ℏ

For ℏ=1/10 and n=3, here is the quantization condition as a function of ε.

Plot[Evaluate[Table[quantizationCondition[ε, 3, 1/10, m], {m, 10}]], 
     {ε, 0, 0.2}, PlotRange -> {-1, 1}, 
     PlotStyle -> Table[Hue[i 0.7], {i, 10}]]

We use FindRoot to calculate numerical values for the energies.

Table[FindRoot[Evaluate[quantizationCondition[ε, n, 1/10, m] == 0], 
                {ε, n/10}, WorkingPrecision -> 30, 
               AccuracyGoal -> 30], {n, 3, 6}, {m, 0, 10, 2}] // 
                                     Chop // SetPrecision[#, 12]&

The higher n, the better is the convergence.

Table[FindRoot[Evaluate[quantizationCondition[ε, 100, 1/10, m] == 0], 
               {ε, 1/10}, WorkingPrecision -> 30, 
               AccuracyGoal -> 30], {m, 0, 10, 2}] // 
                                     Chop // SetPrecision[#, 12]&

Here, the same for ℏ=1/100 is done.

Plot[Evaluate[Table[quantizationCondition[ε, 3, 1/100, m], {m, 10}]], 
     {ε, 0, 0.02}, PlotRange -> {-1/10, 1/10}, 
     PlotStyle -> Table[Hue[i 0.7], {i, 10}]]

Table[FindRoot[
   Evaluate[quantizationCondition[ε, n, 1/100, m] == 0], 
                {ε, 5n/100}, WorkingPrecision -> 30, 
               AccuracyGoal -> 30], {n, 3, 6}, {m, 0, 10, 2}] // 
                                     Chop // SetPrecision[#, 12]&

Table[FindRoot[Evaluate[quantizationCondition[ε, 100, 1/10, m] == 0], 
               {ε, 10}, WorkingPrecision -> 30, 
               AccuracyGoal -> 30], {m, 0, 10, 2}] // 
                                     Chop // SetPrecision[#, 12]&

For fractional power potentials, see [1189✶]. For other ways to derive the WKB coefficients, see [1186✶] and [1187✶].

For summing the corrections to all orders, see [1349✶] and [1387✶]. For a discussion when the WKB approximations becomes exact, see [1363✶]. For an investigation about the accuracy of the higher orders, see [1305✶]. For an improved momentum definition, see [1188✶]

δ = KroneckerDelta;
(* Pauli matrices *)
σ[1] = {{0,  1}, {1,  0}};
σ[2] = {{0, -I}, {I,  0}};
σ[3] = {{1,  0}, {0, -1}};
(* act on a ket of a given particle *)
σ[k_, j_][ψ[l_, "↑"]] := δ[k, l] σ[j].{1, 0}.{ψ[l, "↑"], ψ[l, "↓"]} +  
                         (1 - δ[k, l])ψ[l, "↑"];
σ[k_, j_][ψ[l_, "↓"]] := δ[k, l] σ[j].{0, 1}.{ψ[l, "↑"], ψ[l, "↓"]} + 
                         (1 - δ[k, l])ψ[l, "↓"];
(* pull out constant factors *)
σ[k_, j_][c_?(FreeQ[#, _ψ, {0, ∞}]&) t_] := c σ[k, j][t]    
(* sums and products *)
σ[k_, j_][pt_Plus | pt_Times] := σ[k, j] /@ pt;

This is the Greenberger–Horne–Zeilinger state under consideration. (We omit the normalization constant.)

Ψ = (ψ[1, "↑"]ψ[2, "↑"]ψ[3, "↑"] - ψ[1, "↓"]ψ[2, "↓"]ψ[3, "↓"]);

Here are two examples of operators (Subscript[(OverHat[Ξ]), ±]).

{(σ[1, 1] @ σ[2, 2] @ σ[3, 2] @ Ψ)/Ψ,
 (σ[1, 1] @ σ[2, 1] @ σ[3, 1] @ Ψ)/Ψ} // Cancel

For the (Subscript[(OverVector[n]), k]), we can use the following obvious parametrization.

n[k_, 1] = Cos[φ[k]] Sin[ϑ[k]];
n[k_, 2] = Sin[φ[k]] Sin[ϑ[k]];
n[k_, 3] = Cos[ϑ[k]];

Acting now with (Subscript[((Subscript[(OverVector[n]), 1]).(OverVector[σ])), 1])⊗(Subscript[((Subscript[(OverVector[n]), 2]).(OverVector[σ])), 2])⊗(Subscript[((Subscript[(OverVector[n]), 3]).(OverVector[σ])), 3]) on |Ψ⟩, we get the following result sum3 for arbitrary (Subscript[(OverVector[n]), k]).

sum1 = Sum[n[1, j] σ[1, j][Ψ], {j, 3}];
sum2 = Sum[n[2, j] σ[2, j][sum1], {j, 3}];
sum3 = Sum[n[3, j] σ[3, j][sum2], {j, 3}];

This gives the following condition for (Subscript[(OverHat[Ξ]), ±])|Ψ⟩=±1|Ψ⟩.

sum = Expand[sum3 - ±1 Ψ];
Short[sum, 4]

The Hilbert space of three two-state particles is spanned by the following eight states.

ψΠs = {ψ[1, "↑"] ψ[2, "↑"] ψ[3, "↑"], ψ[1, "↑"] ψ[2, "↑"] ψ[3, "↓"], 
       ψ[1, "↑"] ψ[2, "↓"] ψ[3, "↑"], ψ[1, "↑"] ψ[2, "↓"] ψ[3, "↓"], 
       ψ[1, "↓"] ψ[2, "↑"] ψ[3, "↑"], ψ[1, "↓"] ψ[2, "↑"] ψ[3, "↓"], 
       ψ[1, "↓"] ψ[2, "↓"] ψ[3, "↑"], ψ[1, "↓"] ψ[2, "↓"] ψ[3, "↓"]};

eqs1 is the list of the coefficients of the ψΠs in sum.

eqs1 = Coefficient[sum, #]& /@ ψΠs;

Because eqs1 is polynomial in cos((Subscript[φ, k])), sin((Subscript[φ, k])), cos((Subscript[ϑ, k])), sin((Subscript[ϑ, k])), we will use these four quantities as polynomial variables.

vars = Flatten[Table[{Cos[φ[k]], Sin[φ[k]],
                      Cos[ϑ[k]], Sin[ϑ[k]]}, {k, 3}]]

Supplementing eqs1 with the usual trigonometric constraints allows us to solve for the cos((Subscript[φ, k])), sin((Subscript[φ, k])), cos((Subscript[ϑ, k])), sin((Subscript[ϑ, k])).

eqs2 = Table[{Cos[φ[k]]^2 + Sin[φ[k]]^2 - 1,
              Cos[ϑ[k]]^2 + Sin[ϑ[k]]^2 - 1}, {k, 3}] // Flatten;
eqs = Flatten[{eqs1, eqs2}];

gbp1 = Simplify[GroebnerBasis[eqs /. ±1 -> 1, vars]]

solp1 = Solve[# == 0& /@ gbp1, vars] // Union

Making use of the results for the (Subscript[ϑ, k]), we finally obtain the following condition for the (Subscript[φ, k]).

Drop[solp1[[1]] /. {_ϑ -> Pi/2}, -3]

This means the most general (SubPlus[(OverHat[Ξ])]) is given by

(SubPlus[(OverHat[Ξ])])=(Subscript[(cos(π-(Subscript[φ, 2])-(Subscript[φ, 3]))(Subscript[σ, 1])+sin(π-(Subscript[φ, 2])-(Subscript[φ, 3]))(Subscript[σ, 2])), 1])⊗ 
     (Subscript[(cos((Subscript[φ, 2]))(Subscript[σ, 1])+sin((Subscript[φ, 2]))(Subscript[σ, 2])), 2])⊗(Subscript[(cos((Subscript[φ, 3]))(Subscript[σ, 1])+sin((Subscript[φ, 3]))(Subscript[σ, 2])), 3]).

In a similar manner we obtain for (SubMinus[(OverHat[Ξ])]) the result

(SubMinus[(OverHat[Ξ])])=(Subscript[(cos(-(Subscript[φ, 2])-(Subscript[φ, 3]))(Subscript[σ, 1])+sin(-(Subscript[φ, 2])-(Subscript[φ, 3]))(Subscript[σ, 2])), 1])⊗
     (Subscript[(cos((Subscript[φ, 2]))(Subscript[σ, 1])+sin((Subscript[φ, 2]))(Subscript[σ, 2])), 2])⊗(Subscript[(cos((Subscript[φ, 3]))(Subscript[σ, 1])+sin((Subscript[φ, 3]))(Subscript[σ, 2])), 3]).

gbm1 = Simplify[GroebnerBasis[eqs /. ±1 -> -1, vars]];
solm1 = Solve[# == 0& /@ gbm1, vars] // Union

A moment of reflection shows that these are the to be expected results for (Subscript[(OverHat[Ξ]), ±]).

|Ψ⟩=(∑_((Subscript[i, 1]),(Subscript[i, 2]),(Subscript[i, 3]),(Subscript[i, 4])=0)^1)(Subscript[c, (Subscript[i, 1]),(Subscript[i, 2]),(Subscript[i, 3]),(Subscript[i, 4])])(Subscript[|(Subscript[i, 1])⟩, 1])(Subscript[|(Subscript[i, 2])⟩, 2])(Subscript[|(Subscript[i, 3])⟩, 3])(Subscript[|(Subscript[i, 4])⟩, 4])

where |0⟩=|↓⟩, and |1⟩=|↑⟩. Without loss of generality we can always choose a coordinate system so that (Subscript[c, 1,0,0,0])=(Subscript[c, 0,1,0,0])=(Subscript[c, 0,0,1,0])=(Subscript[c, 0,0,0,1])=0 [1675✶], [763✶], [12✶]. The corresponding density matrix is ρ4. In the following implementation, we write KetBra[{i1, i2, i3, i4}, {j1, j2, j3, j4}]
for (Subscript[|i1⟩, 1])(Subscript[|i2⟩, 2])(Subscript[|i3⟩, 3])(Subscript[|i4⟩, 4]) ⟨i4(Subscript[|, 4])(Subscript[⟨i3|, 3])(Subscript[⟨i2|, 2])(Subscript[⟨i1|, 1]). cn and cc stand for c and its conjugate (OverBar[c]).

ρ4 = Sum[cn[i1, i2, i3, i4] cc[j1, j2, j3, j4] *
         KetBra[{i1, i2, i3, i4}, {j1, j2, j3, j4}],
         {i1, 0, 1}, {i2, 0, 1}, {i3, 0, 1}, {i4, 0, 1},
         {j1, 0, 1}, {j2, 0, 1}, {j3, 0, 1}, {j4, 0, 1}] //.
         ((cn[s__] | cc[s__]) /; Count[{s}, 1] === 1) -> 0;

The function makeReducedDensityMatrix[i, j] generates the reduced two-particle density matrix (Subscript[ρ2, i,j])=(Subscript[Tr, k,l])ρ4.

makeReducedDensityMatrix[i_, j_] := 
Module[{lhs, rhs},
 (* the particles to be traced out *)
 {k, l} = Complement[{1, 2, 3, 4}, {i, j}];    
 (* the ket-bras to be contracted *)           
 lhs = f_ KetBra[{i1_, i2_, i3_, i4_}, 
  MapAt[{i1_, i2_, i3_, i4_}[[l]]&,  
    MapAt[{i1_, i2_, i3_, i4_}[[k]]&, {j1_, j2_, j3_, j4_}, k], l]];
 (* the surviving ket-bras *)
 rhs = f KetBra[{i1, i2, i3, i4}[[{i, j}]], 
                {j1, j2, j3, j4}[[{i, j}]]];
 (* collect wrt the surviving ket-bras *)
collect[Plus @@ Cases[ρ4, RuleDelayed @@ {lhs, rhs}]]]

collect[ρ_] := Collect[ρ, Cases[ρ, _KetBra, Infinity] // Union];

Here are the six reduced two-particle density matrices (Subscript[ρ2, 1,2]),(Subscript[ρ2, 1,3]),(Subscript[ρ2, 1,4]),(Subscript[ρ2, 2,3]),(Subscript[ρ2, 2,4]), and  (Subscript[ρ2, 3,4]).

{ρ2[1, 2], ρ2[1, 3], ρ2[1, 4], ρ2[2, 3], ρ2[2, 4], ρ2[3, 4]} =
Apply[makeReducedDensityMatrix,
     {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}}, {1}];

Equating all diagonal elements of the reduced two-particle density matrices to 1 and the nondiagonal elements to 0 yields 96 equations in 24 variables.

eqs = Flatten[Apply[List, 
     {ρ2[1, 2], ρ2[1, 3], ρ2[1, 4], ρ2[2, 3], 
      ρ2[2, 4], ρ2[3, 4]}, {1}] /. (* diagonal elements *)
            {f_ KetBra[x_, x_] :> f - 1} /. _KetBra :> 1];

vars = Cases[eqs, _cc | _cn, Infinity] // Union;

{Length[vars], Length[eqs]}

Using GroebnerBasis we can quickly show that the 96 polynomial equations in cn and cc have no solutions [763✶]. (Because there does not exist a solution to the system of equations eqs we use the monomial order DegreeReverseLexicographic. Using this order, a Gröbner basis is typically computed quite quickly.)

GroebnerBasis[eqs, vars, MonomialOrder -> DegreeReverseLexicographic]

δx = Exp[-Integrate[1/(2L) Log[1/(2L)], {x, -L, L}]]

The corresponding w(p) is w(p)=(sin^2)(L p)/(L (p^2) π).

w[p_] = (1/Sqrt[2 Pi] Integrate[1/Sqrt[2 L] Exp[I p x], 
                                {x, -L, L}])^2 // 
                                 ExpToTrig // Simplify

The direct evaluation of the entropic uncertainty of the momentum fails.

Integrate[w[p] Log[w[p]], {p, -Infinity, Infinity}]

The infinite number of integrable singularities at (Subscript[p, k])=k π/L are a problem for the Integrate function. Expanding the argument of the logarithm gives one simple and one complicated integral.

int1 = -1/(L Pi) Integrate[Sin[L p]^2/p^2 Log[L Pi p^2], {p, -Infinity, Infinity},
                           Assumptions -> L > 0]

The complicated integral with the countable number of integrable singularities is not done by Mathematica.

1/(L Pi) Integrate[Sin[L p]^2/p^2 Log[Sin[L p]^2], {p, -Infinity, Infinity}]

We use the periodicity of parts of the integrand to obtain an integral over a finite range having only two singularities at the end points.

(∫_(-∞)^∞)(( (sin^2)(p L))/((p )^2))ln((sin^2)(p L))dp=(∑_(k=-∞)^∞)(∫_0^(π/L))(( (sin^2)((p -k π/L)L))/(((p -k π/L))^2))ln((sin^2)((p -k π/L)L))dp
=(∫_0^(π/L))((∑_(k=-∞)^∞)(((p -k π/L))^(-2)))(sin^2)(p L)ln((sin^2)(p L))dp=(L^2)(∫_0^(π/L))ln((sin^2)(p L))dp

Sum[1/(p - k Pi/L)^2, {k, -Infinity, Infinity}]

int2 = 1/(L Pi) L^2 Integrate[2 Log[Sin[p L]], {p, 0, Pi/L}, Assumptions -> L > 0]

So, we obtain the value π exp(2(1-γ))/L for the entropic momentum uncertainty.

δp = Exp[-(int1 + int2)] // Together // Simplify

δx δp

This is slightly larger than the possible minimal value.

N[{%, %/(E Pi)}]

poly[a_, x_] = a - x^6 + 4 x^2;

int[a_?NumberQ] :=
Module[{x0 = Cases[x /. NSolve[poly[a, x] == 0, x], 
                   _Real?Positive][[1]]},
        NIntegrate[Evaluate[Sqrt[poly[a, x]]], {x, -x0, x0}]]

The following plot shows that the value of a is about 3.

Plot[int[a] - 2Pi, {a, 1/2, 12}]

We calculate a high-precision value of a.

int[a_?NumberQ] :=
With[{α = SetPrecision[a, 40]},
Module[{(* the root *)
        x0 = Cases[x /. NSolve[poly[α, x] == 0, x,
           WorkingPrecision -> 40], _Real?Positive][[1]]},
        (* the integral to high precision *)
        NIntegrate[Evaluate[SetPrecision[Sqrt[poly[α, x]], 40]], 
                   {x, -x0, x0}, WorkingPrecision -> 40]]]

FindRoot[int[a] - 2 Pi, {a, 2, 3},
         WorkingPrecision -> 30, AccuracyGoal -> 30, Compiled -> False]

Using the package NumberTheory`Recognize`, we find a low-order algebraic number that has the same value.

Needs["NumberTheory`Recognize`"]

Recognize[%%[[1, 2]], 2, t]

Solve[% == 0, t]

For this value of a, the polynomial actually factors.

Factor[16/3/Sqrt[3] - x^6 + 4 x^2, Extension -> Automatic]

Calculating the exact value for x0, we can symbolically integrate the integral and obtain the value 2π.

Solve[16/3/Sqrt[3] - x^6 + 4 x^2 == 0, x]

Integrate[Sqrt[%%], {x, -2/3^(1/4), 2/3^(1/4)}]

int = Integrate[1/(z^8 + 5 z^6 + 14 z^4 + 5 z^2 +1)^4, 
                {z, -Infinity, Infinity}];

ByteCount[int]

Here is the approximative value of the integral.

N[int, 50]

The result is a product of 2π i and a sum that contains four terms.

int1 = int/(2 Pi I);
Head[int1]

Each of the four terms has the structure of a rational function of some radicals. Here is the structure of the first term.

Short[int1[[1]], 2]

To simplify int, we could apply RootReduce to first find a canonical form for int. Although conceptually this is a useful operation, practically, it would take a long time because of the high-degree radicals. So we simplify the numerators and denominators of the four summands by applying Together and Simplify.

{nums, dens} = {Simplify[Numerator[#]]& /@ (List @@ int1),
                Simplify[Expand[Denominator[#]]]& /@ (List @@ int1)};

The last operations shrank the expressions considerably.

ByteCount[{nums, dens}]

Now we first unite complex conjugate roots and the apply RootReduce to the result. Numericalization shows which terms are complex conjugate to each other.

N[nums/dens]

ord = Last /@ Sort[MapIndexed[{Abs[#1], #2[[1]]}&, N[nums/dens]]]

RootReduce[
 RootReduce[Simplify[nums[[ord[[1]]]]/dens[[ord[[1]]]] + 
                     nums[[ord[[2]]]]/dens[[ord[[2]]]]]] +
 RootReduce[Simplify[nums[[ord[[3]]]]/dens[[ord[[3]]]] + 
                     nums[[ord[[4]]]]/dens[[ord[[4]]]]]]]

The last result is a root of a biquadratic polynomial. It can be easily written as a nested radical.

2 Pi I ToRadicals[%] // Simplify

N[%, 50]

int = (z^γ - 1)/γ/z^2 (1 + (z^γ - 1) x)^(-γ^(-1) - 1);

Integrate[int, {z, 1, Infinity}, Assumptions -> x > 1]

TimeConstrained[Limit[%, γ -> 0], 10]

We will try a term by term integration after expanding he integrand in a power series around γ=0. The terms might not be integrable, so potentially we might have to regularize the result.

Off[Power::infy];
Limit[int, γ -> 0] + γ Limit[D[int, γ], γ -> 0]

Now a direct call to Integrate succeeds.

Integrate[%, {z, 1, Infinity}, Assumptions -> x > 1,
          GenerateConditions -> False] /. γ -> 0

Here is a quick check for a random value of x and a small value of γ.

With[{γ = 10^-20, x = E Pi}, 
   {(* numerical value for small γ *)
    NIntegrate[(z^γ - 1)/γ (1 + (z^γ - 1)x)^(-1/γ - 1)/z^2, 
                {z, 1, 2, Infinity}, 
               PrecisionGoal -> 20, WorkingPrecision -> 22], 
    (* exact result *)
    (1 + 2x + x^2)/(1 + x)^4} // N[#, 20]&]

root = Root[#^6 - x # - x &, 1];
integrand = Log[x^2] root;
Integrate[integrand, x]

It seems natural to introduce a new integration variable X=root.

newIntegrand = integrand /. root -> X

Expressing the original integration variable x through X is straightforward.

sol = Solve[root[[1]][X] == 0, x]

So we have the following new integrand.

newIntegrand2 = newIntegrand /. sol[[1]]

The change of variables ∫f(x) dx=∫f(x(X))(dx/dX)dX requires the calculation of the derivative dx/dX as a function of X.

gb = GroebnerBasis[{#, D[#, X]}&[root[[1]][X] /. x -> x[X]] /. x[X] -> x,
                   {}, {x}, MonomialOrder -> EliminationOrder];

dxdX = x'[X] /. Solve[gb[[1]] == 0, x'[X]][[1]]

So we arrive at the following result for the first integral.

int = (Integrate[newIntegrand2 dxdX, X] // Simplify) /. X -> root

Differentiating the last result allows us straightforwardly to check the integral.

D[int, x] - integrand // Simplify

Mathematica also cannot carry out the second integral directly.

root = Root[#^7 - #^2 - x &, 3];
integrand = Exp[root] Log[root] root;
Integrate[integrand, x]

Again, we introduce a new integration variable X=root.

newIntegrand = integrand /. root -> X

We proceed as above and express the integrand and dx/dX as a function of X. Then, we carry out the resulting integral and substitute root for X.

sol = Solve[root[[1]][X] == 0, x]

newIntegrand2 = newIntegrand /. sol[[1]]

gb = GroebnerBasis[{#, D[#, X]}&[root[[1]][X] /. x -> x[X]] /. x[X] -> x,
                    {}, {x}, MonomialOrder -> EliminationOrder];

dxdX = x'[X] /. Solve[gb[[1]] == 0, x'[X]][[1]]

int = (Integrate[newIntegrand2 dxdX, X] // Simplify) /. X -> root

Again, we can use differentiation to check the result.

D[int, x] - integrand // Simplify

The third integrand is a square root of a ratio of roots.

Clear[x, integrand];
poly[x_] = #^3 - # - x&;

ratio[x_] = Root[poly[x], 2]/Root[poly[x], 3];
integrand[x_] = (ratio[x]^2)^(1/2);

A direct integration fails again.

Integrate[integrand[x], x]

In this example some discontinuities come from the Root-objects and some from the square root. The following graphic shows the imaginary part of the integrand and the argument of the square root.

Plot[{Im[ratio[x]], Im[integrand[x]]}, {x, -10, 10},
     PlotStyle -> {{Thickness[0.02], GrayLevel[0.4]}, {Hue[0]}},
     Frame -> True, Axes -> False]

Along the real line the discontinuities arising from the roots are at x≈±0.385.

NSolve[{poly[x][ξ] == 0, D[poly[x][ξ], ξ] == 0}, {x}, {ξ}]

We proceed as above and introduce the new integration variable X=(Subscript[ℛ, 2])(ξ, -x- ξ+(ξ^3))/(Subscript[ℛ, 3])(ξ, -x- ξ+(ξ^3)).

xXEq = Factor[GroebnerBasis[Numerator[Together[
              {poly[x][r2], poly[x][r3], (* definition for variable X *)
               X^2 - (r2/r3)^2}]], {X, x}, {r2, r3},
               MonomialOrder -> EliminationOrder][[1]]]

It turns out that the last factor is the one of interest for us.

sol = x'[X] /. Solve[{xXEq[[-1]] == 0, D[xXEq[[-1]] /. 
                  x -> x[X], X] == 0} /. x[X] -> x, {x'[X]}, {x}]

In the new integration variable X the integral is relatively simple.

intPreX = Integrate[Sqrt[X^2] sol[[1]], X] // Simplify

Unfortunately, due to the outer square root, the integral is not correct everywhere. The ratio of the derivative of intPre[x] and the original integrand integrand[x] is a differential algebraic constant of value ±1. The following graphic shows this clearly.

intPre[x_] = intPreX /. X -> ratio[x];

aux1[R2_, R3_, x_] = Simplify[D[intPre[x], x] /. {Root[poly[x], 2] -> R2,
                                                  Root[poly[x], 3] -> R3}];

der[x_] := Module[{R2 = Root[poly[x], 2], R3 = Root[poly[x], 3]}, 
                  aux1[R2, R3, x]]

Plot3D[Re[der[x + I y]/integrand[x + I y]], {x, -3, 3}, {y, -3, 3},
       PlotPoints -> 60, Mesh -> False]

Let α(x) be this differential algebraic constant. Let (Subscript[ℐ, P])(x) be the current integral intPre[x] and ℐ(x) the correct value. Differentiating the relation ℐ(x)=α(x)(Subscript[ℐ, P])(x) and taking into account α'(x)=0 yields ℐ(x)=integrand(x)/(Subscript[ℐ, P]^′)(x)(Subscript[ℐ, P])(x). Calculating ℐ(x) according to this formula yields the following result. (We abbreviate the two roots for brevity.)

int = integrand[x]/D[intPre[x], x] intPre[x];

Simplify[int /. {Root[poly[x], 2] -> R2, Root[poly[x], 3] -> R3}]

Using the defining polynomial relations for R2 and R3 we could eliminate all powers of degree ≥3, but we do not need this here. A quick numerical check (because of the large size of the derivative we use a numerical check here) shows that int is the correct indefinite integral for all complex x.

aux2[R2_, R3_, x_] = Simplify[D[int, x] /. 
         {Root[poly[x], 2] -> R2, Root[poly[x], 3] -> R3}];

(* compiled version for faster numerical evaluation *)                       
aux2c = Compile[{{R2, _Complex}, {R3, _Complex}, {x, _Complex}},
                Evaluate[aux2[R2, R3, x]]];

der[x_] := Module[{R2 = Root[poly[x], 2], R3 = Root[poly[x], 3]}, 
                  aux2c[R2, R3, x]]

Plot3D[Re[der[x + I y]/integrand[x + I y]] - 1,
       {x, -3, 3}, {y, -3, 3}, PlotPoints -> 60, Mesh -> False]

Although the fourth integrand looks more complicated than the third one, it is actually easier to integrate.

poly[x_] = #^3 - x # - x&;

ratio[x_] = Root[poly[x], 2]/Root[poly[x], 3];
integrand[x_] = (ratio[x]^3)^(1/3);

A direct integration fails again.

TimeConstrained[Integrate[integrand[x], x], 100]

TimeConstrained[Integrate[ToRadicals[integrand[x]], x], 100]

Again, we let the new integration variable be the ratio of the roots X=(Subscript[ℛ, 2])(ξ, -x- ξ+(ξ^3))/(Subscript[ℛ, 3])(ξ, -x- ξ+(ξ^3)).

xXEq = Factor[GroebnerBasis[Numerator[Together[
              {poly[x][r2], poly[x][r3],
               X^3 - (r2/r3)^3}]], {X, x}, {r2, r3},
               MonomialOrder -> EliminationOrder][[1]]]

This time, the second factor is the one of relevance.

sol = x'[X] /. Solve[{xXEq[[-2]] == 0, D[xXEq[[-2]] /. 
               x -> x[X], X] == 0} /. x[X] -> x, {x'[X]}, {x}]

The resulting indefinite integral is quite simple.

intX = Integrate[(X^3)^(1/3) sol[[1]], X] // Simplify

A numerical check shows that int is the correct indefinite integral.

int = intX /. X -> ratio[x];

Clear[diff];
diff[x_] = D[int, x] - integrand[x] // Simplify;

Plot3D[Re[diff[x + I y]], {x, -3, 3}, {y, -3, 3},
       PlotPoints -> 60, Mesh -> False]

diff[x]

Mathematica cannot carry out the fifth integral directly.

integrand = Root[#^3 - # - x&, 2]/(Root[#^3 - # + x&, 2] - 1);
Integrate[integrand, {x, 0, 1}]

Also the indefinite integral cannot be calculated.

Integrate[integrand, x]

Of course we can calculate a numerical approximation of this integral.

NIntegrate[integrand, {x, 0, 2/(3 Sqrt[3]), 1}]

We introduce a new integration variable X=integrand.

xXEq = Eliminate[{r1^3 - r1 - x == 0, r2^3 - r2 + x == 0, 
                  X - r1/(r2 - 1) == 0},
                 {r1, r2}] // Subtract @@ #& // Factor

This time, we have two different possibilities for ((dx)/(dX)).

sol = Solve[{xXEq == 0, D[xXEq /. x -> x[X], X] == 0} /. 
            x[X] -> x, {x'[X]}, {x}]

The first one is correct in certain parts of the complex x-plane.

int1 = Integrate[X sol[[1, 1, 2]], X] /. X -> integrand

Plot[Evaluate[Abs[D[int1, x] - integrand]], {x, -1, 1}, PlotRange -> All]

The boundaries of the interval where int1 is correct coincide with the points of discontinuity of Root[#^3 - # - x&, 2].

Show[GraphicsArray[Plot[Evaluate[#[Root[#^3 - # - x&, 2]]], {x, -1, 1}, 
     PlotRange -> All, DisplayFunction -> Identity]& /@ {Re, Im}]]

The two points are branch points of ((r(x))^3)-r(x)+x==0.

Solve[{r1^3 - r1 + x == 0, D[r1^3 - r1 - x, r1] == 0}, {x}, {r1}]

The integral int1 is a continuous function of x at the branch points.

Show[GraphicsArray[
Plot[Evaluate[#[int1]], {x, -1, 1}, 
     PlotRange -> All, Frame -> True, Axes -> False,
     DisplayFunction -> Identity]& /@ {Re, Im}]]

In a similar manner, we find that int2 is the correct indefinite integral outside of the interval (-2/(3(Sqrt[3])),2/(3(Sqrt[3]))).

int2 = Integrate[X sol[[2, 1, 2]], X] /. X -> integrand

Plot[Evaluate[Abs[D[int2, x] - integrand]], {x, -1, 1}, PlotRange -> All]

int2 too is a continuous function at the branch points.

Show[GraphicsArray[
   Plot[Evaluate[#[int2]], {x, -1, 1}, 
        PlotRange -> All, Frame -> True, Axes -> False,
        DisplayFunction -> Identity]& /@ {Re, Im}]]

Using now the two indefinite integrals int1 and int2 allows us to calculate the definite integral.

(int1 /. x -> 2/(3 Sqrt[3])) - (int1 /. x -> 0) +
(int2 /. x -> 1) - (int2 /. x -> 2/(3 Sqrt[3])) // RootReduce

Combining the logarithms, we have the following final result.

% //. Log[x_] + a_. Log[y_] :> Log[x y^a] // RootReduce

The numerical value of the last expression agrees with the above result from NIntegrate.

N[%]

Mathematica also cannot carry out the last integral directly.

integrand = 1/Root[#^5 + # - x&, 1] - (x^(-1/5) + 1/5 x^-1);
Integrate[integrand, {x, 1, Infinity}]

We can use NIntegrate to get a numerical approximation of the integral.

NIntegrate[integrand, {x, 1, Infinity}, Method -> DoubleExponential]

We introduce a new integration variable X=Root[#^5 + # - x&, 1] to integrate the first summand (∫_1^∞)1/(Subscript[ℛ, 1])(ξ,- x+ξ+(ξ^5))dξ.

Solve[{X^5 + X - x == 0, D[X^5 + X - x[X], X] == 0} /.
      x[X] -> x, {x'[X]}, {x}]

The integral is now easily doable and verifiable.

int1 = Integrate[1/X (1 + 5 X^4), X] /. X -> Root[#^5 + # - x&, 1]

D[int1, x] - 1/Root[#^5 + # - x&, 1] // Simplify

The integration over the second and third summand is trivial.

int2 = Integrate[(x^(-1/5) + 1/5 x^-1), x] // PowerExpand

The series expansion of 1/(Subscript[ℛ, 1])(ξ,- x+ξ+(ξ^5))dξ around x=∞ shows that the second and third summand of the integral are simply the leading terms of the inverse root.

rootSer = InverseSeries[Series[x^5 + x, {x, Infinity, 20}], x]

1/rootSer

The remaining series terms are convergent at x=∞. At x=∞, int1 differs from int2 by 1.

int1 /. _Root -> rootSer // Normal

Putting all subresults together, we arrive at the following short result for the integral.

int2 - int1 - 1 /. x -> 1 // RootReduce

The numerical value of the last result agrees with the above value from NIntegrate.

N[%]

For an algorithmic treatment of the integration of algebraic functions, see [398✶].

AppendTo[$ContextPath, "Experimental`"]

conds = CylindricalAlgebraicDecomposition[#, {a1, a2, a3}]& @
Resolve[Exists[{x1, x2, x3}, 
  Element[{a1, a2, a3, x1, x2, x3}, Reals],
  (* x1, x2, x3 are roots of cubic *)
  x1 x2 x3 == a3 && x1 x2 + x1 x3 + x2 x3 == a2 &&
  x1 + x2 + x3 == -a1 &&
  (* triangle conditions *)
  x1 > 0 && x2 > 0 && x3 > 0 &&
  x1 + x2 > x3 && x2 + x3 > x1 && x1 + x3 > x2]]

For the visualization and probability calculation we can ignore lower-dimensional parts of conds.

conds2 = DeleteCases[conds //. a_ && (b_ || c_) :> a && b || a && c,
         _?(MemberQ[#, Equal, Infinity, Heads -> True]&)] /.
                                               LessEqual -> Less;

conds2 yields immediately a piecewise parametrization of the region in (Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3])-space. The right graphic shows the cross section of the 3D region for (Subscript[a, 1])=-1.

makePoints[a1 < 0 && Inequality[a2l_, Less, a2, Less, a2u_] &&
           Inequality[a3l_, Less, a3, Less, a3u_], {ε_, pp_}] := 
(* points along boundaries; 
   avoid endpoints for numerical evaluation *)
Table[{a1, a2, Re[#]}, {a1, -2 + ε, 0 - ε, (2 - 2ε)/pp}, 
      {a2, Re[a2l + ε], Re[a2u - ε], 
           Re[(a2u - a2l - 2ε)/pp]}]& /@ {a3l, a3u};

Needs["Graphics`Graphics3D`"]

Show[GraphicsArray[{
Graphics3D[{EdgeForm[], Cases[(* the region in a1,a2,a3-space *)
     Map[ListSurfacePlot3D[#, DisplayFunction -> Identity]&,
         makePoints[#, {10^-12, 24}]& /@ conds2, {2}],
         _Polygon, Infinity]}, BoxRatios -> {1, 1, 1}, 
         Axes -> True, PlotRange -> All] // N,
(* zoomed in outline plot in the a1 == -1 plane *)      
ContourPlot[Evaluate[If[conds2 /. a1 -> -1, 1, -1]],
            {a2, 0.25, 0.35}, {a3, 0.01, 0.04}, 
            PlotPoints -> 250, ContourShading -> False,
            Contours -> {0}, DisplayFunction -> Identity]}]]

conds2 also yields immediately the boundaries for the 3D region that allows for a triangle interpretation of the roots. A1 is the smallest value of a1.

toIntegral[a1 < 0 && Inequality[a2l_, Less, a2, Less, a2u_] &&
      Inequality[a3l_, Less, a3, Less, a3u_], A1_] := 
      Integrate[1, {a1, A1, 0}, {a2, a2l, a2u}, {a3, a3l, a3u},
                GenerateConditions -> False]

Calculating the volume of the region for -1<(Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3])<1 gives a 0.00014% probability that for random (Subscript[a, 1]), (Subscript[a, 2]), (Subscript[a, 3]) from the interval [-1,1] the roots are the side length of a nondegenerate triangle.

Simplify[toIntegral[conds2[[1]], A1] + 
         toIntegral[conds2[[2]], A1], A1 < 0]

{#, N[#]}&[%/2^3 /. A1 -> 1]

A “random” check shows that it takes in average about three quarter of a million trials until we find a cubic whose roots can be interpreted as triangle side lengths.

(* do the three numbers x1, x2, and x3 form the edges of a triangle? *)
triangleQ[{x1_, x2_, x3_}] :=
If[Union[Head /@ {x1, x2, x3}] === {Real},
   If[x1 + x2 > x3 && x2 + x3 > x1 && x1 + x3 > x2, 
      True, False], False]

SeedRandom[18];
counter = 0;
While[{a1, a2, a3} = Table[Random[Real, {-1, 1}], {3}];
      {x1, x2, x3} = x /. {ToRules[NRoots[
                           x^3 + a1 x^2 + a2 x + a3 == 0, x]]};
      Not[triangleQ[{x1, x2, x3}]], counter++];
counter

Because the branch points and the branch cuts are unknown in this example, it is not so obvious how to generate a picture like those in the corresponding examples treated in Chapter 2 of the Graphics volume [1560✶] of the GuideBooks. Of course, we could use the general numerical algorithm implemented in Subsection 1.11.1 of the Numerics volume [1561✶] of the GuideBooks, but here we will use some more symbolic calculations to generate the Riemann surface under consideration.

We start by looking at the branch points of the Riemann surface. Because they connect the various sheets, they occur at the points (Subscript[a, "bp"]) where the polynomial (x^3)+(x^2)+a x-1/2=0 has multiple roots.

Eliminate[{# == 0, D[#, x] == 0}, x]&[eq = x^3 + x^2 + a x - 1/2]

That means we have three branch points bps that have the following coordinates.

bps = #[[1, 2]]& /@ NSolve[%, a]

Solving the above cubic equation eq for x yields three solutions corresponding to three sheets of the Riemann surface.

sol = Solve[eq == 0, x]

Unfortunately, a direct visualization of the real or imaginary part of x(a) by putting together three Plot3D-generated pictures of the above solution sol does not give a satisfactory result. (We use the imaginary part here; the real part results in very similar pictures.) This is because branch cuts that come out from the branch points give nearly vertical walls in the picture.

Show[GraphicsArray[ (* the three pictures *)
  Plot3D[Evaluate[Im[#[[1, 2]] /. a -> ax + I ay]], {ax, -3, 3},
         {ay, -3, 3}, PlotRange -> All, PlotPoints -> 45,
         DisplayFunction -> Identity]& /@ sol]]

The use of NSolve or NRoots also does not avoid this problem, because in their output, the roots are ordered lexicographically, which, of course, does not give better pictures. To avoid these discontinuities in the graphic, we have to be a little bit more careful. First, we determine where the above branch cuts are located. Looking at the solution sol, we recognize that they are caused by negative values of the expression under the square root, this means by (19+36a-4(a^2)+16(a^3)), which is simply the left-hand side of the defining equation for the branch points. Here, the branch cuts are calculated and graphically represented. The underlying ContourGraphics shows the real part of the first solution of sol.

ContourPlot[Evaluate[Im[sol[[1, 1, 2]] /. a -> ax + I ay]],
            {ax, -3, 3}, {ay, -3, 3}, PlotPoints -> 120, 
            ContourShading -> False, Contours -> 50,
            (* the branch cuts implicitly parametrized *)
            Epilog -> (* use ParametricPlot for smooth curves *)
         ParametricPlot[Evaluate[{Re[#[[1, 2]]], Im[#[[1, 2]]]}& /@
             Solve[19 + 36 a - 4 a^2 + 16 a^3 == -t, a]], {t, 0, 600},
             PlotStyle -> {{Thickness[0.02], Dashing[{0.01, 0.04}]}},
             PlotRange -> {{-3, 3}, {-3, 3}}, AspectRatio -> Automatic,
             DisplayFunction -> Identity][[1]]]

By using a=r(e^(iφ)) in 19+36a-4(a^2)+16(a^3), we can obtain an implicit equation for the branch cuts.

Module[{y1, realPart, imaginaryPart},
       (* change to polar coordinates *)
       y1 = (19 + 36a - 4 a^2 + 16 a^3 /.
            {a -> r (Cos[φ] + I Sin[φ])}) // Expand;
       (* take out real and imaginary parts *)
       imaginaryPart = Plus @@ Cases[y1, _ _Complex];
       realPart = y1 - ii;
       (* make nice equations *)Factor[Simplify[Subtract @@
       Eliminate[{realPart == -t, imaginaryPart == 0}, {t}]]]]

For a given value of r, we can determine the corresponding φ. (We do this here numerically to make sure that we pick the “correct” one in the first quadrant.)

pOfr[r_] := pOfr[r] =
FindRoot[9 Sin[φ] - r Sin[2φ] + 4 r^2 Sin[3φ], {φ, 1.3}][[1, 2]]

Now we have to put all of these together to make a picture of the Riemann surface of x(a). 
To avoid the vertical walls due to the branch cuts, we subdivide the complex a\[Hyphen]plane in various regions. For \[LeftBracketingBar]a\[RightBracketingBar]<r1 (where r1 is the distance of the nearest branch point to the origin), no problems arise; all three sheets are disconnected in this region. For r1<\[LeftBracketingBar]a\[RightBracketingBar]<r2 (r2 being the distance of the two branch points further away from the origin) we avoid the line φ=π, where two sheets intersect each other, and in the region \[LeftBracketingBar]a\[RightBracketingBar]>r2, we model the surface by three pieces, consisting of the various solutions, arranged in such a manner that they fit together continuously over the branch point. (Because of the complicated function structure inside ParametricPlot3D, we precompile the above solutions to speed up the numerical calculations. The chosen values for the plot points make a homogeneously divided surface. The φ division is homogeneous; this could be refined to fit exactly within the branch cuts.)

{r1, r2} = {Abs[bps[[1]]], Abs[bps[[2]]]}

Do[f[i] = Compile[{{a, _Complex}}, Evaluate[sol[[i, 1, 2]]]], {i, 3}]

Module[{ε = 10^-6 (* not visible in picture;
                     but avoids touching the branch cuts *),
        np = 41, nr = 2, opts = Sequence[Compiled -> False, 
                               DisplayFunction -> Identity]},
Flatten[{(* the various parts, avoiding crossing any branch cut *)
(* the inner parts wrt r *)
Table[ParametricPlot3D[{r Cos[φ], r Sin[φ], Re @ f[i][N[r Exp[I φ]]]},
                       {r, 0, r1}, {φ, 0, 2Pi}, PlotPoints -> {2nr, np},
                       Evaluate[opts]][[1]], 
      {i, 3}],
(* the middle part wrt r *)
Table[ParametricPlot3D[{r Cos[φ], r Sin[φ], Re @ f[i][N[r Exp[I φ]]]},
                       {r, r1, r2}, {φ, -Pi + ε, Pi - ε},
                       PlotPoints -> {5nr, np}, Evaluate[opts]][[1]],
     {i, 3}],
(* the outer part wrt r *)
ParametricPlot3D[{r Cos[φ], r Sin[φ],
Which[φ < pOfr[r],           Re @ f[1][N[r Exp[I φ]]],
      φ < N[Pi] + ε,         Re @ f[3][N[r Exp[I φ]]],
      φ < N[2Pi - pOfr[r]],  Re @ f[2][N[r Exp[I φ]]],
      True,                  Re @ f[1][N[r Exp[I φ]]]]},
                {r, r2, 3.2}, {φ, 0, 2Pi}, 
                PlotPoints -> {7nr, np}, Evaluate[opts]][[1]],
ParametricPlot3D[{r Cos[φ], r Sin[φ],
Which[φ < N[Pi] + ε,       Re @ f[2][N[r Exp[I φ]]],
      True,                Re @ f[3][N[r Exp[I φ]]]]},
                 {r, r2, 3}, {φ, 0, 2Pi}, PlotPoints -> {7nr, np},
                 Evaluate[opts]][[1]],
                 
ParametricPlot3D[{r Cos[φ], r Sin[φ],
Which[φ < pOfr[r],           Re @ f[3][N[r Exp[I φ]]],
      φ < N[2Pi - pOfr[r]],  Re @ f[1][N[r Exp[I φ]]],
      True,                  Re @ f[2][N[r Exp[I φ]]]]},
                 {r, r2, 3}, {φ, 0, 2Pi}, PlotPoints -> {7nr, np},
                 Evaluate[opts]][[1]]}]];

So we can display the whole surface. If all the pieces are put together now, no spurious vertical walls will be there. For better visibility, we make holes in the polygons.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity, opts = Sequence[
       Boxed -> False, BoxRatios -> {1, 1, 2}, 
       ViewPoint -> {1.53, -1.9, 1.15},
       PlotRange ->  {{-3.25, 3.25}, {-3.25, 3.25}, {-2.3, 1.45}}]},
{Show[Graphics3D[%], opts],
 Show[Graphics3D[{Thickness[0.002], EdgeForm[],
                  SurfaceColor[Hue[0.22], Hue[0.12], 2.1],
(* make holes in the polygons to better see that it is one surface *)
Function[l, Module[{mp = Plus @@ l/Length[l], λ, nOld, nNew},
  λ = (mp + 0.74 (# - mp))& /@ l;
 {nOld, nNew} = Partition[Append[#, First[#]], 2, 1]& /@ {l, λ};
 {MapThread[Polygon[Join[#1, Reverse[#2]]]&, {nOld, nNew}],
  Line[Append[#, First[#]]]&[λ]}]] /@ 
  (* the polygons of the last picture *) 
  (First /@ Cases[%, _Polygon, Infinity])}], opts]}]]]

Function[ord, (* rewrite at the end *)
Collect[#, Cases[#, _Sin, {0, Infinity}]]&[
(* simplify the sin functions *)
TrigFactor /@ Expand[Fold[Normal[M + e Sin[#1 +
 (* this makes automatically the expansion *) O[e]^#2]]&,
         M, Range[ord]]]]][10]

Note that by using the Lagrange-Bürmann theorem, it is possible to give this result in closed form [748✶].

(* scalar product is commutative *)
SetAttributes[dot, Orderless]

(* linearity of 𝒹 *)
𝒹[sum_Plus, t] := 𝒹[#, t]& /@ sum

(* Leibniz rule for differentiation of products *)
𝒹[product_Times, t] := Plus @@
MapIndexed[Function[{arg, pos}, MapAt[𝒹[#, t]&, arg, pos[[1]]]],
           Array[product&, Length[product]]]

(* time derivative of a constant vanishes *)
𝒹[_?(FreeQ[#, r[t], {0, Infinity}] &&
     FreeQ[#, R[t], {0, Infinity}] &), t] = 0;

(* time derivative of r[t] via explicit differentiation *)
𝒹[r[t]^n_., t] := n r[t]^(n - 1) dot[R[t], 𝒹[R[t], t]]/r[t]

(* time derivative of scalar product *)
𝒹[dot[a_, b_], t] := dot[𝒹[a, t], b] + dot[a, 𝒹[b, t]]

(* time derivative of powers of scalar products *)
𝒹[dot[R[t], 𝒹[R[t], t]]^n_, t] :=
  n dot[R[t], 𝒹[R[t], t]]^(n - 1) 𝒹[dot[R[t], 𝒹[R[t], t]], t]

(* equation of motion for 𝒹[𝒹[R[t], t], t] *)
𝒹[𝒹[R[t], t], t] = -R[t]/r[t]^3;

(* pulling out nonvectors from the scalar product *)
dot[a_?(FreeQ[#, R[t]] && FreeQ[#, 𝒹[R[t], t]]&) b_, c_] := a dot[b, c]

(* definition of r[t] through scalar product of R[t] *)
dot[R[t], R[t]] = r[t]^2;

The most important ingredient in the last definition is the use of the equation of motion. This allows us to reduce all higher-order time derivatives as linear combinations of the two vectors R[0] and R'[0]. 
The derivatives needed in "r"(t)="r"(0)+("r")'(0)+1/2!("r")''(0)(t^2)+1/3!("r")'''(0)(t^3)+… are calculated recursively.

term[0] = R[t];
term[n_] := term[n] = Expand[𝒹[term[n - 1], t]];

The command shorten introduces the abbreviations given above. shorten[term[i]] gives a list with the coefficients of (Subscript["r", 0]) and (Subscript["v", 0]) in term[i]. (Because the lowest-order terms are not sums, we give their short forms separately.)

(* initial terms *)
shorten[term[0]] = { 1, 0};
shorten[term[1]] = { 0, 1};
shorten[term[2]] = {-u, 0};

shorten[term_] := shorten[term] =
(* collect wrt R[t] and d[R[t], t]; factor coefficients *)
{Factor[Plus @@ (Cases[#, R[t] _.]/R[t])],
 Factor[Plus @@ (Cases[#, 𝒹[R[t], t] _.]/𝒹[R[t], t])]}&[
(* introduce shortcuts *)
(term //. {dot[𝒹[R[t], t], R[t]] -> s r[t]^2,
           dot[𝒹[R[t], t], 𝒹[R[t], t]] -> w r[t]^2}) //.
                                 {r[t]^n_ -> u^(-n/3)}]

Now we have everything together to define and to test the resulting series.

newtonSeries[ord_] := {r0, v0}.
   Table[Sum[shorten[term[i]][[1]] t^i/i!, {i, 0, ord}], {i, 2}]

Here are the first few terms of the resulting series expansion.

newtonSeries[5]

Much larger expansions can be calculated quite quickly too.

Short[newtonSeries[15], 8] // Timing

x1 = -μ; x2 = 1 - μ;

V[x, y] = 
With[{r1 = Sqrt[(x - x1)^2 + y^2], r2 = Sqrt[(x - x2)^2 + y^2]},
      -(1/2 (x^2 + y^2) + (1 - μ)/r1 + μ/r2)];

The two equations to be solved (meaning equilibrium points) are the following.

eqs1 = {D[V[x, y], x], D[V[x, y], y]}

Solving the last two equations directly fails in a reasonable amount of time. So we will solve the two equations “manually”.

TimeConstrained[Solve[Thread[eqs1 == {0, 0}], {x, y}], 100]

To avoid the presence of radicals, we first rewrite the two equations in a polynomial form by introducing two auxiliary variables R1 and R2.

eqs2 = Factor[Numerator[Together[eqs1]] /. 
       {Sqrt[(x - x2)^2 + y^2] -> R2, Sqrt[(x - x1)^2 + y^2] -> R1}]

The second equation of eqs2 shows that we can split the problem into the case y=0, and into the case in which the more complicated term in the second element of eqs2 is equal to zero. Let us start with the y=0 case. Eliminating R1 and R2 gives the following polynomial system.

gb1 = GroebnerBasis[{eqs2[[1]], y, (x - x2)^2 + y^2 - R2^2, 
                                   (x - x1)^2 + y^2 - R1^2}, 
                     {x, y}, {R1, R2}, 
                     MonomialOrder -> EliminationOrder,
                     ParameterVariables -> {μ},
                     CoefficientDomain -> Rationals] // Factor

Solving this system results in x-coordinates that are solutions of fifth-order equations.

(* do not give radicals in the solution—
   Root-objects are shorter *)
SetOptions[Roots, Cubics -> False, Quartics -> False];

sol1 = Union[Append[#, y -> 0]& /@ 
                   (ToRules[Roots[# == 0, x]]& /@ Rest[gb1])]

The second case results in a more complicated set of equations after the elimination of R1 and R2.

gb2 = GroebnerBasis[{eqs2[[1]], eqs2[[2, -1]], 
                     (x - x2)^2 + y^2 - R2^2, (x - x1)^2 + y^2 - R1^2}, 
                     {x, y}, {R1, R2}, MonomialOrder -> EliminationOrder,
                     ParameterVariables -> {μ},
                     CoefficientDomain -> Rationals] // Factor

Rewriting gb2 in lexicographic order shows more clearly the nature of the solutions.

gb3 = GroebnerBasis[gb2, {x, y}, ParameterVariables -> {μ}] // Factor;
Short[gb3, 14]

The first two equations determine the possible y-values.

Prepend[Union[(ToRules[Roots[# == 0, y]]& /@ 
            Union[Cases[gb3, _Plus?(FreeQ[#, x]&), Infinity]])], {y -> 0}]

Here is the whole solution set of gb3.

sol2 = Solve[# == 0& /@ gb3, {x, y}] // Union

Now let us deal with the special case μ=1/10. We first select all real solutions.

solAll1 = Select[RootReduce[Join[sol1, sol2] /. μ -> 1/10],
                 (Im[x] == 0 && Im[y] == 0 /. #)&]

Because in the process of rewriting a system of equations that contains radicals into a polynomial system some solutions of the polynomial system may not be solutions of the original system containing radicals, we backsubstitute the solutions solAll1 and check if they satisfy the original equations eqs1.

(* to avoid messages due to vanishing denominators *)
Off[Power::infy]; Off[Infinity::indet];

solAll2 = Select[solAll1, (RootReduce[eqs1 /. μ -> 1/10 /. #] === {0, 0})&]

The so-obtained solutions are exactly the same as the ones produced by a direct call to Solve with specified parameters. (Using Solve on eqs1 for an explicitly specified μ is quite fast.)

Solve[# == 0& /@ (eqs1 /. μ -> 1/10), {x, y}]

The following picture shows the location of the five Lagrange points on the surface V(x,y).

Show[Graphics3D[{
     {EdgeForm[], SurfaceColor[Hue[0.3]],
      Cases[Graphics3D[Plot3D[Evaluate[V[x, y] /. μ -> 1/10], 
                              {x, -3/2, 3/2}, {y, -1.2, 1.2},
                              PlotPoints -> {120, 80}, 
                              DisplayFunction -> Identity]], 
                                          _Polygon, Infinity]},
     {PointSize[0.02], Hue[0], 
      Point[{x, y, 0.05 + V[x, y] /. μ -> 1/20} /. #]& /@ N[%]}}], 
      BoxRatios -> {3/2, 1.2, 1/2}]

For the curves of interest here, we calculate the coefficients (Subscript[a, "ij"]) in a straightforward brute force way. By converting the trigonometric functions into exponentials and expanding the resulting expressions, we get a system of linear equations for the coefficients of exp(ikt), which we solve and extract the interesting part from. Here, this method is implemented. (For the general case, this method should (and can) be refined to shorten the calculation time.)

algebraizise[{x_, y_}, t_, maxPower_, {X_, Y_}] :=
Module[{repRules, x1, y1, sum, terms, poly, vars, c1, c2, sol, facs, a},
 (* trigs to exponentials *)
 repRules = {Sin[a_] -> (((Exp[I a] - Exp[-I a])/(2I))),
             Cos[a_] -> (((Exp[I a] + Exp[-I a])/(2 )))};
 {x1, y1} = {x, y} //. repRules;
 (* the ansatz *)
 sum = Sum[a[i, j] x1^i y1^j, {i, 0, maxPower}, {j, 0, maxPower}];
 (* write as polynomial in Exp[I t] *)
 terms = Collect[sum, Exp[I t]];
 (* change Exp[i t] to new variable *)
 poly = terms //. Exp[u_] -> C[u];
 (* all powers present *)
 vars = Cases[poly, _C, {0, Infinity}];
 (* determine the coefficients *)
 c1 = Coefficient[poly, #]& /@ vars;
 (* take care of the term Exp[0 I t] *)
 c2 = Append[c1, Expand[poly - c1.vars]];
 (* solve the linear system *)
 sol = Solve[# == 0& /@ c2, Flatten[
             Table[a[i, j], {i, 0, maxPower}, {j, 0, maxPower}]]];
 (* factor the result after backsubstitution *)
 facs = Factor[Sum[a[i, j] X^i Y^j,
                   {i, 0, maxPower}, {j, 0, maxPower}] //. sol][[1]];
 (* extract the interesting piece *)
 Times @@ Cases[facs, _Plus?(FreeQ[#, _a, {0, Infinity}]&)]]

Here is an example.

algebraizise[{Sin[3ϑ], Cos[2ϑ]}, ϑ, 4, {x, y}]

The disadvantage of the last implementation is the fact that we explicitly have to specify the maximal degree of the linear system. A better way is to polynomialize the equations and then eliminate the auxiliary variable using Resultant.

algebraizise[{x_, y_}, t_, {X_, Y_}] :=
Module[{aux1, aux2, aux3, aux4, s},
(* transform trigs of multiple arguments to simple arguments *)
aux1 = {x, y} /.
{Cos[n_Integer t] :> Sum[(-1)^k Binomial[n, 2k] *
                         Cos[t]^(n - 2k) Sin[t]^(2k), {k, 0, n/2}],
 Sin[n_Integer t] :> Sum[(-1)^(k) Binomial[n, 2 k + 1] *
                         Sin[t]^(2k + 1) Cos[t]^(n - 2k - 1),
                         {k, 0, (n - 1)/2}]};
(* use rational parametrization for trigs *)
 aux2 = ({X, Y} - aux1) /. {Cos[t] -> (1 - s^2)/(1 + s^2),
                            Sin[t] -> 2s/(1 + s^2)};
(* make polynomial equations *)
 aux3 = Numerator[Together[aux2]];
(* eliminate parametrization variable s *)
 aux4 = Factor[Resultant[##, s]& @@ aux3];
(* if present - delete X and Y independent prefactor *)
 If[Head[aux4] === Times, DeleteCases[aux4, _?IntegerQ], aux4]]

As a first test, we treat the circle.

algebraizise[{Cos[t], Sin[t]}, t, {x, y}]

Here are the two Lissajous curves of interest.

algebraizise[{Cos[t], Sin[2t]}, t, {x, y}]

algebraizise[{Cos[3t], Sin[2t]}, t, {x, y}]

For the second one, we compare the contour plot of the implicit representation with the plot of the parametric representation.

Show[GraphicsArray[{
(* the parametrized form *)
ParametricPlot[{Cos[3t], Sin[2t]}, {t, 0, 2Pi}, Frame -> True,
               Axes -> False, DisplayFunction -> Identity,
               AspectRatio -> 1],
(* the implicit form *)               
ContourPlot[4 x^4 - 4 x^2 + 9 y^2 - 24 y^4 + 16 y^6,
            {x, -1.1, 1.1}, {y, -1.1, 1.1},
            Contours -> {0}, PlotPoints -> 160,
            DisplayFunction -> Identity, AspectRatio -> 1]}]]

For some other, more effective methods of how to implicitize parametrically given curves, see [375✶], [790✶], [1124✶], and [674✶].

lissa = (9 x^2 - 24 x^4 + 16 x^6 - 4 y^2 + 4 y^4)^2 - 1/2;

To get an idea about the shape of the region under consideration, we use ContourPlot. The black part is the region to be described. Because of the obvious symmetry of lissa with respect to the x-axis and y-axis, we restrict our investigation to the region x≥0,y≥0.

sketch = ContourPlot[Evaluate[lissa], {x, 0, 1.1}, {y, 0, 1.1},
                      PlotPoints -> 60, ContourShading -> True, 
                      Contours -> {0}]

We divide the region under interest in vertical stripes (Subscript[x, l])<x<(Subscript[x, u]), in such a manner that in each stripe, (Subscript[y, l])(x) and (Subscript[y, u])(x) are real analytic functions. In principle, the (Subscript[y, l])(x) and (Subscript[y, u])(x) may change their form (form = the branch of the roots of lissa) if a beginning or end of a hole or extremum is traversed. Analytically, this means y'(x)=∞. The points (Subscript[x, l]) and (Subscript[x, u]) are so described by the following equation.

res = Resultant[lissa, D[lissa, y], y] // Factor

Here, these points are explicitly calculated.

xPoints = Simplify @ Sort[Cases[Union[x /. Solve[res == 0, x]],
              _?((Im[Chop[N[#]]] == 0 && Re[Chop[N[#]]] > 0)&)],
                                         Re[N[#1]] < Re[N[#2]]&]

Adding the vertical lines corresponding to xPoints to sketch, we clearly see the six resulting stripes.

Show[{sketch, Graphics[{Hue[0], Line[{{#, 0}, {#, 1.1}}]& /@ xPoints}]}]

Inside each of the stripes, we need the solutions of lissa with respect to y. Because lissa is a quartic polynomial in y, we can explicitly solve for y(x) in radicals.

sol = Simplify[Union[Solve[lissa == 0, y]]]

To see which of the last solutions is describing which part of the boundary inside each stripe, we look at the curves described by the solutions.

(* avoid messages from spurious numericalization *)
Off[Plot::plnr];

Show[GraphicsArray[#]]& /@ Partition[
Show[{sketch,
      Graphics[{Hue[0], Line[{{#, 0}, {#, 1.1}}]& /@ xPoints}],
      Plot[Evaluate[#[[1, 2]]], {x, 0, 1.2},
           PlotStyle -> {{RGBColor[0, 1, 0], Thickness[0.02]}},
           DisplayFunction -> Identity, PlotRange -> {0, 1.1}]},
     DisplayFunction -> Identity, PlotRange -> {0, 1.1}]& /@ sol, 4]

So we finally have the following (Subscript[x, l]), (Subscript[x, u]), (Subscript[y, l])(x), and (Subscript[y, u])(x).

u = (1 - Sqrt[2] + I Sqrt[2 Sqrt[2] - 2]);
v = 2 - 18 x^2 + 48 x^4 - 32 x^6;

x1 = 0;
x2 = Sqrt[4 - u^(-1/3) - I Sqrt[3]/u^(1/3) -
          u^(1/3) + I Sqrt[3] u^(1/3)]/(2 Sqrt[2]);
x3 = Sqrt[2 - u^(-1/3) - u^(1/3)]/2;
x4 = Sqrt[4 + u^(-1/3) - I Sqrt[3]/u^(1/3) +
          u^(1/3) + I Sqrt[3] u^(1/3)]/(2 Sqrt[2]);
x5 = Sqrt[4 - u^(-1/3) + I Sqrt[3]/u^(1/3) -
          u^(1/3) - I Sqrt[3] u^(1/3)]/(2 Sqrt[2]);
x6 = Sqrt[2 + u^(-1/3) + u^(1/3)]/2;
x7 = Sqrt[4 + u^(-1/3) + I Sqrt[3]/u^(1/3) +
          u^(1/3) - I Sqrt[3] u^(1/3)]/(2 Sqrt[2]);
x8 = ((1 + Sqrt[2] + Sqrt[2 + 2 Sqrt[2]])^(-1/6) +
      (1 + Sqrt[2] + Sqrt[2 + 2 Sqrt[2]])^( 1/6))/2;

y1 = 0;
y2 = Sqrt[2 - Sqrt[2] Sqrt[v - Sqrt[2]]]/2;
y3 = Sqrt[2 + Sqrt[2] Sqrt[v - Sqrt[2]]]/2;
y4 = Sqrt[2 - Sqrt[2] Sqrt[v + Sqrt[2]]]/2;
y5 = Sqrt[2 + Sqrt[2] Sqrt[v + Sqrt[2]]]/2;

In terms of x0, x1, x2, x3, x4, x5, x6, x7, x8, y0, y1, y2, y3, y4, and y5, the region lissa < 0 can be described in the following manner.

(* avoid messages from spurious numericalization *)
Off[Less::"nord"];

negativeRegion =
x1 < x < x2 && y1 < y < y2 || x1 < x < x2 && y3 < y < y5 ||
x2 < x < x3 && y1 < y < y5 || x3 < x < x4 && y4 < y < y5 ||
x4 < x < x5 && y1 < y < y5 || x5 < x < x6 && y1 < y < y2 ||
x5 < x < x6 && y3 < y < y5 || x6 < x < x7 && y1 < y < y5 ||
x7 < x < x8 && y4 < y < y5;

We suppressed messages from Less in the last input. They would have been issued because Less uses numerical techniques to establish if a comparison is correct. The numericalization of the nested radical expressions for the xi and yi will yield an imaginary term of the form 0.×(10^(-exp))i.

N[x2, 22]

Because Mathematica cannot exclude the possibility that the imaginary part is not identical to zero, it issues a message. For the variables of interest xi and yi, we know that they are purely real; so we can safely suppress this message.

For every And of negativeRegion, we now form a polygon by discretizing (Subscript[y, l])(x) and (Subscript[y, u])(x).

makePoly[xl_ < x < xu_ && yl_ < y < yu_, pp_] :=
Polygon[Re @ N @ Join[
        Table[Evaluate[{x, yl}], {x, xl, xu, (xu - xl)/pp}],
Reverse[Table[Evaluate[{x, yu}], {x, xl, xu, (xu - xl)/pp}]]]]

The next picture shows the nine pieces from negativeRegion in different colors.

Show[Graphics[{Hue[Random[]], makePoly[#, 30]}& /@ 
                              (List @@ negativeRegion)],
     AspectRatio -> Automatic, PlotRange -> All]

Here, the region lissa < 0 as a whole is shown.

Show[Graphics[{#, (* mirror in other three quadrants *)
                  Map[{+1, -1}#&, #, {-2}], 
                  Map[{-1, +1}#&, #, {-2}],
                  Map[{-1, -1}#&, #, {-2}]}&[
     (* original polygons *) Cases[%, _Polygon, Infinity]]],
     AspectRatio -> Automatic, PlotRange -> All]

For the solution of similar, but more general problems, see the literature for cylindrical algebraic decomposition, e.g., [235✶], [989✶], [51✶], [1089✶], [1104✶], [78✶], [79✶], [219✶], [77✶], [1150✶], [1026✶], and [855✶]. For an efficient way to determine the topology of a plane algebraic curve, see [675✶].

One would be to derive the parametric representation of the evolute and then try to implicitize it. Because this is a difficult problem, we start with the already implicit representation of the Lissajous curve derived in a) and derive the implicit representation of the evolute from it. We carry out this program by eliminating the variables x and y from the equation of the evolute to get an implicit equation for ξ and η. 
This is the equation of the Lissajous curve under consideration. (In the following, we write only the left-hand side of the equation, and the right-hand side is always zero.)

f[x_, y_] = 4 x^4 - 4 x^2 + y^2;

The x-coordinate of the evolute is given by the following equation.

eqx = ξ - (x - D[f[x, y], x] (D[f[x, y], x]^2 + D[f[x, y], y]^2)/
       (D[f[x, y], y]^2 D[f[x, y], {x, 2}] -
        2 D[f[x, y], x] D[f[x, y], y] D[D[f[x, y], x], y] +
        D[f[x, y], x]^2 D[f[x, y], {y, 2}]))

Here is the y-component.

eqy = η - (y - D[f[x, y], y] (D[f[x, y], x]^2 + D[f[x, y], y]^2)/
          (D[f[x, y], y]^2 D[f[x, y], {x, 2}] -
           2 D[f[x, y], x] D[f[x, y], y] D[D[f[x, y], x], y] +
           D[f[x, y], x]^2 D[f[x, y], {y, 2}]))

By taking the numerator of the last two equations, we get two polynomials in the four variables x, y, ξ, and η.

numx = Numerator[Together[eqx]] // Factor

numy = Numerator[Together[eqy]] // Factor

Now we eliminate the variable y from the last two equations.

Resultant[numx, f[x, y], y] // Factor

Resultant[numy, f[x, y], y] // Factor

Finally, from the resulting two equations, we eliminate the variable x and end up with a polynomial in ξ and η.

evolute[ξ_, η_] =
(Resultant[First[Last[%%]], Last[%], x] // Factor)/24209548902400

Here is the plot of the parametric representation and the contour plot of the implicit representation.

Show[GraphicsArray[{
Graphics[{Thickness[0.002], With[{ε = 10^-8},
(* the parametric plot *)
Apply[ParametricPlot[Evaluate[
With[{x = Cos[t], y = Sin[2t]},
{x - D[y, t] (D[x, t]^2 + D[y, t]^2)/
             (D[x, t] D[y, {t, 2}] - D[y, t] D[x, {t, 2}]),
 y + D[x, t] (D[x, t]^2 + D[y, t]^2)/
             (D[x, t] D[y, {t, 2}] - D[y, t] D[x, {t, 2}])}]],
            {t, ##}, DisplayFunction -> Identity][[1]]&, # + {ε, -ε}& /@
            Partition[Table[φ, {φ, 0, 2Pi, Pi/2}], 2, 1], 1]]},
         PlotRange -> {{-3, 3}, {-3/2, 3/2}}, 
         Frame -> True, AspectRatio -> 1],
(* the implicit plot *)
ContourPlot[evolute[ξ, η], {ξ, -3, 3}, {η, -3/2, 3/2},
            PlotPoints -> 160, Contours -> {0}, AspectRatio -> 1,
            DisplayFunction -> Identity]}]]

This is the implicit representation of the curve of interest here. (Again, we only write the left-hand side of the equations; the right-hand side is always zero.)

f[x_, y_] = 4 x^4 - 4 x^2 + y^2

These are the equations to be fulfilled by the point of the curve where the first and second tangents are attached.

eq[1] = f[x1, y1];
eq[2] = f[x2, y2];

The function ys represents the derivative y'(x), derived by implicit differentiation.

ys[x_, y_] = -D[f[x, y], x]/D[f[x, y], y]

Using ys, the condition that the two tangents intersect perpendicularly can be written as follows.

eq[3] = 1 + ys[x1, y1] ys[x2, y2]

These are the parametric forms of (Subscript[x, 1])(t), (Subscript[y, 1])(t), (Subscript[x, 2])(s) and (Subscript[y, 2])(s).

eq[4] = x - (x1 + t);
eq[5] = y - (y1 + t ys[x1, y1]);
eq[6] = x - (x2 + s)
eq[7] = y - (y2 + s ys[x2, y2])

Having written down all equations of interest here, we convert them to pure polynomials by taking the numerators.

Table[eq1[i] = Numerator[Together[eq[i]]], {i, 7}]

Now we start to eliminate the variables we are not interested in. This eliminates the parameter t from the parametric representation of the first tangent.

eq1[4] = Resultant[eq1[4], eq1[5], t]

This eliminates the parameter s from the parametric representation of the second tangent.

eq1[5] = Resultant[eq1[6], eq1[7], s]

Using the implicit representation of the curve, we eliminate (Subscript[y, 1]) from the equation describing the condition that the two tangents cross perpendicularly.

eq2[1] = (Resultant[eq1[1], eq1[3], y1] /. y2^2 -> 4 x2^2 - 4 x2^4) //
                                                      Expand // Factor

This is the equation h((Subscript[x, 1]),(Subscript[x, 2])) we were looking for. 
The same process for the second tangent leads to the same equation.

eq2[2] = (Resultant[eq1[2], eq1[3], y2] /. y1^2 -> 4 x1^2 - 4 x1^4) //
                                                      Expand // Factor

We eliminate (Subscript[y, 1]) from the implicit representation of the first tangent.

eq2[3] = Resultant[eq1[1], eq1[4], y1] // Factor

We also eliminate (Subscript[y, 2]) from the implicit representation of the second tangent.

eq2[4] = Resultant[eq1[2], eq1[5], y2] // Factor

Thus, we have to eliminate the variables (Subscript[x, 1]) and (Subscript[x, 2]) to get the implicit representation of the orthopodic locus. We do not carry out the two missing steps here because they take a long time and the result is an expression which is not of interest here. eq2[5] = Resultant[Last[eq2[1]], Last[eq2[3]], x1] results in a polynomial with 175 terms, and the last step Resultant[eq2[5], Last[eq2[4]], x2] yields a polynomial of degree 64 in x and degree 96 in y with 1073 terms. 
Let us now concentrate on the animation. The equation h((Subscript[x, 1]),(Subscript[x, 2]))= eq2[1] can be explicitly solved with respect to (Subscript[x, 2]).

x2 /. Solve[15 - 63 x1^2 + 64 x1^4 - 63 x2^2 + 255 x1^2 x2^2 -
            256 x1^4 x2^2 + 64 x2^4 - 256 x1^2 x2^4 +
            256 x1^4 x2^4 == 0, x2]

We inspect the four solutions.

Show[GraphicsArray[
     Plot[Evaluate[#[%]], {x1, -1, 1}, Frame -> True, 
          Axes -> False, DisplayFunction -> Identity]& /@ {Re, Im}]]

We see that the four solutions are not real for every -1≤(Subscript[x, 1])≤1. We find the regions where the first and second solution for (Subscript[x, 2]) are not real with the following.

Function[data, Abs[data[[#]]]& /@ {Position[#, Min[#]][[1, 1]],
               Position[#, Max[#]][[1, 1]]}&[Abs[N[data]]]][
x1 /. Solve[(63 - 255 x1^2 + 256 x1^4)^2 -
            (129 - 642 x1^2 + 1025 x1^4 - 512 x1^6) == 0, x1]]

So we can implement the following solution of the equation h((Subscript[x, 1]),(Subscript[x, 2]))= eq2[1].

x2Roots[x1_] :=
With[{denom = Sqrt[2] Sqrt[64 - 256 x1^2 + 256 x1^4],
      num1 = Sqrt[129 - 642 x1^2 + 1025 x1^4 - 512 x1^6],
      num2 = 63 - 255 x1^2 + 256 x1^4},
If[N[Sqrt[63 - Sqrt[129]]/(8 Sqrt[2])] < Abs[x1] <
   N[Sqrt[63 + Sqrt[129]]/(8 Sqrt[2])],
  Drop[#, 2], #]&[{-Sqrt[num2 - num1]/denom, Sqrt[num2 - num1]/denom,
                   -Sqrt[num2 + num1]/denom, Sqrt[num2 + num1]/denom}]]

For the actual construction of the two tangents, we need the two y-values corresponding to every x-value.

Clear[y];

{y[1][x_], y[2][x_]} = {+Sqrt[4 x^2 - 4 x^4], -Sqrt[4 x^2 - 4 x^4]};

We also need the crossing point of the two tangents originating from (Subscript[x, 1]),(Subscript[y, 1]) and (Subscript[x, 2]),(Subscript[y, 2]) and having slope (Subscript[y, 1]^′) and (Subscript[y, 2]^′).

cp[{x1_, y1_}, {x2_, y2_}, ys1_, ys2_] =
{0, y1} + {x2 ys2 - x1 ys1 + y1 - y2,
           ys1(x2 ys2 - x1 ys2 + y1 - y2)}/(ys2 - ys1);

So we can program for the points of the orthopodic locus.

orthopodicLocus[x1_] := orthopodicLocus[x1] =
Module[{x2p = x2Roots[x1] // N, ε = 10^-6, x2real, snips},
Table[(* y[1] and y[2] *) ysa = ys[x1, y[i][x1]];
(* select perpendicular crossings *)
 x2real = Select[x2p, Abs[N[(1 + ysa ys[#, y[j][#]])]] < ε&];
 snips = cp[{x1, y[i][x1]},
            {#, y[j][#]}, ysa, ys[#, y[j][#]]]& /@ x2real;
       snips, {i, 2}, {j, 2}]]

This is the original curve.

curve = ParametricPlot[{Cos[1t], Sin[2t]}, {t, 0, 2Pi},
                       PlotStyle -> {{Thickness[0.01], Hue[0]}},
                       DisplayFunction -> Identity];

This shows the original curve and its orthopodic locus.

Module[{a = ArcCos @ N[Sqrt[63 - Sqrt[129]]/(8 Sqrt[2])],
        b = ArcCos @ N[Sqrt[63 + Sqrt[129]]/(8 Sqrt[2])],
        ε = 10.^-6, pp = 60},
Show[{curve, (* the orthopodic locus *)
Graphics[{#, Map[# {-1, 1}&, #, {-2}]}&[
Map[Line, Transpose[#, {4, 2, 3, 1, 5}], {3}]& /@
{Table[orthopodicLocus[Cos[t]], {t, ε, b - ε, (b - 2ε)/pp}],
 Table[orthopodicLocus[Cos[t]], {t, a + ε, N[Pi/2 - ε],
                      N[(Pi/2b - 2ε)]/pp}]}]]},
      DisplayFunction -> $DisplayFunction, Axes -> False]]

For the animation, we should also display the tangents. We vary (Subscript[x, 1]) between 1 and -1 and mark the points of the orthopodic locus traversed.

orthopodicLocusAndTangents[x1_] := orthopodicLocusAndTangents[x1] =
Module[{x2p = x2Roots[x1] // N, ε = 10^-6, x2real, snips},
 Table[(* y[1] and y[2] *) ysa = ys[x1, y[i][x1]];
(* select perpendicular crossings *)
 x2real = Select[x2p, Abs[(1 + ysa ys[#, y[j][#]])] < ε&];
 snips = cp[{x1, y[i][x1]}, {#, y[j][#]}, ysa, ys[#, y[j][#]]]& /@ x2real;
 {MapThread[Line[{##}]&, {Table[Evaluate[{x1, y[i][x1]}], {Length[snips]}],
               snips, {#, y[j][#]}& /@ x2real}],
 Point /@ snips}, {i, 2}, {j, 2}]]

Here are a few configurations for various (Subscript[x, 1]).

Show[GraphicsArray[#]]& /@ Map[
Show[{curve, Graphics[{Thickness[0.002], PointSize[0.015],
      (* the tangents *)
      orthopodicLocusAndTangents[#]}]}, Frame -> True, Axes -> False,
      PlotRange -> {{-2, 2}, {-2, 2}}, AspectRatio -> Automatic, 
      FrameTicks -> None, DisplayFunction -> Identity]&,
      Partition[Table[N[t], {t, 1/10, 9/10, 1/10}], 3], {2}]

The animation could now be done via the following.

(* points of the orthopodic locus already traversed *)
rememberPoints[x1_] :=
Cases[DownValues[orthopodicLocusAndTangents], _Point, {-3}];

orthopodicLocusAnimation[n_] := With[{ε = 10^-6}, 
Do[Show[{curve, Graphics[
        {Thickness[0.002], PointSize[0.01],
        (* the current x1 value *) orthopodicLocusAndTangents[N[Cos[t]]],
        (* already traversed points of the orthopodic locus *) rememberPoints[N[t]]}]},
        Frame -> True, Axes -> False, PlotRange -> {{-2, 2}, {-2, 2}},
        AspectRatio -> Automatic, FrameTicks -> None,
        DisplayFunction -> $DisplayFunction],
   {t, ε, Pi - ε, (Pi - 2ε)/n}]];

(* 250 frames give a smooth animation *)
orthopodicLocusAnimation[250]

f[x_, y_] = 4 x^4 - 4 x^2 + y^2;

Because the cissoid is the midpoint of two points on the curve, these two points {x1, y1} and {x2, y2} fulfill the implicit representation.

{eq[1] = f[x1, y1], eq[2] = f[x2, y2]}

The points of the cissoid lie on straight lines through the point {px, py}.

eq[3] = Resultant[x - (px + t(x1 - px)), y - (py + t(y1 - py)), t]

eq[4] = Resultant[x - (px + s(x2 - px)), y - (py + s(y2 - py)), s]

The following two equations are the explicit form of the left-hand side of the equation that states the following: the points of the cissoid are midpoints of the line segments formed by two points from the given curve.

eq[5] = x - (x1 + x2)/2; eq[6] = y - (y1 + y2)/2;

Putting all equations together and eliminating the coordinates of the two points {x1, y1} and {x2, y2}, we arrive at the implicit representation of the cissoid of the Lissajous curve under consideration here.

res = (Subtract @@ Eliminate[# == 0& /@ Array[eq, 6],
                               {x1, y1, x2, y2}]) // Factor

The first factor of the last result is just the implicit representation of the curve. It appears here because of the possibility that {x1, y1} and {x2, y2} are identical. The second part gives the nontrivial solution. Using ContourPlot, let us now have a look at the cissoid.

(* special point for this picture *) px = 1/2; py = 1/2;

Show[Block[{$DisplayFunction = Identity},
(* the original curve in gray *)
{lissa = ParametricPlot[{Cos[t], Sin[2t]}, {t, 0, 2Pi},
    PlotStyle -> {{Thickness[0.01], GrayLevel[1/2]}}],
(* the cissoid *)
ContourPlot[Evaluate[res[[2]]], {x, -1, 1}, {y, -1, 1},
            Contours -> {0}, ContourShading -> False,
            PlotPoints -> 200, ContourStyle -> {Thickness[0.02]}]}],
      Frame -> True, Axes -> False, PlotRange -> All,
      AspectRatio -> Automatic]

Note that due to the implicit form, points outside of the original curve are also contained in the above representation of the cissoid. 
For comparison, let us construct the cissoid for the last example explicitly. The first problem is the calculation of all points of the Lissajous curve that go through a given line. To avoid the numerical solution of transcendental equations, we calculate a polynomial equation for the x-values of these points.

x1Eq = Resultant[eq[1], dx py + dy x1 - dx y1 - dy px, y1] // Factor

Next, rotating a line through {px, py}, we calculate for each configuration all x-values on the Lissajous curve, all corresponding y-values, and select all points which actually lie on the given line. Then, forming all pairs of different points, we get all lines segments, the midpoints of which form the cissoid. The next input carries out this construction.

Show[{lissa, Graphics[{PointSize[0.02],
Table[(* direction of line *) dx = Cos[t]; dy = Sin[t];
MapIndexed[(* only different points *) Drop,
(* all point pairs *) Outer[Point[(#1 + #2)/2]&, #, #, 1]]&[
Flatten[(Function[x, Select[{x[[1]], #}& /@ x[[2]],
          (* select all points on line *)
          (Abs[# - t] < 10^-5 || Abs[# - N[(t - Pi)]] < 10^-5)&[
                     (ArcTan @@ (# - {px, py}))]&]] /@
({#, Cases[(* all y-values *) NRoots[f[#, y] == 0, y], _Real, {-1}]}& /@
           (* all x-values *)
           Cases[NRoots[x1Eq == 0, x1], _Real, {-1}])), 1]],
           (* a bunch of lines *) {t, N[0], N[Pi], N[Pi]/5555}]}]},
           PlotRange -> All, AspectRatio -> Automatic,
           Frame -> True, Axes -> False]

For the calculation of the implicit form, we rewrite all trigonometric functions of a multiple argument into powers of sin(φ) and cos(φ) and then call Eliminate with the given equations and the identity ((cos(φ))^2)+((sin(φ))^2)=1.

eq = Factor[(Subtract @@ Eliminate[Append[TrigExpand //@
      {x == Cos[3φ] - Sin[φ]/5, y == Sin[2φ] + Cos[φ]/3},
       (* add algebraic relation between Cos and Sin *)
       Sin[φ]^2 + Cos[φ]^2 == 1], {Cos[φ], Sin[φ]}])] == 0

Now we transform the FullForm of the Mathematica expression eq into a string (for compactness, we eliminate all spaces).

string = StringReplace[ToString[FullForm[eq]], " " -> ""]

To adjust the equation properly, we treat every letter individually. Here are all letters from string.

chars = Characters[string];

To have the same spacing between all letters, we now calculate the arc length of the given curve (for later work, we do not use NIntegrate here, but NDSolve, because the resulting InterpolatingFunction will be reused later).

sol = NDSolve[{arcLength'[φ] == Sqrt[D[Cos[3φ] - Sin[φ]/5, φ]^2 +
                                     D[Sin[2φ] + Cos[φ]/3, φ]^2],
              arcLength[0] == 0}, arcLength, {φ, 0, 2Pi}]

The length of the whole curve is about 15.35.

curveLength = (arcLength[N[2Pi]] /. sol)[[1]]

Now we divide the curve into pieces of equal length using the interpolating function of sol.

φTab = Table[φ /. FindRoot[sol[[1, 1, 2]][φ] ==
                         i/(Length[chars] + 2) curveLength,
             {φ, 0, N[2Pi]}, Compiled -> False], {i, Length[chars]}];

The letters should change their orientation along the curve, so they are always parallel to the tangent of the curve.

letterDir[φ_] = {D[Cos[3φ] - Sin[φ]/5, φ], D[Sin[2φ] + Cos[φ]/3, φ]}

As a guide for the eye, we underly a thick version of the curve under the equation.

curve = ParametricPlot[{Cos[3φ] - Sin[φ]/5, Sin[2φ] + Cos[φ]/3},
                       {φ, 0, N[2Pi]}, DisplayFunction -> Identity];

Finally, we can display the curve and its implicit representation.

Show[Graphics[{
 {GrayLevel[0], Thickness[0.04], curve[[1, 1, 1]]},
 {GrayLevel[1], Table[(* the characters *)
  Text[StyleForm[chars[[i]], FontFamily -> "Courier", FontSize -> 12],
       {Cos[3#] - Sin[#]/5, Sin[2#] + Cos[#]/3}, {0, 0},
        (* their direction *)
        letterDir[#]]&[φTab[[i]]], {i, Length[chars]}]}}], 
           AspectRatio -> Automatic, FrameTicks -> None,
           Frame -> True, PlotRange -> {{-1.5, 1.5}, {-1.5, 1.5}}]

Let us start and have a look at the region under consideration.

poly0[x_, y_] = x^4 + y^4 - 2 x^3 + 2 y - 1 + 2 x;

cp = Graphics[ContourPlot[Evaluate[poly0[x, y]], {x, -2, 2}, {y, -2, 1},
              PlotPoints -> 60, Contours -> {0}]];

After calculating the x-values enclosing the region, we could have also used Plot to get a picture of the region as follows.

Module[{domain, sol, ε = 10^-6},
(* boundaries with respect to x *)
domain = Cases[NRoots[poly0[x,
Cases[NRoots[Numerator[D[poly0[x, y], y]/D[poly0[x, y], x]] == 0, y],
      _Real, {-1}][[1]]] == 0, x], _Real, {-1}] + {ε, -ε};
(* get y = y(x) *) sol = Solve[poly0[x, y] == 0, y];
(* form polygons from discretized y(x) curves *)
Show[Graphics[Polygon[Join[#1, Reverse[#2]]]& @@
(Plot[Evaluate[sol[[#, 1, 2]]], Evaluate[{x, Sequence @@ domain},
      DisplayFunction -> Identity]][[1, 1, 1, 1]]& /@ {3, 4})],
      AspectRatio -> 1, PlotRange -> {{-2, 2}, {-2, 1}}, Frame -> True]]

To follow the light ray, we must calculate where a given ray hits the boundary of our region and its new direction after the reflection. Taking a ray originating from {x0, y0} and pointing in the direction {dx, dx}, the implicit equation for the x-value of the intersection with the region is given by the following.

polyInx[dx_, dy_, x0_, y0_] =
 Factor[Resultant[dy x0 + dx y - dx y0 - dy x, poly0[x, y], y]]

We can now use this result to straightforwardly implement the following routine that calculates the point of intersection. We first calculate the roots of polyInx[dx, dy, x0, y0]. We select the real ones and calculate the corresponding y-values as the roots of poly0. Again, we select the real solutions. Then we discard the starting point (which is, of course, also a solution), check if the direction of the so-calculated points are the same as the direction of {dx, dx}, and finally, take the nearest point to the starting point. (Due to the fact that the region is concave, there might be more than one intersection in a given direction.) Here is the corresponding Mathematica implementation.

nextPoint[{x0_, y0_}, {dx_, dy_}] :=
Module[{s1, s2, s3, s4, s5, ε = 10^-7},
 (* maybe add here a check if point is on curve and if normal points 
    toward the interior; but we start always inside, 
    so we do not check this here *)
 (* all solutions of polyInx *)
 s1 = Chop[Last /@ List @@ NRoots[polyInx[dx, dy, x0, y0] == 0, x]];
 (* discard solutions with imaginary part *)
 s2 = Union[Re @ Cases[s1, _?((Abs[Im[#]] < ε)&)],
            SameTest -> (Abs[#1 - #2] < ε&)];
 (* calculate corresponding y-values and discard them if they have 
    a "nonvanishing" imaginary part *)
 s3 = Flatten[Function[xv, {xv, #}& /@
  Union[Re @ Cases[Last /@ List @@ NRoots[poly0[xv, y] == 0, y],
           _?((Abs[Im[#]] < ε)&)],
            SameTest -> (Abs[#1 - #2] < ε&)]] /@ s2, 1];
 (* discard the starting point {x0, y0} *)
 s4 = Delete[s3, Position[#, Min[#]]&[(#.#&[{x0, y0} - #])& /@ s3][[1, 1]]];
  (* which solutions are on the ray in the specified direction;
    ε is chosen somewhat arbitrary *)
 s5 = Select[s4, Chop[Abs[(#[[1]] - x0) dy - (#[[2]] - y0)dx], ε] === 0&];
 If[s5 === {}, s5 = {s4[[Position[#, Min[#]]&[
                   Abs[(#[[1]] - x0) dy - (#[[2]] - y0)dx]& /@
                                               s4][[1, 1]]]]}];
 (* choose the nearest point
    (if boundary is concave, s5 may have more than one element); 
     for the general case this test needs refinement! *)
 If[Length[s5] === 1, s5[[1]],
    s5[[Position[#, Min[#]]&[#.#&[{x0, y0} - #]& /@ s5][[1, 1]]]]]]

For calculating the new direction of the light ray after it has undergone one reflection, we need the normal to the boundary of our region.

normal[{x_, y_}] = -{D[poly0[x, y], x], D[poly0[x, y], y]};

Now we have everything together to implement newPointAndDirection, that calculates the point of intersection of a ray originating from {x0, y0} and pointing in the direction {dx, dx} and its direction after reflection.

newPointAndDirection[{{x0_, y0_}, {dx_, dy_}}] :=
Module[{p1, dir1, n},
       (* the next point *)
       p1 = nextPoint[{x0, y0}, {dx, dy}];
       n = #/Sqrt[#.#]&[normal[p1]];
       (* the reflection law *)
       dir1 = #/Sqrt[#.#]&[-{dx, dy} + 2 n({dx, dy}.n)];
       {p1, dir1}]

Let us have a look at some rays that are reflected multiple times. (To see better what happens after multiple reflections, we use rays which all originate from {x0, y0}, but start in the direction {dx, dx} + {0, r div}, -rays ≤r≤ rays.)

reflectionPicture[{x0_, y0_}, {dx_, dy_},
                  rays_, reflections_, div_, opts___Rule] :=
Show[{cp, Graphics[{Thickness[0.002],
(* a small arrow at the starting point *)
{GrayLevel[0.2],
Function[{d, n}, {Line[{{x0, y0} - 0.1 d, {x0, y0} - 0.35 d}],
 Polygon[{{x0, y0} - 0.1 d, {x0, y0} - 0.2 d - 0.03 n,
          {x0, y0} - 0.2 d + 0.03 n}]}][#/Sqrt[#.#]&[{dx, dy}],
     Reverse[#/Sqrt[#.#]&[{dx, dy}]] {-1, 1}]},
Transpose[Table[(* the path *)
  {Hue[(r + rays) 0.78/(2 rays + 1)], Line[#]}& /@
(Partition[First /@ NestList[(* construct the path *)
  newPointAndDirection, {{x0, y0},
                 {dx, dy} + {0, r div}}, reflections], 2, 1]),
                         {r, -rays, rays}]]}]},
    opts, PlotRange -> All, AspectRatio -> Automatic,
    Frame -> False, Axes -> False]

Here are three examples (the little arrow indicates the starting point and the starting direction of the light ray). The spreading of the ray after multiple reflections is clearly visible.

Show[GraphicsArray[
Module[{x0, y0, dp = DisplayFunction -> Identity},
{x0 = 0; y0 = Min[Cases[NRoots[poly0[x0, y] == 0, y],
                  _?(Im[#] == 0&), {-1}]];
 reflectionPicture[{x0, y0}, {1, 1}, 12, 20, 10^-7, dp],
 x0 = -0.55; y0 = Max[Cases[NRoots[poly0[x0, y] == 0, y],
                      _?(Im[#] == 0&), {-1}]];
 reflectionPicture[{x0, y0}, {1, -0.39}, 12, 17, 10^-6, dp],
 x0 = 1.7; y0 = Min[Cases[NRoots[poly0[x0, y] == 0, y],
                    _?(Im[#] == 0&), {-1}]];
 reflectionPicture[{x0, y0}, {-1, 0.11}, 12, 12, 10^-6, dp]}]]]

To find some stationary light rays, that means light rays that are each reflected into itself, we need to find points (Subscript[P, 1]) and (Subscript[P, 2]) on the boundary of our region, so that their normal aims in the opposite direction and that the direction given by (OverBar[(Subscript[P, 1])(Subscript[P, 2])]) also points in the same direction. 
We start by forming an equation that expresses that the normal in the point (Subscript[P, 1]) lies on the same line as (OverBar[(Subscript[P, 1])(Subscript[P, 2])]) .

r1 = Resultant[Sequence @@
Apply[Subtract, Thread[normal[{x1, y1}] ==
                       a1 ({x2, y2} - {x1, y1})], {1}], a1]

The following equation expresses that the normal in the point (Subscript[P, 2]) lies on the same line as (OverBar[(Subscript[P, 1])(Subscript[P, 2])]) .

r2 = Resultant[Sequence @@
Apply[Subtract, Thread[normal[{x2, y2}] ==
                       a2({x2, y2} - {x1, y1})], {1}], a2]

These two equations, together with the equations for the boundary of our region applied to (Subscript[P, 1]) and (Subscript[P, 2]), form four equations for the four unknowns x1, x2, y1, and y2.

eqs[{x1_, x2_, y1_, y2_}] = {r1, r2, poly0[x1, y1], poly0[x2, y2]}

The equations can also be found using Fermat’s principle of minimizing the length of the path.

With[{l = 2 Sqrt[#.#]&[{x1, y1[x1]} - {x2, y2[x2]}]},
Expand[Numerator[Together[#]]]& /@ ({D[l, x1], D[l, x2]} /. 
      {y1'[x1] -> -((1 - 3 x1^2 + 2 x1^3)/(1 + 2 y1^3)),
       y2'[x2] -> -((1 - 3 x2^2 + 2 x2^3)/(1 + 2 y2^3))} //.
      {y1[x1] -> y1, y2[x2] -> y2})]

We could now try to solve this system symbolically, but here we are only interested in a few solutions, which we search numerically. To avoid FindRoot spending too much time in cases when the process does not converge (and to prevent all these messages from printing), we catch the generated messages via $MessagePrePrint and abort immediately the FindRoot calculation via $MessagePrePrint = (Abort[])&. To prevent the whole While loop searching until five solutions are found is aborted, we catch the generated abort via CheckAbort and start a new numerical search with FindRoot for new randomly selected starting values.

rayBag = {};

($MessagePrePrint = (Abort[])&);

SeedRandom[999]

While[Length[rayBag] < 5,
If[# =!= Null, (* startpoint and endpoint should be different *)
  If[(({x1, y1} - {x2, y2}).({x1, y1} - {x2, y2}) /. #) > 0.01,
               AppendTo[rayBag, #], Null]]&[
CheckAbort[
FindRoot[Evaluate[# == 0& /@ eqs[{x1, x2, y1, y2}]],
         {x1, Random[Real, {-1, 1}]}, {x2, Random[Real, {-1, 1}]},
         {y1, Random[Real, {-1, 1}]}, {y2, Random[Real, {-1, 1}]},
         MaxIterations -> 50], Null]]]

$MessagePrePrint = Short;

Here are the so-generated stationary rays.

rayBag

Finally, let us have a look at some stationary points over 12 reflections to make sure that they are reflected into themselves. (Be aware that following the light ray over many more reflections requires the use of much more accurate starting values and a higher working precision in all of the above-defined routines.)

Show[GraphicsArray[#]]& /@ 
Map[reflectionPicture[#, normal[#], 0, 12, 0,
                      DisplayFunction -> Identity]&,
  {Take[#, {1, 4}], Take[#, {5, 7}]}&[
   (* the data found after a long numerical search *)
   {{ 1.0000000000000000,  0.0000000000000000}, 
    {-0.1635363018502669, -1.4295866669246624}, 
    {-0.9118376919491141, -1.3493071403532364}, 
    { 1.6904691540714618, -1.0495609404364403}, 
    { 1.7483143392872937, -0.8911301339349427}, 
    {-0.5000000000000000, -1.4660592721926984}, 
    { 1.7559486066393841, -0.7937005259840998}}], {2}]

It is also possible to determine all rays that are reflected into themselves symbolically. This is the system of equations to be solved.

Clear[x1, y1, x2, y2]

eqs = {2 (-x1 + x2 + y1 - 3 x1^2 y1 + 2 x1^3 y1 - 
          2 x1 y1^3 + 2 x2 y1^3 - y2 + 3 x1^2 y2 - 2 x1^3 y2), 
       -2 (x1 - x2 - y1 + 3 x2^2 y1 - 2 x2^3 y1 + y2 - 
           3 x2^2 y2 + 2 x2^3 y2 + 2 x1 y2^3 - 2 x2 y2^3), 
      -1 + 2 x1 - 2 x1^3 + x1^4 + 2 y1 + y1^4, 
      -1 + 2 x2 - 2 x2^3 + x2^4 + 2 y2 + y2^4};

There are two equations that are linear.

Exponent[#, {x1, x2, y1, y2}]& /@ eqs

We use the linearity in x2 to eliminate x2.

s1 = Factor //@ Solve[eqs[[1]] == 0, x2]

These are the three remaining equations.

eqs1 = Factor[Numerator[Together[#]]]& /@ 
                         (Rest[eqs] /. s1[[1]]);

We only use the last factor of the first polynomial in the following.

Head /@ eqs1

The small factors of the last result shows that we must specially treat the cases x1==1, x1==-1/2 and y1==y2. So we have the following set of new equations.

eqs2 = {eqs1[[1, -1]], eqs1[[2]], eqs1[[3]]};

We eliminate y2 from the first and the last equations (because their degree is not too high).

Exponent[#, {x1, x2, y1, y2}]& /@ eqs2

This gives the following equation in x1 and y1.

Short[res1 = Factor[Resultant[eqs2[[1]], eqs2[[3]], y2]], 6]

We will later treat the case (1 + 2y1^3) == 0; for the moment, we keep only the last factor of res1.

Exponent[res1[[-1]], {x1, y1}]

Now we use the defining equation for the region in x1 and y1 to eliminate x1 from res1.

Short[res2 = Factor[Resultant[res1[[-1]], eqs2[[2]], x1]], 6]

Now we have a univariate polynomial. The above-mentioned factor (1 + 2y1^3) appears; so it is already taken care of.

Let us have a look on the number of real solutions of res2.

Needs["Algebra`RootIsolation`"]

CountRoots[res2, {y1, -Infinity, Infinity}]

This means there are 13 different ones (because one factor in res2 appears in power 2). We treat the four factors of res2 individually and calculate numerical values of the real solutions.

l1 = Select[List @@ res2, MemberQ[#, y1, {0, Infinity}]&];
Length[l1]

y1Sols1 = {0};
y1Sols2 = Select[Last /@ List @@ Union[Roots[l1[[2]] == 0, y1]],
                 Im[#] === 0&]

y1Sols3 = Select[Last /@ List @@ Union[Roots[l1[[3]] == 0, y1]],
                 Im[#] === 0&]

N[y1Sols4 = Select[Last /@ List @@ Union[Roots[l1[[4]] == 0, 
                   y1]], Im[N[#]] === 0&] // N[#, 60]&, 22]

Here are all 13 of them.

N[y1Solutions = SetPrecision[Sort[{y1 -> #}& /@
       N[Union[Join[y1Sols1, y1Sols2, y1Sols3, y1Sols4]], 60]], 60], 22]

Length[y1Solutions]

Now we use the defining equation for the region to calculate corresponding y1 values. If there are multiple roots, we only use one.

Short[N[x1y1Solutions = Flatten[
Function[y1Solution, Prepend[y1Solution, x1 -> #1]& /@ 
   Select[Union[Cases[NRoots[(eqs[[3]] /. y1Solution) == 0, x1, 60],
                   _?NumberQ, {-1}], 
                 SameTest -> (Abs[N[#1] - N[#2]] < 10^-6&)], 
        Abs[Im[#]] < 10^-6&]] /@ y1Solutions, 1], 22], 6]

Now we need values for x2. We first derive an equation for x2 that involves x1, y1 (which we already know) and x2.

Factor[Resultant[eqs[[1]], eqs[[2]], y2]]

The case (1 + 2 y1^3)== 0 is already taken care of, and with the case x1 == x2, we will deal later.

res3 = %[[-1]];

Now we use the defining equation for the region to calculate corresponding y1-values. In case of multiple roots, we only use one. We also take care of the case x1 == x2 here.

Short[N[x1y1x2Solutions = Join[Flatten[
Function[x1y1Solution, Append[x1y1Solution, x2 -> #]& /@ 
        Select[Union[Cases[NRoots[(res3 /. x1y1Solution) == 0, x2, 60],
                  _?NumberQ, {-1}],
 SameTest -> (Abs[N[#1] - N[#2]] < 10^-6&)],
              Abs[Im[#]] < 10^-6&]] /@ x1y1Solutions, 1],
        Append[#, x2 -> (x1 /. #)]& /@ x1y1Solutions], 22], 6]

Now we need only the remaining values for y2. We use the defining equation for the region to calculate corresponding y1-values. If there are multiple roots, we only use one. We also take care of the case y1 == y2 here.

Short[N[x1y1x2y2Solutions = Join[Flatten[
Function[x1y1x2Solution, Append[x1y1x2Solution, y2 -> #]& /@ 
         Select[Union[Cases[NRoots[(eqs[[4]] /. x1y1x2Solution) == 0, 
  y2, 60], _?NumberQ, {-1}], 
   SameTest -> (Abs[N[#1] - N[#2]] < 10^-6&)],
                Abs[Im[#]] < 10^-6&]] /@ x1y1x2Solutions, 1],
         Append[#, y2 -> (y1 /. #)]& /@ x1y1x2Solutions], 22], 6]

Length[x1y1x2y2Solutions]

We now sort out all solutions that do not satisfy the original equations.

Short[N[finalSolutions1 =
Select[x1y1x2y2Solutions /. xy_?NumberQ :> Re[xy], 
        Chop[eqs /. #, 10^-6] === {0, 0, 0, 0}&], 22], 12]

And we sort out all solutions in which the point {x1, y1} coincides with the point {x2, y2}.

Short[N[finalSolutions2 = Select[finalSolutions1,
            #.#&[N[({x1, y1} /. #) - ({x2, y2} /. #)]] > 10^-6&], 22], 6]

Length[finalSolutions2]

Now we must take care of the remaining special cases. The case x==1 is already in the solution set finalSolutions3. It remains to treat the cases y1==y2 and x1==-1/2. Let us start with the last one. We calculate all possible solutions.

gb1 = GroebnerBasis[eqs /. x1 -> -1/2, {x2, y1, y2}]

SetOptions[Roots, Quartics -> False, Cubics -> False];

Short[N[additionalSolutionsA1 = N[Prepend[#, x1 -> -1/2]& /@
      Union[Select[Solve[# == 0& /@ gb1, {y1, x2, y2}],
      (And @@ (Abs[Im[N[#]]] < 10^-8& /@ ({y1, x2, y2} /. #)))&]], 
                60], 22], 6]

Again, we drop coinciding points.

N[additionalSolutionsA2 = Select[additionalSolutionsA1,
                #.#&[N[({x1, y1} /. #) - ({x2, y2} /. #)]] > 10^-6&], 22]

Now the condition y1 == y2 is treated.

gb2 = GroebnerBasis[eqs /. y2 -> y1, {x1, x2, y1}]

N[additionalSolutionsB1 = N[Prepend[#, y2 -> (y1 /. #)]& /@
 Union[Select[N[Solve[# == 0& /@ gb2, {x1, x2, y1}], 60],
 (And @@ (Abs[Im[N[#]]] < 10^-8& /@ ({x1, x2, y1} /. #)))&]], 60], 22]

Again, we drop coinciding points.

N[additionalSolutionsB2 = Select[additionalSolutionsB1,
         #.#&[N[({x1, y1} /. #) - ({x2, y2} /. #)]] > 10^-6&], 22]

So we finally have the following solutions.

Short[N[finalSolutions4 = Join[finalSolutions2, additionalSolutionsA2,
                             additionalSolutionsB2], 22], 6]

All of them fulfill the original system of equations. We see that within the precision of the roots the original equations are fulfilled.

Abs[Max[eqs /. finalSolutions4]]

Finally, we drop coinciding points and solutions that are the same up to an exchange of x1⟷x2 and y1⟷y2.

(finalSolutions5 = Union[Union[finalSolutions4,
   SameTest -> (#.#&[({x1, y1, x2, y2} /. #1) -
                     ({x1, y1, x2, y2} /. #2)] < 10^-6&)],
   SameTest -> (#.#&[({x1, y1, x2, y2} /. #1) - 
                     ({x2, y2, x1, y1} /. #2)] < 10^-6&)]) // N

Length[%]

Show[GraphicsArray[#]]& /@ 
Map[Show[{cp, Graphics[{Hue[0], Thickness[0.002], 
                   Line[{{x1, y1} /. #, {x2, y2} /. #}]}]}, 
       DisplayFunction -> Identity, 
       Frame -> False]&, (* the seven solutions found *)
    {Take[finalSolutions5, {1, 4}], Take[finalSolutions5, {5, 7}]}, {2}]

We give one more way to solve the polynomial system under consideration. First we add an equation that guarantees x1≠x2 and y1≠y2.

eqs = AppendTo[eqs, 1 - z ((x1 - x2)^2 + (y1 - y2)^2)];

Next we eliminate the auxiliary variable z that was introduced in the last input.

(gbElim = GroebnerBasis[eqs, {x1, y1, x2, y2}, {z},
                  MonomialOrder -> EliminationOrder];) // Timing

gbElim is quite a large polynomial system and its direct solution is not easy. So in a first step we convert it to a degree reverse lexicographic basis.

{Length[gbElim], ByteCount[gbElim]}

(gbDegRevLex =  GroebnerBasis[gbElim, {x1, y1, x2, y2}, 
 MonomialOrder -> DegreeReverseLexicographic];) // Timing

{Length[gbDegRevLex], ByteCount[gbDegRevLex]}

Using the internal function Internal`GroebnerWalk allows us to convert this basis to a lexicographic basis.

(gbLex = Internal`GroebnerWalk[gbDegRevLex, 
                               {x1, y1, x2, y2}];) // Timing

Again, this is a large polynomial system with large coefficients.

{Length[gbLex], ByteCount[gbLex],
 Cases[gbLex, _Integer, {-1}] // Abs // Max // N}

The univariate equation in y2 in gbLex has degree 125.

pos = Position[Variables /@ gbLex, {y2}][[1, 1]];
Exponent[gbLex[[pos]], y2]

And the real roots of this univariate equation are all the values of y1 and y2 we found above. (Because of the symmetry y1↔y2 we now have 13 possible values for y2.)

roots = Roots[gbLex[[pos]] == 0, y2];
y2Rules = {ToRules[Select[N[roots], Im[#[[2]]] == 0&]]}

If the reader liked this kind of exercise, one could go on and calculate the “mirror cabinet map” [991✶] of this curve or calculate multiple reflections using more reflecting obstacles [428✶] or in 3D [1523✶].

h[t_] := -Cos[t] + 2 Cos[6t]

makeLine[t_] := Line[{{-16, (h[t] - (-16) Cos[t])/Sin[t]},
                      {+16, (h[t] - (+16) Cos[t])/Sin[t]}}]

The hedgehog is clearly visible.

With[{ε = 10^-10},
Show[Graphics[{Thickness[0.002], Table[makeLine[t] // N, 
                         {t, ε, 2Pi - ε, (2Pi - 2 ε)/200}]}], 
    AspectRatio -> Automatic, PlotRange -> {{-16, 15}, {-15, 15}}]]

A parametric description of the hedgehog can be easily derived by differentiating h(t).

sol = Solve[{x Cos[t] + y Sin[t] == h[t],
             D[x Cos[t] + y Sin[t] == h[t], t]}, {x, y}] // Simplify

An implicit description of the hedgehog can be derived using GroebnerBasis.

p = x Cos[t] + y Sin[t] - TrigExpand[h[t]]

gb = GroebnerBasis[{p, D[p, t], Cos[t]^2 + Sin[t]^2 - 1}, {},
              {Cos[t], Sin[t]}, MonomialOrder -> EliminationOrder]

The next graphic shows the parametric and implicit representations.

pp = 300;
cp = ContourPlot[Evaluate[N[gb[[1]]]], {x, -13, 12}, {y, -12, 12}, 
                 PlotPoints -> pp, Contours -> {0},
                Epilog -> (* parametric representation *)
                 ParametricPlot[Evaluate[{x, y} /. sol[[1]]], {t, 0, 2Pi}, 
                  PlotPoints -> 200, DisplayFunction -> Identity,
                  PlotStyle -> {Hue[0]}][[1]]]

Here is a more general contour plot of the polynomial of the implicit representation of the hedgehog.

pp = 300; c = 60;
(* preliminary contour plot *)
cp = ContourPlot[Evaluate[Log[Abs[N[gb[[1]]]]]], 
                 {x, -6, 4}, {y, -5, 5}, PlotPoints -> pp,
                 DisplayFunction -> Identity];
(* equally spaced contour values *)
cls = #[[Round[pp^2/c/2]]]& /@ 
          Partition[Sort[Flatten[cp[[1]]]], Round[pp^2/c]];
(* pure (color) function for alternating coloring *)
color[γ_] = Which @@ Flatten[Append[Prepend[
MapIndexed[{#1[[1]] <= γ < #1[[2]], 
            GrayLevel @ If[OddQ[#2[[1]]], 1, 0]}&,
                              Partition[cls, 2, 1]],
        {γ <  cls[[1]], GrayLevel @ 0}], 
        {γ >= cls[[1]], GrayLevel @ If[EvenQ[Length[cls]], 0, 1]}]];
(* final contour plot *)
ListContourPlot[cp[[1]], Contours -> cls, ColorFunction -> color,
                ContourLines -> False, ColorFunctionScaling -> False,
                FrameTicks -> None]

R[φ_] = (Cos[φ]^4 + Sin[φ]^4)^(-1/4);

(* angles values φ for equal arclength *)
φValues[ppφ_] := Module[{ndsol, f, l, ipo, s},
 (* calculate arclength as a function of φ *)
 ndsol = NDSolve[{s'[φ] == Sqrt[#.#]&[D[R[φ] {Cos[φ], Sin[φ]}, φ]], 
                 s[0] == 0}, s, {φ, 0, 2Pi}, PrecisionGoal -> 8];
 f = ndsol[[1, 1, 2]]; L = f[2Pi]; 
 (* interpolate arclength(φ) *)
 ipo = Interpolation[{f[#], #}& /@ ndsol[[1, 1, 2]][[3, 1]]];
 (* equally arclength spaced φ values *)
 Table[ipo[j/ppφ L], {j, 0, ppφ - 1}]];

(* discretize normals and add their contributions *)
addRaysCF = Compile[{k, {d, _Integer}, {pp, _Integer}, {φs, _Real, 1}},
Module[{m = Table[0. + 0. I, {2d}, {2d}], r, p0, normal, ξ, η, s, i, j, φ},
(* loop over all φ-values *)
Do[φ = φs[[kφ]]; r = (Cos[φ]^4 + Sin[φ]^4)^(-1/4); p0 = r {Cos[φ], Sin[φ]};
   normal = -{Cos[φ]^3, Sin[φ]^3}/Sqrt[Cos[φ]^6 + Sin[φ]^6];
   Do[{ξ, η} = p0 + s normal;
      If[(* inside only *) ξ^4 + η^4 < 1., 
         (* add ray contribution *)
         {i, j} = Round[{ξ, η} d] + {d, d};
         If[1 <= i <= 2d && 1 <= j <= 2d,
            m[[i, j]] = m[[i, j]] + Exp[I k s]]], {s, 0., 3., 3/pp}],
   {kφ, Length[φs]}]; m]];

Here is the resulting graphic for k=120 and d=360 using 3600 rays. Each ray is discretized at 3600 points.

ListDensityPlot[Log[Abs[addRaysCF[120, 360, 3600, φValues[3600]]] + 1], 
                Mesh -> False, PlotRange -> All, FrameTicks -> False]

While the last approach works, it will be inefficient for a multi-frame animation. Rewriting (Subscript[ℐ, k])(x,y) as

(Subscript[ℐ, k])(x,y)=(∫_0^(2π))exp(i k d({x,y},{ξ(s(φ)),η(s(φ))}))δ(g({x,y},{ξ(s(φ)),η(s(φ))}))ds
=(∑_(j=1)^n)exp(i k ((((((x-ξ((Subscript[φ, j]))))^2)+(((x-η((Subscript[φ, j]))))^2)))^(1/2)))(1/(|a'((Subscript[φ, j]))y+b'((Subscript[φ, j]))x+c'((Subscript[φ, j]))|))s'((Subscript[φ, j]))

(where we used δ(f(x))=∑δ(x-(Subscript[x, k]))/|f'((Subscript[x, k]))| for the simple zeros (Subscript[x, k]) of f(x) and φ is the polar angle), we see that at each point {x,y} only a finite number of (k-independent) points {ξ((Subscript[φ, j])), η((Subscript[φ, j]))} contribute to (Subscript[ℐ, k])(x,y). So we will calculate these points {ξ((Subscript[φ, j])), η((Subscript[φ, j]))}  of C once and then it will be possible to quickly add their contribution for each k-value.

The equation for a normal through {x,y} is given by x ((η(s(φ)))^3)-ξ (s(φ))((η(s(φ)))^3)+((ξ(s(φ)))^3) η(s(φ))-y ((ξ(s(φ)))^3)=0. The next inputs derive this equation.

superCircle[{ξ_, η_}] = ξ^4 + η^4 - 1;

normalLine[{ξ_, η_}, {x_, y_}] = 
Resultant[x - (ξ + s/4 D[superCircle[{ξ, η}], ξ]), 
          y - (η + s/4 D[superCircle[{ξ, η}], η]), s]

By eliminating η using the implicit equation for C, we obtain a degree 16 polynomial in ξ.

ξRootPoly[ξ_, {x_, y_}] = Resultant[normalLine[{ξ, η}, {x, y}],
                                    superCircle[{ξ, η}], η]

Using the last polynomial, the function ξηPoints[{x, y}] calculates all points {ξ(x,y),η(x,y)} through the point {x,y}.

ξηPoints[{x_, y_}] := 
Module[{ξRoots, ξηRoots, prec = 30}, 
 ξRoots = Union[Select[Last /@ (List @@ N[Union[Roots[
                ξRootPoly[ξ, {x, y}] == 0, ξ]], prec]), Im[#] == 0&]];
 ξηRoots = Function[ξ, Union[{{ξ, +(1 - ξ^4)^(1/4)}, 
                              {ξ, -(1 - ξ^4)^(1/4)}}]] /@ ξRoots;
 Select[Flatten[ξηRoots, 1], 
        (#[[1]]^3 (y - #[[2]]) == #[[2]]^3 (x - #[[1]]))&]]

Generically either two, four, six, or eight normals go through a point {x,y}.

Length[ξηPoints[#]]& /@ 
{{0, 0}, {0, 1/3}, {1/Pi, 1/E}, {1/2, 1/2}, {9/10, 1/10}}

We visualize the normals for some {x,y}-points. For a nicer graphic, and for later use, we also display the curve C and the wavefront caustics.

(* implicit equation of the wavefront caustics *)
causticsImplicit[{x_, y_}] = 
Module[{det, res1, res2}, 
 (* determinant that must vanish; caustics are envelopes *)
 det = η^3/4 Factor[Together[Det @ 
 Outer[D, {ξ + s D[superCircle[{ξ, η}], ξ], 
           η + s D[superCircle[{ξ, η}], η]} /. η -> η[ξ], {ξ, s}] /. 
        Solve[D[superCircle[{ξ, η[ξ]}], ξ] == 0, η'[ξ]][[1]] /. η[ξ] -> η]];
 (* eliminate line parameter s *)
 res1 = Resultant[x - ξ - 4 s ξ^3, det, s]/(-4 ξ^2) // Factor;
 res2 = Resultant[y - η - 4 s η^3, det, s]/(-4 η^2) // Factor;
 (* eliminate boundary values ξ and η *)
 GroebnerBasis[{res1, res2, superCircle[{ξ, η}]}, {x, y}, {ξ, η},
              MonomialOrder -> EliminationOrder][[1]] // Factor]

(* graphic of the supercircle *)
superCircleGraphics = 
Graphics[{Thickness[0.005], RGBColor[0, 0, 1],
          Line[Table[R[φ] {Cos[φ], Sin[φ]}, {φ, 0., 2.Pi, 2Pi/240}]]}];
          
(* graphic of the wavefront caustics of the supercircle *)
(* domain to visualize *) L = 11/10;

causticsGraphics = Graphics[
ContourPlot[Evaluate[causticsImplicit[{x, y}]], {x, -L, L}, {y, -L, L},
            PlotPoints -> 600, Contours -> {0},
            ContourShading -> False, DisplayFunction -> Identity,
            ContourStyle -> {{Thickness[0.008], Hue[0]}}]];

Show[GraphicsArray[Function[xys, 
Show[{(* supercircle and its wave caustics *)
      superCircleGraphics, causticsGraphics,
      (* normals through point {x,y} *)
      Graphics[{Thickness[0.002], GrayLevel[1/2], 
                Function[xy, Line[{xy, #}]& /@ ξηPoints[xy]] /@ xys}]},
     AspectRatio -> Automatic, DisplayFunction -> Identity]] /@
 (* two points {x, y}} *)    
 {{{1/6, 1/5}},  
  {{0, Root[(-128 + 6429 #^4 + 552 #^8 + 16 #^12)& , 2]}}}]]

Now, we calculate the intersection points of the normals for a dense set of {x,y}-points. Because of the symmetry of C, we restrict the {x,y}-points to the first quadrant.

ξηData = With[{pp = 200},
         Table[{{x, y}, ξηPoints[{x, y}]}, {y, 0, L, L/pp}, {x, 0, L, L/pp}]];

The following graphic shows the number of normals as a function of x and y. The wavefront caustics divide the regions of identical number of normals.

ListDensityPlot[Map[Length[Last[#]]&, ξηData, {2}], Mesh -> False,
                MeshRange -> {{0, 1}, {0, 1}}, PlotRange -> All]

For the above expression for (Subscript[ℐ, k])(x,y), we can easily calculate the expressions |a'(φ)y+b'(φ)x+c'(φ)| and s'(φ).

δDen[{x_, y_}, φ_] = 
Abs[Simplify[D[normalLine[{R[φ] Cos[φ], R[φ] Sin[φ]}, {x, y}], φ]]]

s[φ_] = Sqrt[D[R[φ] Cos[φ], φ]^2 + D[R[φ] Sin[φ], φ]^2] // Simplify

Now, we have everything together to generate the animation. ΨCF is a compiled function that calculates, for a given value of k, a point xy and the intersection points ξηs of the normals with 𝒞.

ℐCF = Compile[{k, {xy, _Real, 1}, {ξηs, _Real, 2}}, 
Module[{x = xy[[1]], y = xy[[2]], ξ, η, φ, l, Ψ = 0.I, ψ},
       (* sum over all normals *)
       Sum[{ξ, η} = ξηs[[j]]; φ = ArcTan[ξ, η]; 
           l = Sqrt[(x - ξ)^2 + (y - η)^2];
           #1/#2 Exp[I k l], {j, Length[ξηs]}]]]&[s[φ], δDen[{x, y}, φ]];

The function fullMatrix uses the reflection symmetry of 𝒞 to generate an array of (Subscript[ℐ, k])(x,y)-values for all points inside 𝒞 (meaning it adds the points from the second, third, and fourth quadrants).

fullMatrix[m_] := Join[Reverse[Rest[#]], #]& /@ Join[Reverse[Rest[m]], m]

Here is finally the resulting animation.

(* show sum of ray contributions, supercircle, and caustics *)
superCircleDataGraphics[m_] := 
Show[{ListDensityPlot[fullMatrix[m], Mesh -> False, 
                MeshRange -> L {{-1, 1}, {-1, 1}}, 
                PlotRange -> Automatic, FrameTicks -> None,
                DisplayFunction -> Identity],
                superCircleGraphics, causticsGraphics},
       DisplayFunction -> $DisplayFunction, Frame -> False]

animationGraphicsℐ[k_, 𝒻_] := 
superCircleDataGraphics[𝒻 @ Apply[ℐCF[k, ##]&, N[ξηData], {2}]]

Show[GraphicsArray[Block[{$DisplayFunction = Identity},
     animationGraphicsℐ[#, Log[Abs[Re[#]] + 1]&]& /@ #]]]& /@
            (* selected frames *) {{0, 10, 30}, {60, 90, 120}}

Do[animationGraphicsℐ[k, Log[Abs[Re[#]] + 1]&], {k, 1, 150}]

Now, we will calculate and visualize (Subscript[(OverTilde[ℐ]), k])(x,y). This time we have to carry out a numerical integration for each point {x,y}. Because of the periodic nature of the integrand, we use the Trapezoidal method. And, for visualization purposes, the precision goal value 3 is sufficient.

ℐT[k_, {x_, y_}, opts___] := NIntegrate[Evaluate[
Exp[I k Sqrt[(x - R[φ] Cos[φ])^2 + (y - R[φ] Sin[φ])^2]] s[φ]] , 
                                         {φ, 0, 2Pi}, opts]

animationGraphicsℐT[k_, 𝒻_] := 
Module[{pp = 200, dataℐT, m},
(* calculate values for 0 <= x <= y *)
dataℐT = Table[Table[ℐT[k, {x, y}, PrecisionGoal -> 3, AccuracyGoal -> 2, 
                               MaxRecursion -> 16, Method -> Trapezoidal], 
              {x, 0, y, 1/pp}], {y, 0, L, 1/pp}];
(* mirror to obtain remaining values for first quadrant *)
m = Table[0.I, {pp}, {pp}];
Do[m[[i, j]] = dataℐT[[i, j]]; m[[j, i]] = dataℐT[[i, j]], {i, pp}, {j, i}];              
(* add supercircle and caustics *)
superCircleDataGraphics[𝒻 @ m]]

The next graphics show (Subscript[ℐ, k])(x,y) and (Subscript[(OverTilde[ℐ]), k])(x,y), the absolute value and the argument for two k-values. No direct relation between the two graphic exists. (Subscript[ℐ, k])(x,y) has caustics (we display the logarithm), while (Subscript[(OverTilde[ℐ]), k])(x,y) has no singularities.

(* absolute value for k == 120; use logarithmic scale for ℐ *)
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {animationGraphicsℐ[120, Log[Abs[#] + 1]&], 
       animationGraphicsℐT[120, Abs]}]]]

(* argument value for k == 30 *)
Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {animationGraphicsℐ[30, Arg], animationGraphicsℐT[30, Arg]}]]]

y'[x] == D[y[x], x] 
      == D[u[x1], x] 
      == D[x1, x] D[u[x1], x1] 
      == y''[x] u'[x1],

y''[x] == D[y'[x], x] 
       == D[y''[x] u'[x1], x]
       == D[y''[x], x] u'[x1] + y''[x] D[u'[x1], x]
       == y'''[x] u'[x1] + D[x1, x]  D[u'[x1], x1]
       == y'''[x] u'[x1] + y''[x]^2 u''[x1].

So we arrive at the following set of equations. (Be aware that we added the differentiated form of the original equation to get an expression for y'''[x].)

eqs = {x1 == y'[x], 
       u[x1] == y[x],
       y'[x] == y''[x] u'[x1],
       y''[x] == y'''[x] u'[x1] + y''[x]^2 u''[x1],
       y''[x] == x^3 + y[x]^3 + y'[x]^3,
       y'''[x] == 3 x^2 + 3 y[x]^2 y'[x] + 3 y'[x]^2 y''[x]}

Now we eliminate the five variables x, y[x], y'[x], y''[x], and y'''[x] from the above six equations to get the desired differential equation for u[x1].
(We temporarily use the variables y, ys, yss, ysss, u, us, uss for GroebnerBasis.)

eqs1 = Apply[Subtract,
eqs /. y[x] -> y /. y'[x] -> ys /. y''[x] -> yss /. y'''[x] -> ysss /.
       u[x1] -> u /. u'[x1] -> us /. u''[x1] -> uss, {1}]

gb = GroebnerBasis[eqs1, {x1, u, us, uss}, {x, y, ys, yss, ysss}, 
                   MonomialOrder -> EliminationOrder][[1]]

newOde = gb /. u -> u[x1] /. us -> u'[x1] /. uss -> u''[x1]

Now let us calculate the series solution for u[x1]. Because we do not know the general form of the series terms of u[x1], we calculate the series for y[x], which is a pure power series. Then we convert this series into a series for u[x1].
Here, the first 13 terms of the series for y[x] are calculated.

cBag = {}; 
Do[(* substitute already-calculated terms *)
   y[x_] = 0 + 0 x + Sum[c[i] x^i, {i, 2, n}] + O[x]^(n + 1) /. cBag; 
   (* plug in y[x] in the differential equation *)
   odeRest = y''[x] - (x^3 + y[x]^3 + y'[x]^3); 
   (* the rest must vanish *)
   mustBeZero = SeriesCoefficient[odeRest, n - 2]; 
   (* solve for the next coefficient c[n] *)
   sol = Solve[mustBeZero == 0, c[n]][[1, 1]]; 
   AppendTo[cBag, sol], {n, 2, 50}]

seriesSolutionY = 0 + 0 x + Sum[c[i] x^i, {i, 2, 50}] + 
                   O[x]^(51 + 1) /. cBag

Substituting the series into the differential equation for y[x] verifies that the solution is correct.

y1''[x] - (x^3 + y1[x]^3 + y1'[x]^3) /. 
         y1 -> Function[x, Evaluate[seriesSolutionY]]

Now we calculate x as a function of x1 by inverting the relation x1 = y[x].

xOfx1 = InverseSeries[D[seriesSolutionY, x], x1]

Substituting this series into the series solution for y[x] gives the series solution for u[x1] we are looking for.

seriesSolutionU = (seriesSolutionY /. x -> xOfx1) // Simplify

A quick check for the correctness of seriesSolutionU.

newOde /. u -> Function[x1, Evaluate[seriesSolutionU]]

Now we see the structure of the series; it is a series in x1^(1/4). So we could equivalently have done the following.

cBag = {};
Do[(* substitute already calculated terms *)
   u[x1_] = Sqrt[2]/5 x1^(5/4) + Sum[c[i/4] x1^(i/4), {i, 6, n}] + 
                                         O[x1]^((n + 1)/4) /. cBag;
   (* plug in y[x] in the differential equation *) odeRest = newOde;
   (* the rest must vanish *) mustBeZero = odeRest[[3, 1]];
   (* solve for the next coefficient c[n] *)
   sol = Solve[mustBeZero == 0, c[n/4]][[1, 1]];
   AppendTo[cBag, sol], {n, 6, 60}]

Here is a plot of the series solution. Plotting each partial sum of the series solution gives a rough idea about the range where the series solution is correct. This is done in the right picture.

seriesSolutionU1 = Normal[seriesSolutionU];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
  {Plot[Evaluate[seriesSolutionU1], {x1, 0, 3}],
   Plot[Evaluate[Rest[FoldList[Plus, 0,
          List @@ seriesSolutionU1]]], {x1, 0, 3},
        PlotStyle -> Table[{Thickness[0.002], Hue[i/18]}, {i, 13}]]}]]]

Now let us compare the series solution with the numerical solution for u[x1]. We solve newOde with respect to u''[x].

s1 = (Solve[newOde == 0, u''[x1]] // Simplify) /.
            u[x1] -> u /. u'[x1] -> us

It turns out that the second solution is the one that corresponds to the above series solution.

We now use NDSolve to solve the resulting differential equation. We cannot start with the numerical solution at x==0 because the right-hand side does not evaluate to a number. Instead, we use our above series solution to start at a small distance away from the origin.)

ε = 10^-2; (* start away from the origin *)
nsol = NDSolve[(* the differential equation *)
{u''[x1] ==  1/(2 x1^6) *
 (2 x1^5 u'[x1] - 6 x1^7 u'[x1]^2 - 
    6 x1^5 u[x1]^2 u'[x1]^3 - 3 (-x1^12 u'[x1]^7 
        (x1 - (x1^3 + u[x1]^3) u'[x1])^2)^(1/3) + 
      3 I Sqrt[3] (-x1^12 u'[x1]^7 *
        (x1 - (x1^3 + u[x1]^3)  u'[x1])^2)^(1/3)), 
        (* initial values from series solution *)
       u[ε] == seriesSolutionU1 /. x1 -> ε, 
       u'[ε] == D[seriesSolutionU1, x1] /. x1 -> ε}, u[x1], {x1, ε, 3},
       MaxSteps -> 10000, WorkingPrecision -> 20,
       PrecisionGoal -> 15, AccuracyGoal -> 12];

Here, the numerically calculated solution shown (we use Re because due to numerical inaccuracies, we got a small imaginary part from extracting the cube root). The right plot shows the difference of the partial sums of the above-calculated series solution to the numerical solution.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
 {Plot[Evaluate[Re[u[x1]] /. nsol], {x1, ε, 3}, PlotRange -> All],
  Plot[Evaluate[Re[u[x1] /. nsol[[1]]] - (* list of partial sums *)
                 Rest[FoldList[Plus, 0, List @@ seriesSolutionU1]]],
      {x1, ε, 3}, PlotRange -> All, PlotStyle -> 
                      Table[{Thickness[0.002], Hue[i/18]}, {i, 13}]]}]]]

Because for x<2 the difference between the series solution and the numerical solution is quite small, let us look at the logarithm of the difference.

Plot[Evaluate[Log[10, Abs[Re[u[x1] /. nsol[[1]]] -
              (* list of partial sums *)
              Rest[FoldList[Plus, 0, List @@ seriesSolutionU1]]]]],
    {x1, ε, 3}, PlotRange -> All, PlotStyle -> 
                      Table[{Thickness[0.002], Hue[i/18]}, {i, 13}]]

The large cusps in the above curve are due to the different signs of the last term of the partial sums.

fContinued[q_, z_] := (q/2 (fContinued[q, z/q]^2 - 1) + 1) /; Abs[z] > ϵ

For a small enough argument z, we will use the first few terms of the series of (Subscript[f, q])(z). Using a generic ansatz of the form (Subscript[f, q])(z)=(Subscript[c, 0])(q)+(Subscript[c, 1])(q)z+(Subscript[c, 2])(q)(z^2)+…, it is straightforward to calculate as many series terms as wanted. Here we calculate the first four.

eqs = ((f[q x] - (2 - q + q f[x]^2)/2) /. 
        f[x_] :> Sum[c[k] x^k, {k, 0, 4}]) + O[x]^5

Inspecting the equations shows that, for generic q, we must have (Subscript[c, 0])(q)=1 and without loss of generality we choose (Subscript[c, 1])(q)=1.

cl = CoefficientList[eqs, x] // Factor

sol = Solve[# == 0& /@ (cl /. {c[0] -> 1, c[1] -> 1}), 
            {c[2], c[3], c[4]}] // Simplify

fSeries[q_, z_] = 1 + z + Sum[c[k] z^k, {k, 2, 4}] /. sol[[1]]

fContinued[q_, z_] := fSeries[q, z] /; Abs[z] <= ϵ

Here is a quick high-precision check that the so-calculated values for (Subscript[f, q])(z) fulfill the original functional equation.

Block[{ϵ = 10^-10, q = Pi/2, z = N[I E, 30], f = fContinued},
      f[q, q z] - (2 - q + q f[q, z]^2)/2]

For an animation, we want to calculate the function values quickly and so we implement a compiled version of the above formulas.

cf = Compile[{{a, _Complex}, {z, _Complex}},
        Module[{ε = 10.^-10, ζ = z, c = 0, z0, f0},
               While[Abs[ζ] > ε, ζ = ζ/a; c++];
               Nest[(a/2 (#^2 - 1) + 1)&, 
                    1 + ζ + ζ^2/(2(a - 1)) + ζ^3/(2(a - 1)^2(a + 1)) +
                    ζ^4 (5 + a)/(8(a - 1)^3(1 + a)(a^2 + a + 1)), c]]];

(* check if compilation was successful *)
Union[Head /@ Flatten[cf[[4]]]]

For the visualization of (Subscript[f, q])(z), we will choose a contour plot of Im((Subscript[f, q])(z))≶0 and simultaneously display the contour lines of Re((Subscript[f, q])(z))=0.

graphic[{r_:1.65, φ_}, L_:25, pp_:400, opts___] := 
Module[{(* generate data *)
        data = Table[cf[r Exp[I φ], x + I y], 
                    {y, -L, L, 2L/pp}, {x, -L, L, 2L/pp}],
        (* set graphics options *)
        opts1 = Sequence[Contours -> {0}, DisplayFunction -> Identity]},
        Show[{ListContourPlot[Im[data], opts1], 
              ListContourPlot[Re[data], opts1, ContourShading -> False, 
                                               ContourStyle -> {Hue[0]}]}, 
             opts, Frame -> False]]

With[{o = 16, L = 25, pp = 200},
Show[GraphicsArray[#]]& /@ Partition[
     Table[graphic[{φ}, L, pp, DisplayFunction -> Identity],
           {φ, 0, 2Pi(1 - 1/o), 2Pi/o}], 4]]

Here is the corresponding animation.

With[{o = 128, L = 25, pp = 240},
     Do[graphic[{φ}, L, pp, DisplayFunction -> $DisplayFunction], 
        {φ, 0, 2Pi(1 - 1/o), 2Pi/o}]]

For some theoretical considerations of related functional equations, see [1375✶].

disc = 256 z^3 + 128 x^2 z^2 + 16 x^4 z - 144 x z y^2 - 4 x^3 y^2 + 27 y^4;

This determines the lower values for the z-coordinate for the picture. (This can be easily verified with the next picture.)

{#, N[#]}&[Solve[disc == 0 /. {x -> 2, y -> 3/2}, z]]

To get a rough overview of the surface, we use ContourPlot3D.

Needs["Graphics`ContourPlot3D`"]

ContourPlot3D[disc, {x, -1, 2}, {y, -3/2, 3/2},
              (* to fit good *) {z, -(592 + 208Sqrt[13])/512, 1},
              MaxRecursion -> 1, PlotPoints -> {12, 3},
              PlotRange -> All, Axes -> True, AxesLabel -> {x, y, z}]

Now we see the problem. This surface has some sharp edges, and due to the regularly spaced tensor product grid used by ContourPlot3D, the sharp edges cannot be modeled with high quality. Some of the partial derivatives must vanish at the sharp edges. We can use this fact to get a parametric representation {x,y(x),z(x)} of the sharp edges.

Solve[{D[disc, y] == 0, D[disc, z] == 0, disc == 0}, {y, z}]

Here is the above picture together with the parametrized edges.

Show[{%%, Graphics3D[{
{Thickness[0.02], (* the sharp edges *) Line /@ {
 Table[{x, -(2x/3)^(3/2), x^2/12}, {x, 0, 2, 0.01}],
 Table[{x, +(2x/3)^(3/2), x^2/12}, {x, 0, 2, 0.01}],
 Table[{x, 0, -x^2/4}, {x, 0, 2, 0.01}]}}}]},
     PlotRange -> All, Axes -> True]

To get a better resolution of the sharp edges, we calculate all parts of the surface bounded by these edges separately. From the above crude picture (and as well from the equation), we see that z=z(x,y) is in general a three-valued function, and by sorting the three real roots of disc == 0, we get all parts of the surface separately. prePoints are the x,y-coordinates of the points used to calculate the corresponding z-values numerically.

pp = 12;
prePoints = Table[{x, i/pp 2/3 Sqrt[2/3] x^(3/2)},
                  {x, 0, 2, 2/pp}, {i, 0, pp}] // N;

This is the grid formed by these x,y-coordinates. (Because of symmetry, we calculate only points with y>0.)

Show[Graphics[{Line /@ prePoints, Line /@ Transpose[prePoints]}],
     AxesLabel -> {"x", "y"}, Axes -> True]

We calculate and sort the roots z(x,y).

roots = Map[Sort[List @@ (Last (* the last is of interest *) /@
             NRoots[(* the polynomial *) disc == 0 /. 
                Apply[Rule, Transpose[{{x, y}, #}], {1}], z])]&,
            prePoints, {2}];

It gives the following two parts of the surface, which are bounded by the sharp edges.

{s2, s3} = Function[p, Map[#[[p]]&, roots, {2}]] /@ {2, 3};
{f2, f3} = MapThread[Append, {prePoints, #}, 2]& /@ {s2, s3};

For the graphical visualization, we again use ListSurfacePlot3D from the package Graphics`Graphics3D`.

Needs["Graphics`Graphics3D`"]

pic1 = Show[ListSurfacePlot3D[#, DisplayFunction -> Identity]& /@ 
            {f2, f3}, DisplayFunction -> $DisplayFunction, 
            PlotRange -> All, Axes -> True]

The missing third part of the surface is now easily calculated and displayed.

f1 = Table[{ξ, η, If[η === 0 && ξ <= 0, 0,
         (* choose correct root *) Min[Cases[Chop[Last /@
           NRoots[disc == 0 /. {x -> ξ, y -> η}, z]], _Real]]]},
           {ξ, -1, 2, 2/pp}, {η, 0, 3/2, (3/2)/pp}] /.
                               {0, 0, Infinity} -> {0, 0, 0};

pic2 = ListSurfacePlot3D[f1, PlotRange -> All, Axes -> True]

After mirroring the surface constructed so far to get the second half, we finally have the following picture, which is much better than the earlier ContourPlot3D.

Show[Graphics3D[{(* mirror on x,z-plane *)
 pic1[[1]], Map[{1, -1, 1}#&, pic1[[1]], {-2}],
 pic2[[1]], Map[{1, -1, 1}#&, pic2[[1]], {-2}]}],
 PlotRange -> All, ViewPoint -> {1.8, -2.2, 2.2}, Boxed -> False]

Needs["Graphics`ContourPlot3D`"]
pi = N[Pi];

ContourPlot3D[Sin[x] Cos[y] + Sin[y] Cos[z] + Sin[z] Cos[x],
              {x, 0, 2pi}, {y, 0, 2pi}, {z, 0, 2pi}, Axes -> True,
              PlotPoints -> 18, MaxRecursion -> 0]

This is the implicit form of the surface.

F[x_, y_, z_] = Sin[x] Cos[y] + Sin[y] Cos[z] + Sin[z] Cos[x];

To avoid the use of ContourPlot3D for the generation of the picture, we need a parametric description of the surface (at least locally). The x, y, and z appear in a symmetrical way in F; so we pick z as the dependent variable and we try to construct z=z(x,y). We have four different solutions for z.

Solve[F[x, y, z] == 0, z] // Simplify

Taking into account that Mathematica chooses the values of arccos in the range [0,π], we define the following solutions for z=z(x,y).

{sol1[x_, y_], sol2[x_, y_]} = 
 (-Cos[y] Sin[x] Sin[y] - # Sqrt[Cos[x]^2 *
  (Cos[x]^2 - Cos[y]^2 Sin[x]^2 + Sin[y]^2)])/
             (Cos[x]^2 + Sin[y]^2)& /@ {+1, -1}

f1[x_, y_] = +ArcCos[sol1[x, y]]; f2[x_, y_] = +ArcCos[sol2[x, y]];
f3[x_, y_] = -ArcCos[sol1[x, y]]; f4[x_, y_] = -ArcCos[sol2[x, y]];

Now we must look for which regions of the x,y-plane where the four functions f1, f2, f3, and f4 are really solutions. The solution should satisfy the following two conditions: a) z(x,y) must be real, and b) z(x,y) must be a solution of the implicit equation. For better visibility of the various regions (shown in black if the two conditions are satisfied) that are related to each other by translations and reflections, we add some grid lines.

grid = {GrayLevel[1/2], Line[{{0, #}, {2pi, #}}]& /@ (pi/2 Range[0, 4]),
                        Line[{{#, 0}, {#, 2pi}}]& /@ (pi/2 Range[0, 4])};

Show[GraphicsArray[#]]& /@ Map[ContourPlot[
If[(* does the “solution” fulfill the equation? *)
   Abs[F[x, y, #1]] < 10^-10 &&
   (* is the solution real-valued? *) Im[#] === 0, -1, 1],
   {x, 0, N[2Pi]}, {y, 0, N[2Pi]}, Contours -> {0},
  PlotPoints -> 100, AspectRatio -> Automatic,
  Epilog -> grid, DisplayFunction -> Identity,
  Evaluate[FrameTicks -> {#, #}&[Table[i Pi/2, {i, 0, 4}]]]]&,
  (* the four solutions *)
  {{f1[x, y], f2[x, y]}, {f3[x, y], f4[x, y]}}, {2}]

We see (modulo translation and reflection symmetry) three types of regions where our function F can be locally inverted by our f1 or f2 or f3 or f4. Let us analytically calculate the boundaries of these three regions. Because of the underlying symmetry, we restrict the calculation to the square of π/2≤x≤π,0≤y≤π/2. The first restriction is given by the condition of real-valuedness of the f1, f2, f3, and f4. This means that arguments of the square root appearing in the fs must be nonnegative. Solving argumentOfTheSquareRoot == 0 for y thus gives the boundary curve in the form y=y(x).

Solve[{Cos[x]^4 - Cos[x]^2 Cos[y]^2 Sin[x]^2 + 
       Cos[x]^2 Sin[y]^2 == 0 /. Cos[y]^2 -> 1 - Sin[y]^2}, 
       {Sin[y]}] // Simplify

The second condition is that F[x, y, fi[x, y]] == 0 holds. A little bit of inspection shows that this means that f1[x, y] for a fixed x,x>(Subscript[x, "min"]) is a solution of F[x, y, fi[x, y]] == 0 for increasing values of y as long as sol1[x, y]≤-1. A direct solution of sol1[x, y] == -1 works just fine.

Solve[sol1[x, y] == -1, y]

We rewrite this solution for sin(y) instead for y.

Sin[y /. %] // Simplify // PowerExpand // Union

So we have analytical descriptions of the two arcs bounding the region of validity of F[x, y, fi[x, y]] == 0. Our next step is to generate mesh for the three (up to translation and reflection symmetry) different regions. To get a nice-looking mesh, we subdivide the region in a polar coordinate system-like fashion generated by radial rays going outward from the point (π/2,0) and divide the rays into equal parts. To calculate the starting length for the rays, we have to solve the equation y(x)=(Subscript[y, "ray"])(x). 
Here, the above two equations are rewritten as an equation in r for the two arcs. (We take (π/2,0) as the origin.)

y1[r_, φ_] = ArcSin[Sqrt[-Cos[2(Pi/2 + r Cos[φ])]]/
                    Sqrt[1 + Sin[(Pi/2 + r Cos[φ])]^2]] ==
                                       r Sin[φ] // ExpandAll

y2[r_, φ_] = ArcSin[Sin[Pi/2 + r Cos[φ]]/
                    Sqrt[1 + Sin[Pi/2 + r Cos[φ]]^2]] ==
                                      r Sin[φ] // ExpandAll

We solve the two equations numerically using FindRoot.

radius1[φ_] := FindRoot[Evaluate[y1[r, φ]], {r, Pi/4}][[1, 2]]
radius2[φ_] := FindRoot[Evaluate[y2[r, φ]], {r, pi/4}][[1, 2]]

Now we have all ingredients together to generate the meshes for the three regions of interest.

ppr = 12; ppl = 12;

tab[1] = Table[#[[1]] + i/ppr(#[[2]] - #[[1]]), {i, 0, ppr}]& /@
Table[{radius1[φ] {Cos[φ], Sin[φ]},
       (* the endpoint along the sides of the square *)
       Which[φ <= pi/4, {pi/2, pi/2 Tan[φ]},
             pi/4 <= φ <= 3pi/4, {pi/2 Cot[φ], pi/2},
             φ > 3pi/4, {-pi/2, -pi/2 Tan[φ]}]}, 
      {φ, 0, pi/2, pi/4/ppl}];

tab[2] = Table[#[[1]] + i/ppr(#[[2]] - #[[1]]), {i, 0, ppr}]& /@
Table[{radius2[φ] {Cos[φ], Sin[φ]},
       (* the endpoint along the sides of the square *)
       Which[φ <= pi/4, {pi/2, pi/2 Tan[φ]},
             pi/4 <= φ <= 3pi/4, {pi/2 Cot[φ], pi/2},
             φ > 3pi/4, {-pi/2, -pi/2 Tan[φ]}]}, 
      {φ, 0, pi/2, pi/4/ppl}];

tab[3] = Table[#[[1]] + i/ppr(#[[2]] - #[[1]]), {i, 0, ppr}]& /@
Table[{radius1[φ] {Cos[φ], Sin[φ]}, radius2[φ] {Cos[φ], Sin[φ]}}, 
      {φ, 0, pi/2, pi/4/ppl}];

This shows the three meshes.

Show[GraphicsArray[
Graphics[{Line /@ tab[#], Line /@ Transpose[tab[#]]},
     Frame -> True, AspectRatio -> Automatic]& /@ {1, 2, 3}]]

By translation and reflection, we generate the corresponding meshes in the other 15 pieces of the above-shown grid of the region 0≤x<2π,0≤y<2π.

Do[(* the first row *)
   κ[i, 1, 1] = Map[{-1,  1}# + {pi/2, 0}&, tab[i], {-2}];
   κ[i, 1, 2] = Map[# + {pi/2, 0}&, tab[i], {-2}];
   κ[i, 1, 3] = Map[{-1,  1}# + {3pi/2, 0}&, tab[i], {-2}];
   κ[i, 1, 4] = Map[# + {3pi/2, 0}&, tab[i], {-2}];
   (* the second row *)
   κ[i, 2, 1] = Map[{-1, -1}# + {pi/2, pi}&, tab[i], {-2}];
   κ[i, 2, 2] = Map[{ 1, -1}# + {pi/2, pi}&, tab[i], {-2}];
   κ[i, 2, 3] = Map[{-1, -1}# + {3pi/2, pi}&, tab[i], {-2}];
   κ[i, 2, 4] = Map[{ 1, -1}# + {3pi/2, pi}&, tab[i], {-2}];
   (* the third row *)
   κ[i, 3, 1] = Map[{-1,  1}# + {pi/2, pi}&, tab[i], {-2}];
   κ[i, 3, 2] = Map[# + {pi/2, pi}&, tab[i], {-2}];
   κ[i, 3, 3] = Map[{-1,  1}# + {3pi/2, pi}&, tab[i], {-2}];
   κ[i, 3, 4] = Map[# + {3pi/2, pi}&, tab[i], {-2}];
   (* the fourth row *)
   κ[i, 4, 1] = Map[{-1, -1}# + {pi/2, 2pi}&, tab[i], {-2}];
   κ[i, 4, 2] = Map[{ 1, -1}# + {pi/2, 2pi}&, tab[i], {-2}];
   κ[i, 4, 3] = Map[{-1, -1}# + {3pi/2, 2pi}&, tab[i], {-2}];
   κ[i, 4, 4] = Map[{ 1, -1}# + {3pi/2, 2pi}&, tab[i], {-2}],
   (* the three meshes *) {i, 3}]

Looking at the above contour plot that shows the validity, we can easily determine which mesh describes the region of validity of the four solutions f1, f2, f3, and f4 in each of the 16 pieces. (The validity of the various solutions in the various regions could also be established analytically with a bit more effort.)

mesh1 = {κ[1, 1, 4], κ[1, 2, 1], κ[1, 3, 3], κ[1, 4, 2],
         κ[2, 1, 1], κ[2, 2, 4], κ[2, 3, 2], κ[2, 4, 3],
         κ[3, 1, 2], κ[3, 2, 3], κ[3, 3, 1], κ[3, 4, 4]};

mesh2 = {κ[1, 1, 2], κ[1, 2, 3], κ[1, 3, 1], κ[1, 4, 4],
         κ[2, 1, 3], κ[2, 2, 2], κ[2, 3, 4], κ[2, 4, 1],
         κ[3, 1, 4], κ[3, 2, 1], κ[3, 3, 3], κ[3, 4, 2]};

mesh3 = {κ[1, 1, 3], κ[1, 2, 2], κ[1, 3, 4], κ[1, 4, 1],
         κ[2, 1, 2], κ[2, 2, 3], κ[2, 3, 1], κ[2, 4, 4],
         κ[3, 1, 1], κ[3, 2, 4], κ[3, 3, 2], κ[3, 4, 3]};

mesh4 = {κ[1, 1, 1], κ[1, 2, 4], κ[1, 3, 2], κ[1, 4, 3],
         κ[2, 1, 4], κ[2, 2, 1], κ[2, 3, 3], κ[2, 4, 2],
         κ[3, 1, 3], κ[3, 2, 2], κ[3, 3, 4], κ[3, 4, 1]};

For comparison with the above contour graphic, here are the four meshed regions for fi to f4.

Show[GraphicsArray[#]]& /@ 
Map[Graphics[{Thickness[0.002], (* make lines from mesh *)
Map[{Line /@ #, Line /@ Transpose[#]}&, #]},
     AspectRatio -> Automatic, PlotRange -> All,
     Epilog -> grid]&, {mesh1, mesh2, mesh3, mesh4}, {1}]

To generate the three-dimensional graphic, we use the command ListSurfacePlot3D from the package Graphics`Graphics3D`.

Needs["Graphics`Graphics3D`"]

Here, each of the four solutions is shown.

Show[GraphicsArray[#]]& /@
MapThread[Function[{func, mesh}, Show[
ListSurfacePlot3D[(* generate z-values on the mesh *)
          Map[Flatten[{#, Re[func @@ #]}]&, #, {-2}],
                      DisplayFunction -> Identity]& /@ mesh]],
  (* the solutions and corresponding meshes *)
  {{{f1, f2}, {f3, f4}}, {{mesh1, mesh2}, {mesh3, mesh4}}}, 2]

Together, they form the complete surface described by sin(x) cos(y)+sin(y) cos(z)+sin(z) cos(x)=0.

Show[Graphics3D[Cases[%, _Polygon, {0, Infinity}]],
     Axes -> True, PlotRange -> All]

Due to the 2π periodicity of the surface along the x, y, and z-axes, we can continue this surface. With enough memory, one could, for instance, display the surface continued to seven adjacent cubes.

(* extract polygons from last graphic *)
allPolys = Cases[%, _Polygon, Infinity];

(* the Gauss curvatue of an implicitly given surface; 
   see Chapter 3 of the Graphics volume *)
κ[{x_, y_, z_}] = Together @ 
Module[{𝒹}, 
 𝒹[ds__] := Derivative[ds][Function[{x, y, z}, 
            Sin[x] Cos[y] + Sin[y] Cos[z] + Sin[z] Cos[x]]][x, y, z];
 (-(𝒹[0, 0, 2] 𝒹[0, 1, 0] 𝒹[1, 0, 0] + 
    𝒹[0, 0, 1] (-𝒹[0, 1, 1] 𝒹[1, 0, 0] - 𝒹[0, 1, 0] 𝒹[1, 0, 1] +
    𝒹[0, 0, 1] 𝒹[1, 1, 0]))^2 + 
   (𝒹[0, 0, 2] 𝒹[0, 1, 0]^2 + 𝒹[0, 0, 1] (-2 𝒹[0, 1, 0] 𝒹[0, 1, 1] + 
    𝒹[0, 0, 1] 𝒹[0, 2, 0])) (𝒹[0, 0, 2] 𝒹[1, 0, 0]^2 + 
    𝒹[0, 0, 1] (-2 𝒹[1, 0, 0] 𝒹[1, 0, 1] + 𝒹[0, 0, 1] 𝒹[2, 0, 0])))/
   (𝒹[0, 0, 1]^2 (𝒹[0, 0, 1]^2 + 𝒹[0, 1, 0]^2 + 𝒹[1, 0, 0]^2)^2)];
  
(* color polygons according to Gauss curvature *)
colorPolygon[p:Polygon[l_]] :=
Module[{𝒸 = Hue[-Plus @@ (κ /@ l)/4]}, {SurfaceColor[𝒸, 𝒸, 2.2], p}]

Show[Graphics3D[{EdgeForm[{}], 
 Table[(colorPolygon /@ allPolys) /. (* use periodicity of the surface *)
               Polygon[l_] :> Polygon[(# + 2Pi {i, j, k})& /@ l],
       {i, 0, 1}, {j, 0, 1}, {k, 0, 1}]}],
     Boxed -> False, Axes -> False]

For similar surfaces, see [618✶] and [619✶].

clebsch = 32 - 216 x^2 + 648 x^2 y - 216 y^2 - 216 y^3 - 150 z +
          216 x^2 z + 216 y^2 z + 231 z^2 - 113 z^3;

Let us make the following ansatz for the (18, as will be shown in the following) lines which are not in a plane parallel to the x,y-plane: {x, y, z}={(Subscript[x, 0]),(Subscript[y, 0]),0}+t{(Subscript[x, 1]),(Subscript[y, 1]),1}.

Here, t is the parameter of the line. The coefficients (Subscript[x, 0]), (Subscript[x, 1]), (Subscript[y, 0]), and (Subscript[y, 1]) are to be determined. (Every line not parallel to the x,y-plane will cross the x,y-plane; so we have taken (Subscript[z, 0])=0, and (Subscript[z, 1])=1 can always be achieved by a reparametrization.) 
We insert this parametrization for the lines into clebsch.

clebsch /. {x -> x0 + x1 t, y -> y0 + y1 t, z -> t}

Extracting the coefficients with respect to t gives us a set of polynomial equations for (Subscript[x, 0]), (Subscript[x, 1]), (Subscript[y, 0]), and (Subscript[y, 1]).

cl1 = CoefficientList[%, t]

We can now straightforwardly solve these equations.

sol2 = Solve[# == 0& /@ GroebnerBasis[cl1, {x0, y0, x1, y1}], 
             {x0, y0, x1, y1}] // Union

As previously mentioned, there are 18 lines.

Length[sol2]

For the picture to be constructed later, we numericalize the data for (Subscript[x, 0]), (Subscript[x, 1]), (Subscript[y, 0]), and (Subscript[y, 1]).

sol3 = N[sol2];
sol4 = {x0, x1, y0, y1} /. sol3;

We will make a picture for the surface for all values of z, which arise when x and y vary inside a circle of radius R. To make the lines fit inside the region where the surface is drawn, we determine the relevant parameter values.

tRange[{x0_, x1_, y0_, y1_}, R_] =
  t /. Solve[(x0 + x1 t)^2 + (y0 + y1 t)^2 == R^2, {t}]

So we get the following lines. (We take R=0.9 as an appropriate parameter for a neat picture here.)

lines1 = Apply[Function[{t0, t1, x0, x1, y0, y1},
                        Line[{{x0, y0, 0} + t0 {x1, y1, 1},
                              {x0, y0, 0} + t1 {x1, y1, 1}}]],
                        Flatten[{tRange[#, 0.9], #}]& /@ sol4, {1}];

Now we must treat the case that there are lines that are parallel to the x,y-plane. We make a similar ansatz as above: {x, y, z}={(Subscript[x, 0]),(Subscript[y, 0]),(Subscript[z, 0])}+t{1,(Subscript[y, 1]),0}.

clebsch /. {x -> x0 + t, y -> y0 + y1 t, z -> z0}

We again extract the coefficients with respect to t.

cl1 = CoefficientList[%, t]

The resulting equations can be easily solved for (Subscript[x, 0]), (Subscript[y, 0]), (Subscript[y, 1]), and (Subscript[z, 0]).

sol1 = Solve[# == 0& /@ cl1, {x0, y0, y1, z0}]

There are nine remaining solutions.

Length[sol1]

Replacing the undetermined values of variables appearing in an parametric way in the solution sol1 by 0, we can again calculate explicit representations for these nine lines.

sol2 = # /. (# -> 0& /@ Cases[Last /@ #, _Symbol, {-1}])& /@ sol1

sol3 = Join[#, # -> 0& /@ Complement[{x0, y0, y1, z0}, First /@ #]]& /@ sol2;
sol4 = N[{x0, 1, y0, y1, z0} /. sol3];

lines2 = Apply[Function[{t0, t1, x0, x1, y0, y1, z0},
                        Line[{{x0, y0, z0} + t0 {x1, y1, 0},
                              {x0, y0, z0} + t1 {x1, y1, 0}}]],
               Flatten[{tRange[Drop[#, -1], 0.9], #}]& /@ sol4, {1}];

So we finally have the following 27 lines.

twentySevenLines = Join[lines1, lines2];

Let us have a look at them. Viewing from far above (right picture), we see how the calculated lines reflect the threefold rotational symmetry of the Clebsch surface.

Show[GraphicsArray[
Graphics3D[twentySevenLines, PlotRange -> All, ViewPoint -> #]& /@
                                    {{1.3, -2.4, 2}, {0, 0, 100}}]]

Now let us make a picture of the Clebsch surface and the 27 lines. Here is a picture of the Clebsch surface. As in Chapter 1 of the Numerics volume [1561✶] of the GuideBooks, we use ContourPlot3D to calculate this picture and exploit the symmetry of the surface.

Needs["Graphics`ContourPlot3D`"]

clebschSurface = Graphics3D[{
{#, Function[m, Map[m.#&, #, {-2}]][
(* make other parts of the surface *)
     N[{{-1, Sqrt[3], 0}, {-Sqrt[3], -1, 0}, {0, 0, 2}}/2]],
   Function[m, Map[m.#&, #, {-2}]][
     N[{{-1, -Sqrt[3], 0}, {Sqrt[3], -1, 0}, {0, 0, 2}}/2]]}&[
   Union[#, Map[{-1, 1, 1}#&, #, {-2}]]&[
     (* change to Cartesian coordinates *)
   Apply[{#1 Cos[#2], #1 Sin[#2], #3}&,
(* make 1/6 of the surface with ContourPlot3D
   in cylindrical coordinates *)
ContourPlot3D[32 - 216 r^2 - 150 z + 216 r^2 z + 231 z^2 -
              113 z^3 + 216 r^3 Sin[3φ],
              {r, 0, 0.9}, {φ, N[-Pi/2], N[-Pi/6]},
(* carefully selected z-boundaries to fit exactly *)
              {z, -0.975, 2.173}, MaxRecursion -> 1,
              PlotPoints -> {{8, 4}, {8, 3}, {22, 3}},
              DisplayFunction -> Identity][[1]], {-2}]]]}]

Just displaying this surface and the lines together in one picture does not yield a reasonable quality. Due to the approximative nature of the polygons from the surface, they intersect in a complicated manner with the lines, and so some parts of the lines will be “below” and some parts “above” the surface. To avoid this, we “lift” the lines slightly in the direction of the local normal on the surface. Here is the normal vector for our cubic.

normalVector[{x_, y_, z_}] = 
 #/Sqrt[#.#]&[{D[#, x], D[#, y], D[#, z]}&[clebsch]];

The routine liftLines lifts its first argument (a line) to both sides of the surface to avoid intersections with the polygons by a height height.

liftLines[Line[{p1_, p2_}], height_, pp_] :=
Function[{l, normal}, (* move slightly up and down *)
{Line[MapThread[Plus, {l, +height normal}]],
 Line[MapThread[Plus, {l, -height normal}]]}] @@
  {#, normalVector /@ #}&[
    Evaluate[p1 + # (p2 - p1)]& /@ (Range[0, pp]/pp)];

Now we can display the lines and the surface together.

Show[Graphics3D[{
{(* the 27 lines *) GrayLevel[1], Thickness[0.004],
 liftLines[#, 0.005, 200]& /@ twentySevenLines},
 (* the Clebsch surface *)
 {EdgeForm[{GrayLevel[0], Thickness[0.002]}],
  Flatten[clebschSurface[[1]]]}}],
     PlotRange -> All, Axes -> False, Boxed -> False,
     ViewPoint -> {1.87, -1.6, 0.9}, BoxRatios -> {1, 1, 2.45},
     Background -> GrayLevel[0.9]]

clebsch3 = 32 - 216 x^2 + 648 x^2 y - 216 y^2 - 216 y^3 - 150 z +
           216 x^2 z + 216 y^2 z + 231 z^2 - 113 z^3;

The threefold rotational symmetry becomes obvious in cylindrical coordinates.

Simplify[clebsch3 /. {x -> r Sin[φ], y -> r Cos[φ]}]

A straightforward generalization from the threefold rotational symmetry to an n-fold rotational symmetry is achieved by using Cos[n φ] instead of Cos[3 φ].

clebsch[n_] := (z - 1) (-32 + 216 r^2 + 118 z - 113 z^2) - 216 r^3 Cos[n φ]

To obtain the corresponding implicit representation, we eliminate the coordinates r and φ and use the Cartesian x and y instead. Using, say, the elimination capabilities of GroebnerBasis, this is straightforward.

generalizedClebsch[n_] := 
GroebnerBasis[{TrigExpand[clebsch[n]], x - r Sin[φ], y - r Cos[φ],
              Sin[φ]^2 + Cos[φ]^2 - 1}, {x, y, z}, {r, Sin[φ], Cos[φ]},
             MonomialOrder -> EliminationOrder][[1]] // Factor

Another possibility to obtain an implicit representation would be the direct substitution of r and φ as functions of x and y and ongoing simplification of the resulting formula.

generalizedClebsch1[n_] := 
Module[{aux, pre},
       (* remove r and φ *)
       aux = clebsch[n] /. {r -> Sqrt[x^2 + y^2], 
                            φ -> ArcCos[y/Sqrt[x^2 + y^2]]};
       (* remove trigs *)
       pre = Numerator[Factor[Together[TrigExpand[aux]]]];
       (* remove square roots if present *)
       If[MemberQ[pre, Sqrt[x^2 + y^2], Infinity],
                  Factor[Expand[(pre - #)^2 - #^2]]&[
                    Plus @@ Cases[pre, Sqrt[x^2 + y^2] _]], pre]]

For n=3, we recover the original Clebsch surface.

generalizedClebsch[3]

generalizedClebsch[3] == generalizedClebsch1[3]

For n=5,n= 7, we get the following implicit representations of Clebsch surfaces.

generalizedClebsch[5]

generalizedClebsch[7]

For an even number n, we get the following implicit representations of Clebsch surfaces.

generalizedClebsch[2]

generalizedClebsch[4]

generalizedClebsch is more advantageous than is generalizedClebsch1 because it does not contain additional factors.

generalizedClebsch1[2]

Now let us visualize some of the generalized Clebsch surfaces. For efficiency, we will make use of the symmetry of the surface and generate a contour plot of a part of the surface and then rotate this part to generate the whole surface.

Needs["Graphics`ContourPlot3D`"]

clebschPicture[n_, opts___] :=
Module[{cpPolys, CartesianPolys, ℛ},
       (* contour plot in cylindrical coordinates *)
       cpPolys = ContourPlot3D[Evaluate[clebsch[n]],
                               {r, 0, 0.9}, {φ, 0, N[2Pi/n]},
                               {z, -0.975, 2.173}, MaxRecursion -> 1,
                               PlotPoints -> {{8, 3}, {12, 3}, {22, 3}},
                               DisplayFunction -> Identity][[1]];
       (* polygons in Cartesian coordinates *)
       CartesianPolys = Apply[{#1 Cos[#2], #1 Sin[#2], #3}&, 
                              cpPolys, {-2}];
       (* rotation matrices *)
       Do[ℛ[i] = N[{{ Cos[i 2Pi/n], Sin[i 2Pi/n], 0}, 
                    {-Sin[i 2Pi/n], Cos[i 2Pi/n], 0}, 
                    {0, 0, 1}}], {i, 0, n - 1}];
       (* show generalized Clebsch surface *)
       Show[Graphics3D[{EdgeForm[], 
          SurfaceColor[Hue[Random[]], Hue[Random[]], 2.6],
          Table[Map[ℛ[i].#&, CartesianPolys, {-2}],
                {i, 0, n - 1}]}], opts, Boxed -> False]]

Show[GraphicsArray[#]]& /@ Partition[clebschPicture[#, 
          DisplayFunction -> Identity]& /@ Range[2, 7], 3]

We could now continue and calculate the straight lines that could be found on these surfaces.

F[x_, y_] = x^4 + y^4 - 6 (x^2 + y^2) + 10;

Let us have a look at the form of this curve.

sketch = ContourPlot[Evaluate[F[x, y]], {x, -3, 3}, {y, -3, 3},
                     Contours -> {0}, PlotPoints -> 100]

We see four equal components in symmetrical position. Between each of the six possible pairs of these regions, there are obviously four (two outer and two crossing) bitangents. As it will turn out later, the remaining four bitangents touch the regions in the point nearest to {0,0} where a degenerate bitangent occurs. 
Let us now explicitly calculate the bitangents. We will derive an equation for the slope m of the possible bitangents, and then calculate the constants b in the equations y=m x+b of the bitangents (assuming m≠∞ and treating the case m=∞ later on). 
We could also try to calculate the points where the bitangents touch the quartic and then calculate m and b for each line. Let us attach a tangent at the point {(Subscript[x, 1]),(Subscript[y, 1])}. These tangents will generically intersect the quartic at two additional points or nowhere else. We will derive an equation that forces the tangent to have just one additional intersection; this means to become a bitangent. 
The following four equations describe a tangent attached to point {(Subscript[x, 1]),(Subscript[y, 1])}. The point {(Subscript[x, 2]),(Subscript[y, 2])} represents the additional point(s) of intersection.

{eq1, eq2, eq3, eq4} = Numerator[Together[#]]& /@
{(* definition of slope m *)
 y2 - y1 - m (x2 - x1),
 (* condition for slope m at point P1 *)
 m + D[F[x1, y1], x1]/D[F[x1, y1], y1],
 (* point P1 lies on the curve *) F[x1, y1],
 (* point P2 lies on the curve *) F[x2, y2]}

One possible solution to this equation is {(Subscript[x, 1]),(Subscript[y, 1])}={(Subscript[x, 2]),(Subscript[y, 2])}. Here, we are interested only in the case of degeneracy. So we will try to get rid of this solution. Let us first derive an equation describing the additional points of intersection that depend on (Subscript[x, 1]). To achieve this, we eliminate m, (Subscript[y, 1]), and (Subscript[y, 2]) from the four equations.

res1 = Resultant[eq1, eq2, m] // Factor

res2 = Resultant[res1, eq3, y1] // Factor

res3 = Resultant[res2, eq4, y2] // Factor

The last result shows the solution {(Subscript[x, 1]),(Subscript[y, 1])}={(Subscript[x, 2]),(Subscript[y, 2])}, which we are not interested in. We will ignore this term in the following. The condition that at {(Subscript[x, 2]),(Subscript[y, 2])} we again have a tangency condition means that (Subscript[x, 2]) has a double root ((Subscript[x, 1]) viewed as a parameter).

res4 =  Resultant[res3[[-1, 1]], D[res3[[-1, 1]], x2], x2] // Factor

The various possibilities to make the last expression zero are collected in the list terms.

terms = Cases[res4, _Plus, Infinity]

Using these possibilities, we can derive equations for the potential slopes m to be obeyed. To do this, we first derive an equation between (Subscript[x, 1]) and m.

res5 = Resultant[eq2, eq3, y1]

We do not use the last two high-order polynomials in terms in the following because, as it turns out, they do not give any solution of interest to us.

mEquations = Factor[Resultant[#, res5, x1]]& /@ Drop[terms, -2]

Because some of the solutions for m may be complex and because the multiple use of resultants might have introduced spurious solutions, we now select the correct ones. In a first step, we solve explicitly for all possible slopes resulting from mEquations and select the real ones.

mPreSols1 = Union[Flatten[Solve[# == 0, m]& /@ mEquations]] // Simplify;
mPreSols2 = Simplify[Select[Last /@ mPreSols1, Im[Chop[N[#]]] == 0&]]

Let us now calculate the constants b. First, we derive an equation connecting m and b.

res6 = Numerator[Together[#]]& /@
Resultant[F[x1, m x1 + b], m + D[F[x1, y1], x1]/D[F[x1, y1], y1] /.
                                        y1 -> m x1 + b, x1] // Factor

Now for every value m from mPreSols2, we calculate the possible values of b. Then for the resulting line y=m x+b, we have to check if it is really a bitangent. We do this by calculating its intersection with the quartic and then see if the quantity ((Subscript[y, 2])-(Subscript[y, 1]))/((Subscript[x, 2])-(Subscript[x, 1])) is identical to the m we started with. The function goodSlopeQ does exactly this check for a given pair {m,b}. Here, we take into account the case of degeneracy, in which the two points where the bitangent touches the quartic coincide.

slopeFromTwoPoints[{{x1_, y1_}, {x2_, y2_}}] :=
If[Abs[x2 - x1] < 10^-6,
   If[Abs[y2 - y1], Indeterminate, Infinity], (y2 - y1)/(x2 - x1)]

goodSlopeQ[{m1_, b1_}] :=
Module[{x1Roots, countRoots, touchPoints, x1y1Pairs, twoPointPairs},
 x1Roots = Re @ Cases[NRoots[F[x1, m1 x1 + b1] == 0, x1],
                      _?(Im[Chop[#]] === 0&), {-1}];
 If[Length[x1Roots] =!= 4, False,
 (* counting coinciding roots *)
 countRoots = Count[Chop[Flatten[Table[x1Roots[[i]] - x1Roots[[j]],
                          {i, 3}, {j, i + 1, 4}]], 10^-6], 0];
 Which[(* double tangent at one point *) countRoots === 6, True,
       (* only one tangent *)            countRoots  <  2, False,
       (* two tangents at two different points *)  True,
 (* x-values of the two points *)
 touchPoints = Union[x1Roots, SameTest -> (Abs[#1 - #2] < 10^-6&)];
 (* coordinates of the points *)
 x1y1Pairs = Chop[N[{#, m1 # + b1}]]& /@ touchPoints;
 (* all possible pairs *)
 twoPointPairs = Flatten[Table[{x1y1Pairs[[i]], x1y1Pairs[[j]]},
       {i, Length[x1y1Pairs] - 1},
        {j, i + 1, Length[x1y1Pairs]}], 1];
 (* is the slope calculated via y2 - y1 - m*(x2 - x1) equal to m1 ? *)
 Min[Abs[N[(slopeFromTwoPoints /@ twoPointPairs) - m1]]] < 10^-6]]]

The function selectGoodShifts calculates the values of b for a given m such that we have a bitangent and returns a list of all possible {m,b} pairs.

selectGoodShifts[μ_] :=
Module[{bEquation, bSymbSolsPre, bSymbSols},
 (* the resulting equation for b *)
 bEquation = Factor[(res6[[-1]] /. m -> μ)];
 (* possible values for b in y  == m x + b *)
 bSymbSolsPre = Union[Solve[bEquation == 0, b]];
 (* the real solutions for b *)
 bSymbSols = Select[bSymbSolsPre, Chop[Im[N[#[[1, 2]]]]] == 0&];
 If[FreeQ[bSymbSols, ToRules, Infinity],
    (* all pairs of m and b *)
    mbPairs = {μ, #}& /@ (Last /@ Flatten[bSymbSols]);
    (* select the real bitangents *)
    Select[mbPairs, goodSlopeQ] // Simplify]]

Finally, we have the following solutions for our bitangents.

mbPairList = Flatten[selectGoodShifts /@ mPreSols2, 1]

There are now 24 solutions.

Length[mbPairList]

The remaining four solutions result from the case m=∞. Because of the symmetry of the quartic under consideration, there is no need to calculate this case explicitly; we can easily get the four bitangents that are parallel to the y-axis from the pairs with m=0, which are parallel to the x-axis. 
Because we used numerical approximations in goodSlopeQ, let us make sure that all solutions from mbPairList are really bitangents by symbolically calculating the quantity ((Subscript[y, 2])-(Subscript[y, 1]))/((Subscript[y, 2])-(Subscript[y, 1]))-m.

test[{m_, b_}] :=
Module[{sol, rules, x, y, x1, x2, y1, y2},
(* intersection (better touch) points *)
sol = Union[Solve[{F[x, y] == 0, y == m x + b}, {y, x}]];
Which[(* degenerate case *) Length[sol] === 1, True,
      (* too many touch points *)
      Length[sol] === 3 || Length[sol] === 4, False,
      (* two touch points *) Length[sol] === 2,
      (* make replacement rules for the two points *)
      rules = Flatten[{sol[[1]] /. {x -> x1, y -> y1},
                       sol[[2]] /. {x -> x2, y -> y2}}];
      (* calculate slope from intersection points
         and compare with m *)
      Together[((y2 - y1)/(x2 - x1) /. rules) - m] === 0]]

(test /@ mbPairList) // Union

So we have the following 28 equations describing the bitangents.

(# == 0& /@
Join[Apply[Numerator[Together[y - #1 x - #2]]&, mbPairList, {1}],
     (* the m == Infinity equations *)
     Apply[Numerator[Together[x - #2]]&, Cases[mbPairList, {0, _}], {1}]])

Let us now add the lines representing the bitangents to the above picture sketch. The function makeLine generates graphic lines with Line, which fit into the above plot range.

makeLine[{0, b_}] := {Line[{{-3, b}, {3, b}}], Line[{{b, -3}, {b, 3}}]}

makeLine[{m_, b_}] := Line[{{-3, -3m + b}, {3, 3 m + b}}]

To better see the points of tangency, we also calculate the points where the bitangents touch the quartic.

makePoint[{0, b_}] := {Point[{#, b}], Point[{b, #}]}& /@
           Re[Cases[NRoots[F[x, b] == 0, x], _?NumberQ, {-1}]]

makePoint[{m_, b_}] := Point[{#, m # + b}]& /@
           Re[Cases[NRoots[F[x, m x + b] == 0, x], _?NumberQ, {-1}]]

We finally have the following picture.

Show[{Graphics[sketch] /. GrayLevel[0.] -> GrayLevel[1/2],
      (* the lines and points of the 28 tangents *)
      Graphics[{{Thickness[0.002], makeLine /@ mbPairList},
                {PointSize[0.0125], makePoint /@ mbPairList}}]},
     PlotRange -> {{-3, 3}, {-3, 3}}, AspectRatio -> Automatic,
     Frame -> False]

For other explicit equations of quartics with real bitangents, see [169✶], [1555✶], and [1445✶]. For a GröbnerBasis use for calculating all 28 bitangents see [1555✶]. For the inverse problem, namely determining the curve from its 28 bitangents, see [274✶].

eq[q_, z_] = 2 z^6 - q^3 - q;

pic = With[{R = 0.9, pp = 1000},
           Show[Graphics[{PointSize[0.002],
                          Table[Point[{Re[#], Im[#]}]& /@ 
                                Cases[NRoots[eq[R Exp[I φ], z] == 0, z], 
                          _Real | _Complex, {-1}], {φ, 0, 2Pi, 2Pi/pp}]}], 
                PlotRange -> All, Frame -> True, AspectRatio -> Automatic]]

To calculate the intersection points, we find the solutions of {Re(z(φ)), Im(z(φ))}={Re(z(ϕ)), Im(z(ϕ))} for φ≠ϕ [1250✶].

eqs0 = {eq[r (Cos[φ] + I Sin[φ]), zr + I zi], 
        eq[r (Cos[ϕ] + I Sin[ϕ]), zr + I zi]} // Expand

We separate real and imaginary parts and obtain a coupled set of four equations.

eqs1 = Flatten[Function[expr, Flatten[Expand[{expr - #, #/I}&[
                      Plus @@ Cases[expr, _Complex _]]]]] /@ eqs0]

Eliminating the two sin functions yields a set of 18 equations.

gb1 = GroebnerBasis[Join[eqs1, {Cos[φ]^2 + Sin[φ]^2 - 1, 
                    Cos[ϕ]^2 + Sin[ϕ]^2 - 1}], {}, {Sin[φ], Sin[ϕ]},
                    MonomialOrder -> EliminationOrder] // Factor;

Not unexpectedly, many of the equations of gb1 have factors of the form cos(φ)-cos(ϕ). (These factors represent the trivial solution that the two points are identical. The situation situation φ=-ϕ does not occur here.)

Short[gb1, 12]

We eliminate these factors and then eliminate the two cos functions. This gives a two equations for Re(z(φ)) and Im(z(φ)).

gb1a = DeleteCases[gb1, Cos[ϕ] - Cos[φ], Infinity];
gb2 = GroebnerBasis[gb1a, {}, {Cos[φ], Cos[ϕ]}]

We solve this equation and extract the Re(z(φ)) and Im(z(φ)) that are real. This results in 12 points.

sol1 = Solve[# == 0& /@ gb2, {zi, zr}] // Union;

iPoints = {zr, zi} /. Select[sol1  /. r -> 9/10,
              (Im[N[{zr, zi} /. #, 22]] == {0., 0.})&];

Length[iPoints]

Because of the symmetry of the curve it is enough to show the intersection points in the first quadrant.

Select[iPoints, (#[[1]] >= 0 && #[[2]] >= 0)&]

Here is the curve together with the just-calculated intersection points shown.

Show[{pic, Graphics[{
 {PointSize[0.02], Hue[0.0], Point[#]& /@ iPoints}}]}, 
 PlotRange -> All, Frame -> True, AspectRatio -> Automatic]

To derive a polynomial equation from this description we have to eliminate the five square roots. We could, for instance, introduce auxiliary variables for the square roots and then use GroebnerBasis with an elimination order. Instead we will follow a more straightforward approach. We eliminate one square root on one side the equation and then square the equation. Doing this repeatedly eliminates all square roots. The function step eliminates the linearly in eq occurring variable v by squaring and replaces (v^2) by V.

step[eq_, v_, V_] :=
Module[{rhs, lhs},
       (* isolate v *)
       lhs = Plus @@ Cases[Expand[eq], f_. v, {1}];
       rhs = Expand[eq - lhs];
       Expand[Factor[lhs]^2 - rhs^2 /. v^2 -> V] /.
           {r[k_]^e_ :> (* use squares if possible *)
            If[EvenQ[e], R[k]^(e/2), R[k]^((e - 1)/2) R[K]]}]

Writing r[k] for |{sin(k 2π/5), cos(k 2π/5)}-{x, y}|, the following expression s0 is our pentaellipse.

s0 = r[1] + r[2] + r[3] + r[4] + r[5] - c;

The next call to step eliminates r[1].

s1 = step[s0, r[1], R[1]]

The next four calls to step eliminate all square roots containing x and y.

s2 = step[s1, r[2], R[2]];
s3 = step[s2, r[3], R[3]];
s4 = step[s3, r[4], R[4]];
s5 = step[s4, r[5], R[5]];

The resulting polynomial s5 is quite large. Expanded it has 20349 terms.

{Length[#], ByteCount[#], LeafCount[#]}&[Expand @ s5]

s5 is of degree 32 in c.

Exponent[s5, c]

To get an explicit polynomial, we have to expand the squared distances R[k]. Let 𝒹[p1, p2] denote the distance between the points p1 and p2.

p[5][j_] = {Sin[j 2Pi/5], Cos[j 2Pi/5]};
𝒹[p1_, p2_] := Sqrt[(p1 - p2).(p1 - p2)]

The symmetry of the pentaellipse suggests that the coefficients of the powers of c in s5 are most naturally expressed as symmetric functions in the five R[k]. Using the package Algebra`SymmetricPolynomials` we eliminate all the R[k].

Needs["Algebra`SymmetricPolynomials`"]

rules = Append[(* general case *)
(# -> Expand[# /. R[j_] :> 𝒹[p[5][j], {x, y}]^2])& /@ 
Table[SymmetricPolynomial[{R[1], R[2], R[3], R[4], R[5]}, k], {k, 5}],
     (* pure product case *)
     R[1]^e_ R[2]^e_ R[3]^e_ R[4]^e_ R[5]^e_ -> 
     ExpandAll[((R[1] R[2] R[3] R[4] R[5])^e /. 
                                     R[j_] :> 𝒹[p[5][j], {x, y}]^2)]]

eliminateRs[expr_] := Factor[Plus @@ 
 SymmetricReduction[expr, {R[1], R[2], R[3], R[4], R[5]}] //.  
       (* use explicit values for the distances *) rules]

poly = Collect[s5, c, eliminateRs];

Luckily, not only did we eliminate all R[k], but also all square roots resulting from sin(k 2π/5) and cos(k 2π/5).

Union[Head /@ ((List @@ poly) /. {x -> 1, y -> 1, c -> 1})]

poly is still quite large, but it is considerably smaller than s5.

{Length[#], ByteCount[#], LeafCount[#]}&[Expand @ poly]

Max[Plus @@@ (First /@ Internal`DistributedTermsList[Expand[poly], 
                                                 {x, y, c}][[1]])]

Switching finally to a polar coordinate system results in polynomial polarPoly of manageble size.

polarPoly = Collect[poly, c, 
                    Simplify[#  /. {x -> r Cos[φ], y -> r Sin[φ]}]&];

{Length[#], ByteCount[#], LeafCount[#]}&[Expand @ polarPoly]

Short[polarPoly, 12]

Now let us visualize (Subscript[p, c])(x,y). We start by generating an efficient routine to calculate the numerical version of polarPoly.

Needs["NumericalMath`OptimizeExpression`"]

optimize = If[$VersionNumber > 4, 
   (* use function from Experimental` context *)
    Experimental`OptimizeExpression[#,
        OptimizationLevel -> 1, ExcludedForms -> {}],
   (* use package function*)
   OptimizeExpression[#, OptimizeLevel -> -1, ExcludedForms -> {}]]&;

optPolarPoly = optimize[Evaluate[N[polarPoly]]];

cfpolarPoly = Compile[{r, φ, c}, Evaluate[optPolarPoly]];

We will make explicit use of the symmetry and calculate the contours (Subscript[p, c])(x,y)=0 for only 1/10th of the whole graphic and generate the remaining 9/10th by reflection and rotation. ℛ[i] are the rotation matrices to do this and makeAll generates the other 9 graphic parts.

Do[ℛ[i] = {{ Cos[2Pi/5 i], Sin[2Pi/5 i]},
           {-Sin[2Pi/5 i], Cos[2Pi/5 i]}}, {i, 0, 4}]

makeAll[gr_] := 
With[{ℊ𝓇 = {gr, gr /. (pl:(Polygon | Line))[l_] :> pl[{-1, 1}#& /@ l]}},
      Table[ℊ𝓇 /. (pl:(Polygon | Line))[l_] :> pl[ℛ[i].#& /@ l], {i, 0, 4}]]

We will use ContourPlot in a polar coordinate system. The function addPoints refines polygons generated by Graphics[ContourGraphics[...]]].

addPoints[points_, δε_] := 
  Module[{n, l}, Join @@ (
     Function[s, If[(l = Sqrt[#. #]&[Subtract @@ s]) < δε, s, 
         n = Floor[l/δε] + 1; (* form segments *)
         Table[# + i/n (#2 - #1), {i, 0, n - 1}]& @@ s]] /@ 
           Partition[Append[points, First[points]], 2, 1])]

p[5][j_] = {Sin[j 2Pi/5], Cos[j 2Pi/5]};
𝒹[p1_, p2_] := Sqrt[(p1 - p2).(p1 - p2)]

We will calculate the contour lines of the original expression s0 using 𝕡.

𝕡[x_, y_, c_] = s0 /. r[j_] :> 𝒹[p[5][j], {x, y}];

The function 𝕔Graphics finally calculates all contour lines for a given value of c. The contour lines of the original expression will be shown in red.

𝕔Graphics[c_, opts___] := 
Module[{R = 7, ppr = 300, ppφ = 120, ε = 0.1,
        cp, grC, L1, L2, grD, cpO, outerCircle},
 (* contour plot in r,φ-coordinates *)
 cp = ContourPlot[cfpolarPoly[r, φ, c],
      {r, 0, R}, {φ, 3Pi/10, Pi/2}, Compiled -> False,
      ContourLines -> False, DisplayFunction -> Identity,
      PlotPoints -> {ppr, ppφ}, Contours -> {0}];
 (* convert contour graphics into Cartesian polygons *)   
 grC = Graphics[cp] /. Polygon[l_] :> Polygon[addPoints[l, 0.1]] /.
         Polygon[l_] :> Polygon[Apply[#1 {Cos[#2], Sin[#2]}&, l, {1}]];
 (* deal especially with boundaries of the Pi/5 wedge *)
 L1 = {GrayLevel[Sign[Plus @@ (Last /@ #)] /. -1 -> 0], 
       Line[{0, #}& @@@ #]}& /@ 
        Split[Table[{r, cfpolarPoly[r, Pi/2, c]}, {r, 0, R, R/(ppr)}], 
              Sign[#1] == Sign[#2]&];
 L2 = {GrayLevel[Sign[Plus @@ (Last /@ #)] /. -1 -> 0], 
       Line[# {Cos[3Pi/10], Sin[3Pi/10]}& @@@ #]}& /@ 
        Split[Table[{N @ r, cfpolarPoly[r, 3Pi/10, c]}, {r, 0, R, R/(2ppr)}],
              Sign[#1] == Sign[#2]&];
 grD = {Graphics[{Thickness[0.004], L1, L2 }]};
  (* contour plot of the radical version *)
 cpO = ContourPlot[Evaluate[𝕡[r Cos[φ], r Sin[φ], c]],
    {r, 0, R}, {φ, 3Pi/10, Pi/2}, 
    ContourShading -> False, DisplayFunction -> Identity,
    PlotPoints -> {ppr, ppφ}, Contours -> {0}];
 (* convert contour graphics into polygons *)      
 grO = Graphics[cpO] /. Line[l_] :> {Hue[0], Thickness[0.002], 
                 Line[Apply[#1 {Cos[#2], Sin[#2]}&, l, {1}]]};
 (* outer white boundary *)   
 outerCircle = Graphics[{GrayLevel[1], 
                Polygon[Join[0.99 #, 1.01 Reverse[#]]]&[
                Table[R{Cos[φ], Sin[φ]}, {φ, 0, 2Pi, 2Pi/360}]]}];
 (* display all elements *)   
 Show[{makeAll[grC], makeAll[grD], makeAll[grO], outerCircle}, 
       opts, Frame -> False, DisplayFunction -> $DisplayFunction] // N]

The following array of graphics shows the contour lines of the polynomial and the original version for various values of the parameter c. As expected, all graphics show a fivefold symmetry.

Show[GraphicsArray[
 𝕔Graphics[#, DisplayFunction -> Identity]& /@ #]]& /@ 
                Partition[Table[c, {c, 0, 11, 11/14}], 3]

Here is the corresponding animation.

Do[𝕔Graphics[c], {c, 0, 11, 1/8}]

curl[{ax_, ay_, az_}] := 
  {D[az, y] - D[ay, z], D[ax, z] - D[az, x], D[ay, x] - D[ax, y]}

div[{ax_, ay_, az_}] := D[ax, x] + D[ay, y] + D[az, z]

laplace[a_] := D[a, x, x] + D[a, y, y] + D[a, z, z]

nablaV[{vx_, vy_, vz_}, ψ_] := vx D[ψ, x] + vy D[ψ, y] + vz D[ψ, z]

The unprimed fields fulfill the Maxwell equations in the unprimed coordinates. We write substitution rules that will replace all time derivatives by the corresponding space derivatives.

maxwellRules1 = 
   {Derivative[1, dx_, dy_, dz_][Ex][t_, x_, y_, z_] -> 
       -Derivative[0, dx, dy, dz + 1][Hy][t, x, y, z] + 
        Derivative[0, dx, dy + 1, dz][Hz][t, x, y, z], 
    Derivative[1, dx_, dy_, dz_][Ey][t_, x_, y_, z_] -> 
        Derivative[0, dx, dy, dz + 1][Hx][t, x, y, z] - 
        Derivative[0, dx + 1, dy, dz][Hz][t, x, y, z], 
    Derivative[1, dx_, dy_, dz_][Ez][t_, x_, y_, z_] -> 
       -Derivative[0, dx, dy + 1, dz][Hx][t, x, y, z] + 
        Derivative[0, dx + 1, dy, dz][Hy][t, x, y, z], 
    Derivative[1, dx_, dy_, dz_][Hx][t_, x_, y_, z_] -> 
        Derivative[0, dx, dy, dz + 1][Ey][t, x, y, z] - 
        Derivative[0, dx, dy + 1, dz][Ez][t, x, y, z], 
    Derivative[1, dx_, dy_, dz_][Hy][t_, x_, y_, z_] -> 
       -Derivative[0, dx, dy, dz + 1][Ex][t, x, y, z] + 
        Derivative[0, dx + 1, dy, dz][Ez][t, x, y, z], 
    Derivative[1, dx_, dy_, dz_][Hz][t_, x_, y_, z_] -> 
        Derivative[0, dx, dy + 1, dz][Ex][t, x, y, z] - 
        Derivative[0, dx + 1, dy, dz][Ey][t, x, y, z]};

In a similar way, we solve the last two Maxwell equations with respect to the (Subscript[E, x]) and (Subscript[H, x]).

maxwellRules2 =
{Derivative[0, dx_?(# >= 1&), dy_, dz_][Ex][t_, x_, y_, z_] -> 
          -Derivative[0, dx - 1, dy + 1, dz][Ey][t, x, y, z] + 
          -Derivative[0, dx - 1, dy, dz + 1][Ez][t, x, y, z],
 Derivative[0, dx_?(# >= 1&), dy_, dz_][Hx][t_, x_, y_, z_] -> 
          -Derivative[0, dx - 1, dy + 1, dz][Hy][t, x, y, z] + 
          -Derivative[0, dx - 1, dy, dz + 1][Hz][t, x, y, z]};

The following implements some abbreviations for the fields, the position and the velocity vector.

e = {Ex[t, x, y, z], Ey[t, x, y, z], Ez[t, x, y, z]}; 
h = {Hx[t, x, y, z], Hy[t, x, y, z], Hz[t, x, y, z]}; 
v = {vx, vy, vz}; 
r = {x, y, z};

These are the transformed fields.

eP = e - Cross[v, h] - (v.r + 1/2 v.v t) curl[h] + 
    1/2 (v.v e - v v.e + r.v (nablaV[v, e] - 2 Cross[v, curl[e]]) + 
        (r.v)^2 laplace[e]);

hP = h + Cross[v, e] + (v.r + 1/2 v.v t) curl[e] + 
    1/2 (v.v h - v v.h + r.v (nablaV[v, h] - 2 Cross[v, curl[h]]) + 
        (r.v)^2 laplace[h]);

The function Υ checks if eq is zero up to order 3 in (OverVector[v]).

Υ[eq_] := Expand[Expand[eq] /. maxwellRules1 /. maxwellRules2] /. 
                  {vx -> λ vx, vy -> λ vy, vz -> λ vz} /. 
                           λ^(n_)?(# >= 3&) -> 0 /. λ -> 1

According to the chain rule and using the Galilei transformation, the derivatives transform as ∇'=∇ and (∂_(t'))=(∂_t)-∇.(OverVector[v]). Here are the transformed fields used in the Maxwell equations.

Υ[D[hP, t] - nablaV[v, hP] + curl[eP]]

Υ[D[eP, t] - nablaV[v, eP] - curl[hP]]

Υ[div[eP]]

Υ[div[hP]]

This means that the transformed fields fulfill the Maxwell equations to the given order. Only the relation between the fields in a media determines if the symmetry is the one of the Galilei group or of the Lorentz group. 
For the transition from the Lorentz invariance to the Galilei invariance in the Maxwell equations, see [786✶]. To calculate the maximal symmetry group of a free nonrelativistic point particle, see [833✶].

{ℰ, ℋ, 𝒟, ℬ, v} = Map[(# /@ Range[3])&, {ℰc, ℋc, 𝒟c, ℬc, vc}];

Componentwise, it is straightforward to solve the constitutive equations for 𝒟 and ℬ.

eqs = Flatten[Thread /@ 
        {𝒟 + 1/c Cross[v, ℋ] == ε (ℰ + 1/c Cross[v, ℬ]),
         ℬ - 1/c Cross[v, ℰ] == μ (ℋ - 1/c Cross[v, 𝒟])}]

sol = Simplify[Solve[eqs, Join[𝒟, ℬ]]]

Inspecting these solutions for a while would allow one to guess and then to verify the correct vector version of the solution. (For some four versions of electrodynamic equations that are more difficult to translate into three-vector equations, see, for instance, equation (8) of [1473✶], [643✶], or [71✶].) Instead of following this heuristic approach we will choose a more mechanical one. The scalar quantities appearing in the solutions are either vector components (the possible vectors are ℰ, ℋ, v, ℰ×ℋ, v×ℰ, or v×ℋ) or scalars (the possible “pure ” scalars are ℰ.ℰ, ℋ.ℋ, v.v, v.ℰ, or v.ℋ).

vars = {vc[2], vc[3], ℰc[2], ℰc[3], ℋc[2], ℋc[2],
        vxℰc[1], vxℋc[1], ℰxℋc[1], vℰ, vℋ, ℰℋ, ℰℰ, ℋℋ, vv};

The goal is to eliminate in the solutions for the ith component all occurrences of vector components other than i. Such an elimination can be performed using PolynomialReduce. We preprocess the defining set of equations by forming a Gröbner basis. The variables to eliminate come first in the list of variables. Here, this done for the first component of 𝒟.

gb = GroebnerBasis[
 Flatten[{vℰ - v.ℰ, vℋ - v.ℋ, ℰℋ - ℰ.ℋ, ℰℰ - ℰ.ℰ, ℋℋ - ℋ.ℋ, vv - v.v,
          vxℰ[1] - Cross[v, ℰ][[1]], vxℋ[1] - Cross[v, ℋ][[1]],
          ℰxℋ[1] - Cross[ℰ, ℋ][[1]]}], vars];

{num, den} = {Numerator[#], Denominator[#]}&[Together[𝒟c[1] /. First[sol]]];

Simplify[PolynomialReduce[#, gb, vars,
                 MonomialOrder -> Lexicographic][[-1]]]& /@ {num, den}

In a completely analogous way, we deal with the first component of ℬ.

{num, den} = {Numerator[#], Denominator[#]}&[Together[ℬc[1] /. First[sol]]];

Simplify[PolynomialReduce[#, gb, vars,
                 MonomialOrder -> Lexicographic][[-1]]]& /@ {num, den}

The last two equations show that the first component has been appropriately expressed in other quantities that are either scalars or contain only the first components of the fields and the velocity. Proceeding in a similar way shows that the second and third components give a similar result. This means that the corresponding vector equation can be obtained by simply dropping the component index, and we arrive at:

𝒟=(1/((c^2)-ε μ v.v))(ε (1-ε μ)v.ℰ v+c (ε μ-1) v×ℋ+ε (c^2)ℰ-ε v.v ℰ),
ℬ=(1/((c^2)-ε μ v.v))(μ (1-ε μ)v.ℋ v+c (1-ε μ) v×ℰ+μ (c^2) ℋ-μ v.v ℋ).

φ[{ρ_, z_}, t_, {α_, v_}] := 
  (z - t v + I α)/Sqrt[(z - t v + I α)^2 + (1 - (v/c)^2) ρ^2]^3

It is straightforward to show that the real part and the imaginary part of (Subscript[φ, v])(ρ,z;t) fulfill the 3D wave equation.

With[{(* X-wave *) ϕ = φ[{ρ, z}, t, {α, v}]},
     (* 1D wave equation *)
     1/c^2 D[ϕ, t, t] - (1/ρ D[ρ D[ϕ, ρ], ρ] + D[ϕ, z, z])] // 
                                                        Together

Here is the real part written in an explicitly real way.

ComplexExpand[Re[φ[{ρ, z}, t, {α, v}]], 
              TargetFunctions -> {Re, Im}] // Simplify

(Subscript[φ, v])(ρ,z;t) is a solution of the wave equation for any value of v. Because (Subscript[φ, v])(ρ,z;t)=(Subscript[φ, v])(ρ,z-v t;0), it is a (unphysical) solution that propagates with any possible speed v. The following graphics show the Re((Subscript[φ, v])(ρ,z;0)) for v=1/2 and v=2 in the ρ,z-plane.

Show[GraphicsArray[
Plot3D[Evaluate[Re[φ[{ρ, z}, 0, {1, # c}]] /. c -> 1], 
       {ρ, 0, 5}, {z, -5, 5}, PlotPoints -> 120, 
       DisplayFunction -> Identity,
       Mesh -> False, PlotRange -> All]& /@ {1/2, 1, 2}]]

For similar superluminal solutions of the wave equations, see [1324✶], [1710✶], [151✶], [1485✶], [1438✶], [768✶], [38✶], [1144✶], [189✶], [1728✶], [1708✶], [1709✶], [1319✶], [458✶], and [1211✶]; for localized, finite energy solutions, see [1610✶].

σ[1] = {{0,  1}, {1,  0}};
σ[2] = {{0, -I}, {I,  0}};
σ[3] = {{1,  0}, {0, -1}};

m1 = MatrixExp[-ξ σ[3]].MatrixExp[η (Sin[α] σ[1] + Cos[α] σ[3])]

m2 = MatrixExp[ρ (Sin[θ] σ[1] + Cos[θ] σ[3])].MatrixExp[I ψ σ[2]] //
     Expand // Simplify // TrigExpand // Expand

After threading m1 == m2 we have a set of four pseudopolynomial equations to be solved. Due to the complexity of this problem, a direct call to Solve will not succeed. To be on safe ground for equation solving, we rewrite the equations m1 == m2 in polynomial form by replacing the exponents with variables and clearing denominators.

eqs1 = Expand[Numerator[Together[(Flatten[m1 - m2] // Expand) /.
              {Exp[ρ] -> 𝕖ρ, Exp[-ρ] -> 1/𝕖ρ}]]]

We now introduce auxiliary variables for the nonpolynomially occurring variables. This gives the following equations

eqs2 = {𝕖ρ + 𝕖ρ ηP^2 - 𝕖ρ Cos[α] + 𝕖ρ ηP^2 Cos[α] - ηP ξP Cos[ψ] - 
 𝕖ρ^2 ηP ξP Cos[ψ] + ηP ξP Cos[θ] Cos[ψ] - 𝕖ρ^2 ηP ξP Cos[θ] Cos[ψ] - 
 ηP ξP Sin[θ] Sin[ψ] + 𝕖ρ^2 ηP ξP Sin[θ] Sin[ψ], 
 -𝕖ρ Sin[α] + 𝕖ρ ηP^2 Sin[α] + ηP ξP Cos[ψ] Sin[θ] - 
 𝕖ρ^2 ηP ξP Cos[ψ] Sin[θ] - ηP ξP Sin[ψ] - 𝕖ρ^2 ηP ξP Sin[ψ] + 
 ηP ξP Cos[θ] Sin[ψ] - 𝕖ρ^2 ηP ξP Cos[θ] Sin[ψ], -𝕖ρ ξP Sin[α] + 
 𝕖ρ ηP^2 ξP Sin[α] + ηP Cos[ψ] Sin[θ] - 𝕖ρ^2 ηP Cos[ψ] Sin[θ] + 
 ηP Sin[ψ] + 𝕖ρ^2 ηP Sin[ψ] + ηP Cos[θ] Sin[ψ] - 𝕖ρ^2 ηP Cos[θ] Sin[ψ], 
 𝕖ρ ξP + 𝕖ρ ηP^2 ξP + 𝕖ρ ξP Cos[α] - 𝕖ρ ηP^2 ξP Cos[α] - ηP Cos[ψ] - 
 𝕖ρ^2 ηP Cos[ψ] - ηP Cos[θ] Cos[ψ] + 𝕖ρ^2 ηP Cos[θ] Cos[ψ] + 
 ηP Sin[θ] Sin[ψ] - 𝕖ρ^2 ηP Sin[θ] Sin[ψ]};

We have to eliminate the three variables 𝕖ρ, Sin[θ], and Cos[θ] from four the equations eqs1. Normally we would supplement our system with Sin[θ]2+Cos[θ]^2-1, but because of the excess equation this is not needed and we can eliminate Sin[θ] and Cos[θ] immediately.

GroebnerBasis[eqs2, {ξP, ηP, Sin[α], Cos[α], Sin[ψ], Cos[ψ]}, 
              {Sin[θ], Cos[θ], 𝕖ρ}, Sort -> False, 
              MonomialOrder -> EliminationOrder] // Factor

We could now evaluate Solve[gb[[1]] == 0, ψ]. This gives the correct, but slightly clumsy, result. Instead we solve for Tan[ψ] and simplify the result (to avoid autoevaluation we use tan instead of Tan temporarily). This gives a nice, concise answer.

GroebnerBasis[{%, Cos[ψ]^2 + Sin[ψ]^2 - 1, 
               tan[ψ] Cos[ψ] - Sin[ψ]}, {}, {Sin[ψ], Cos[ψ]},
              MonomialOrder -> EliminationOrder] /. tan -> Tan

Solve[%[[1]] == 0, Tan[ψ]] /. {ξP -> Exp[ξ], ηP -> Exp[η]} // 
                                                 FullSimplify

Unprotect[Dot]; 
SetAttributes[Dot, Orderless];

Next, because we work with symbolic vectors, we teach Dot linearity and distributivity over nonvector quantities. We will use the doublestruck letters 𝕣 and 𝕧 for vectors.

(* distribute over sums *)
Dot[a_Plus, b_] := Dot[#, b]& /@ a

(* extract nonvector prefactors *)
Dot[f_ a_, b_] := f Dot[a, b] /; 
  Not[MatchQ[f, _. (𝕣[_] | 𝕧[_] | 𝕣 | 𝕧 | 
                    Derivative[_][𝕣 | 𝕧][_] | Derivative[_][𝕣 | 𝕧])]]

The next definition implements the scalar product for two Taylor series, both having vector-valued coefficients.

Dot[s_SeriesData, σ_SeriesData] :=         
  (* calculate components *)
  ExpandAll[Normal[s]].ExpandAll[Normal[σ]] + 
    (* make series again *)
    O[s[[1]]]^Min[s[[-2]], σ[[-2]]] /; First[s] === First[σ]

For uniformity we write higher-order derivatives of 𝕣 as derivatives of 𝕧.

Derivative[k_][𝕣][τ_] := -Derivative[k - 1][𝕧][τ]

The basic identity to be used repeatedly in the following is the τ-derivative of r(τ). It is easily derived from the defining equations [1454✶].

r'[τ_] := -𝕣[τ].𝕧[τ]/r[τ]

To obtain an expansion for the potential φ in inverse powers of c, we start by expressing the implicitly defined τ(t) (parametrically depending on γ) in inverse powers of c. Using γ=1/c, we have τ(t)=(∑_(k=0)^∞)(γ^k)/k!(∂^k)τ(t)/∂(γ^k)(Subscript[|, γ=0]).

The 0th order time represents an infinite speed of light, meaning τ=t. By solγ[k] we denote the replacement rule for (∂^k)τ(t)/∂(γ^k)(Subscript[|, γ=0]).

solγ[0] = {τ[t][0] -> t};

The higher derivatives of τ(t) with respect to γ can be obtained through implicit differentiation. Here this is done for the first order.

eq[0] = τ[t][γ] == (t - γ r[τ[t][γ]]);

eq[1] = D[eq[0], γ]

sol[1] = Solve[eq[1], τ[t]'[γ]][[1]]

solγ[1] = sol[1] /. γ -> 0 /. solγ[0]

It is straightforward to automate the last steps for the higher derivatives.

o = 5;

Do[eq[k] = D[eq[k - 1], γ];
   sol[k] = Solve[eq[k], Derivative[k][τ[t]][γ]][[1]];
   solγ[k] = Fold[ReplaceAll, sol[k] /. γ -> 0, 
               Table[solγ[j], {j, k - 1, 0, -1}]] // Simplify, 
   {k, 2, o}]

Here are the first few terms of the resulting power series for τ. Because now all quantities depend only on the unretarded time t, we suppress all time dependencies for brevity.

τ𝒮 = Sum[γ^k/k! solγ[k][[1, 2]], {k, 0, o}] + O[γ]^(o + 1) /. x_[t] :> x

Having a series expansion for τ, we can easily calculate series expansions for 𝕣(τ), 𝕧(τ), and r(τ).

r𝒮 = (t - τ𝒮)/γ;
{𝕣𝒮, 𝕧𝒮} = {𝕣[τ𝒮], 𝕧[τ𝒮]} + O[γ]^(o + 1) /. x_[t] :> x // Simplify;
(* show first two terms *) {𝕣𝒮, 𝕧𝒮} + O[γ]^3

So we finally arrive at the following first terms for in γ=1/c. The 0th order term is just the Newtonian distance; a first order term is absent. The higher order terms are relatively complicated expressions, involving scalar products between the various vectors.

φ𝒮 = 1/(r𝒮 - γ 𝕣𝒮.𝕧𝒮) // Simplify

For the non-Abelian case, see [1399✶].

er := {Cos[φ] Sin[ϑ], Sin[φ] Sin[ϑ], Cos[ϑ]}
eφ := {-Sin[φ], Cos[φ], 0}
eϑ := {Cos[φ] Cos[ϑ], Sin[φ] Cos[ϑ], -Sin[ϑ]}

The function makeMaxwellEquations constructs the above given ansatz (with the coefficients c[𝕒, ir, irc, irs, irse, jϑc, jϑs, jϑse])for given field components, and plugs the ansatz into the four Maxwell equations [639✶]. We use some vector analysis functions for spherical coordinates from the package Calculus`VectorAnalysis`.

Needs["Calculus`VectorAnalysis`"]

makeMaxwellEquations[ℰℬComponents_, o_] := 
Module[{ℰA, ℬA},
 (* the ansatz; ℰℬComponentsAnsatz is globally visible *)
 ℰℬComponentsAnsatz = 
 Sum[c[#, ir, irc, irs, irse, jϑc, jϑs, jϑse] r^ir*
  Cos[irc r] If[irs === irse === 0, 0, Sin[irs r]^irse]*
  Cos[jϑc ϑ] If[jϑs === jϑse === 0, 0, Sin[jϑs ϑ]^jϑse], 
    {ir, -3, -1}, {irc, 0, 1}, {irs, 0, 1}, {irse, 0, 1},
    {jϑc, 0, o}, {jϑs, 0, o}, {jϑse, 0, 1}]& /@ ℰℬComponents;
 (* field definitions *)
 {ℰA, ℬA} = {#[[1]] Sin[t], #[[2]] Cos[t]}& @ Partition[
 If[# === {}, 0, ℰℬComponentsAnsatz[[#[[1, 1]]]]]&[
    Position[ℰℬComponents, #]]& /@ {ℰr, ℰϑ, ℰφ, ℬr, ℬϑ, ℬφ}, 3];
 (* use ansatz in Maxwell equations *)
 {Div[ℰA, Spherical[r, ϑ, φ]],
  Sin[ϑ] Div[ℬA, Spherical[r, ϑ, φ]],
  Sin[ϑ] (Curl[ℰA, Spherical[r, ϑ, φ]] + D[ℬA, t]),
  Sin[ϑ] (Curl[ℬA, Spherical[r, ϑ, φ]] - D[ℰA, t])}]

makeMaxwellEquations returns a list of four (possibly quite large) unsimplified Poisson polynomials. To obtain a linear system of equations for the coefficients c[…], we write all trigonometric functions in exponential form and extract their coefficients. extractCoefficients takes the result of makeMaxwellEquations as its argument and returns a list with two elements—a list of rules for the coefficients that are obviously zero and a list of the nontrivial equations.

extractCoefficients[mwes_] := 
 (* trivial and nontrivial equations in the c[...] *)
 {zeroCoefficientsRules[#], nontrivialRelations[#]}&[
 (* write equations in canonical form  *)  
   Join @@ (makecEquations /@ Expand[Map[TrigToExp, 
     Cases[Expand[#], _Plus, {0, Infinity}], {2}]])]& /@ mwes;
     
(* separate Poisson monomial and coefficient *)
monomialsAndCoefficients[expr_] := 
With[{𝓂 = Times @@ DeleteCases[List @@ expr, _c | _?NumericQ, 
                    {1}]}, {𝓂, expr/𝓂}]

(* collect with respect to Poisson monomials *)
makecEquations[p_] := If[Head[p] =!= Plus, 0, 
 Plus @@@ Map[Last, Split[Sort[monomialsAndCoefficients /@ 
                    (List @@ p)], #1[[1]] == #2[[1]]&], {2}]]
      
(* make rules . -> 0 for coefficients that do not appear in sums *)
zeroCoefficientsRules[l_] := 
With[{h = Cases[l, _?(Head[#] =!= Plus&)]},
     (# -> 0)& /@ Union[(h/(h /. _c -> 1))]]
     
(* extract equations that contain only a single coefficient *)
nontrivialRelations[l_] := Cases[l, _?(Head[#] === Plus&)]

Next, we have to solve the linear system of equations that we obtained from the second argument of extractCoefficients. The function solveCoefficientEquations does this. It returns the solutions plugged into the ansatz ℰℬComponentsAnsatz.

solveCoefficientEquations[ceqs_] :=
Module[{dpr, allEqs, allVars, sol},
       (* use trivial zeros of the c[...] *)
       dpr = Dispatch[Join @@ (First /@ ceqs)];
       (* all equations *)
       allEqs = Flatten[(Last /@ ceqs) //. dpr];
       (* all variables c[...] *)
       allVars = Union[Cases[allEqs, _c, Infinity]];
       (* print number of equations and variables *)
       Print[Length[allEqs], " equations in ", 
             Length[allVars], " variables."];
       (* solve linear system of the c[...] *)
       sol = Solve[Take[allEqs, All] == 0, allVars];
       (* substitute solution into ansatz *)
       ℰℬComponentsAnsatz //. dpr //. sol[[1]]]

The solutions we obtain at this point might be not realizable due to diverging field values at the origin. makeFiniteValueAtOrigin avoids divergent terms by making a series expansion around r=0 and guaranteeing divergent terms to vanish. We start with o=2 and, if needed, will use larger values of o later.

makeFiniteValueAtOrigin[ℰℬComponentsR_] := 
Module[{zeroEqs, zeroCs, solFinite},
If[ℰℬComponentsR =!= {0, 0, 0}, 
   (* series terms of the fields ~ r^-n *)
   zeroEqs = makecEquations /@ 
   Flatten[ExpandAll[TrigToExp[finiteOriginValue /@ 
            ℰℬComponentsR]]];
   zeroCs = Union[Cases[zeroEqs, _c, Infinity]];
   (* solve equations for the c[...] *)
   solFinite = Solve[zeroEqs == 0, zeroCs];
    (* resulting field components; finite at the origin *)
   ℰℬComponentsR //. solFinite[[1]]] // Simplify]

(* series terms that must vanish *)
finiteOriginValue[expr_] := 
 With[{ser = Series[expr, {r, 0, 0}]}, 
      If[(* expr is a constant *) Head[ser] =!= SeriesData, {},
         Table[SeriesCoefficient[ser, k], {k, ser[[4]], -1}]]]

Finally, the function ℰℬResult forms the resulting time-dependent vectors of the ℰ(r) and ℬ(r) fields in spherical coordinates.

ℰℬResult[fieldComponents_, ℰℬres_] :=
   Function[r, (* substitute subscripted c’s for c[...] *)
     r //. Table[#[[k]] -> Subscript[c, k], 
       {k, Length[#]}]&[Union[Cases[r, _c, Infinity]]]][
(* add time dependence *)
{Sin[t] #[[1]], Cos[t] #[[2]]}& @ (* make ℰ and ℬ field *)
  ((If[MemberQ[fieldComponents, #], ℰℬres[[
      Position[fieldComponents, #][[1, 1]]]], 0]& /@ #)& /@
             {{ℰr, ℰϑ, ℰφ}, {ℬr, ℬϑ, ℬφ}})]

Now, we will search for nontrivial solutions for the six possible component assignments that guarantee ℰ(r).ℬ(r)=0. As a side effect, we print the number linear equations and the number of variables.

(* turn off message telling that not all coefficients can be 
   uniquely determined *)
Off[Solve::svars]

Function[fieldComponents, 
 (* use ansatz in Maxwell equations *)
 mwes = makeMaxwellEquations[fieldComponents, 2];
 (* form linear equations for the coefficients *)
 ceqs = extractCoefficients[mwes];
 (* solve equations and form fields *)
 ℰℬComponentsR = solveCoefficientEquations[ceqs];
 (* make finite field values at origin *)
 ℰℬres = makeFiniteValueAtOrigin[ℰℬComponentsR] // 
                            TrigReduce // Simplify;
 (* the resulting field components *)
 {ℰ, ℬ} = ℰℬResult[fieldComponents, ℰℬres]] /@ 
    (* the six field component assignments *)
    {{ℰr, ℬϑ, ℬφ}, {ℰϑ, ℬr, ℬφ}, {ℰφ, ℬr, ℬϑ},
     {ℰr, ℰϑ, ℬφ}, {ℰr, ℰφ, ℬϑ}, {ℰϑ, ℰφ, ℬr}}

We indeed found two nontrivial “spherical”, standing wave-like solutions of the homogeneous Maxwell equations. Here is a quick check.

(With[{cs = Spherical[r, ϑ, φ], ℰ = #[[1]], ℬ = #[[2]]},
{Div[ℰ, cs], Div[ℬ, cs], 
 Curl[ℰ, cs] + D[ℬ, t], Curl[ℬ, cs] - D[ℰ, t]} // 
            TrigToExp // ExpandAll // Together]& /@ %) // Union

For visualizations of the first of these fields, and potential applications for ball lightnings, see [333✶]. The second solution is the dual solution to the first.

Now, we want to solve the equations of motions of a test particle in one of these fields. The equations of motion of a test particle are m (Overscript[r, ..])(t)=e (ℰ(r(t))+ (Overscript[r, ..])(t)×ℬ(r(t))).

(* the time\[Hyphen]dependent field components *)
{ℰφt, ℬrt, ℬϑt} = 
 {Sin[ϑ] (Sin[r] - r Cos[r]) Sin[t]/r^2, 
  2 Cos[t] Cos[ϑ] (Sin[r] - r Cos[r])/r^3, 
  -Cos[t] Sin[ϑ](r Cos[r] + (r^2 - 1) Sin[r])/r^3} /.
                        {r -> r[t], φ -> φ[t], ϑ -> ϑ[t]};
(* the time\[Hyphen]dependent unit vectors *)
{ert, eϑt, eφt} = {er, eϑ, eφ} /. {r -> r[t], φ -> φ[t], ϑ -> ϑ[t]};                    
                        
(* equations of motion *)
eqsNewton[α_] = D[r[t] ert, t, t] == ℰφt eφt -
                Cross[D[r[t] ert, t], ℬrt ert + ℬϑt eϑt];

Here are some trajectories for selected initial conditions.

nsol[α_, {r0_, ϑ0_, φ0_}, T_] := 
NDSolve[Join[Thread[eqsNewton[α]], 
             {r[0] == r0, ϑ[0] == ϑ0, φ[0] == φ0},
             {r'[0] == 0, ϑ'[0] == 0, φ'[0] == 0}],
        {r, ϑ, φ}, {t, 0, T}, MaxSteps -> 10^5,
        MaxStepSize -> 0.1];

Show[GraphicsArray[
Function[{α, inits, T},
 (* solve odes and plot curve *)
 ParametricPlot3D[Evaluate[
  {r[t] Cos[φ[t]] Sin[ϑ[t]], r[t] Sin[φ[t]] Sin[ϑ[t]], 
   r[t] Cos[ϑ[t]], {Thickness[0.002], Hue[0]}} /. 
  nsol[α, inits, T]], {t, 0, T}, PlotPoints -> 4 T,
   PlotRange -> All, BoxRatios -> {1, 1, 1},
   DisplayFunction -> Identity, Axes -> False]] @@@
   (* some parameter  sets *)
   {{-0.509325, {6.558630, 3.133570, 2.263920},  200},
    { 1.000000, {9.736281, 1.447010, 4.663740}, 4000},
    { 1.903598, {3.668112, 1.193021, 1.937031}, 2000}}]]

Normal[Series[n!, {n, Infinity, 5}]]

We separate the purely Laurent part ser of the series for the first 150 series terms.

fac[n_] = Exp[-n] n^(n + 1) Sqrt[Pi/2] Sqrt[n];

ser[n_] = Sort[List @@ PowerExpand[Expand[
                1/fac[n] Normal[Series[n!, {n, Infinity, 150}]]]],
               (* increasing negative powers of n *)
               Exponent[#1, n] > Exponent[#2, n]&];

Here is a graphics of the zeros of the first 50 partial sums.

Show[Graphics[Table[{Hue[k/50], Point[{Re[#], Im[#]}]& /@ 
  (n /. NSolve[(Plus @@ Take[ser[n], k]) == 0, n])}, {k, 2, 40}]],
  PlotRange -> All, Frame -> True, AspectRatio -> Automatic]

The function pos gives the number of terms and the difference to the exact value of n! for a given n.

pos[n_] := 
Module[{data = fac[N[n, 250]] FoldList[Plus, 0, ser[N[n, 500]]] - n!, p},
       (* where is the difference minimal? *)
       p = Position[Abs[data], Min[Abs[data]]][[1, 1]];
       {n, p, N @ data[[p]]}]

Here, the number of terms and the differences to the exact result for the first 150 factorials are calculated.

data = Table[pos[k], {k, 150}];

The next graphic shows how the relative precision of the approximation is increasing, the absolute difference has a minimum and the position of the smallest element is increasing.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
      {(* absolute difference *)
       ListPlot[{#1, Log[10, Abs[#3]]}& @@@ data], 
       (* relative difference *)
       ListPlot[{#1, Log[10, Abs[#3]/#1!]}& @@@ data],
       (* position of smallest term *)
       ListPlot[{#1, #2}& @@@ data]}]]]

Here is the convergence to a complex value of n shown. After approaching and encircling the exact value, including further terms of the formally divergent series results in a divergent path of the partial sums.

Show[Graphics[
{{Hue[0], PointSize[0.03], 
  Point[{Re[N[(5 + I)!]], Im[N[(5 + I)!]]}]}, 
 {Thickness[0.002], GrayLevel[0], 
  Line[{Re[#], Im[#]}& /@  N[N[fac[5 + I]*
             FoldList[Plus, 0, ser[5 + I]], 250]]]}}], 
  Frame -> True, PlotRange -> 
  (* appropriate rectangle around the exact value (5 + I)! *)
    {{-15.38094275, -15.38094276}, {108.56846148, 108.5684615}}]

Series[n!, {n, Infinity, 4}]

Both have the same prefactors (Sqrt[π])(((n/e))^n). Equating the remaining terms yields the following form for R(n).

sol = Solve[(8 n^3 + 4 n^2 + n + 1/30 + R)^(1/6) == S, R]

Taking now 110 series terms of the classical expansion allows us to calculate 100 of the (Subscript[c, k]).

Off[Series::esss];
facSer = Series[n!, {n, Infinity, 110}]/(Sqrt[Pi] (n/E)^n);
rSer = sol[[1, 1, 2]] /. S -> facSer;

terms[n_] = Reverse[List @@ Normal[rSer]];

Here are the first few terms of the resulting series.

RamanujanFactorialSeries[x_, o_] := 
Sqrt[Pi] (x/E)^x (8 x^3 + 4 x^2 + x + 1/30 + (Plus @@ Take[terms[x], o]))^(1/6)

RamanujanFactorialSeries[n, 6]

The following two graphics show the logarithm of the relative error as a function of the number of terms for n=10 and n=100. The left graphic clearly shows that the series is asymptotic (as is the original series for n!).

$MaxExtraPrecision = 1000;
Show[GraphicsArray[Function[ν, 
ListPlot[Table[{k, Log[10, 
                Abs[(1 - RamanujanFactorialSeries[ν, k]/ν!) // N[#, 22]&]]},
         {k, 100}], DisplayFunction -> Identity]] /@ {10, 100}]]

From the right graphic we infer that we need 68 terms to obtain 100 correct digits of 100!.

With[{ν = 100},
     (1 - RamanujanFactorialSeries[ν, 68]/ν!) // N[#, 22]&]

For a closed form for the (Subscript[c, k]), see [895✶]. 
The interested reader could now go on and find similar expansion of the form

n!=(Sqrt[π])((((n/e)))^n)((((2^o) (n^o)+((∑_(k=0)^(o-1))(Subscript[c, k])(n^k))+R(n)))^(1/(2o))).

ser = 1 + ck q^8 + O[q]^9

ser (1 - q^8)^αk

The function factorOut𝕢Product implements the calculation of (((1-(q^k)))^(Subscript[α, k])).

factorOut𝕢Product[HoldPattern[SeriesData[q_, 0, 
   {1, zeros:(0 ...), c_?(# =!= 0&), ___}, 0, n_, 1]]] := 
                   (1 - q^(Length[{zeros}] + 1))^c

factorOut𝕢Product[HoldPattern[SeriesData[q_, 0, {1}, 0, n_, 1]]] := 1

After factoring out a product (((1-(q^k)))^(Subscript[α, k])) we multiply the series with this product and continue the process. For the example series Σ this is done in the following inputs.

Σ = 1 + q + q^2 + q^3 + 2 q^4 + 2 q^5 + 3 q^6 + O[q]^7

factorOut𝕢Product[Σ]

Σ = Σ %

factorOut𝕢Product[Σ]

Σ = Σ %

factorOut𝕢Product[Σ]

Σ = Σ %

We automate the repeated factor extraction and series calculation in the function to𝕢Product.

to𝕢Product[s_] := 1/FixedPoint[Function[x,
     {First[x] #, Last[x] #}&[factorOut𝕢Product[First[x]]]], 
    {s, 1}, 20, SameTest -> (First[#1] === First[#2]&)][[2]]

A random q-series shows to𝕢Product at work.

SeedRandom[111];
random𝕢Series[q_, degree_, maxCoeff_] := 
1 + Sum[Random[Integer, maxCoeff{-1, 1}] q^k, {k, degree}] + 
                                              O[q]^(degree + 1);
Σ = random𝕢Series[q, 8, 8]

to𝕢Product[Σ]

Σ - %

Now it is straightforward to unite the two functions factorOut𝕢Product and to𝕢Product in one function 𝕢SeriesTo𝕢Product.

𝕢SeriesTo𝕢Product[qs:qSeries_SeriesData] := 
With[{𝓆 = First[qSeries], ℋ = HoldPattern, 𝒮 = SeriesData},
     FixedPoint[Function[x, {First[x] Series[#, {qs[[1]], 0, qs[[5]]}], 
                             Last[x] #}&[First[x] /. 
        {ℋ[𝒮[q_, 0, {1, ξ:(0 ...), c_?(# != 0&), ___}, 0, n_, 1]] :>
                                          (1 - 𝓆^(Length[{ξ}] + 1))^c,
     ℋ[𝒮[q_, 0, {1}, 0, n_, 1]] :> 1}]], {qSeries, 1}, 
               SameTest -> (First[#1] === First[#2]&)][[2]]^-1 /;
              MatchQ[qSeries, ℋ[𝒮[_, 0, {1, _Integer ...}, 0, _, 1]]]]

Here are six examples of q-series and the corresponding q-products together with a quick check of their correctness.

Table[{#, 𝕢SeriesTo𝕢Product[#]}&[random𝕢Series[q, 12, 10]], {6}]

Subtract @@@ %

Here are three well known series.

𝕢SeriesTo𝕢Product[Sum[q^k, {k, 0, 20}] + O[q]^21]

𝕢SeriesTo𝕢Product[Sum[(k + 1) q^k, {k, 0, 20}] + O[q]^21]

𝕢SeriesTo𝕢Product[Sum[(-1)^k q^((6k + 1)^2), {k, -360, 360}]/q + O[q]^361]

Here are two very nice products using the function PartitionsP and PartitionsQ from Chapter 2 of the Numerics volume [1561✶] of the GuideBooks.

Sum[PartitionsP[k] q^k, {k, 0, 20}] + O[q]^21

𝕢SeriesTo𝕢Product[%]

Sum[PartitionsQ[k] q^k, {k, 0, 20}] + O[q]^21

𝕢SeriesTo𝕢Product[%]

The next inputs recover the product (∏_(k=2)^n)(1-(q^(Subscript[F, k]))) [1347✶].

Product[(1 - q^Fibonacci[k]), {k, 2, 30}] + O[q]^31

𝕢SeriesTo𝕢Product[%]

For many more q-series that have nice q-product forms, see [369✶], [1731✶].

qBinomialPolynomial[n_, k_, q_] :=
   Product[1 - q^j, {j, n - k + 1, n}]/Product[1 - q^j, {j, 1, k}]

qBinomialPolynomial[150, 60, q] // Cancel // Factor // Length // Timing

We observe that we must repeatedly factor terms of the form 1-(q^j). We will do this once, abbreviate the factors, and remember the factors.

o = 250;
factoredqPolys = Table[-Factor[1 - q^k], {k, 2, o}];

(* all single factors; ordered by degree *)
allFactors = Sort[Union[Flatten[List @@@ factoredqPolys]],
                  (Exponent[#1, q] <= Exponent[#2, q]&)];

(* replace factors by variables *)
rules = MapIndexed[(#1 -> C[#2[[1]] + 1])&, allFactors] // Reverse;

(* simplified form of factored form of 1 - q^j *)
ℱ[1] = C[2];
MapIndexed[(ℱ[#2[[1]] + 1] = (#1 /. rules))&, factoredqPolys, {1}];

Using the symbolic factors ℱ[j], the number of factors of the q-binomial coefficients can now be calculated hundreds of times faster.

qBL[n_, k_] := If[k > n, 0, Length[
 Product[ℱ[j], {j, n - k + 1, n}]/Product[ℱ[j], {j, 1, k}]]]

qBL[150, 60] // Timing

The following graphic shows the number of factors as a function of k and n.

tab = Table[Table[qBL[n, k], {k, o}], {n, o}];

ListPlot3D[tab, Mesh -> False]

For interesting identities of the q-binomial coefficients, see [608✶].

ΠSeries[k_, o_] := ΠSeries[k, o] = 
         Series[Product[1 - q^(j k), {j, Ceiling[o/k] + 1}], {q, 0, o}]

Now let us implement a function multiplicativeIdentities which generates all identities that must be satisfied by the coefficients (Subscript[c, k]) for k≤n.

multiplicativeIdentities[c_, n_] := multiplicativeIdentities[c, n] = 
And @@ ((c[#1] c[#2] == c[#1 #2])& @@@ 
    Select[Union[Sort /@ (* pairs of divisors *)
    Flatten[Function[k, {#, k/#}& /@ Divisors[k]] /@ Range[2, n], 1]],
    (FreeQ[#, 1] && (GCD @@ #) === 1)&])

Here are all 15 identities that the coefficients up to (Subscript[c, 30]) must fulfill.

multiplicativeIdentities[c, 30]

The first 1000 of the (Subscript[c, 30]) must fulfill 1494 relations.

multiplicativeIdentities[c, 1000] // Length

The function multiplicativeSeriesQ checks if a given ser is a multiplicative series.

multiplicativeSeriesQ[ser_SeriesData] := 
With[{cl = Rest[CoefficientList[ser, ser[[1]]]]},
     multiplicativeIdentities[c, Length[cl]] /. c[j_] :> cl[[j]]]

q(∏_(k=1)^∞)(((1-(q^( k))))^24) is a well-known multiplicative series.

multiplicativeSeriesQ[q ΠSeries[24, 20]]

Now we have all functions that create and analyze a series. Next we must create the factors of the products. The function divisorGroups generates a list of all pairs of lists of divisors of the integer n. The two pairs of numbers will be used as the (Subscript[α, j]) and (Subscript[β, j]) in the numerator and denominator powers of q.

divisorGroups[n_] := 
Module[{d = Divisors[n], λ}, λ = Length[d];
      Select[Union[{Sort[#], Sort[Complement[d, #]]}& /@ Level[
      (* table of all possible divisors *)
      Table[Table[If[α[k] === 0, Sequence @@ {}, d[[k]]], {k, λ}],
      Evaluate[Sequence @@ Table[{α[k], 0, 1}, {k, λ}]]], {-2}]],
      FreeQ[#, {}]&]]

Here are the 14 possibilities to split the divisors of 15.

divisorGroups[15]

The number of such pairs is a highly fluctuating, but in average increasing function of n.

ListPlot[Table[{k, Log[10, 1 + Length[divisorGroups[k]]]}, {k, 100}],
         PlotRange -> All, Frame -> True]

Given the (Subscript[α, j])s (or (Subscript[β, j])s) and an integer s, the function ΠProducts generates all products (∏_(j=1)^m)(Subscript[Π, (Subscript[α, j])]^(Subscript[μ, j])) where (Subscript[Π, (Subscript[α, j])])=(∏_(k=1)^∞)(1-(q^((Subscript[α, j])k))) and the (Subscript[μ, j]) fulfill the following sum condition: (∑_(j=1)^𝓂)(Subscript[α, j])(Subscript[μ, j])=s.

ΠProducts[divs_, s_] := 
Module[{𝒹 = Reverse[Sort[divs]], 𝓉1},
 (* table of all divisors; exclude smallest *)
 𝓉1 = Table[Evaluate[Table[{𝒹[[k]], α[k]}, {k, Length[𝒹] - 1}]],
 Evaluate[Sequence @@ Table[{α[k], 0, Floor[(s - Sum[α[j] 𝒹[[j]], 
          {j, 1, k - 1}])/𝒹[[k]]]}, {k, Length[𝒹] - 1}]]];
 (* append smallest divisor *)
 𝓉2 = Append[#, {𝒹[[-1]], (s - (Plus @@ (Times @@@ #)))/𝒹[[-1]]}]& /@ 
                       Flatten[𝓉1, Max[{0, Length[𝒹] - 2}]];
 Times @@@ Apply[Subscript[Π, #1]^#2&, (* select integer pairs *)
 Select[DeleteCases[𝓉2, {_, 0}, Infinity], 
                           FreeQ[#, _Rational, Infinity]&], {2}]]
                           
ΠProducts[{}, s_] := {}

ΠProducts[{d_}, s_] := If[IntegerQ[s/d], {Subscript[Π, d]^(s/d)}, {}]

Here is an example.

ΠProducts[{2, 3, 6}, 18]

For a given list of the (Subscript[α, k]) and (Subscript[β, k]) and a given s, forming now all possible combinations of potential numerators and denominators gives all possible quotients. The function ΠQuotients forms these quotients.

ΠQuotients[{n_List, d_List}, s_, maxTerms_:Infinity] := 
With[{nums = ΠProducts[n, s], dens = ΠProducts[d, s]},
      If[Length[nums] Length[dens] > maxTerms, {}, 
         Flatten[Outer[Divide, ΠProducts[n, s], ΠProducts[d, s]]]]]

Finally, the function allΠQuotients generates all quotients for a given n and a given s.

allΠQuotients[n_, s_, maxTerms_:Infinity] := 
 Union[Flatten[ΠQuotients[#, s, maxTerms]& /@ divisorGroups[n]]]

Here is an explicit example. For n=s=8 we get 34 possible fractions.

allΠQuotients[8, 8]

Now we have everything together to check the 35312 possible series for mutiplicativeness. We do a quick check for 20 series terms and if this test succeeds, we test with 200 terms.

o1 = 20; o2 = 100; bag = {};

counter = 0;
Do[(* all quotients for given n and s *) 
   quots = allΠQuotients[n, s, Infinity];
   (* cumulative number of quotients checked *)
   counter = counter + Length[quots];
   (* newly found multiplicative series *)
   sel = Select[quots, multiplicativeSeriesQ[# /. 
                       Subscript[Π, x_] :> ΠSeries[x, o1]]&];
   If[sel =!= {}, 
      (* keep newly found multiplicative series *)
      sel1 = Select[sel, multiplicativeSeriesQ[# /. 
                           Subscript[Π, x_] :> ΠSeries[x, o2]]&];
      If[sel1 =!= {}, bag = Union[Join[bag, sel1]]]], 
   {n, 2, 24}, {s, n, 24}]

Seven multiplicative series were found.

{counter, Length[bag]}

A check with 800 series terms confirms that these seven series are all multiplicative.

multiplicativeSeriesQ[# /. Subscript[Π, x_] :> ΠSeries[x, 800]]& /@ bag

Here are these seven quotients and the first terms of their series.

bag

bag /. Subscript[Π, x_] :> ΠSeries[x, 12] // TableForm

GCDFreePartition[primes_?(VectorQ[#, PrimeQ]&), 
                  n_Integer?Positive] := 
Module[{m, r, 𝓈, fp, z, j = 1},
       {m, r} = {Times @@ primes, Length[primes]};
       (* truncated polynomial *)
       𝓈[j_] = Cyclotomic[m, z^j]^((-1)^(r - 1)) + O[z]^(n + 1);
       (* multiply as long as needed *)
       fp = FixedPoint[(j++; 𝓈[j] #)&, 𝓈[j]];
       (* extract coefficient *)
       SeriesCoefficient[fp, n]]

For (Subscript[P, 2,3,5,7,11])(111) the function GCDFreePartition yields the answer 1036.

n = 111; primes = {2, 3, 5, 7, 11};
GCDFreePartition[primes, n]

Now we will calculate the partitions explicitly using the function GCDFreePartitions. We first select the possible (Subscript[m, j]) and then recursively subtract them form the initial integer n. The result is a list of lists, each sublist being of the form {{(Subscript[m, 1]),(Subscript[ρ, 1])},…,{(Subscript[m, j]),(Subscript[ρ, j])}} where all the (Subscript[m, l]) are now different and (Subscript[ρ, l]) represents the number of times (Subscript[m, l]) appears in the partition.

GCDFreePartitions[primes_?(VectorQ[#, PrimeQ]&), 
                  n_Integer?Positive] := 
Module[{m = Times @@ primes, pps, l, aux},
       (* possible m's *)
       pps = Select[Reverse @ Range[n], GCD[#, m] === 1&];     
       l = Length[pps];         
       aux = Select[DeleteCases[Level[
         (* recursively subtract m's from n *)
         Table[(* occurrences of the m's *)
               Evaluate[Table[j[i], {i, l}]],
               (* iterators *)
               Evaluate[Sequence @@ 
                Table[{j[i], 0, (n - Sum[pps[[k]] j[k], 
                       {k, 1, i - 1}])/pps[[i]]}, {i, l}]]],
                {-2}], {}], (pps.# === n)&];
       (* delete nonappearing m's *)
       DeleteCases[#, {_, 0}, {2}]& @ (Reverse /@ 
        MapIndexed[{pps[[#2[[2]]]], #1}&, aux, {2}])]

For (Subscript[P, 2,3,5,7,11])(111), the function GCDFreePartitions yields 1036 different partitions.

gcffp111 = GCDFreePartitions[primes, n];

{Length[gcffp111], Length[Union[gcffp111]],
 Union[Apply[Plus, Apply[Times, gcffp111, {2}], {1}]]}

Here are the first and the last few calculated partitions.

Short[gcffp111, 6]

eq1 = x''[t]^2 (x[t]^2 + y[t]^2) - x[t]^2

We use the second differential equation of the original problem (the one for the y-component) to eliminate y''(t) in the calculations below.

yEq = y''[t]^2 (x[t]^2 + y[t]^2) - y[t]^2;

Differentiating the first equation two times yields a differential equation which contains y''(t) and x'''(t) and (x^((4)))(t).

eq2 = D[eq1, t]

eq3 = D[eq2, t]

Now we have four equations (eq1, eq2, eq3, and yEq), so that we can eliminate y(t) , y'(t), and y''(t) to get one nonlinear differential equation of order 4 for x(t). This differential equation factors into three factors.

GroebnerBasis[{eq1, eq2, eq3, yEq},
              {x[t], x'[t], x''[t], x'''[t], x''''[t]}, {y[t], y'[t], y''[t]},
              MonomialOrder -> EliminationOrder] // Factor

For the elimination of the time variable t, see [900✶], [915✶], [354✶].

eqs = {x'[t] - a y[t] z[t], y'[t] - b x[t] z[t], z'[t] - c x[t] y[t]}

We differentiate these three equations two times with respect to t and introduce some new variables.

gl1 = Flatten[{eqs, D[eqs, t], D[eqs, t, t]}] /.
   {x[t] -> x,  x'[t] -> x1,  x''[t] -> x2,  x'''[t] -> x3,
    y[t] -> y,  y'[t] -> y1,  y''[t] -> y2,  y'''[t] -> y3,
    z[t] -> z,  z'[t] -> z1,  z''[t] -> z2,  z'''[t] -> z3}

Now we have nine equations and we want to eliminate eight variables y, y1, y2, y3, z, z1, z2, and z3. Because y1 and z1 appear linear, it is straightforward to eliminate them.

gl2 = Delete[gl1, {{2}, {3}}] /. {y1 -> b x z, z1 -> c x y}

z3 also appears linearly; so we can eliminate it.

Exponent[#, {y, y2, y3, z, z2, z3}]& /@ gl2

sol = Solve[gl2[[-1]] == 0, z3][[1]]

gl3 = Drop[gl2, -1] /. sol

The same we do for y3.

Exponent[#, {y, y2, y3, z, z2}]& /@ gl3

sol = Solve[gl3[[-1]] == 0, y3][[1]]

gl4 = Drop[gl3, -1] /. sol

The same we do for z2.

Exponent[#, {y, y2, z, z2}]& /@ gl4

sol = Solve[gl4[[-1]] == 0, z2][[1]]

gl5 = Numerator[Together[#]]& /@ (Drop[gl4, -1] /. sol)

The same we do for z.

Exponent[#, {y, y2, z}]& /@ gl5

sol = Solve[gl5[[-1]] == 0, z][[1]]

gl6 = Numerator[Together[#]]& /@ (Drop[gl5, -1] /. sol)

The same we do for y2.

Exponent[#, {y, y2}]& /@ gl6

sol = Solve[gl6[[1]] == 0, y2][[1]]

gl7 = Numerator[Together[#]]& /@ (Drop[gl6, 1] /. sol)

Let us factor the two remaining equations.

gl7a = Factor[gl7]

Eliminating y from the nonequal factors, we arrive at the following equation for x(t).

Factor[Resultant[gl7a[[1, -1]], gl7a[[2, -1]], y]& @@ gl7] /.
{x -> x[t], x1 -> x'[t], x2 -> x''[t], x3 -> x'''[t]}

u = α Exp[β/Sqrt[z - z0]]

We start by explicitly calculating the first three derivatives of u(x). up[i] is the ith derivative of u(x).

eqs1 = Numerator[Together[Table[up[i] - D[u, {z, i}], {i, 3}]]]

The parameter α and the exponential function are easily eliminated by introducing the original function u(x).

eqs2 = eqs1 /. Exp[β/Sqrt[z - z0]] -> up[0]/α

Because we are looking for a polynomial differential equation, we eliminate the square roots (Sqrt[z-(Subscript[z, 0])]) by squaring the equations.

eliminateSquareRoot[expr_Plus] := Expand[#^2 - (expr - #)^2]&[
                    Select[expr, MemberQ[#1, Sqrt[z - z0]] & ]]

Factoring eqs2, we see one unwanted factor: z-(Subscript[z, 0]).

(eqs3 = Factor[eliminateSquareRoot /@ eqs2]) // Short[#, 4]&

After eliminating this factor, we arrive at the following three polynomial equations.

(eqs4 = MapAt[Rest, eqs3, 2]) // Short[#, 4]&

We now try to eliminate the variables z, (Subscript[z, 0]), and β.

GroebnerBasis[eqs4, {up[0], up[1], up[2], up[3]}, 
              {β, z, z0}, MonomialOrder -> EliminationOrder]

Unfortunately, the last try did not work. It is not to unexpected since we tried to eliminate three parameters from three equations. So let us be less ambitious and only eliminate two variables. We try all three possibilities.

GroebnerBasis[eqs4, {up[0], up[1], up[2], up[3]}, 
              {β, z}, MonomialOrder -> EliminationOrder]

GroebnerBasis[eqs4, {up[0], up[1], up[2], up[3]}, 
              {β, z0}, MonomialOrder -> EliminationOrder]

gb = GroebnerBasis[eqs4, {up[0], up[1], up[2], up[3]}, 
                   {z, z0 }, MonomialOrder -> EliminationOrder];

The last Gröbner basis is a pretty large one.

{ByteCount[gb], LeafCount[gb]}

We select all nontrivial expressions (no single factors like up[0] are of interest for us).

candidates = Union[Cases[Factor[gb], _Plus, Infinity]];

We have 50 such terms.

Length[candidates]

Fortunately, among the 50 candidates, we find some that do not even contain β.

Select[candidates, FreeQ[#, β]&]

And among the last four differential equations, we find one such that the original function is a solution.

Select[%, (Together[# /. up[i_] :> D[u, {z, i}]] === 0)&]

So the differential equation we were looking for is:

((u'(x))^4)+u(x) ((u'(x))^2)u''(x)-5((u(x))^2)((u''(x))^2)+3((u(x))^2)u'(x)u'''(x)=0.

Here is a quick final check.

Together[χ'[x]^4 + χ[x] χ'[x]^2 χ''[x] - 5 χ[x]^2 χ''[x]^2 + 
         3 χ[x]^2 χ'[x] χ'''[x] /. 
                     χ -> Function[x, α Exp[β/Sqrt[x - x0]]]]

For algorithms to derive minimal differential equations from algebraic and differential equations, see [1322✶].

eqs = {w1'[z] - (w1[z] (w2[z] + w3[z]) - w2[z] w3[z]),
       w2'[z] - (w2[z] (w1[z] + w3[z]) - w1[z] w3[z]),
       w3'[z] - (w3[z] (w1[z] + w2[z]) - w1[z] w2[z]),
       W[z] - 2 (w1[z] + w2[z] + w3[z])};

The function makeOde tries to find a single oth order ordinary differential equation for W(z). It does this by differentiating the Darboux–Halphen system and eliminating (Subscript[w, 1])(z), (Subscript[w, 2])(z), (Subscript[w, 3])(z) and their derivatives.

makeOde[o_] := 
Module[{eqs1, funcs, ws},
  (* the equations *)
  eqs1 = Append[Flatten[Table[D[eqs, {z, k}], {k, 0, o - 1}]],
                D[Last[eqs], {z, o}]];
  (* the functions *)
  funs = Flatten[Table[D[{w1[z], w2[z], w3[z]}, {z, k}], {k, 0, o}]];
  (* the derivatives of W *)
  Ws = Flatten[Table[D[W[z], {z, k}], {k, 0, o}]];
  (* eliminate w1, w2, and w3 *)
  GroebnerBasis[eqs1, Ws, funs, MonomialOrder -> EliminationOrder]]

There are no first or second order differential equations for W(z).

{makeOde[1], makeOde[2]}

But there is a third order nonlinear differential equation for W(z)—the Chazy equation [736✶].

makeOde[3]

makeOde[4] gives again the Chazy equation, its derivative, and an additional fourth order differential equation.

makeOde[4]

f[x_] = Exp[Exp[Exp[Exp[x]]]];
eqs1 = Table[F[i] - D[f[x], {x, i}], {i, 0, 4}] // ExpandAll;

We convert the terms in eqs1 to polynomial form by replacing the n-nested exponential function by en.

eqs2 = eqs1 //. {Exp[Exp[Exp[Exp[x]]] + 
       a_. Exp[Exp[x]] + b_. Exp[x] + c_. x] :> e4 e3^a e2^b e1^c,
       Exp[Exp[Exp[Exp[x]]]] -> e4}

Eliminating e1, e2, and e4is straightforward—these three variables appear linearly.

eqs3 = Rest[eqs2] /. e4 -> F[0];
sol1 = Solve[eqs3[[1]] == 0, e1];
eqs4 = Numerator[Together[Rest[eqs3] /. sol1[[1]]]] // Factor;
sol2 = Solve[eqs4[[1]] == 0, e2];
eqs5 = Numerator[Together[Rest[eqs4] /. sol2[[1]]]] // Factor;
(* ignore multiplicative factors *)
eqs6 = Cases[eqs5, _Plus, Infinity];

Using Resultant we eliminate the remaining variable e3 from the two equations that are left.

res = Cases[Factor[Resultant[##, e3]& @@ eqs6], _Plus, Infinity];

res /.  (* abbreviate result *)
        F[k_] :> Derivative[k][𝒻] // TraditionalForm

Here is a quick check of the result.

res /. F[k_] :> D[f[x], {x, k}] // Expand

We proceed in a similar manner for the function g(x).

g[x_] = x^x;
eqs1 = Table[G[k] - D[g[x], {x, k}], {k, 0, 3}] // ExpandAll

The first three derivatives of g(x) contain ln(x), (x^x), and x. Assuming that these three quantities are linear independent we replace them with the polynomial variables log, xx, and ξ.

eqs2 = eqs1 //. {Log[x] -> log, x^(x + c_) -> xx ξ^c, x^x -> xx}

eqs3 = Numerator[Together[eqs2]];
gb = GroebnerBasis[eqs3, {}, {log, ξ, xx}] // Factor;

gb /. G[k_] :> Derivative[k][ℊ] // TraditionalForm

Here is a quick check of the result.

gb /. G[k_] :> D[g[x], {x, k}] // Expand

(Subscript[G, α])(w) =(1/(π^3))(∑_(k=0)^∞)(1/(w^(k+1)))((∫_0^π)(∫_0^π)(∫_0^π)(((cos((Subscript[ϑ, 1]))+cos((Subscript[ϑ, 2]))+α cos((Subscript[ϑ, 3]))))^k)d(Subscript[ϑ, 1])d(Subscript[ϑ, 2])d(Subscript[ϑ, 3]))

The triple integral over the power of cos((Subscript[ϑ, 1]))+cos((Subscript[ϑ, 2]))+α cos((Subscript[ϑ, 3])) can be conveniently calculated for small k by the multinomial theorem. The terms of the integrands factors and we only need the basic integral

(1/π)(∫_0^π)(cos^n)(ϑ)dϑ=(((1+(((-1))^n)) ((n/2)-(1/2))!)/(n (Sqrt[π]) ((n/2)-1)!)).

ℐ[n, α] calculates the triple integral over (((cos((Subscript[ϑ, 1]))+cos((Subscript[ϑ, 2]))+α cos((Subscript[ϑ, 3])) ))^n).

h[0] = 1;
h[n_] = Integrate[Cos[ϑ]^n, {ϑ, 0, Pi}]/Pi // Simplify;
int[n_] := int[n] = h[n]

ℐ[n_, α_] := ℐ[n, α] = 
Sum[Multinomial[n1, n2, n - n1 - n2]*
      If[n - n1 - n2 >= 0,  
         int[n1] int[n2] α^(n - n1 - n2) int[n - n1 - n2], 0], 
      {n1, 0, n}, {n2, 0, n}]

The integral vanishes for odd n because of symmetry.

{ℐ[7, α], ℐ[8, α]}

(* compare with direct (much slower) calculation *)
Integrate[(Cos[ϑ1] + Cos[ϑ2] + α Cos[ϑ3])^#,
          {ϑ1, 0, Pi}, {ϑ2, 0, Pi}, 
          {ϑ3, 0, Pi}]/Pi^3& /@ {7, 8} // Expand

ℐ[n_?OddQ, α_] := 0

Let us next find the order of the differential equation we are looking for. We start by assuming the following general form of a differential equation.

(∑_(j=0)^o)(((∑_(l=0)^d)(Subscript[c, j,l])(α)(w^l))(((∂^j)(Subscript[G, α])(w) )/(∂(w^j))))=0.

Here the (Subscript[c, j,l])(α) are yet-to-be-determined polynomials in α. We also do not know the values of d and o in the moment. So we will increase the value of the product d×o and for each d×o try all possible realizations for d and o until we find candidates for d and o. For symbolic α, even this is virtually hopeless at this point. To obtain a manageable problem we will a) use a concrete value for α (17 in the following; any other number will do too) and b) only look for modular solutions now. A nontrivial solution for the (Subscript[c, j,l])(α) for a concrete α is necessary (but not sufficient) for a nontrivial solution for general α.  
The following input searches for the first two candidates of d and o.

α𝓅 = 17;
founddoPairs = 0;
dTo = 2;
While[founddoPairs < 2, 
      (* all values for d and o for a given d × o *) 
      doPairs = {#, dTo/#}& /@ Divisors[dTo];
      λ = 1;
   While[λ < Length[doPairs] && founddoPairs < 2,
      {d, o} = doPairs[[λ]]; 
      (* sufficient high order *)
      do = 2 d o + 8;
      (* the series of the function G(w) for concrete α *)
      G = Sum[w^(-k - 1) ℐ[k, α𝓅], {k, 0, do + 4}] // 
                                     Series[#, {w, Infinity, do}]&;
      (* differential equation of series *)
      eq = Sum[Sum[c[j, l] w^l, {l, 0, d}] D[G, {w, j}], {j, 0, o}];
      (* coefficients in w *)
      eqs = DeleteCases[eq[[3]], 0];
      (* all occurring cs *)
      vars = Cases[eqs, _c, Infinity] // Union;
      (* modular solution *)
      sol = Solve[Append[# == 0& /@ eqs, Modulus == Prime[10000]], 
                  vars, Mode -> Modular];
      (* was a nontrivial solution found? *)
      If[Union[Last /@ Rest[sol[[1]]]] =!= {0},
         (* print candidate values for d and o *)
         Print[{d, o}]; founddoPairs++]; λ++]; 
      (* increase d × o *) dTo++]

Let us proceed with the found candidate differential equation of order 4. We have d=9. We now generate the coefficients of w with symbolic α and calculate a full (not only a modular) solution.

d = 9; o = 4; do = 2 d o + 8;
(* the series of the function G(w) for symbolic α *)
G = Sum[w^(-k - 1) ℐ[k, α], {k, 0, do + 4}] // 
                                       Series[#, {w, ∞, do}]&;
eq = Sum[Sum[c[j, l] w^l, {l, 0, d}] D[G, {w, j}], {j, 0, o}];
(* specialize α *)
eqs = DeleteCases[eq[[3]], 0];
(* use "random" prime for α *)
eqsN = Block[{α = 17}, eqs];
vars = Cases[eqsN, _c, Infinity] // Union;
sol = Solve[# == 0& /@ eqsN, vars];

To reduce the complexity of the problem, we eliminate the vanishing (Subscript[c, j,l])(α) .

zerocs = Select[sol[[1]], Last[#] === 0&]

eqsA = DeleteCases[eqs //. zerocs, 0];

38 equations remain.

Length[eqsA]

Now we make an ansatz for the (Subscript[c, j,l])(α) in the form (Subscript[c, j,l])(α) =(∑_(k=0)^e)(Subscript[c, j,l,k])(α^k). We now loop over e to find its smallest possible value for a nontrivial solution.

e = 2;
While[
 (* substitute polynomial in α for the c[i, l] *)
 eqsB = eqsA //. c[j_, l_] :> Sum[c[j, l, k] α^k, {k, 0, e}];
 (* extract c[j, l, k]'s *)
 varsB = Cases[eqsB, _c, Infinity] // Union;
 (* the coefficients of the c[j, l, k]'s *)
 tab = Table[Coefficient[eqsB[[k]], #]& /@ varsB, {k, Length[eqsB]}];
 (* substitute prime values for α *)
 eqsC = Join @@ Table[tab /. α -> Prime[j], 
                      {j, 2, Round[3 Length[varsB]/Length[tab]]}];
 (* calculate modular null space *)
 nsp = NullSpace[eqsC, Modulus -> Prime[10^6]];
 Length[nsp] === 0, (* increase e *) e++];
 e

So, we have e=8. We extract the vanishing (Subscript[c, j,l,k]) and eliminate these (Subscript[c, j,l,k]) in the list of equations eqsB. Now we are left with 38 equations (with symbolic α) in 51variables.

zeroRules = Rule @@@ Cases[Transpose[{varsB, nsp[[1]]}], {_, 0}];
eqsC = eqsB //. zeroRules;
varsC = Cases[eqsC, _c, Infinity] // Union;
{Length[eqsC], Length[varsC]}

Specializing α yields now a set of equations that can be solved exactly.

eqsD = Join @@ Table[eqsC /. α -> Prime[j], {j, 2, 6}];
solD = Solve[# == 0& /@ eqsD, varsC];
Short[solD, 6]

One of the (Subscript[c, j,l,k]) remained undetermined (as it has to be for a linear homogeneous differential equation and the ansatz used).

ucs = Union[Flatten[Cases[Last[#], _c, Infinity]& /@ solD[[1]]]]

Now we collect all results, substitute them in the full ansatz for the differential equation, and simplify the coefficients of the resulting differential equation.

(* substitute results in ansatz *)
ode1 = Sum[Sum[c[j, l] w^l, {l, 0, 9}] D[𝒢[w], {w, j}], {j, 0, 4}] /.
 zerocs /. c[j_, l_] :> Sum[c[j, l, k] α^k, {k, 0, 8}] /.
 zeroRules /. solD /. ucs[[1]] -> 1;

(* simplify coefficients *)
ode2 = Collect[Numerator[Together[ode1]], 
        Table[D[𝒢[w], {w, j}], {j, 0, o}], 
                   Collect[#, w, Factor]&][[1]]

We end with a check of the derived differential equation by calculating the first 100 nonvanishing series terms.

do = 200;
(ode2 /. 𝒢 -> Function[w, 
         Evaluate[Sum[w^(-k - 1) ℐ[k, α], {k, 0, do + 4}]]]) // 
                                   Series[#, {w, Infinity, do}]&

For other approaches to derive this differential equation, see [827✶] and [422✶]. For other complicated integrals that can be calculated through differential equations, see [385✶].

DSolve[Derivative[1 + (Pi + 1)^2 - Pi^2 - 2 Pi][y][x] == x^2, y, x]

ExpandAll[%]

Integrate[Integrate[x^x, x]^3, Integrate[x^x, x]]

Mathematica tries to evaluate the two occurrences of Integrate[x^x, x]. Both integrals remain undone. Then, the Integrate[x^x, x] is viewed as a variable and we have an integral of the form Integrate[y^3, y] which gives y^4/4 with y = Integrate[x^x, x].

In D[D[1[1], 1]^2, D[1[1], 1]], the arguments evaluate first. This yields the messages General::ivar because 1[1] cannot be differentiated with respect to 1. Then, D[1[1], 1] becomes the differentiation variable, and the result after differentiation is 2D[1[1], 1].

D[D[1[1], 1]^2, D[1[1], 1]]

Now let us look at the nested Sum. Sum has the HoldAll attribute. To localize its iterator variables in a first try, it tries to make Sum[k, {1, 4}] the local iterator variable. Sum locally creates a Block-like environment, and because of the Protected attribute assignments cannot be carried out. This yields the Sum::write message. In a next step, Sum evaluates the iterator variable and the body; this means in the example under consideration, the expression Sum[k, {1, 4}]. Here, 1 would be the iterator variable and we get the Sum::itraw messages. Because all tries to localize iterator variables fail, we end up with Sum[Sum[k, {1, 4}]^2, {Sum[k, {1, 4}], 1, 4}].

Sum[Sum[k, {1, 4}]^2, {Sum[k, {1, 4}], 1, 4}]

Repeating the last evaluation, but unprotecting Sum, enables the use of Sum[k, {1, 4}] as an iterator variable. We get the result 30.

Unprotect[Sum]; 
Sum[Sum[k, {1, 4}]^2, {Sum[k, {1, 4}], 1, 4}]

In the next example, the second argument of Solve, the expression Positive[x] is the variable to be solved for. So we get the result {{Positive[x]->-1},{Positive[x]->1}}. (Only expressions with head List, Plus, Times, Power, and Equal are not allowed as “solve variables”.)

Solve[Positive[x]^2 == 1, Positive[x]]

Now let us deal with the double integral and the double sum. The integration example is easy. Integrate does not have any options. The inner integral (∫_(-1)^1)(Subscript[x, 1])d(Subscript[x, 1]) gives zero; the outer integral does too.

Integrate[x[1], {x, 0, 2}, {x[1], -1, 1}]

In distinction to Integrate, the function Sum has the attribute HoldAll. Sum uses this attribute to scope the summation variables in a Block-like manner. So the outer sum localizes the symbol x. The local variable of the inner sum is not a symbol, but the expression x[1]. So it cannot be localized exactly the same way as a symbol is in Block. When the inner sum is carried out, the values of the iterator are assigned to x[1]. But the head is the variable of the outer iterator and has an integer value. So the assignment 0[1] = -1 gets evaluated. Because the head Integer is protected we get Set::write messages and the sum evaluates to 3 0[1] + 3 1[1] + 3 2[1].

Sum[x[1], {x, 0, 2}, {x[1], -1, 1}]

If we unprotect the symbol Integer, we get no messages and the result of the sum is 0 too.

Unprotect[Integer];
Sum[x[1], {x, 0, 2}, {x[1], -1, 1}]

Unprotect[Message]
Message /: Message[___] := Null /; (Abort[]; False);
Integrate[1/(Sqrt[C^2] - C), {C, -1, 1}]

So the result of the input under consideration is $Aborted. This is not surprising. As a side effect, an abort is happening whenever a message is issued. And a message is issued because the integral can be evaluated, but substituting limits produces Power::infy messages.

HoldPattern[Message[___]] =.

Integrate[1/(Sqrt[C^2] - C), {C, -1, 1}]

One rule, mentioned already in Chapter 2 of the Programming volume [1559✶] of the GuideBooks, is that Times[0, somethingThatDoesNotEvaluateToZero] evaluates to zero. So we should look for somethingThatDoesNotEvaluateToZero that is zero. Then Mathematica would give 0 as the result of 0/0. There are an infinite number of (theoretically impossible to detect) zeros, but already togethered (meaning written over a common denominator) versus nontogethered rational functions or expanded versus factored polynomials will do. To avoid variables we use a constant instead, say E. So we are led to the following 17 character input (without counting white space).

0/(1/E + 1 - (1 + E)/E)

Here is a 19 character (again without counting white space) factored-expanded version of a similar input.

0/((E + 1)^2 - E^2 - 2 E - 1)

We had to rely on Times; Power for instance will numericalize its arguments.

{(1/E + 1 - (1 + E)/E)^0, 0^(1/E + 1 - (1 + E)/E)}

𝕥[x_] := ((x + 1)^2 - x^2 - x - 1)/x

Evaluating 𝕥'[0] leads to messages, and the result is Indeterminate.

𝕥'[0]

Evaluating 𝕥'[0] starts with evaluating 𝕥' as a pure function and then supplies the argument 0 to this pure function.

𝕥'

But evaluating 𝕥' forms a derivative without any ongoing simplification. The resulting expression has ξ in the denominator and substituting 0 for ξ leads to messages.

D[𝕥[ξ], ξ]

Be aware that, because of the HoldAll attribute of Function, applying Simplify to the pure function has no effect.

{Simplify[𝕥'], Simplify[𝕥'[[1]]]}

Block[{E}, Print @ D[E[x], x]]

The replacement rule head_[arg_] :> arg[head] gets applied to the resulting expression Derivative[1][E][x]. Derivative[1][E] matches head and E matches arg. The result is x[E'].

Block[{E}, Print[D[E[x], x] /. head_[arg_] :> arg[head]]]

After leaving the Block, the constant E has again the attribute Constant and E' evaluates to 0&.

Block[{E}, D[E[x], x] /. head_[arg_] :> arg[head]]

(* a random variable *)
randomVar := {x, y, z}[[Random[Integer, {1, 3}]]];
(* a random product of powers *)
randomTerm := Product[randomVar^Random[Integer, {-5, 5}], 
                     {Random[Integer, {1, 3}]}];
(* a random Laurent polynomial *)
randomPoly := Sum[Random[Integer, {-5, 5}] randomTerm, 
                  {Random[Integer, {1, 3}]}];
(* a random rational function *)
randomRationalFunction := randomPoly/randomPoly

Now we search for a function such that Together does not act idempotent on it.

SeedRandom[444];
While[𝕣2 = Together[𝕣1 = Together[
        𝕣0 = Sum[randomRationalFunction, {3}]]];
      𝕣2 === 𝕣1, Null];
      
{𝕣1, 𝕣2}

The nonuniqueness in the form of Together[𝕣(x, y, z)] results often from the factorization of the denominator.

f1 = Factor[(x[2] - x[1])^3];
f2 = Factor[(x[2] - x[3])^3];
x[1] = x[3];
f1 - f2 === 0

Here is what happens in detail: Because of the Orderless attribute of Plus, the summands of (x[2] - x[1])^3 become reordered.

Clear[x];
{(x[2] - x[1])^3, (x[2] - x[3])^3}

Factor operates on multivariate polynomials without an explicit variable specification. This means that the result is unique only up to a factor ±1 and a corresponding change in one of the factors. The coefficient -1 of x[2] in (- x[1] + x[2])^3 gets pulled out, but no -1 is pulled out from (x[2] - x[3])^3.

Factor[%]

Identifying now x[3] with x[1] yields two mathematically identical, but structurally different, expressions.

x[1] = x[3]; %

So SameQ returns False.

SameQ @@ %

Names["*Q"]

A moment of reflection shows that IntervalMemberQ is such a function we are looking for. Because it is impossible to recognize all transcendental zeros algorithmically, inputs such as IntervalMemberQ[Interval[{a, b}], (a + b)/2 + i hiddenZero] or IntervalMemberQ[Interval[{a, b}], a ± hiddenZero] for complicated enough hiddenZero might give a wrong answer. Similar to the functions Equal, Less, … the function IntervalMemberQ must make use of numerical techniques to determine if an exact numeric expression lies within certain bounds.
Here is an example that uses one of the real solutions of an irreducible cubic with three real roots. The unavoidable imaginary part after numericalization fools IntervalMemberQ into giving the wrong result.

r = Solve[1 - 3x - 2x^2 + x^3 == 0, x][[2, 1, 2]]

The quantity r is mathematically a real number, but numericalization to any precision will always yield a number with the head Complex.

N[r, 30]

IntervalMemberQ[Interval[{0, 1}], r]

For algebraic numbers, RootReduce can, in principle, be used to give the correct result.

IntervalMemberQ[Interval[{0, 1}], RootReduce @ r]

Here is a transcendental zero. We again get a wrong result, but this time with a message that warns us.

hZ = Sin[Pi/256] - Sqrt[2 - Sqrt[2 + Sqrt[2 + Sqrt[2 + 
                      Sqrt[2 + Sqrt[2 + Sqrt[2]]]]]]]/2

IntervalMemberQ[Interval[{1, 2}], 1 + hZ + Exp[-1000]]

Of course, raising the value of $MaxExtraPrecision to a sufficiently large value helps here.

$MaxExtraPrecision = 10^4;
IntervalMemberQ[Interval[{1, 2}], 1 + hZ + Exp[-1000]]

Currently Mathematica evaluates functions with iterator constructs like Table, Sum, Product, etc. if the bounds are real numeric. In case the number of steps cannot be uniquely decided currently, a message is issued and the numericalized number of steps is carried out. This behavior could also be used to generate a wrong result. Here is an example (no $MaxExtraPrecision messages are generated).

Table[k, {k, 1, 2 + hZ - 10^-1000}]

Of course, one could imagine such Table, Sum, Product-constructs, etc. to stay unevaluated. But because of the Q-ending, IntervalMemberQ will always evaluate to True or False.

For a general discussion, why some calculations sometimes must give wrong results, see [1672✶].

(# - ToRadicals[#] - 
     (* small, numerically "invisible" zero *) 10^-1000)&[
       Roots[x^3 - 2x + 5 == 0, x, Cubics -> False][[1, 2]]];

Developer`ZeroQ[(# - ToRadicals[#] - 10^-1000)&[
    Roots[x^3 - 2x + 5 == 0, x, Cubics -> False][[1, 2]]]]

Here is another example. It uses the small difference between π and a high-order rational approximation to π.

Developer`ZeroQ[E^(Pi - FromContinuedFraction[
                           ContinuedFraction[Pi, 200]]) - 1]

But again, this is a relatively large input. So let us look for a short transcendental function. The following search gives some candidates.

Select[Names["*"], (StringLength[#] <= 3 &&
                    MemberQ[Attributes[#], NumericFunction])&]

Inspecting the last list makes Erf a prime candidate (we discuss the special functions in detail in Chapter 3). It is a transcendental function and approaches 1 exponentially fast as z->∞ (erf(z)≈1-exp((z^2))/((π^(1/2))z)). This means erf(99) is a number with more than 4000 9’s. Any quick numerical check will not detect the difference to 1. So the eight character input Erf@99-1 is an example what we were looking for.

Developer`ZeroQ[Erf@99-1]

In addition to giving sometimes mathematically incorrect answers, the function Developer`ZeroQ can be very slow on relatively simple inputs. Here is an example where a high-precision numericalization is used to determine if the expression vanishes.

Developer`ZeroQ[Nest[Tan, E, 8]] // Timing

f[x_, y_] := y^x x^(-1/3)

{Integrate[f[x, y], {x, 0, 1}, {y, 0, 1}], 
 Integrate[f[x, y], {y, 0, 1}, {x, 0, 1}]}

While the last returned integral can in principle be carried out, it requires a clever change of variables. Numerically the two results agree, of course.

{N[%], {NIntegrate[f[x, y], {x, 0, 1}, {y, 0, 1}], 
        NIntegrate[f[x, y], {y, 0, 1}, {x, 0, 1}]}}

makeDef1[𝕕_, f_, 𝒜_] := 
 f /: 𝕕[1][f] /; (clearDef1[𝕕, f, 𝒜]; makeDef2[𝕕, f, 𝒜]; False) := Null

clearDef1[𝕕_, f_, 𝒜_] := 
 f /: 𝕕[1][f] /; (clearDef1[𝕕, f, 𝒜]; makeDef2[𝕕, f, 𝒜]; False) =.

makeDef2[𝕕_, f_, 𝒜_] := 
 𝕕 /: HoldPattern[𝕕[1][f][0]] := (clearDef2[𝕕, f]; makeDef1[𝕕, f, 𝒜]; 𝒜)


clearDef2[𝕕_, f_] := 𝕕 /: HoldPattern[𝕕[1][f][0]] =.

makeDef1[Derivative, 𝕗, 𝔣0];
D[𝕗[x], x] /. x -> 0

So the result was 𝔣0. Here is what happened: First definitions for the functions makeDef1, clearDef1, makeDef2, and clearDef2 were made. Then makeDef1[Derivative, 𝕗, 𝔣0] was evaluated. This made an upvalue for 𝕗.

makeDef1[Derivative, 𝕗, 𝔣0]
??𝕗

Then D[𝕗[x], x] evaluated to Derivative[1][𝕗][x]. The head of the last expression, Derivative[1][𝕗], fires the upvalue for 𝕗. While the upvalue rule itself does not match (the condition gives always False), as a side effect of evaluating the condition the two statements clearDef1[Derivative,𝕗,𝔣0] and makeDef2[Derivative,𝕗,𝔣0] are evaluated. The first one removes the upvalue for 𝕗 and the second one creates a subvalue for Derivative.

clearDef1[Derivative, 𝕗, 𝔣0]
makeDef2[Derivative, 𝕗, 𝔣0]
SubValues[Derivative]

Then the replacement x -> 0 gets evaluated. As a result the expression Derivative[1][𝕗][0] is created. The subvalue definition of Derivative matches now and the right-hand side of the last rule is evaluated. By doing so the subvalue definition itself is destroyed, the original upvalue definition for 𝕗 is restored and the expression 𝔣0 is returned.
Using On[], the previously described steps can be seen.

Clear[𝕗, Derivative];
makeDef1[Derivative, 𝕗, 𝔣0];
On[]; $MessagePrePrint = Identity;
D[𝕗[x], x] /. x -> 0

After evaluating D[𝕗[x], x] /. x -> 0 we have again the same state of affairs for the definitions as before—the upvalue for 𝕗 and no definitions for Derivative.

Off[];
??𝕗

??Derivative

𝕣𝕗 := {Exp, Log, #^2&, 1/#&, (1 + #)&}[[Random[Integer, {1, 5}]]]

(* avoid messages *)
Off[$MaxExtraPrecision::meprec]; Off[General::ovfl]; Off[Power::infy];

notLimitableFunction[nestDepth_:10] := 
Module[{f}, 
       While[f = Nest[𝕣𝕗[#]&, x, 10];
             TimeConstrained[Head[Limit[f, x -> 0]], 10] =!= Limit, Null];
       f]

Here are five examples of functions returned by notLimitableFunction.

SeedRandom[111];
Limit[#, x -> 0]& @ Table[notLimitableFunction[], {5}]

myTrigIntegrate[int_, x_] := 
Module[{ξ}, intTξ = TrigToExp[int] //. Exp[c_ x] :> ξ^(c/I);
       Integrate[-I intTξ/ξ, ξ] /. ξ -> Exp[I x]]

The function myTrigIntegrate works as expected.

myTrigIntegrate[(Cos[x]^2 + 2)/(Tan[x] + Sin[2x]), x]

D[%, x] - (Cos[x]^2 + 2)/(Tan[x] + Sin[2x]) // Simplify

Next, we define a function randomTrigSum that returns a random sum of trigonometric function. The function randomTrigRational returns the quotient of two random sum of trigonometric function—a rational trigonometric function.

(* random sum of trigonometric functions *)
randomTrigSum[c_, n_, o_, p_] := 
 Sum[Random[Integer, {-c, c}] {Cos, Sin, Csc, Sec, Tan, Cot}[[
                               Random[Integer, {1, 6}]]][
      (2 Random[Integer] - 1)*
      Random[Integer, {1, c}] x]^Random[Integer, {-p, p}], {n}]
      
(* random rational function of trigonometric functions *)
randomTrigRational[c_, n_, o_, p_] := 
Module[{num, den}, 
       While[den = randomTrigSum[c, n, o, p];
             FreeQ[Simplify[den], x, Infinity], Null];
       num = randomTrigSum[c, n, o, p]; num/den]

Here are some examples of random rational trigonometric functions.

Table[randomTrigRational[3, 3, 3, 3], {3}]

Now, we generate random rational trigonometric functions until we find an integrand that the built-in Integrate cannot integrate. The function findFunction, beginning with seeding the random number generator, does this.

findFunction[seed_, {c_, n_, o_, p_}] := 
Module[{integrand, builtInIntegral, myIntegral},
(* seed random number generator *) SeedRandom[seed];
While[((* built-in integration *)
       integrand = randomTrigRational[c, n, o, p];
       builtInIntegral = Integrate[integrand, x]; 
       FreeQ[builtInIntegral, Integrate, {0, Infinity}, 
            Heads -> True]) ||
       ((* manual substitution of variables *)
        myIntegral = myTrigIntegrate[integrand, x];
        MemberQ[ToRadicals[Normal[myIntegral]], 
                Root, {0, Infinity}, Heads -> True]),
       Null]; (* found integrand *) integrand]

Here is a rational trigonometric function with the property we were looking for.

findFunction[7797068820, {2, 2, 2, 2}]

{Integrate[%, x], myTrigIntegrate[%, x]}

(* quick check of the result of myTrigIntegrate *)
D[%[[2]], x] - %% // Simplify

We do not have to search too hard to find an expression that is zero, but is not recognized as such by Mathematica. zero is an example.

zero = (# - Together[TrigToExp[#]])&[Sin[Pi/13]]

Simplify[zero]

Using zero as the leading coefficient in a quadratic yields correctly one solution.

Solve[zero x^2 + x - 1 == 0, x]

Perturbing the leading coefficient now slightly, yields an expression that Mathematica cannot symbolically determine to be nonvanishing. So it uses numerical techniques and within the default setting for $MaxExtraPrecision, it finds that the leading coefficient vanishes.

Solve[(zero + 10^-100) x^2 + x - 1 == 0, x]

myFourierTransform[f_, t_, ω_, opts___] := 
 1/Sqrt[2 Pi] Integrate[f Exp[I t ω], {t, -Infinity, Infinity}, opts]

myFourierTransform[Exp[-t^2], t, ω, Assumptions -> Im[k] == 0]

A problem arises in the case myFourierTransform[f(ω), ω, ω].

myFourierTransform[Exp[-ω^2], ω, ω, Assumptions -> Im[ω] == 0]

(Subscript[ℱ, t])[f(t)](ω) is a functional of f, depending on the variable ω. The variable t itself is of no relevance, only the map t->f(t). This means the “integration variable” has to be a truly dummy variable and the result has to depend on the third argument of myFourierTransform. The function myBetterFourierTransform uses a dummy integration variable and only later substitutes the third argument. It also guards this substitution against the situation of an unevaluated integral.

myBetterFourierTransform[f_, t_, ω_, opts___] := 
Module[{κ, res},
 res =  1/Sqrt[2 Pi] Integrate[f Exp[I t κ], {t, -Infinity, Infinity}, 
                               Sequence @@ ({opts} /. ω -> κ)] /. κ -> ω; 
 res /;  FreeQ[res, _Integrate, {0, Infinity}]];

Now, we get the expected result for (Subscript[ℱ, ω])[f(ω)](ω).

myBetterFourierTransform[Exp[-ω^2], ω, ω, Assumptions -> Im[ω] == 0]

f[z_] := α z + β; fInv[z_] := (z - β)/α

{f[fInv[z]], fInv[f[z]]}

It is also easy to find a function such that f((f^(-1))(z))=f((f^(-1))(z))=z almost everywhere. We just add a function to f(z) that vanishes almost everywhere, but not everywhere.

f[z_] := z + (Log[z] + Log[1/z])/(2 I Pi)
fInv[z_] := z

Along the negative real axis the f((f^(-1))(z))=f((f^(-1))(z))=z does not hold.

{f[fInv[z]] - z, fInv[f[z]] - z} /. 
       {{z -> Random[Complex, {-1 - I, 1 + I}, 20]},
        {z -> Random[Real, {0, -4}, 20]}}

The third class, the pairs f, (f^(-1)) such that f((f^(-1))(z))=z everywhere, but f((f^(-1))(z))=z not everywhere is the standard situation of the named functions of Mathematica. Here are two typical examples.

f[z_] := Exp[z]; fInv[z_] := Log[z]

{f[fInv[z]], fInv[f[z]]}

f[z_] := Sin[z]; fInv[z_] := ArcSin[z]

{f[fInv[z]], fInv[f[z]]}

(The pair EllipticNomeQ and InverseEllipticNomeQ are special in the sense that InverseEllipticNomeQ plays, despite its name, the role of f.)

The last type of functions is easily generated by starting with a function that has a branch cut. Here is an example.

f[z_] = z^2 + Sqrt[z];
fInv[z_] = (z /. Solve[f[z] == w, z][[2]]) /.
             w -> z // Simplify

The following plot shows the region where the two identities f((f^(-1))(z))=z and f((f^(-1))(z))=z hold and not hold.

Show[GraphicsArray[
  Plot3D[Chop[Abs[#[(x + I y)] - (x + I y)]],
         {x, -6, 6}, {y, -6, 6}, 
         DisplayFunction -> Identity, Mesh -> False,
         PlotPoints -> 120, PlotRange -> All]& /@
      {f[fInv[#]]&, fInv[f[#]]&}]]

Simplify[Sin[x]/x, x == 0]

And because of the rule for Times that 0 something evaluates to 0, we get in the example under consideration 0.

Simplify[x DiracDelta'[x], x == 0]

Using the function Simplify`SimplifyPseudoFunctions instead, we get the mathematically correct result.

Simplify`SimplifyPseudoFunctions[x DiracDelta'[x]]

int = Integrate[Sqrt[(x - y)^2], x, y]

The integral is “correct”.

D[%, x, y] // Simplify

The 2D indefinite integral is a continuous (but not everywhere differentiable) function of x and y.

Plot3D[int, {x, 0, 1}, {y, 0, 1}, PlotPoints -> 61]

But the substitution of limits gives the obviously wrong (a positive integrand should give a positive integral) result 0.

((# /. x -> 1) - (# /. x -> 0))&[(int /. y -> 1) - (int /. y -> 0)]

Carrying out the definite integration using Integrate too gives a wrong result.

Integrate[Sqrt[(x - y)^2], {x, 0, 1}, {y, 0, 1}]

This means that the Newton–Leibniz theorem was not applicable because the indefinite integral did not fulfill all suppositions needed. Now we do the two integrations step by step.

int = Integrate[Sqrt[(x - y)^2], x] // Factor

The integral has a jump for a generic value of y.

(* suppress messages due to division by 0 *)
Off[Power::"infy"]; Off[Infinity::"indet"]; 
Off[Plot3D::"plnc"]; Off[Plot3D::"gval"]

indefIntGraphics[int_] := 
Show[GraphicsArray[
  Block[{$DisplayFunction = Identity},
        {Plot[Evaluate[int /. y -> 0.3], {x, 0, 1}], 
         Plot3D[Evaluate[int], {x, 0, 1}, {y, 0, 1}, 
                PlotPoints -> {61, 61}, Mesh -> False]}]]];

indefIntGraphics[int];

Let us fix this jump by adding a function that makes everything together smooth.

δ = (-x (x - 2y) /. x -> y)(Sqrt[(x - y)^2]/(x - y) + 1)/2

int1 = int + δ // Together // Factor

indefIntGraphics[int1]

Now let us deal with the second integration.

int2 = Integrate[int1, y] // Together // Factor

Again, we have a jump.

indefIntGraphics[int2]

We again add a function δ2 to obtain a smooth function of two variables.

int2a = int2 // Expand

int2a /. Sqrt[(x - y)^2]/(x - y) -> 1

Together[%] /. y -> x

δ2 = x^3/3 (Sqrt[(x - y)^2]/(x - y) + 1)/2

int3 = int2 - δ2 // Together // Factor

Collect[int3, Sqrt[(x - y)^2]] // Factor

Now we have a nice, smooth, correct double indefinite result.

indefIntGraphics[int3]

Differentiation yields (Sqrt[(((x-y))^2)]).

D[int3, x, y] // Together // Factor

(int3 /. y -> 1) - (int3 /. y -> 0)

(% /. x -> 1) - (% /. x -> 0)

This is the result we also get from numerical integration.

NIntegrate[Sqrt[(x - y)^2], {x, 0, 1}, {y, 0, 1}]

Off[Series::esss];
Integrate[integrand = Exp[-2 x] (Coth[x] - 1/x), {x, 0, Infinity}]

But we can calculate the indefinite integral.

indefInt = Integrate[integrand, x] // Simplify

The indefinite integral is a continuous function along the positive real line. Its value at x=0 is γ-1/2.

-Series[indefInt, {x, 0, 0}]

After making the indefinite integral real valued along the positive real axis and expanding the function ExpIntegralEi, we see that the upper limit contribution to the integral vanishes.

indefInt + I Pi /. {Log[Exp[-2 x] - 1] -> -I Pi,
 ExpIntegralEi[-2 x] :>
 (Normal[Series[ExpIntegralEi[ξ], {ξ, Infinity, 1}]] /. ξ -> -2x)}

Another possibility to calculate the integral is the following. We split the one convergent integral into two divergent integrals and use the option setting GenerateConditions -> False. This allows to evaluate one of the integrals.

Integrate[#, {x, 0, Infinity}, 
          GenerateConditions -> False]& /@  Expand[integrand]

Multiplying each term with a symbolic factor of the form (x^μ) yields again the result γ-1/2.

Integrate[x^μ #, {x, 0, Infinity}, 
          GenerateConditions -> False]& /@  Expand[integrand]

Series[%, {μ, 0, 0}] // Simplify // Normal

The value γ-1/2 agrees with the result of a numerical integration.

Off[General::unfl]; Off[General::ovfl];
{NIntegrate[Evaluate[integrand], {x, 0, Infinity},
            WorkingPrecision -> 30], N[EulerGamma - 1/2, 30]}

(* unite adjacent differential operators *)
ℐ[a___, 𝒹[i_], 𝒹[j_], b___] := ℐ[a, 𝒹[i + j], b]  

(* bring all 𝒹's to the right of x-dependent functions *)
ℐ[start___, 𝒹[i_], f_, rest___] := 
  Sum[Binomial[i, k] ℐ[start, D[f, {x, k}], 𝒹[i - k], rest], 
      {k, 0, o}] /; Head[f] =!= 𝒹 && Head[f] =!= ℐ
  
(* pull out numeric factors *)
ℐ[a___, 𝒻_?NumericQ b_, c___] := 𝒻 ℐ[a, b, c] // Expand

(* distribute 𝒹's over sums *)
ℐ[a___, p_Plus, b___] := ℐ[a, #, b]& /@ p 

(* flatten out nested ℐ’s *)
ℐ[a___, ℐ[b___], c___] := ℐ[a, b, c]

Now let us calculate (Subscript[α, 0]). Truncating the ansatz for (Sqrt[ℒ]) at k=0 and truncating the infinite binomial sum yields the following expression for (Sqrt[ℒ])((Sqrt[ℒ])(.))=ℒ(.) .

o = 3;
δ = ℐ[𝒹[1] + ℐ[α[0][x], 𝒹[0]]];
ℐ[δ, δ]

Because ℒ does not contain any term of the form ∂/∂x, it follows immediately that (Subscript[α, 0])=0. 
Next let us repeat this procedure to calculate (Subscript[α, 1])(x).

δ = ℐ[𝒹[1] + ℐ[α[-1][x], 𝒹[-1]]];
ℐ[δ, δ]

Equating the terms of the form ...(x). with u(x). yields the result (Subscript[α, -1])(x)=u(x)/2.

Plus @@ (Cases[%, _. ℐ[___, 𝒹[0]]])

Solve[2 α[-1][x] == u[x], α[-1][x]]

Now it is straightforward to automate the process of the calculation of (Subscript[α, -k])(x) after (Subscript[α, 0])(x), …, (Subscript[α, -k+1])(x) are already calculated.

(* current approximation of sqrtℒ *)
sqrtℒ = 𝒹[1] + ℐ[u[x]/2, 𝒹[-1]];

Do[(* take enough terms *) o = Abs[k] + 3;
   (* new ansatz approximation for sqrtℒ *)
   δ = ℐ[sqrtℒ + ℐ[α[k][x], 𝒹[k]]];
   (* calculate sqrtℒ @ sqrtℒ *)
   δℐ = ℐ[δ, δ];
   (* original ℒ does not contain D[., {x, k}] *)
   zero = (Plus @@ (Cases[δℐ, _. ℐ[___, 𝒹[k + 1]]])) /. 
                                 ℐ[ts__, _] :> Times[ts];
   
   (* solve for α[d] *)
   sol = Solve[zero == 0, α[k][x]]; 
   (* new approximation for sqrtℒ *)
   sqrtℒ = sqrtℒ + ℐ[α[k][x] /. sol[[1]], 𝒹[k]], {k, -2, -10, -1}]

We implement some formatting rules to display the result in a concise form.

With[{tf = TraditionalForm},
 (* format x-dependent parts to the left of ∂’s *)
 MakeBoxes[𝒹[k_], tf] := SuperscriptBox["∂", MakeBoxes[k, tf]];
 (* format 𝒹’s as ∂’s *)
 MakeBoxes[C[us_, 𝒹[k_]], tf] := 
               RowBox[{MakeBoxes[us, tf], MakeBoxes[𝒹[k], tf]}];
 (* sort 𝒹’s in decreasing order *)
 MakeBoxes[ℒList[args__], tf] := RowBox[Drop[Flatten[    
           Transpose[{MakeBoxes[#, tf]& /@ {args},
                      Table["+", {Length[{args}]}]}], 1], -1]]]

We now simplify and format the calculated first terms of the factorization of ℒ=(∂^2)./∂(x^2) +u(x)..

res1 = Simplify[(* unite prefactors of equal 𝒹[k] *)
         (sqrtℒ /. ℐ -> C) //. α_. C[a_, 𝒹_] :> C[α a, 𝒹] //.
   C[a_, 𝒹_] + C[b_, 𝒹_] :> C[a + b, 𝒹]] /. {u[x] -> u,
       Derivative[j_][u][x_] :> Derivative[j][u]};

res2 = Sort[ℒList @@ res1, Function[f, f[#1] > f[#2]][
            Cases[#, 𝒹[_], {0, Infinity}, Heads -> True][[1, 1]]&]&];

res2 // TraditionalForm

With some handwork one can, for the special differential operator ℒ=(∂^2)./∂(x^2) +u(x), even derive a closed-form nonlinear recursion relation for the (Subscript[α, -k])(x)=(Subscript[α, -k])(u(x),u'(x),…,(u^((k)))(x)) [1415✶]

(Subscript[α, k])(x)=-(1/2) ((Subscript[α, k+1]^′)(x)+(∑_(j=1)^(-k-2))(∑_(i=1)^(-j-k-1))(({{          -j}, {-i-j-k-1}})) (Subscript[α, -j])(x)(Subscript[α, -i]^((-i-j-k-1)))(x))

where the recursion starts with (Subscript[α, -1])(x)=u(x)/2.

α[-1] = u[x]/2;

α[k_] := α[k] = Factor[-(D[α[k + 1], x] + 
      Sum[Binomial[-j, -k - 1 - j - i]*
          α[-j] D[α[-i], {x, -k - 1 - j - i}], 
                  {j, -k - 2}, {i, -k - 1 - j}])/2]

This recursion yields the just-calculated result.

(* above calculated coefficients *)
Expand[Table[Cases[res1, C[_, 𝒹[k]]][[1, 1]], {k, -1, -10, -1}] -
(* coefficients from the recursion relation *)
(Table[α[k], {k, -1, -10, -1}] /.   {u[x] -> u,
                 Derivative[j_][u][x_] :> Derivative[j][u]})]

coeffs = Drop[CoefficientList[(x - x1)(x - x2)(x - x3), x], -1]

Forming all possible combinations of coefficients and roots, we have the following equations.

eqs = (coeffs - #)& /@ Permutations[{x1, x2, x3}]

Solving these equations gives the following 28 solutions.

(* avoid large outputs containing radicals *)
SetOptions[Roots, Cubics -> False, Quartics -> False];

sols = Union[Sort /@ Flatten[RootReduce[
       Solve[# == 0& /@ #, {x1, x2, x3}]& /@ eqs], 1]]

Here are the corresponding numerical values.

{x1, x2, x2} /. N[sols]

Here is a quick numerical check of the correctness of the solutions.

poly = {-(x1 x2 x3), x1 x2 + x1 x3 + x2 x3, 
        -x1 - x2 - x3}.{1, x, x^2} + x^3

((Sort[N[{x1, x2, x3} /. #]] == 
  Sort[x /. NSolve[(poly /. #) == 0, x]])& /@ 
                  DeleteCases[sols, {x1 -> 0, x2 -> 0, x3 -> 0}]) // Union

f[z_] := 1 + 2z - z^3;
log[z_] := Log[Abs[z]];

(* parameter settings *) R = 4; ppr = 480; ppφ = 120;
(* avoid messages *) Off[Graphics::gptn];
gr = Show[Graphics[{PointSize[0.003], 
Table[{Hue[0.78 r/R], Point[{log[N[r Exp[I φ]]], log[f[N[r Exp[I φ]]]]}]},
      {r, 0, R, R/ppr}, {φ, 0, 2Pi, 2Pi/ppφ}]} // N], 
      Frame -> True, PlotRange -> All]

For an exact description of the amoeba, we first observe that applying log to |(Subscript[z, k])| just stretches a figure in (ℝ^n) [1607✶]. So it is enough to get a description of the map {(Subscript[z, 1]),(Subscript[z, 2]),…,(Subscript[z, n])}->{|(Subscript[z, 1])|, |(Subscript[z, 2])|, …,|(Subscript[z, 2])|}. Writing (Subscript[z, k])=Re((Subscript[z, k]))+i Im((Subscript[z, k])) yields a quantified expression that can be resolved using Resolve. The z parametrizes the solution and is the quantified (complex) variable to be eliminated. (We use the notations (Subscript[z, 1])=x, and (Subscript[z, 2])=y.)

ComplexExpand[(Re[#]^2 + Im[#]^2)&[1 + 2z - z^3 /. 
                z -> xr + I xi]] // Simplify

AppendTo[$ContextPath, "Experimental`"]

amoeba = 
Exists[{xr, xi}, Element[{x, y, xr, xi}, Reals],
       (* x parametrizes the solution *)
       x^2 == xr^2 + xi^2 && 
       (* y is the solution *)
       y^2 == xi^6 + xi^4 (4 + 3 xr^2) + (1 + 2 xr - xr^3)^2 + 
              xi^2 (4 + 6 xr + 3 xr^4) &&
       (* Abs implies positive x and y *)       
       x > 0 && y > 0] // Resolve

The following contour plot shows the resulting region in the x,y-plane.

cp = ContourPlot[Evaluate[If[amoeba, -1, 1]], {x, 0, 3}, {y, 0, 10},
PlotPoints -> 200, Contours -> {0}, ContourLines -> False]

Using the cylindrical description amoeba we can discretise the boundary and apply the (nonfolding) transformation log.

plot[Inequality[xl_, Less, x, Less, xu_] && 
     Inequality[yl_, Less, y, Less, yu_], pp_] := 
With[{ε = N[10^-40, 60]}, (* make points along boundaries *)
Polygon[((#2[Table[Log @ {x, #1}, 
                   {x, xl + ε, xu - ε, (xu - xl - 2ε)/pp}]])& @@@ 
        {{yl, Identity}, {yu, Reverse}}) // (Join @@ #)&]];

Here is the resulting picture of the amoeba.

Show[{Graphics[plot[#, 120]& /@ 
     (List @@ (DeleteCases[amoeba, x == _ && _] /. LessEqual -> Less /.
               x > xl_ :> Inequality[xl, Less, x, Less, 4xl]))], gr} // N, 
      Frame -> True, PlotRange -> {{-5, 2}, {-5, 5}},
      AspectRatio -> Automatic]

f[{x_, y_}] = (3 x + y) (x + 3 y);

(* take (2 n + 1)^2 - 1 neighbor lattice points into account *)
conds[n_] := 
And @@ Flatten[Table[If[i == j == 0, {}, 
                     Abs[f[{x, y}]] < Abs[f[{x + i, y + j}]]], 
                     {i, -n, n}, {j, -n, n}]];

Show[GraphicsArray[Table[
 ContourPlot[Evaluate[If[conds[k], -1, 1]], {x, -4, 4}, {y, -4, 4},
             Contours -> {0}, PlotPoints -> 240,
             DisplayFunction -> Identity], {k, 2, 4}]]]

The next graphic shows the tile from conds[3] together with the 48 corresponding contours |f(x,y)|=|f(x+i,y+j)|.

Show[{%[[1, 2]], (* the 48 bounding curves *) Table[
ContourPlot[Evaluate[Subtract @@ conds[3][[k]]], {x, -2, 2}, {y, -2, 2},
            Contours -> {0}, PlotPoints -> 240,
            DisplayFunction -> Identity, ContourShading -> False,
            ContourStyle -> {{Hue[Random[]]}}], {k, Length[conds[3]]}]},
     DisplayFunction -> $DisplayFunction, 
     PlotRange -> {{-2, 2}, {-2, 2}}]

The symmetry f(x,y)=f(y,x) suggests changing the coordinate system to simplify the problem of the construction of an exact description of the tile. The obvious change is ξ=3x+y, and η=x+3 y.

Solve[{3x + y == ξ, x + 3 y == η}, {x, y}]

condsξη[n_] := condsξη[n] = 
               conds[n] //. {x -> (3ξ - η)/8, y -> (3η - ξ)/8};

Here is the resulting tile. The twofold mirror symmetry of the resulting figure suggests finding an exact description of the tile for the region ξ≥0, -ξ≤η≤ξ. The other three congruent parts can than easily obtained by mirroring and rotating.

ContourPlot[Evaluate[If[condsξη[3], -1, 1]], {ξ, -5, 5}, {η, -5, 5},
            Contours -> {0}, PlotPoints -> 240]

To find an exact description of the tile in the ξ,η-coordinates means nothing else other than carrying out a decomposition of (ℝ^2) with respect to the 48 inequalities condsξη[3]. Because we are not interested in lower dimensional subparts, we will use the function CylindricalAlgebraicDecomposition.

AppendTo[$ContextPath, "Experimental`"]

(* initial two inequalities and symmetry restrictions *)
gcad[2] = CylindricalAlgebraicDecomposition[
  And @@ Flatten[{ξ > 0, -ξ < η < ξ, Take[condsξη[3], 2]}], {ξ, η}];

(* use one inequality after the other *)
Do[gcad[k] = CylindricalAlgebraicDecomposition[
                        And @@ {gcad[k - 1], condsξη[3][[k]]}, {ξ, η}], 
   {k, 3, Length[condsξη[3]]}]

The following plot of the sizes of the intermediate decompositions shows that about 15 of the inequalities border the tile.

ListPlot[Table[ByteCount[gcad[k]], {k, 2, 48}], 
         PlotRange -> All, PlotJoined -> True]

Here is the final decomposition.

gcad[48]

For more convenient further manipulations, we expand the obtained decomposition.

tileD1 = DeleteCases[LogicalExpand[gcad[48]], (ξ == _) && __] /.
                                              LessEqual -> Less;

Rewriting the bounds on the variables ξ and η in tileD1 in a form appropriate for Integrate allows to obtain an exact result for the area of the tile.

toIntegrationDomain[l_] :=
  {{Cases[l, _?(FreeQ[#, η]&) < ξ], Cases[l, ξ < _]},
   {Cases[l, _ < η], Cases[l, η < _]}}

iRanges = {{ξ, #[[1, 1, 1, 1]], #[[1, 2, 1, 2]]},
           {η, #[[2, 1, 1, 1]], #[[2, 2, 1, 2]]}}& /@ 
                   toIntegrationDomain /@ (List @@ tileD1);

Here are the first few integration domains.

Take[iRanges, 6]

And here is the area of the whole tile in ξ,η-coordinates.

Expand[4 Plus @@ (Integrate[1, ##]& @@@ iRanges)]

Simplifying the result yields the area 8 in the ξ,η-plane.

Simplify[% //. a_. Log[α_] + b_. Log[β_] :> Log[α^a β^b]]

Taking into account the value 1/8 of the functional determinant from changing variables from x,y to ξ,η shows that the tile in the x,y-plane has area 1—as it has to be for a tile of a square lattice.

Det @ Outer[D, {(3ξ - η)/8, (3η - ξ)/8}, {ξ, η}]

For a graphical representation of the tile we sort the integration regions with respect to ξ and we separate the lower and upper boundaries.

ξηRegions = Sort[iRanges, (#1[[1, 2]] < #2[[1, 2]])&];

upperCurve[ξ] and lowerCurve[ξ] are the upper and lower bounding curves of the quarter of the tile. quarterPoly is a polygon representing the quarter of the tile.

{upperCurve[ξ_], lowerCurve[ξ_]} = Function[{r, p},
Which @@ Flatten[(* ranges and ξ\[Hyphen]dependent functions *)
  {#1[[1, 2]] <= #1[[1, 1]] <= #1[[1, 3]], #1[[2, p]]}& /@
   Cases[ξηRegions, {_, r}]]] @@@ {{{η, 0, _}, 3}, {{η, _, 0}, 2}};

quarterPoly = With[{pp = 12}, N @
Polygon[Join[Flatten[#1, 1], Reverse[Flatten[#2, 1]]]]& @@
(Function[{r, p}, (* ranges and ξ\[Hyphen]dependent functions *)
 Table[{ξ, #[[2, p]]} /. ξ -> #[[1, 2]] + k/pp (#[[1, 3]] - #[[1, 2]]), 
       {k, 0, pp}]& /@ Cases[ξηRegions, {_, r}]] @@@
       {{{η, 0, _}, 3}, {{η, _, 0}, 2}})];

Here is the quarter of the tile and its boundary.

Show[{Graphics[quarterPoly],
      Plot[{upperCurve[ξ], lowerCurve[ξ]}, {ξ, 0, 4},
           PlotStyle -> {{Hue[0], Thickness[0.01]}}, 
           DisplayFunction -> Identity]}, 
           Frame -> True, PlotRange -> All]

Mapping now back to the x,y-plane yields the following polygonal description of the tile.

fullPoly = {quarterPoly, Map[{-1, -1}#&, quarterPoly, {-2}],
            Map[Reverse[#]&, quarterPoly, {-2}],
            Map[{-1, -1}Reverse[#]&, quarterPoly, {-2}]};

tile = Apply[{3#1 - #2, -#1 + 3 #2}/8&, fullPoly, {-2}];

Show[Graphics[tile], Frame -> True, PlotRange -> All,
     AspectRatio -> Automatic]

We end with a graphic of a randomly colored array of the tile. Each individual tile is centered at the lattice points {i,j} of the square lattice.

With[{o = 5},
Show[Graphics[
Table[{{Hue[Random[]], 𝒯 = Map[({i, j} + #)&, tile, {-2}]},
       {GrayLevel[0], Thickness[0.002], 𝒯 /. Polygon -> Line}}, 
      {i, -o, o}, {j, -o, o}]], 
     Frame -> False, PlotRange -> (o - 2) {{-1, 1}, {-1, 1}},
     AspectRatio -> Automatic]]

ContourPlot[x^3 + y^3 - 3 x y, {x, 0, 2}, {y, 0, 2}, 
            Contours -> {0}, PlotPoints -> 40]

Piecewise, we can uniquely solve for y=y(x).

sol = Solve[x^3 + y^3 - 3 x y == 0, y]

Here, the three solutions are shown.

(* avoid messages from Plot due to non-real values *)
Off[Plot::plnr]; 

Show[GraphicsArray[Plot[Evaluate[y /. #], {x, 0, 2}, 
           PlotRange -> All, DisplayFunction -> Identity]& /@ sol]]

We calculate the “rightmost point” (meaning where 1/y'(x) vanishes).

Solve[D[x^3 + y[x]^3 - 3 x y[x], x] == 0, y'[x]]

Select[Solve[{x == y^2, x^3 + y^3 - 3 x y == 0}, {x, y}], 
       Im[x /. #] == 0 && Im[y /. #] == 0 && 
       (x /. #1) > 0 && (y /. #1) > 0&]

Now we must integrate the parts of sol. The first and the third solution bound the area under consideration. Mathematica can carry out the integrations straightforwardly.

Integrate[sol[[1, 1, 2]], {x, 0, 2^(2/3)}]

But calculating the area under the third branch may take a long time.

TimeConstrained[Integrate[sol[[3, 1, 2]], {x, 0, 2^(2/3)}], 20]

The reason is that the handling of the indefinite integral at the limits is a bit subtle.

int3 = Integrate[sol[[3, 1, 2]], x];
int3a = Simplify[int3];

After simplification and series expansion, we can substitute the limits.

Series[int3a, {x, 0, 0}] // Normal // Simplify

Series[int3a, {x, 2^(2/3), 0}] // Normal // Simplify

Putting everything together, we get for the area the value 3/2.

2 - (3/2 - 1)

Integrate[(1 + u^2 + v^2 + w^2)^-2, {u, 0, 1}, {v, 0, 1}, {w, 0, 1}]

Of course, we can calculate a numerical approximation of the remaining 1D integral.

N[%]

NIntegrate[(1 + x^2 + y^2 + z^2)^-2, {x, 0, 1}, {y, 0, 1}, {z, 0, 1},
           PrecisionGoal -> 8]

Integrals of this form often are rational multiples (of small denominator) of powers of π [1120✶]. This seems to be true also for this integral. The next input suggest the conjectured value (π^2)/32 for the integral.

Rationalize[%/Pi^Range[4], 10^-12]

To confirm our conjecture (π^2)/32, we use a spherical coordinate system to calculate the triple integral. Making also use of the symmetry of the integrand we have the following identity (see Exercise 9 of Chapter 3 of the Graphics volume [1560✶] of the GuideBooks). The limits for the r-integration follows from the plane x=1, and the limit for the ϑ-integration follows from the line z=y in the plane x=1.

(∫_0^1)(∫_0^1)(∫_0^1)f(x,y,z)dx dy dz=
6(∫_0^(π/4))(∫_(arctan(1/sin(φ)))^(π/2))(∫_0^(1/(cos(φ) sin(θ))))f(r cos(φ) sin(ϑ), r sin(φ) sin(ϑ),r cos(ϑ))dr dϑ dφ

Here is the numerical integration carried out in spherical coordinates.

NIntegrate[(1 + r^2)^-2 r^2 Sin[ϑ], 
           {φ, 0, Pi/4}, {ϑ, ArcTan[1/Sin[φ]], Pi/2},
           {r, 0, 1/(Cos[φ] Sin[ϑ])}] 6

The integration over r results in a relatively simple expression.

int1 = Integrate[6 (1 + r^2)^-2 r^2 Sin[ϑ],
                 {r, 0, 1/(Cos[φ] Sin[ϑ])}] // Simplify

The definite integration over ϑ cannot be carried out directly. Due to the presence of the symbolic parameter φ, Mathematica fails to apply the Newton–Leibniz theorem successfully.

int2 = Integrate[int1, {ϑ, ArcTan[1/Sin[φ]], Pi/2},
                 GenerateConditions -> False]

But the indefinite integral can be carried out.

int2Indef = Integrate[int1, ϑ] // Simplify

To get shorter expressions, we rewrite the last result by using a stripped down version of the addition theorem for the arctan function (stripped down because we ignore piecewise present multiples of π—for the definite integral, they do not matter as long as we do not pass a branch cut with the integration path). We could also continue with the above form of int2Indef and carry out all further calculations, but some intermediate expressions would be much larger.

int2Indef = int2Indef /. a_ ArcTan[x_] - a_ ArcTan[y_] :> 
                         a ArcTan[(x - y)/(1 + x y)] // Simplify

The value of int2Indef at ϑ=π/2 cannot be determined by substitution; we need to take the limit “by hand”.

int2Upper = int2Indef /. ϑ -> Pi/2

int2Upper = (Series[int2Indef, {ϑ, Pi/2, 0}] // Normal) //. 
                                                Sign[x_] :> -x

The lower limit is easy to calculate.

int2Lower =  int2Indef /. ϑ -> ArcTan[1/Sin[φ]]

Carrying out the remaining definite integral over φ confirms our conjecture that the value of the integral is (π^2)/32.

Integrate[(3 Cos[φ] ((2 ArcTanh[(Sqrt[-3 - Cos[2 φ]] Csc[φ])/Sqrt[2]])/
           Sqrt[-3 - Cos[2 φ]] - Pi/Sqrt[3 + Cos[2 φ]]))/Sqrt[2] + 
           (3 ArcTan[Sqrt[1 + Csc[φ]^2] Tan[φ]])/Sqrt[1 + Csc[φ]^2], 
          {φ, 0, Pi/4}]

integrand = (x^2 + x y + y^2)^ν Exp[-(x + y)];

Integrate[integrand, {x, 0, Infinity}, {y, 0, Infinity}]

An attempt to evaluate the integral in polar coordinates fails too (this trick worked already in the last subexercise).

intPolar = integrand /. {x -> r Cos[φ], y -> r Sin[φ]} // Simplify

Integrate[intPolar r, {r, 0, Infinity}, {φ, 0, Pi/2}]

The structure of the integrand strongly suggests using the new variable u=x+y. A natural companion of this variable is v=x-y. This is the integrand after the change of variables.

intpm = (integrand /. Solve[{u == x + y, v == x - y}, {x, y}][[1]])/
        (* functional determinant from change of variables *)
        (Outer[D, {x + y, x - y}, {x, y}] // Det // Abs) // 
                                                Factor //@ #&

A moment of reflection shows that the new limits are u:0…∞, v:-u … u. Now, we obtain an explicit result for the integral in terms of a product of a Gamma function and a Gauss hypergeometric function.

Integrate[intpm, {u, 0, Infinity}, {v, -u, u}]

ℐ[ν_] = 3^ν 2^(-2ν) Gamma[2ν + 2] Hypergeometric2F1[1/2, -ν, 3/2, -1/3]

Here is a quick check of the result for integer ν. In this case, the direct calculation of the double integral in Cartesian coordinates is straightforward.

Table[Integrate[integrand, {x, 0, Infinity}, {y, 0, Infinity}] -
      ℐ[ν], {ν, 0, 12}]

(∫_0^1)d(Subscript[x, 1]^((1)))(∫_0^1)d(Subscript[x, 2]^((1)))⋯(∫_0^1)d(Subscript[x, 1]^((d)))(∫_0^1)d(((Subscript[x, 2]^((d)))(((((Subscript[x, 1]^((1)))-(Subscript[x, 2]^((1)))))^2)+⋯+ ((((Subscript[x, 1]^((d)))-(Subscript[x, 2]^((d)))))^2)))^(1/2)).

In general, the 2 d dimensional integral can be reduced to a d-dimensional one. The squares of the differences can be converted to a new variable with probability density 2(1-l). (The density 2(1-l) follows immediately from elementary geometric considerations.) This reduces by half the number of integrations that have to be carried out. For the mean distance in the unit square, we have the following by using the probability densities for the projections on the coordinate axes.

Integrate[Sqrt[x^2 + y^2] 2(1 - x) 2(1 - y), {x, 0, 1}, {y, 0, 1}]

The result can still be simplified somewhat.

% // FullSimplify

Here is the numerical result.

N[%]

For comparison, we now conduct a numerical test for 100000 pairs of points.

With[{num = 100000},
     (Plus @@ Table[Sqrt[(Random[] - Random[])^2 +
                         (Random[] - Random[])^2], {num}])/num]

The results for the 3D cube is given by the following expression:

(OverBar[x])=(1/420) (-210 log(2)+42 log(1+(Sqrt[2]))+42 log(2+(Sqrt[2]))+378 log(1+(Sqrt[3]))-21 log(2+(Sqrt[3]))+68 (Sqrt[2])-24 (Sqrt[3])-28 π+16).

In Mathematica, this can be calculated in the following way: Instead of trying to use definite integration, we use indefinite integration and substitute the limits by hand. The advantage is that we avoid that Mathematica has to check for singularities in intermediate expressions that still contain outer integration variables.

(* rewrite Logs with complicated arguments
   in Logs with simpler arguments *)
logRewrite[expr_] := FixedPoint[PowerExpand[# //.
         Log[a_] :> Log[Factor[Together[a]]]]&, TrigToExp[expr]]

(* calculate the indefinite integral wrt x, y, and z *)
Short[indefiniteIntegral =
Integrate[# 2(1 - z), z]& /@ Expand[logRewrite[
     Integrate[Integrate[Sqrt[x^2 + y^2 + z^2] *
                  2(1 - x), x] 2(1 - y), y]]], 18]

(* replace limit procedure *)
replaceLimits[expr_, xyz_] :=
Module[{exprNew = Expand[logRewrite[expr]] /.
        (* get rid of terms that would produce 0 Infinity and that 
           in the limit give 0 *) xyz^n_?Positive Log[xyz] -> 0, δ},
       δ = (exprNew /. xyz -> 1) - (exprNew /. xyz -> 0);
       (* in case direct substitution fails, use series expansion *)
       If[δ === Indeterminate, Normal[Series[exprNew, {xyz, 1, 0}]] - 
          Normal[Series[exprNew, {xyz, 0, 0}]], δ]]

(* substitute all limits *)
Fold[replaceLimits, indefiniteIntegral, {z, y, x}] // Together

FullSimplify[%]

N[%]

Collecting all logarithms, the last result can be further simplified to (4+17 (Sqrt[2])-6 (Sqrt[3])-7 π)/105 + log(4 (((3 (3+2 (Sqrt[2]))))^(1/2))+7 (Sqrt[2])+7)/5.

Here is the comparison with a numerical simulation.

Compile[{{n, _Integer}},
        Module[{sum = 0.},
             Do[sum = sum + Sqrt[(Random[] - Random[])^2 +
                              (Random[] - Random[])^2 +
                              (Random[] - Random[])^2],
                {n}]; sum/n]][10^6]

Carrying out the 3D integration numerically also yields the a similar result, namely. 0.661707.

NIntegrate[2(1 - x) 2(1 - y) 2(1 - z) Sqrt[x^2 + y^2 + z^2], 
           {x, 0, 1}, {y, 0, 1}, {z, 0, 1}]

In a similar way, we could calculate the average line length in a triangle. For the triangle with vertices {0,0}, {1,0}, {0,1}, we obtain the value (1+4 (2^(1/2))+arcsinh(1) (4+(2^(1/2))))/30 =0.41429….

For an asymptotic expansion for the k-dimensional case, see [49✶]; for the shape that minimizes the average value of the distance, see [131✶].

InverseLaplaceTransform[1/Sqrt[x], x, p]

Here is the resulting integral after exchanging the integration order.

ℐ(a,b,c)=(1/(Sqrt[π]))(∫_0^∞)(1/(Sqrt[s]))((∫_0^∞)(∫_0^∞)(∫_0^∞)(e^(-s(x+y+z)))(e^(-x-y-z))sin(a x + b y + c z)dz dy dx)ds .

This yields the following input for the calculation of ℐ(a,b,c). Mathematica can calculate the resulting fourfold integral.

1/Sqrt[Pi] Integrate[
Integrate[1/Sqrt[s] Exp[-(1 + s) (x + y + z)] Sin[a x + b y + c z],
          {x, 0, Infinity}, {y, 0, Infinity}, {z, 0, Infinity},
          Assumptions -> Re[s] > 0, GenerateConditions -> False], 
          {s, 0, Infinity}] // (* abbreviate *) Short[#, 6]&

Here is a concise way of writing the last integral. It nicely shows its structure and its symmetry.

𝒯[a_, b_, c_] = 
With[{𝓈 = Sqrt, 𝕤 = Sign}, I Sqrt[Pi]*
     ((c - b) 𝓈[-I + b] 𝓈[I + b] 𝓈[-I + c] 𝓈[I + c] 
      (𝓈[ I + a] 𝓈[-I/𝕤[-I + a]] 𝓈[𝕤[-I + a]] - 
       𝓈[-I + a] 𝓈[ I/𝕤[ I + a]] 𝓈[𝕤[ I + a]]) + 
      (a - c) 𝓈[-I + a] 𝓈[I + a] 𝓈[-I + c] 𝓈[I + c] 
      (𝓈[ I + b] 𝓈[-I/𝕤[-I + b]] 𝓈[𝕤[-I + b]] - 
       𝓈[-I + b] 𝓈[ I/𝕤[ I + b]] 𝓈[𝕤[ I + b]]) + 
      (b - a) 𝓈[-I + a] 𝓈[I + a] 𝓈[-I + b] 𝓈[I + b] 
      (𝓈[ I + c] 𝓈[-I/𝕤[-I + c]] 𝓈[𝕤[-I + c]] - 
       𝓈[-I + c] 𝓈[ I/𝕤[ I + c]] 𝓈[𝕤[ I + c]]))/
      (2 (a - b) (a - c) (b - c) 𝓈[-I + a]*
        𝓈[I + a] 𝓈[-I + b] 𝓈[I + b] 𝓈[-I + c] 𝓈[I + c])]

A numerical check at random complex parameter values confirms the last result.

With[{a = 1 + 1/4 I, b = Pi - 2/11 I, c = E + 1/Pi I, L = (* truncate *) 12},
     {(* numericalized symbolic result *) 𝒯[a, b, c] // N,
      (* numerical integration result *) 
      NIntegrate[Exp[-(x + y + z)] Sin[a x + b y + c z]/Sqrt[x + y + z],
                {x, 0, L}, {y, 0, L}, {z, 0, L}, Method -> GaussKronrod]}]

The value ℐ(1,1,1) cannot be obtained by substitution because indeterminate expressions arise. Expanding ℐ(a,b,c) in a series around {a,b,c}={1,1,1} gives the result (π^(1/2))3/32 (((1+(2^(1/2))))^(1/2)).

𝒯[1, 1, 1]

Sqrt[Pi] FullSimplify[Simplify[ExpandAll[Normal[Simplify[Series[
  Limit[Limit[FunctionExpand[𝒯[a, b, c]], a -> b], b -> c], {c, 1, 0}]]]]/Sqrt[Pi]]]

For real a, b, c, we would prefer a manifestly real result. By using the following two simplifications, we arrive at the expression ℐReal[a, b, c].

FullSimplify[Sqrt[abc - I] Sqrt[abc + I], abc > 0]

ComplexExpand[FunctionExpand[Sqrt[-I/Sign[abc - I]] Sqrt[Sign[abc - I]]], 
                   TargetFunctions -> {Re, Im}] // Simplify[#, abc > 0]&

f[a_, b_, c_] = -Sqrt[2] (a - b) Sqrt[1 + a^2] Sqrt[1 + b^2]*
                 Sqrt[c^2]/c Sqrt[Sqrt[1 + c^2] - 1];

(* integral is a symmetric function in a, b, c *)                 
ℐReal[a_, b_, c_] = Sqrt[Pi] (f[a, b, c] + f[b, c, a] + f[c, a, b])/
                           (2 (a - c) (b - c) (a - b)*
                            Sqrt[1 + a^2] Sqrt[1 + b^2] Sqrt[1 + c^2])

For a=b=c=1, we again obtain the result 3/32 (((1+(2^(1/2))))^(1/2)).

Series[Series[ℐReal[a, b, c], {b, a, 0}], {c, a, 0}] // Normal // FullSimplify

% /. a -> 1 // FullSimplify

Y = Sum[ε^i y[i][t], {i, 0, 6}] + O[ε]^7

We substitute the series into the differential equation.

eqs = Factor[Numerator[Together[#]]]& /@ 
       CoefficientList[Normal[D[Y, {t, 2}] + Y + ε Y^3], ε];

The first equation becomes the following.

eqs[[1]]

Taking the initial conditions into account, the solution is simply cos.

solList = {y[0] -> (Cos[#]&)}

Now we recursively solve for the higher orders with homogeneous boundary conditions.

Do[(* substitute already calculated solutions *)
   eq[i] = eqs[[i + 1]] //. solList;
   (* solve for next solutions *)
   sol[i] = DSolve[{eq[i] == 0, y[i][0] == 0, y[i]'[0] == 0}, 
                   y[i], t][[1, 1]];
   AppendTo[solList, sol[i]], {i, 5}] // Timing

These are the first terms of the series.

Sum[ε^i y[i][t], {i, 0, 5}] /. solList

We calculate a numerical solution of the differential equation for ε=1/10.

ε = 10^-1;
nSol = NDSolve[{y''[t] + y[t] + ε y[t]^3 == 0, 
                y[0] == 1, y'[0] == 0}, y[t], {t, 0, 8/ε}];

The numerical solution together with the series solutions to various orders in ϵ are shown here.

Show[{(* the numerical solution *)
      Plot[Evaluate[y[t] /. nSol], {t, 0, 8/ε},
           PlotPoints -> 250, DisplayFunction -> Identity,
           PlotStyle -> {{GrayLevel[0], Thickness[0.005]}}],
      Table[(* partial sums of the symbolic solution *)
            Plot[Evaluate[Sum[ε^i y[i][t], {i, 0, j}] /. solList], 
                 {t, 0, 8/ε}, PlotPoints -> 250,
                 DisplayFunction -> Identity,
                 PlotStyle -> {{Hue[0.8 j/5], Thickness[0.002]}}], 
            {j, 0, 5}]}, DisplayFunction -> $DisplayFunction, 
      Frame -> True, Axes -> False]

For easier comparison, we calculate and plot the differences between the numerical and the series solutions in the (Subscript[L, 2])-norm.

Do[d[j] = (* solve differential equation for differences *)
   NDSolve[{diff'[t] == ((y[t] /. First[nSol]) - 
           (Sum[ε^i y[i][t], {i, 0, j}] /. solList))^2,
             diff[0] == 0}, diff[t], {t, 0, 8/ε}], {j, 0, 5}];

Show[Table[
Plot[Evaluate[diff[t] /. d[j]], {t, 0, 8/ε}, 
     PlotPoints -> 250, DisplayFunction -> Identity,
     PlotStyle -> {{Hue[0.8 j/5], Thickness[0.002]}}], 
         {j, 0, 5}], DisplayFunction -> $DisplayFunction,
                     Frame -> True, Axes -> False]

For more general perturbation methods of oscillators, see [92✶], [504✶], [1689✶], and [1245✶].

For the case of general initial conditions, we proceed similarly as above. We will impose general initial conditions to (Subscript[y, 0])(t) and vanishing boundary conditions to all other (Subscript[y, k])(t).

ε =.;
Y = Sum[ε^i y[i][t], {i, 0, 4}] + O[ε]^5;
eqs = Factor[Numerator[Together[#]]]& /@ 
       CoefficientList[Normal[D[Y, {t, 2}] + Y + ε Y^3], ε];

For a more concisely written result we define a function writeNice. It collects terms with respect to the initial conditions.

writeNice  := (a_ -> b_) :> (a -> Internal`FromDistributedTermsList[
      Factor @ Internal`DistributedTermsList[b, {𝕒, 𝕓}]])

Now the solution for the zeroth order is (Subscript[y, 0])(t)=𝕒 cos(t)+𝕓 sin(t).

solList = DSolve[{eqs[[1]] == 0, y[0][0] == 𝕒, y[0]'[0] == 𝕓}, 
                y[0][t], t][[1]]

Iterating backsubstitution and differential equation solving, we obtain the following result.

Do[eq[k] = eqs[[k]] //. solList;
   solList = Append[solList, 
   DSolve[{eq[k] == 0, y[k - 1][0] == 0, y[k - 1]'[0] == 0}, 
          y[k - 1][t], t][[1, 1]] /. writeNice], {k, 2, 4}];

solList // Short[#, 16]& // TraditionalForm

Here is a quick check of the so-obtained solution.

𝓎[t_] = Y + O[ε]^4 /. solList;
{𝓎[0], 𝓎'[0], 𝓎''[t] + 𝓎[t] + ε 𝓎[t]^3}

o = 12;

Ω = Sum[ϵ^k Subscript[ω, k], {k, 0, o}];
X = ϵ Sum[ϵ^k Subscript[x, k][t], {k, 0, o}];

ϵSer = Ω^2 D[X, t, t] + Subscript[ω, 0]^2 X - 
       Sum[Subscript[J, k]/k! X^k, {k, 2, o}] + O[ϵ]^o;

ϵTerms = ϵSer[[3]];

Here are the first three resulting differential equations.

Table[ϵTerms[[j]], {j, 3}]

We see that the inhomogeneous part of the differential equation for (Subscript[x, k])(t) depends only the earlier (Subscript[x, j])(t):

(Subscript[ω, 0]^2)(((∂^2)(Subscript[x, k])(t))/(∂(t^2)))+(Subscript[ω, 0]^2)(Subscript[x, k])(t)=(Subscript[p, k])((Subscript[x, 0])(t),…,(Subscript[x, k-1]^″)(t),(Subscript[ω, 0]),…,(Subscript[ω, k-1]),(Subscript[J, 2]),…,(Subscript[J, k+1])).

We will store the already obtained results for the (Subscript[x, k])(t) and the (Subscript[ω, k]) in the two lists xRules and ωRules. For the zeroth order we only have a nontrivial result for (Subscript[x, 0])(t).

xRules = {Subscript[x, 0] -> 
             Function[t, Subscript[c, "s", 0] Cos[t]]};
ωRules = {};

Now we consider the first order. The resulting differential equation for (Subscript[x, 1])(t) is the following.

μ = 1;
ode = ϵTerms[[μ + 1]] //. xRules //. ωRules

Solving this differential equation is straightforward.

dsol = ExpandAll[TrigFactor //@ 
        DSolve[ode == 0, Subscript[x, μ][t], t]] /.
        (* rename constants *)
        {C[_] Cos[t] :> Subscript[c, "c", μ] Cos[t],
         C[_] Sin[t] :> Subscript[c, "s", μ] Sin[t]}

To get a periodic solution for (Subscript[x, 1])(t), we cannot afford the term (Subscript[c, s,0])t sin(t) (Subscript[ω, 1])/(Subscript[ω, 0]). In general, the secular terms (meaning linearly growing in t) of the form t periodicFunctionInt spoil the periodicity and must be eliminated [1073✶].

secularTerms = Plus @@ Cases[dsol[[1, 1, 2]], t^_. _]

With the (Subscript[ω, k]), k≥1 to be determined, we get the condition (Subscript[ω, 1])=0 for a periodic (Subscript[x, 1])(t).

ωCondition = Factor //@ Solve[secularTerms == 0, Subscript[ω, μ]]

We now use the condition (Subscript[ω, 1])=0 to obtain the final periodic solution for (Subscript[x, 1])(t).

ωRules = AppendTo[ωRules, ωCondition[[1, 1]]];

dsolG = ExpandAll[dsol //. ωRules];

xRules = AppendTo[xRules, Subscript[x, μ] -> 
                    Function[t, Evaluate[dsolG[[1, 1, 2]]]]]

It seems now straightforward to wrap up the last inputs in a Do-loop to calculate (Subscript[x, 2])(t) to (Subscript[x, 10])(t). We just expect all results to become a bit larger for the higher orders. Unfortunately they do not just become a bit larger, but considerable larger. So before calculating the higher orders of the (Subscript[x, k])(t) we will pause a moment and ponder about some optimizations. For the higher orders, the inhomogeneous term in (Subscript[ω, 0]^2)(Subscript[x, k]^″)(t)+(Subscript[ω, 0]^2)(Subscript[x, k])(t)=(Subscript[p, k]) will be a large sum. When DSolve calculates the inhomogeneous solution, DSolve will carry out integrals of the form ∫sin(t) (Subscript[p, k])dt and ∫cos(t) (Subscript[p, k])dt. These integrals will take a while to evaluate for large expressions (Subscript[p, k]) with head Plus. So, we implement a optimized function 𝒟𝒮ℴℓ𝓋ℯ for this purpose. It carefully constructs the solution of (Subscript[ω, 0]^2)(Subscript[x, k]^″)(t)+(Subscript[ω, 0]^2)(Subscript[x, k])(t)=(Subscript[p, k]). The solution is

(* general solution *)
sol = c1 Cos[t] + c2 Sin[t] -
      Cos[t] Integrate[pk[t] Sin[t], t] + 
      Sin[t] Integrate[pk[t] Cos[t], t];
(* check *)
D[sol, t, t] + sol - pk[t] // Simplify

𝒟𝒮ℴℓ𝓋ℯ[lhs_ == 0, Subscript[x_, μ_][t_], t_] := 
Module[{f = Expand[lhs - Subscript[ω, 0]^2 *
            (Subscript[x, μ]''[t] + Subscript[x, μ][t])]},
 {{Subscript[x, μ][t] -> Expand[
   (* homogeneous solution *)
   Subscript[c, "c", μ] Cos[t] + Subscript[c, "s", μ] Sin[t] -
   (* inhomogeneous solution *)
   (-Cos[t] ℐ𝓃𝓉ℯℊ𝓇𝒶𝓉ℯ[f Sin[t], t] + 
     Sin[t] ℐ𝓃𝓉ℯℊ𝓇𝒶𝓉ℯ[f Cos[t], t])/Subscript[ω, 0]^2]}}]

We handle the integrals ∫sin(t) (Subscript[p, k])dt and ∫cos(t) (Subscript[p, k])dt with the specialized function ℐ𝓃𝓉ℯℊ𝓇𝒶𝓉ℯ𝒞ℴ𝓈𝒮𝒾𝓃. This function first collects the terms of (Subscript[p, k]) with respect to (sin^a)(t)(cos^b)(t), and then uses a look-up for these integrals.

ℐ𝓃𝓉ℯℊ𝓇𝒶𝓉ℯ[f_, t_] := With[{𝒻 = Expand[f]}, 
  If[Head[𝒻] === Plus, ℐ𝓃𝓉ℯℊ𝓇𝒶𝓉ℯ𝒞ℴ𝓈𝒮𝒾𝓃[𝒻, t], Integrate[𝒻, t]]]

ℐ𝓃𝓉ℯℊ𝓇𝒶𝓉ℯ𝒞ℴ𝓈𝒮𝒾𝓃[f_, t_] := 
Module[{cosSinPoly, coeffs},
 cosSinPoly = Expand[Plus @@ (TrigExpand /@ (List @@ Expand[f]))];
 (* collect wrt powers of Sin[t] and Cos[t] *)                     
 coeffs = Internal`DistributedTermsList[cosSinPoly, 
                                   {Cos[t], Sin[t]}][[1]];
 (* integrate and expand *) 
 Expand[Plus @@ ((CosSinIntegral[#1] #2)& @@@ coeffs)]]

(* cached integrals *)
CosSinIntegral[{m_, n_}] := CosSinIntegral[{m, n}] = 
             TrigExpand[Integrate[Cos[t]^m Sin[t]^n, t]]

By adding some other optimizations (like preprocessing the differential equation using Together before substituting the already calculated results for the (Subscript[x, k])(t)), we have the following modification of the above code for (Subscript[x, 1])(t). Now it takes a couple of minutes to calculate (Subscript[x, 2])(t) to (Subscript[x, 10])(t).

Do[(* the ODE for the current order *)
   ode = Together[ϵTerms[[μ + 1]]] //. xRules //. ωRules;
   (* solve ODE *)
   dsol = 𝒟𝒮ℴℓ𝓋ℯ[ode == 0, Subscript[x, μ][t], t];
    (* secular terms *)
   secularTerms = Factor[Plus @@ Cases[dsol[[1, 1, 2]], t^_. _]];
   (* condition for the current ω *)
   ωCondition = Factor //@ Solve[secularTerms == 0, Subscript[ω, μ]];
   (* update ωRules and ωRules *) 
   ωRules = AppendTo[ωRules, ωCondition[[1, 1]]];
   dsolG = ExpandAll[dsol //. ωRules];
   xRules = AppendTo[xRules, Subscript[x, μ] -> 
                      Function[t, Evaluate[dsolG[[1, 1, 2]]]]],
    {μ, 2, o - 2}]

The resulting conditions on the (Subscript[ω, k]) are of the form (Subscript[ω, k])=f((Subscript[ω, 0]),(Subscript[J, 2]),…,(Subscript[J, k+1]),(Subscript[c, c,0]),…,(Subscript[c, c,k-2]),(Subscript[c, s,1]),…,(Subscript[c, s,k-2])). As a function of k, they quickly grow in size.

{ByteCount /@ ωRules, LeafCount /@ ωRules,
 (* number of terms in the sum *)
 Length[Cases[#, _Plus, Infinity][[1]]]& /@ Rest[ωRules]}

Length[Cases[#, _Plus, Infinity][[1]]]& /@ Rest[ωRules]

Here are the first three of the resulting conditions on the (Subscript[ω, k]).

Take[ωRules, 3] // TraditionalForm

Here is an abbreviated version for the condition on (Subscript[ω, 10]).

ωRules[[-1]] // Short[#, 12]& // TraditionalForm

ParametricPlot[{Sin[ϑ], Cos[ϑ]^3/2}, {ϑ, 0, 2Pi},
               AspectRatio -> Automatic]

This curve has the following implicit representation.

Numerator[Together[#]]& /@ ({x, y} - {Sin[ϑ], Cos[ϑ]^3/2} /. 
   {Sin[ϑ] -> 2s/(1 + s^2), Cos[ϑ] -> (1 - s^2)/(1 + s^2)})

Factor[Resultant[##, s]& @@ %]

Here is a visualization of the implicit representation.

ContourPlot[-1 + 3 x^2 - 3 x^4 + x^6 + 4 y^2, 
            {x, -3/2, 3/2}, {y, -1, 1}, 
            PlotPoints -> 80, Contours -> {0}]

We rotate this curve around the x-axis.

{{1, 0, 0}, {0, Cos[φ], Sin[φ]}, {0, -Sin[φ], Cos[φ]}}.
 {Sin[ϑ], 1/2 Cos[ϑ]^3, 0}

The resulting formula describes a spindle.

ParametricPlot3D[Evaluate[%], {φ, 0, Pi}, {ϑ, 0, 2Pi},
                 PlotPoints -> {20, 21}]

First, we generate a rational parametrization for the spindle.

{x, y, z} - {Sin[ϑ], Cos[φ] Cos[ϑ]^3/2, -Cos[ϑ]^3 Sin[φ]/2} /. 
            {Sin[ϑ] -> 2 s/(1 + s^2), Cos[ϑ] -> (1 - s^2)/(1 + s^2), 
             Sin[φ] -> 2 u/(1 + u^2), Cos[φ] -> (1 - u^2)/(1 + u^2)}

Then, we generate an equivalent system of polynomials.

Numerator[Together[#]]& /@ %

From the polynomials, we eliminate the parameterization variables s and u and get rid of unimportant factors.

Factor /@ GroebnerBasis[%, {x, y, z}, {s, u}, 
                        MonomialOrder -> EliminationOrder]

Here is a graphics check for the correctness of the so-obtained result—we display the surface defined by the implicit formula.

Needs["Graphics`ContourPlot3D`"]

ContourPlot3D[-1 + 3x^2 - 3x^4 + x^6 + 4y^2 + 4z^2,
              {x, -1, 1}, {y, -1/2, 1/2}, {z, -1/2, 1/2},
              PlotPoints -> {30, 20, 20}, MaxRecursion -> 0,
              PlotRange -> All]

In this case, we could have obtained the implicit equation easier. Because the implicit equation of the cross section had the form (Subscript[p, 1])(x)+(Subscript[p, 2])(y), because of symmetry, the 3D polynomial must have the form (Subscript[p, 1])(x)+(Subscript[p, 2])(y)+(Subscript[p, 2])(z).

{x^3, y^3, z^3} - {Cos[φ] Sin[ϑ], Sin[φ] Sin[ϑ], Cos[ϑ]} /. 
  {Sin[ϑ] -> 2 s/(1 + s^2), Cos[ϑ] -> (1 - s^2)/(1 + s^2), 
   Sin[φ] -> 2 u/(1 + u^2), Cos[φ] -> (1 - u^2)/(1 + u^2)}

Numerator[Together[#]]& /@ %

Eliminating the parametrization variables s and u gives the following result.

Factor[GroebnerBasis[%, {x, y, z}, {s, u}, 
                     MonomialOrder -> EliminationOrder]]

Obviously, the last factor is the equation needed.
Here are pictures of the parametric cube rooted sphere and the implicit one.

Needs["Graphics`ContourPlot3D`"]


Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{(* parametric form *)
 Module[{cubeRoot}, 
    (* use real root *)
    cubeRoot[x_] := If[x > 0, x^(1/3), -(-x)^(1/3)]; 
    ParametricPlot3D[Evaluate[cubeRoot /@ 
                     {Cos[φ] Sin[ϑ], Sin[φ] Sin[ϑ], Cos[ϑ]}], 
                     {φ, 0, 2 Pi}, {ϑ, 0, Pi}]],
 (* implicit form *)
 ContourPlot3D[x^6 + y^6 + z^6 - 1, {x, -1, 1}, {y, -1, 1}, {z, -1, 1},
              PlotPoints -> 20, MaxRecursion -> 0, PlotRange -> All]}]]]

ParametricPlot3D[Evaluate[{Cos[φ] Sin[ϑ], Sin[φ] Sin[ϑ], Cos[ϑ]}^3],
	             {φ, 0, 2Pi}, {ϑ, 0, Pi}, 
	             PlotRange -> All, PlotPoints -> 30]

In a similar way as the last example, we replace the trigonometric functions by corresponding rational parametrizations and polynomialize everything.

{x, y, z} - {Cos[φ] Sin[ϑ], Sin[φ] Sin[ϑ], Cos[ϑ]}^3 /. 
  {Sin[ϑ] -> 2 s/(1 + s^2), Cos[ϑ] -> (1 - s^2)/(1 + s^2), 
   Sin[φ] -> 2 u/(1 + u^2), Cos[φ] -> (1 - u^2)/(1 + u^2)}

eqs = Numerator[Together[#]]& /@ %

Unfortunately, this time a call to GroebnerBasis with
Factor[GroebnerBasis[eqs, {x, y, z}, {s, u},
       MonomialOrder -> EliminationOrder]]
will not return in a reasonable time. So we guide the calculation by hand.

The last equation does not contain the variable u; so we eliminate u from the first two equations.

Short[polyIns = Factor[Resultant[eqs[[1]], eqs[[2]], u]], 22]

polyIns contains only even powers of s, as the last equation of the polynomialized equation does.

Cases[polyIns, s^_, Infinity] // Union

Thinking of the formula Resultant[p[x^n], q[x^n], x]==Resultant[p[y], q[y], y]^n, where n is integer, we introduce a new parameter S==s^2. We use the nontrivial factor of polyIns only.

Short[res = Factor[Resultant[polyIns[[-1]] /. s^(n_) :> S^(n/2), 
                             eqs[[-1]] /. s^(n_) :> S^(n/2), S]], 22]

Here, the cubed sphere is shown using the implicit representation.

Needs["Graphics`ContourPlot3D`"]

(* one-eight of the surface *)
cp3D = ContourPlot3D[Evaluate[N[res[[-1]]]], 
                     {x, 0, 1}, {y, 0, 1}, {z, 0, 1}, 
                     PlotPoints -> {15, 3}, MaxRecursion -> 1, 
                     PlotRange -> All, DisplayFunction -> Identity];

Show[Graphics3D[{EdgeForm[], 
      {#, Map[{-1, 1, 1}#&, #, {-2}]}&[
         {#, Map[{1, -1, 1}#&, #, {-2}]}&[
            {#, Map[{1, 1, -1}#&, #, {-2}]}&[
                Cases[cp3D, _Polygon, Infinity]]]]}]]

parametrization =	
{3 Cos[φ1] + Cos[φ1]( Cos[φ1] Cos[φ2]^3 + Sin[φ1] Sin[φ2]^3),
 3 Sin[φ1] + Sin[φ1]( Cos[φ1] Cos[φ2]^3 + Sin[φ1] Sin[φ2]^3),
                    (-Sin[φ1] Cos[φ2]^3 + Cos[φ1] Sin[φ2]^3)};

Here, a picture of the twisted torus is shown.

ParametricPlot3D[Evaluate[parametrization], {φ1, 0, 2 Pi}, {φ2, 0, 2 Pi},
                 PlotPoints -> {72, 23}]

Using GroebnerBasis, we eliminate the parameter variables.

Short[res = GroebnerBasis[Join[parametrization - 
             {x, y, z}, {Sin[φ1]^2 + Cos[φ1]^2 - 1, 
                         Sin[φ2]^2 + Cos[φ2]^2 - 1}], {x, y, z}, 
             {Cos[φ1], Sin[φ1], Cos[φ2], Sin[φ2]}, 
            MonomialOrder -> EliminationOrder], 6]

Due to the sharp edges, a picture of the implicit form needs many plot points.

Needs["Graphics`ContourPlot3D`"]

Off[CompiledFunction::cfn];
ContourPlot3D[Evaluate[N[res[[-1]]]],
              {x, -4.5, 4.5}, {y, -4.5, 4.5}, {z, -1.5, 1.5},
              PlotPoints -> {{20, 4}, {20, 4}, {10, 4}},
              MaxRecursion -> 1, PlotRange -> All]

parametrization = {{Cos[φ], Sin[φ], 0}, {-Sin[φ], Cos[φ], 0},
                   {0, 0, 1}}.(Cos[φ/4]^2 {Cos[s], 0, Sin[s]});

Here is a graphic showing this surface.

ParametricPlot3D[Evaluate[parametrization], 
                 {s, -Pi, Pi}, {φ, 0, 4Pi}, PlotRange -> All]

To get a better view of the inner parts, we cut some holes in the polygons of the last surface.

makeHole[Polygon[l_], factor_] :=
Module[{mp = Plus @@ l/Length[l], newPoints, nOld, nNew},
       newPoints = (mp + factor(# - mp))& /@ l;
       nOld = Partition[Append[#, First[#]]&[l], 2, 1];
       nNew = Partition[Append[#, First[#]]&[newPoints], 2, 1];
       {MapThread[Polygon[Join[#1, Reverse[#2]]]&, {nOld, nNew}],
        Line[Append[#, First[#]]]&[newPoints]}]

Show[Graphics3D[
{EdgeForm[], Thickness[0.002], (* add some color *)
 SurfaceColor[RGBColor[1, 0, 0], RGBColor[0, 0, 1], 2.12],
 Cases[ParametricPlot3D[Evaluate[
        parametrization], {s, -Pi, Pi}, {φ, 0, 4Pi},
   PlotRange -> All, DisplayFunction -> Identity,
   PlotPoints -> {20, 40}], _Polygon, Infinity] /.
        (* cut holes into polygons *)
         p_Polygon :> makeHole[p, 0.75]}],
              PlotRange -> {{-1, 1}, {-1, 1}, {-1, 0}}]

Again, using the GroebnerBasis command with EliminationOrder easily yields the implicit representation we are looking for.

Short[res = Factor /@ GroebnerBasis[Join[TrigExpand[
    parametrization /. {φ -> 4φ}] - {x, y, z},
     {Cos[φ]^2 + Sin[φ]^2 - 1, Cos[s]^2 + Sin[s]^2 - 1}],
     {x, y, z}, {Cos[φ], Sin[φ], Cos[s], Sin[s]}], 8]

The ContourPlot3D verifies the correctness of the calculated implicit form.

Needs["Graphics`ContourPlot3D`"]

ContourPlot3D[Evaluate[N[res[[1]]]],
              {x, -1.15, 1.15}, {y, -1.15, 1.15}, {z, -1.15, 0},
              PlotPoints -> {25, 25, 18}, MaxRecursion -> 0]

Here is again a picture with holes in the polygons.

Show[Graphics3D[{EdgeForm[], Thickness[0.002],
SurfaceColor[Hue[0.45], Hue[0.34], 2.12],
  Cases[%, _Polygon, Infinity] /. 
     p_Polygon :> makeHole[p, 0.75]}], PlotRange -> All]

This is the function to be drawn.

f[e_] = ArcCos[Cos[Sqrt[e]] + 4/Sqrt[e] Sin[Sqrt[e]]];

Here are the real and the imaginary parts slightly above and below the imaginary axis.

(* small number to avoid discontinuities *) ε = 10^-8;
Show[GraphicsArray[
Function[pm, Plot[Evaluate[#[f[er  + pm I ε]]], {er, -50, 200},
                  DisplayFunction -> Identity, Frame -> True,
                  Axes -> False]& /@ {Re, Im}]]] /@ {+1, -1}

Trying to use Plot3D[Im[…]] results in a graphic with some discontinuities.

Plot3D[Evaluate[Im[f[er + I ei]]], {er, -10, 60}, {ei, -10, 10},
       PlotRange -> All, PlotPoints -> 80]

Most of the discontinuities are all of the following type.

Plot3D[Im[ArcCos[3/2 - (er + I ei)^2]], {er, -3/2, 3/2}, {ei, -1, 1},
       PlotRange -> All, PlotPoints -> 40]

The discontinuities seen in the picture are due to the branch cuts of ArcCos.

Plot3D[Im[-ArcCos[(er + I ei)]], {er, -2, 2}, {ei, -1, 1},
       PlotRange -> All, PlotPoints -> 40]

The discontinuities along the real axis of Im[f[e]] start and end when the expression cos((Sqrt[e]))+4/(Sqrt[e]) sin((Sqrt[e])) equals ±1. Here are these values calculated.

bandEdges =
Apply[(e /. FindRoot[Cos[#1] == Cos[Sqrt[e]] + 4/Sqrt[e] Sin[Sqrt[e]],
         {e, #2}, AccuracyGoal -> 25, WorkingPrecision -> 30])&,
{{0, 4}, {Pi, 10}, {Pi, 20}, {0, 39}, {0, 51}, 
 {Pi, 88}, {Pi, 103}, {0, 156}, {0, 173}, {Pi, 250}}, {1}]

Between the bandEdges, the function f[e] is purely real.

pic = Show[Apply[
Plot[Evaluate[f[e]], {e, #1 + ε, #2 - ε}, 
     DisplayFunction -> Identity]&, Partition[bandEdges, 2], {1}], 
     DisplayFunction -> $DisplayFunction, PlotRange -> All]

Adding multiples of π, we can redraw the last picture in the following way.

Show[Graphics[{{Thickness[0.01], GrayLevel[0.7],
 Line[Table[{e, Sqrt[e]}, {e, 0, 250}]]},
MapIndexed[If[OddQ[#2[[1]]],
              {#[[1]], +#1[[2]] + (#2[[1]] - 1) Pi},
              {#[[1]], -#1[[2]] +  #2[[1]] Pi}]&,
                      Cases[#, _Line, Infinity]& /@ pic[[1]], 
            {-2}]} // N], PlotRange -> All, Frame -> True]

Slightly more common is the following picture, which is obtained by interchanging K and e.

Show[Graphics[
{#, Map[{-1, 1}#&, N[#], {-2}]}& @
MapIndexed[If[OddQ[#2[[1]]],
           {+#1[[2]] + (#2[[1]] - 1) Pi, #1[[1]]},
           {-#1[[2]] +  #2[[1]] Pi, #1[[1]]}]&,
                      Cases[#, _Line, Infinity]& /@ pic[[1]], {-2}]],
           PlotRange -> All, Frame -> True,
           FrameTicks -> {Table[{i Pi, i Pi}, {i, -5, 5}], 
                         Automatic, None, None}]

Now we must deal with the lines of singularities that originate between two band edges and go into the complex plane. This kind of singularity is caused by having the imaginary part of f[e] change its sign. Here are the lines where this happens.

ContourPlot[Im[f[er + I ei]], {er, -100, 250}, {ei, -30, 30}, 
            PlotPoints -> 100, Contours -> {0}, ContourShading -> False]

We can get an implicit equation describing these lines by taking the real part of f[e].

Imf = Plus @@ (Cases[Expand[ComplexExpand[Cos[Sqrt[er + I ei]] + 
                       4/(Sqrt[er + I ei]) Sin[Sqrt[er + I ei]]] /. 
         {Abs[I ei + er] -> Sqrt[er^2 + ei^2],
          Arg[I ei + er] -> ArcTan[er, ei]}], _Complex _]/I)

By viewing er as a function of ei in the last equation, we see that the following expression must be zero.

Imf1 = Imf /. er -> er[ei]

Differentiating this expression with respect to ei and solving for er'[ei] gives us a differential equation for these lines.

Short[ode = Equal @@ (Solve[D[Imf1, ei] == 0, er'[ei]][[1, 1]]), 12]

Let us solve the resulting differential equation numerically. The fri are the initial conditions.

fr1 = er /. FindRoot[Evaluate[Imf == 0 /. ei -> 1], {er, 15},
                     WorkingPrecision -> 22, AccuracyGoal -> 20]

ε = 10^-9; (* starting slightly away from 0 *)
nsol1 = NDSolve[{ode, er[1] == fr1}, er, {ei, ε, 10},
                PrecisionGoal -> 12, MaxSteps -> 5000][[1, 1, 2]]

fr2 = er /. FindRoot[Evaluate[Imf == 0 /. ei -> 1], {er, 45},
                     WorkingPrecision -> 22, AccuracyGoal -> 20]

nsol2 = NDSolve[{ode, er[1] == fr2}, er, {ei, ε, 10},
                PrecisionGoal -> 12, MaxSteps -> 5000][[1, 1, 2]]

Here are the resulting curves.

ParametricPlot[Evaluate[{{nsol1[ei], ei}, {nsol2[ei], ei}}],
               {ei, ε, 10}]

Now we have the location of all discontinuities and we can subdivide the upper-half-plane into regions in such a way that inside these regions, f[e] is a smooth function.

makePart[reim_, {left_, right_}, {ppr_, ppi_}] :=
Module[{erLeft, erRight, ε = 10^-3},
(* list of data points *)
Table[{erLeft, erRight} = {left[ei] + ε, right[ei] - ε};
      Table[{er, ei, reim[f[er + I ei]]},
            {er, erLeft, erRight, (erRight - erLeft)/ppr}],
      {ei, ε, 10, (10 - ε)/ppi}]];

(* the regions in the parameter plane; cut along branch cuts *)
regions = {{{-10.&, bandEdges[[1]]&}, {15, 40}}, 
           {{bandEdges[[1]]&, bandEdges[[2]]&}, {5, 40}}, 
           {{bandEdges[[2]]&, nsol1}, {4, 40}}, 
           {{nsol1, bandEdges[[3]]&}, {6, 40}}, 
           {{bandEdges[[3]]&, bandEdges[[4]]&}, {20, 40}}, 
           {{bandEdges[[4]]&, nsol2}, {6, 40}}, 
           {{nsol2, 60.&}, {15, 40}}};

ImSurfaceParts = Apply[makePart[Im, ##]&, regions, {1}];

Here, the resulting surface is shown.

Needs["Graphics`Graphics3D`"];

ImPolys1 = Cases[ListSurfacePlot3D[#, 
   DisplayFunction -> Identity]& /@ ImSurfaceParts, _Polygon, Infinity];

Show[Graphics3D[ImPolys1]]

Now we must calculate all other parts and sheets of the surface. Potential other sheets either come from the other sheet of the square root or the arccos function. Switching to the other sheet of the square root does not change f[e].

f[e] == (f[e] /. Power[e, pmOneHalf_] -> -Power[e, pmOneHalf])

Now let us make use of the other sheets of arccos. Rewriting ArcCos in logarithms and square roots shows that we must look at the other sheets of the square root and the logarithm function.

ArcCos[x] // TrigToExp

The other sheets of the logarithm do not contribute here because they are different from the principal sheet by a purely imaginary quantity. The second sheet of the square root produces a second sheet in our picture. The value of f[e] on this sheet is simply the negative of the value from the first sheet. Here, the two sheets for ArcCos are shown.

Show[GraphicsArray[Function[pm, 
Plot3D[Im[Pi/2 + I Log[I (xr + I xi) + pm Sqrt[1 - (xr + I xi)^2]]],
       {xr, -2, 2}, {xi, -1, 1}, PlotPoints -> 20,
       DisplayFunction -> Identity]] /@ {+1, -1}]]

Now we generate all other parts of the surface and display them together.

ImPolys2 = {ImPolys1, Map[{1, 1, -1} #&, ImPolys1, {-2}]};
Show[Graphics3D[ImPolys2], BoxRatios -> {1, 1, 1}]

For a better view onto the two sheets of the surface, we could generate the corresponding part along the negative y-axis and make holes in the polygons.

ImPolys3 = {ImPolys2, Map[{1, -1, 1} #&, ImPolys2, {-2}]};

(* cut hole in each polygon *)
makeHole[Polygon[l_], factor_] :=
Module[{mp = Plus @@ l/Length[l], newPoints, nOld, nNew},
       newPoints = (mp + factor(# - mp))& /@ l;
       nOld = Partition[Append[#, First[#]]&[l], 2, 1];
       nNew = Partition[Append[#, First[#]]&[newPoints], 2, 1];
       {MapThread[Polygon[Join[#1, Reverse[#2]]]&, {nOld, nNew}]}];
       
(* display the whole surface *) 
Show[Graphics3D[{EdgeForm[], Thickness[0.002],
SurfaceColor[Hue[0.12], Hue[0.24], 2.5], ImPolys3}] /. 
      p_Polygon :> makeHole[p, 0.78], BoxRatios -> {1, 1, 3/4}]

For the more complicated problem of determining the Riemann surface of e(V) (defined implicitly via cos(K)= cos((e^(1/2)))+V (e^(-1/2)) sin((e^(1/2)))) as a function of the potential strength V, see [1576✶], [573✶].

ellipse[x_, y_] := x^2 + 4 y^2 - 4

This is the implicit representation of a line that joins the two points {x1, y1} and {x2, y2}.

line[{x_, y_}, {{x1_, y1_}, {x2_, y2_}}] =
     Numerator[Together[y - (y2 - y1)/(x2 - x1) (x - x1) - y1]]

The distance between the two points {x1, y1} and {x2, y2} is given by the following expression.

dist[{x1_, y1_}, {x2_, y2_}] = (x1 - x2)^2 + (y1 - y2)^2 - 1

Now we must calculate the envelope. If f(x,y,c) is a family of curves in the x,y-plane, parametrized by c, then the envelope (an implicit function of x and y) formed by this family is obtained by eliminating c from the two equations f(x,y,c) = 0, ∂f(x,y,c) /∂c=0.
In our case let the x-coordinate of the first point (Subscript[x, 1]) be the parameter to be eliminated. (Subscript[y, 1]) due to the defining equation of the ellipse as well as (Subscript[x, 2]) and (Subscript[y, 2]) (due to the distance restriction) are then implicitly depending on (Subscript[x, 1]).
So we have the following set of equations (it is important to take the derivatives of the individual equations into account, too, because they are algebraically independent from the equations).

{(* the first point lies on the ellipse *)
 ellipse[x1, y1[x1]], D[ellipse[x1, y1[x1]], x1],
 (* the second point lies on the ellipse *)
 ellipse[x2[x1], y2[x1]], D[ellipse[x2[x1], y2[x1]], x1],
 (* the distance between the two points is 1 *)
 dist[{x1, y1[x1]}, {x2[x1], y2[x1]}],
 D[dist[{x1, y1[x1]}, {x2[x1], y2[x1]}], x1],
 (* the line between the two points *)
 line[{x, y}, {{x1, y1[x1]}, {x2[x1], y2[x1]}}],
 D[line[{x, y}, {{x1, y1[x1]}, {x2[x1], y2[x1]}}], x1]}

Replacing the nested variables, we get the following polynomial system.

% /. {x2'[x1] -> x2s, y1'[x1] -> y1s, y2'[x1] -> y2s,
      y1[x1] -> y1, y2[x1] -> y2, x2[x1] -> x2}

From these equations, we must eliminate the variables x2s, y1s, y2s, x1, y1, x2, and y2. This is easily done using GroebnerBasis.

gb1 = GroebnerBasis[%, {x, y}, {x2s, y1s, y2s, x1, y1, x2, y2},
                    MonomialOrder -> EliminationOrder]

Here, this region is shown.

cp = ContourPlot[Evaluate[%[[1]]], {x, -2, 2}, {y, -1, 1}, 
                 PlotPoints -> 120, Contours -> {0},
                 ContourStyle -> {Thickness[0.005], RGBColor[0, 0, 1]},
                 ContourShading -> False, AspectRatio -> Automatic]

The routine makeLines calculates all line segments such that one point has the x-coordinate x.

makeLines[x_] :=
Module[{x1y1Sol = Prepend[#, x1 -> x]& /@
       (* calculate y coordinate of the first point *)  
        NSolve[x^2 + 4 y1^2 - 4 == 0, y1], x2y2Sol},
        x2y2Sol = Function[x1y1, Join[x1y1, #]& /@
        Select[(* calculate the second point *)
        NSolve[{x2^2 + 4 y2^2 - 4 == 0,
                (x1 - x2)^2 + (y1 - y2)^2 - 1 == 0} /. x1y1, {x2, y2}],
        And @@ (Im[#] == 0& /@ ({x2, y2} /. #))&]] /@ x1y1Sol;
       (* form the line *)
        Line[{{x1, y1}, {x2, y2}}] /. Flatten[x2y2Sol, 1]]

Here are some of these line segments together with the previously calculated envelope.

Show[{Graphics[{
  {Thickness[0.002], Hue[0], (* the ellipse itself *)
   Line[Table[{x,  Sqrt[4 - x^2]/2}, {x, -2, 2, 1/100}]],
   Line[Table[{x, -Sqrt[4 - x^2]/2}, {x, -2, 2, 1/100}]]},
  {Thickness[0.002], GrayLevel[1/2], (* the line segments *)
   Table[makeLines[x], {x, -2, 2, 1/10}]}}],
   (* the envelope *) cp} // N,
  PlotRange -> All, Frame -> True, AspectRatio -> Automatic]

fourLines = Flatten[
Table[a[i, j] + b[i, j] t[i] - ξ[i, j], {i, 4}, {j, 3}]] /.
      {a[_, 1] -> 0, b[_, 1] -> 1} /.
      {a[1, 2] -> 0, a[1, 3] -> 0, b[1, 2] -> 0, b[1, 3] -> 0,
       a[2, 1] -> 0, a[2, 2] -> 0, a[2, 3] -> 0, b[2, 3] -> 0}

The unknown intersecting line(s) we parametrize in a similar manner. These lines intersect four lines fourLines at ξ[i, j].

intersectingLines = 
Flatten[Table[A[j] + B[j] T[i] - ξ[i, j], {i, 4}, {j, 3}]] /.
              {A[1] -> 0, B[1] -> 1};

eqs = Join[fourLines, intersectingLines];

Now we have 24 equations with 4 unknowns A[2], A[3], B[2], and B[3], 9 parameters, and 20 variables to eliminate.

{Length[eqs], Length[Union[Cases[eqs, _A | _B, Infinity]]]& /@ 
              (* the variables *) {_A | _B, _a | _b, _ξ | _t | _T}}

In a first step, we eliminate all ξ, t, and T variables.

GroebnerBasis[eqs, {}, 
          Join[Union[Cases[eqs, _ξ, Infinity]], 
               Table[T[i], {i, 4}], Table[t[i], {i, 4}]],
          MonomialOrder -> EliminationOrder]

In a second step, we solve for the unknowns A[2], A[3], B[2], and B[3].

GroebnerBasis[%, {A[2], A[3], B[2], B[3]},
              CoefficientDomain -> RationalFunctions]

The last Gröbner basis is pseudotriangular. The equation in B[3] is quadratic. This means that generically two lines exist that intersect four (generic) lines.

Exponent[#, {A[2], A[3], B[2], B[3]}]& /@ %

These are the vertices of the triangle under consideration.

P1 = {0, 0}; P2 = {1, 0}; P3 = {1, 2}; Q = {qx, qy};

The normals of the three triangle sides are the following.

normal12 = {-1, 1} Reverse[P2 - P1];
normal23 = {-1, 1} Reverse[P3 - P2];
normal31 = {-1, 1} Reverse[P1 - P3];

These are the points where the ball is reflected.

P12 = P1 + r (P2 - P1); 
P23 = P2 + s (P3 - P2); 
P31 = P3 + t (P1 - P3);

The conditions for the reflections result in the following set of equations.

𝓃 = #/Sqrt[#.#]&;
eqs1 = Factor[Numerator[Together[#]]]& /@ 
  {(𝓃[Q   - P12].normal12)^2 - (𝓃[P23 - P12].normal12)^2,
   (𝓃[P12 - P23].normal23)^2 - (𝓃[P31 - P23].normal23)^2,
   (𝓃[Q   - P31].normal31)^2 - (𝓃[P23 - P31].normal31)^2}

Next we solve for the reflection points.

sol = Union[Solve[# == 0& /@ eqs1, {r, s, t}]] // Simplify

We have nine possible solutions.

Length[sol]

To see which of the solutions of sol describes reflection points inside the triangle, let us look at a “typical” configuration.

Block[{qx = 0.4, qy = 0.1, P12, P23, P31},
Show[GraphicsArray[
MapIndexed[Graphics[
{Thickness[0.02], Line[{P1, P2, P3, P1}],
 Thickness[0.002], Hue[0], (* billiard path *)
 {P12, P23, P31} = {P1 + r (P2 - P1), P2 + s (P3 - P2), 
                    P3 + t (P1 - P3)} /. N[#];  
  Line[{{qx, qy}, P12, P23, P31, {qx, qy}}]}, 
     PlotRange -> All, AspectRatio -> Automatic, FrameTicks -> None,
     Frame -> True, PlotLabel -> #2[[1]] + 1]&, Rest[sol]]]]]

So it is the seventh solution that is of interest to us.

goodSol = 
{r -> (2 qx^2 + 5 qy + 3 qx qy - 2 qy^2)/(2 qx + 4 qy), 
 t -> 1/10*(10 + 2 qx^2 - 3 qy - 2 qy^2 + qx (-4 + 3 qy)), 
 s -> (2 qx^2 + qy - 2 qy^2 + qx*(-2 + 3 qy))/(2 (-5 + qx + 2 qy))};

Here are 15 different paths with randomly chosen starting points for this case.

Block[{qx, qy, P12, P23, P31},
Show[Graphics[
 {{Thickness[0.02], GrayLevel[0], Line[{P1, P2, P3, P1}]},
  (* random start points *)
  Table[qx = Random[Real, {0.2, 0.4}]; qy = Random[Real, {0, qx}];
  {Thickness[0.002], Hue[Random[]], (* billiard path *)
  {P12, P23, P31} = {P1 + r (P2 - P1), P2 + s (P3 - P2), 
                     P3 + t (P1 - P3)} /. N[goodSol]; 
   Line[{{qx, qy}, P12, P23, P31, {qx, qy}}]}, {15}]}, 
    PlotRange -> All, Frame -> True, FrameTicks -> None,
    AspectRatio -> Automatic]]]

The square of the length of the balls flight.

pL = ((Q   - P12).(Q   - P12) + (P12 - P23).(P12 - P23) +    
      (P23 - P31).(P23 - P31) + (Q   - P31).(Q  -  P31))

Let us graphically look if there is a minimum somewhere.

With[{ε = 10^-6},
ContourPlot[Evaluate[Sqrt[pL /. sol[[7]]]], 
            {qx, ε, 1 - ε}, {qy, ε, 2 - ε}, PlotPoints -> 60, 
            Contours -> 30, ColorFunction -> (Hue[0.7 #]&)]]

Here is a magnification of the interesting area.

With[{ε = 10^-6},
ContourPlot[Evaluate[Sqrt[pL /. sol[[7]]]], 
            {qx, 0.2, 0.6}, {qy, 0, 0.2}, PlotPoints -> 60,  
            Contours -> 30, ColorFunction -> (Hue[0.7 #]&)]]

So it seems there is a minimum near qx==0.46, qy==0.08.

FindMinimum[Evaluate[Sqrt[pL /. sol[[7]]]], {qx, 0.46}, {qy, 0.08}]

As a warm-up for the following, let us calculate the exact coordinates of Q. We differentiate the square path length with respect to qx and qy to obtain two equations for qx and qy.

eqsxy = Factor[Numerator[Together[#]]]& /@ 
            ({D[pL /. goodSol, qx], D[pL /. goodSol, qy]})

We solve these two equations by eliminating qx and qy.

Factor[Resultant[##, qx]& @@ eqsxy]

The smallest root of the last polynomial is the one of interest for us.

Roots[%[[-1]] == 0, qy][[1]]

N[%]

Factor[Resultant[##, qy]& @@ eqsxy]

Again, the smallest root of the last polynomial is the one of interest for us.

Roots[%[[-1]] == 0, qx][[1]]

N[%]

The two numerical values agree with our expectations from the above contour graphics.
Now let us calculate the exact value of the path length. We differentiate now (where LL is the square of the path length) with respect to qx and qy to obtain two polynomial equations for qx and qy after togethering.

pL1 = Factor[Numerator[Together[#]]]&[(LL - pL) /. goodSol]

eqs = Factor[Numerator[Together[#]]]& /@ {D[pL1, qx], D[pL1, qy]}

These equations, together with the defining equation for LL, allow us to eliminate qx and qy.

eqs2 = Flatten[{eqs, pL1}];

Exponent[#, {qx, qy, LL}]& /@ eqs2

First, we eliminate qx to obtain two equations in qy and LL.

res1 = Factor @ Resultant[eqs2[[1]], eqs2[[2]], qx];
Length[res1]

res2 = Factor @ Resultant[eqs2[[1]], eqs2[[3]], qx];
Length[res2]

Now we eliminate qy.

res3 = Resultant[res1[[5]], res2[[4]], qy];

res3 is a large polynomial.

Exponent[res3, LL]

It turns out the last factor is the relevant one.

Factor[res3];

Roots[%[[4]] == 0, LL][[1]]

So we arrive at the following exact expression for the path length.

Sqrt[%[[2]]] // RootReduce

The numerical value is about 1.03603, which is in agreement with the value found above using FindMinimum.

N[%]

sol = DSolve[{y'[x] == 1 - x y[x]^2, y[0] == 1}, y[x], x]

The answer and the messages show that the problem lies in determining the constant C[1]. We help out by doing a hand-supported series expansion at x=0.

Series[BesselI[n, x], {x, 0, 1}] // Normal

Series[PowerExpand[Flatten[sol][[1, 2]] /. 
          BesselI[n_, x_] -> x^n /2^n/Gamma[1 + n]],
       {x, 0, 0}] // Normal // Simplify // FullSimplify

So we arrive at the following value for C[1].

Solve[% == 1, C[1]]

We arrive at the following solution for the differential equation.

sol1 = (y[x] /. Flatten[sol]) /. %[[1]]

A graphical look at the solution shows that the singularity nearest to the origin is around 0.3+1.2 i.

(* 3D plot; suppress displaying the graphic *)
pl3D = Plot3D[Evaluate[Re[N[sol1] /. x -> x + I y]],
              {x, -2, 2}, {y, -2, 2}, PlotPoints -> 90,
              Mesh -> False, DisplayFunction -> Identity];

(* show 3D graphic and corresponding contour plot *)
Show[GraphicsArray[
{pl3D, ListContourPlot[pl3D[[1]], Contours -> 30, 
                       DisplayFunction -> Identity,
                       MeshRange -> {{-2, 2}, {-2, 2}}]}]]

We search numerically for the zero of the inverse to find the precise location of the nearest singularity.

FindRoot[Evaluate[1/sol1], {x, 0.3 + 1.2 I}]

d[k_, n_] := k/n

c[k_, n_, η_] := n!/((n - k)! k!) η^k (1 - η)^(n - k)

Based on the assumed existence of a Fourier expansion, we have to show the above identity for f(x)=exp(i l x). This can be done straightforwardly.

Sum[c[k, n, η] Exp[I (l x - d[k, n])], {k, 0, n}]

% /. Gamma[n + 1] :> n! // 
     Simplify[#, Element[n, Integers] && n > 0]&

Limit[%, n -> ∞]

Expanding the term (((1+(exp(-i/n)-1) η))^n) for large n, we obtain the following.

Exp[n Series[Log[1 + η (Exp[-I/n] - 1)], {n, Infinity, 4}]] // 
                                                     Simplify

This means for the identity to hold we must have n≫(η^2).
Let us end by visualizing the identity under consideration. The left graphic shows the difference between (e^(i(x-η))) and (∑_(k=0)^n)(Subscript[c, k]^((n)))(η)exp(i(x-(Subscript[d, k]^((n))))) over the η,n-plane. The right graphic shows the (Subscript[c, k]^((n)))(η)exp(i(x-(Subscript[d, k]^((n))))) for n=50 and the partial sums (∑_(k=0)^o)(Subscript[c, k]^((n)))(η)exp(i(x-(Subscript[d, k]^((n))))) that approach exp(i(x-η)).

(* difference between approximation and shifted exponential *)
δ[x_, n_, η_] := Sum[c[k, n, η] Exp[I (x - d[k, n])], 
                            {k, 0, n}] - Exp[I (x - η)]

(* sum terms *)
curves = With[{n = 50}, 
              Table[c[k, n, 0.9] Exp[I(x - d[k, n])], {k, 0, n}]];
              
(* cumulative sums *)
sumCurves = Rest[FoldList[Plus, 0, curves]];

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{(* difference *)
 With[{x = 1, o = 20}, ListPlot3D[
       Table[Abs[δ[N[1, 100], n, η]], {n, o}, {η, 1/100, 8, 8/o}],
      PlotRange -> All, MeshRange -> {{0, 6}, {1, o}}]],
 (* cumulative sums *)
 Plot[Evaluate[Re @ Join[{curves, sumCurves}]],
      {x, 0, 2Pi}, PlotRange -> All,
      PlotStyle -> Join[Table[{GrayLevel[1/2]}, {51}],
                       Table[{Hue[k/60]}, {k, 51}]]]}]]]

makeLogarithmicResidue[n_] := 
Module[{f, c, z, Fs, Φs, δs, eqs, gb, sol},
 (* starting series; keep only relevant negative powers *)
 f = Sum[c[k] z^k, {k, -n, -1}];
 (* series of F *) Fs = Expand[z^n f];
 (* series of Φ *) Φs = D[Fs, z]/Fs;
 (* defining equations for derivatives of Φ *)
 δs = Table[Derivative[j][Φ][0] - 
       Normal[Series[D[Φs, {z, j}], {z, 0, 0}]], {j, 0, n - 2}] //.
       c[-n] -> F[0];
 (* make polynomial equations *)
 eqs = Flatten[{Subscript[𝓇ℯ𝓈, n] - c[-1], 
                Numerator[Together[δs]]}] /. c[-n] -> F[0];
 (* eliminate c's *)
 gb = GroebnerBasis[eqs, {}, Table[c[k], {k, -1, -n + 1, -1}],
                    MonomialOrder -> EliminationOrder];
 (* solve with respect to 𝓇ℯ𝓈 *)
 sol = Solve[gb[[1]] == 0, Subscript[𝓇ℯ𝓈, n]];
 (* simplify result *)
 (Equal @@ sol[[1, 1]]) // (Factor //@ #)&]

Here are the resulting logarithmic residues.

Table[makeLogarithmicResidue[k], {k, 10}] // TraditionalForm

Using Mathematicas symbolic capabilities, it is straightforward to calculate the angle ∢CDE. To do this, we calculate the points D and E. This allows us to express the cosine of ∢CDE and so we also get ∢CDE itself.

There are the three vertices of the triangle.

b = {-1, 0}; 
c = {+1, 0}; 
a = {0, Tan[80 Degree]};

We define a function intersectionPoint that calculates the point of intersection between two lines. Every line is given in the form of one point on this line and a direction.

intersectionPoint[{p1_, dir1_}, {p2_, dir2_}] :=
First[p1 + s dir1 /. Solve[Thread[p1 + s dir1 == p2 + t dir2], {s, t}]]

So we get the following expression for the coordinates of the point D.

d = intersectionPoint[{a, b - a}, {c, {Cos[110 Degree], Sin[110 Degree]}}]

It is best to transform every number into an algebraic number. For trigonometric functions with arguments of the form rational π, this can always be done. The function toAlgebraicNumber implements this conversion.

toAlgebraicNumber[y_] :=
          TrigToExp[y] /. Degree -> Pi/180 /. E^α_ -> (-1)^(α/(I Pi))

Now the point D looks the following way.

toAlgebraicNumber[d]

The function RootReduce generates this normal form of the above algebraic number.

d = RootReduce[Simplify[%]]

Doing the same for the point E, we get its coordinates as an algebraic number, too.

e = RootReduce[Simplify[toAlgebraicNumber[
     intersectionPoint[{a, c - a}, 
                       {b, {Cos[60 Degree], Sin[60 Degree]}}]]]]

Now that we have explicit coordinates of the points D and E, the cosine of ∢CDE can be calculated by the following elementary geometry formula.

cos∢cde = RootReduce[RootReduce[(c - d).(e - d)]/
     RootReduce[Sqrt[RootReduce[(c - d).(c - d)]*
                     RootReduce[(e - d).(e - d)]]]]

Taking the arccos of this expression and simplifying it, we get the final answer.

ToRadicals[RootReduce[TrigToExp[ArcCos[cos∢cde]]]]

Knowing the solution, it is straightforward to verify it.

polynomialToDifferentialEquation[polyEq_, y_, x_] :=
Module[{poly, n, ode, derivatives, odePoly, oldMessageState,
        leadingTerm, α, reducedOdePoly, CEqs, CSols, commonCs, res},
 (* make a polynomial from the equation *)
 poly = (Subtract @@ polyEq) /. y -> y[x];
 (* the degree of the polynomial *)
 n = Exponent[poly, y[x]]; 
 (* ansatz for the differential equation;
    the C[i] are to be determined coefficients depending on x *)
 ode = Sum[C[i] D[y[x], {x, i}], {i, 0, n}];
 (* the derivatives expressed in lower derivatives *)          
 derivatives = Flatten[Table[Solve[D[poly, {x, i}] == 0, 
                             D[y[x], {x, i}]], {i, n}]];
 (* substitute all derivatives in the polynomial *)
 odePoly = Numerator[Together[ode //. derivatives]];
 (* turn off a Solve message *)
 oldMessageState = Solve::svars; Off[Solve::svars];
 (* express the leading term of the polynomial *)
 lT = Solve[(poly /. y[x]^n -> α) == 0, α][[1, 1, 2]];
 (* reduce odePoly by using the original polynomial *)
 reducedOdePoly = FixedPoint[Expand[# /. y[x]^m_ :> 
                  lT^Quotient[m, n] y[x]^Mod[m, n]]&, odePoly];
 (* make linear equations for the C[i] *)
 CEqs = (# == 0&) /@ CoefficientList[reducedOdePoly, y[x]];            
 (* solve the equations CEqs for the C[i] *)
 CSols = Solve[CEqs, Table[C[i], {i, 0, n}]][[1]];
 (* the C[i] appearing on the rhs of CSols *)
 commonCs = Cases[Last /@ CSols, _C, Infinity]; 
 (* the resulting differential equation *)
 res = Numerator[Together[(ode /. CSols /. ((# -> 1)& /@ commonCs))]];
 (* some (optional) cosmetics to get a nicer looking solution *)       
 res = Collect[res, Table[D[y[x], {x, i}], {i, 0, n}], Factor];
 (* turn on Solve message again *)       
 If[Head[oldMessageState] === String, On[Solve::svars]];
 (* return the differential equation *) res == 0]

We start with a simple quadratic polynomial.

ode = polynomialToDifferentialEquation[y^2 + x == 0, y, x]

The solution of the polynomial y=(Sqrt[x]) satisfies the derived differential equation.

Expand /@ (ode /. y -> (Function[x, x^(1/2)]))

A slightly more complicated quadratic polynomial.

ode = polynomialToDifferentialEquation[y^2 + a y + b x == 0, y, x]

DSolve solves the derived differential equation.

DSolve[ode, y[x], x]

By fixing the integration constants, we could reproduce the solutions of the original quadratic polynomial.

Solve[y^2 + a y + b x == 0, y]

A simple cubic polynomial.

ode = polynomialToDifferentialEquation[y^3 + x == 0, y, x]

The root y=(x^(1/3)) of the polynomial is also a solution of the differential equation.

Expand /@ (ode[[1]] /. y -> (Function[x, x^(1/3)]))

A slightly more complicated cubic.

ode = polynomialToDifferentialEquation[y^3 + y + x == 0, y, x]

Here is a quick check for the correctness of the differential equation.

Together //@ (ode /. MapAt[Function[x, #]&, #, {1, 2}]& /@ 
                              Solve[y^3 + y + x == 0, y])

Here is a more complicated example: a quartic polynomial.

ode = polynomialToDifferentialEquation[y^4 + y + x^9 == 0, y, x]

The last example is a quintic. The above implementation allows for additional parameters, here a and b.

polynomialToDifferentialEquation[y^5 + a x + b y == 0, y, x]

We check the last differential equation for the first root (the Root-object with root number 1). As mentioned, for the simplification of Root-objects we need the function FullSimplify.

% /. Derivative[k_][y][x] :> D[Root[a*x + b*#1 + #1^5 &, 1], {x, k}] /.
     y[x] -> Root[a*x + b*#1 + #1^5 &, 1] // FullSimplify

For related differential equations, see [371✶].

Needs["Graphics`Polyhedra`"]

neighbors = {#[[1, 1]],(* union *) Union[Flatten[Last /@ #]]}& /@ 
Split[Sort[Join[Sequence @@
      (* neighbors formed by the stellation process *)
Apply[{{#1, {#2, #3}}, {#2, {#1, #3}}, {#3, {#1, #2}}}&,
      Faces[Icosahedron], {1}], (* original neighbors *)
Sequence @@ MapIndexed[{{12 + #2[[1]], #1}, 
            {#1[[1]], {12 + #2[[1]]}}, 
            {#1[[2]], {12 + #2[[1]]}},
            {#1[[3]], {12 + #2[[1]]}}}&, Faces[Icosahedron]]],
      #1[[1]] < #2[[1]]&], #1[[1]] === #2[[1]]&];

Here are the first and last elements of the list neighbors.

Take[neighbors, 2]

Take[neighbors, -2]

Here is a wireframe of the stellated icosahedron.

vertices = Join[Vertices[Icosahedron], 
     Apply[Plus, Map[Vertices[Icosahedron][[#]]&, 
                     Faces[Icosahedron], {-1}], {1}]];

Show[Graphics3D[N @ Map[vertices[[#]]&, 
 Function[x, Line[{x[[1]], #}]& /@ x[[2]]] /@ neighbors, {-1}]]]

We construct the matrix representation of the Laplace operator. It acts on the vector of nodes.

n = Length[neighbors];
mat = Table[0, {n}, {n}];
Do[mat[[k, k]] = Length[neighbors[[k, 2]]];
   (mat[[k, #]] = -1)& /@ neighbors[[k, 2]], {k, n}]

Here are the resulting eigenvalues, together with their multiplicity.

{#[[1]], Length[#]}& /@ 
    Split[Sort[Eigenvalues[mat] // Simplify, #1 < #2&]]

vertices = 
With[{τ = GoldenRatio, g = Function[{f, l}, Flatten[
      f /@ Flatten[Outer[List, Sequence @@ l], 3], 1]],
      evenPermutations = Function[l, l[[#]]& /@ Select[
      Permutations[{1, 2, 3, 4}], Signature[#] === 1&]]},
Union[Join @@ Flatten[{g[Permutations, #]& /@ 
{{{+2, -2}, {+2, -2}, {0}, {0}},
 {{+Sqrt[5], -Sqrt[5]}, {+1, -1}, {+1, -1}, {+1, -1}},
 {{+τ, -τ}, {+τ, -τ}, {+τ, -τ}, {+τ^-2, -τ^-2}}},
g[evenPermutations, #]& /@  
 {{{+τ^2, -τ^2}, {+1/τ, -1/τ}, {+1/τ, -1/τ}, {+1/τ, -1/τ}},
  {{+τ^2, -τ^2}, {+1/τ^2, -1/τ^2}, {+1, -1}, {0}},
  {{+Sqrt[5], -Sqrt[5]}, {+1/τ, -1/τ}, {+τ, -τ}, {0}},
  {{+2, -2}, {+1, -1}, {+τ, -τ}, {+1/τ, -1/τ}}}}, 1]]];

verticesN = N[vertices];
(edgeList = DeleteCases[Union[Sort /@ Flatten[
 Table[s = verticesN[[1]];
      res = {s, #}& /@ Select[verticesN, #.#&[s - #] < 1&];
      verticesN = Rest[verticesN]; res, {599}], 1]], {a_, a_}]);

edgeConnectivity is a list of pairs of connected vertices.

edgeConnectivity = edgeList /. (Rule @@@ Transpose[
     {Union[Flatten[edgeList, 1]], Table[k, {k, 600}]}]);

Each vertex is connected to four others.

(Function[e, Length[Select[edgeConnectivity, 
                           MemberQ[#, e]&]]] /@ Range[600]) // Union

mat is the matrix corresponding to the Laplace operator for the 120-cell.

mat = 4 IdentityMatrix[600] - ReplacePart[Table[0, {600}, {600}], 1,  
     Join[edgeConnectivity, Reverse /@ edgeConnectivity]];

mat is a very sparse matrix.

ListDensityPlot[Sign[Abs[mat]], Mesh -> False, 
                ColorFunction -> (GrayLevel[1 - #]&)]

A machine-precision calculation of the eigenvalues of mat is relatively fast.

(evs = Sort[Re[Eigenvalues[N[mat]]]]); // Timing

The eigenvalues have a high degeneracy.

ListPlot[evs, Frame -> True, Axes -> False]

Here are the 10 smallest and the 10 largest eigenvalues.

Take[evs,  10]

Take[evs, -10]

An exact diagonalization of a 600×600 matrix would be extremely time-consuming. So we will not carry it out here. The above values suggest that 0 is the smallest eigenvalue. It is possible to symbolically confirm that 0 is an eigenvalue.

Det[mat]

Using the function Recognize from the package NumberTheory`Recognize` leads us to the conjecture that the largest eigenvalue is (7+3 (5^(1/2)))/4.

Needs["NumberTheory`Recognize`"]

Recognize[evs[[-1]], 10, x]

evMax = Max[x /. Solve[% == 0, x]]

A machine-precision check does not give an encouraging result.

Det[mat - DiagonalMatrix[Table[N[evMax], {600}]]]

A low precision high-precision check gives a high-precision zero with negative accuracy.

prec = $MachinePrecision + 1;
Det[mat - DiagonalMatrix[Table[N[evMax, prec], {600}]]]

A high precision high-precision check yields hundreds of cancelling digits. This confirms the conjecture.

prec = 200;
Det[mat - DiagonalMatrix[Table[N[evMax, prec], {600}]]]

Now we could continue with the second highest eigenvalue.

Recognize[evs[[-5]], 10, x]

FourierTransform[Exp[-x^2/2], x, y]

Fourier transforming the function exp(-(x^2)/2) allows us to immediately read the eigenvalue as i and the eigenfunctions as y.

FourierTransform[x Exp[-x^2/2], x, y]

For n≥2 we must work more programmatically. We Fourier transform the general ansatz exp(-(x^2)/2)(∑_(k=0)^n)(Subscript[c, k])(x^k) and determine the (Subscript[c, k]). This is easily implemented.

Off[Solve::"svars"]

Table[(* the ansatz *)
      f = Sum[c[i] x^i, {i, 0, n}];
      (* the Fourier transform of the ansatz *)
      ft = FourierTransform[f Exp[-x^2/2], x, y]/Exp[-y^2/2] /. y -> x;
      (* conditions for being eigenfunctions *)
      cl = CoefficientList[f - λ ft, x];  
      (* make sure the c[n] term does not vanish *) 
      gb = GroebnerBasis[Append[cl, 1 - z c[n]], 
                         Append[Table[c[i], {i, 0, n}], λ], z];    
      (* solve for the coefficients *)                   
      sol = Solve[# == 0& /@ gb, Append[Table[c[i], {i, 0, n}], λ]];
      (* return eigenvalue and eigenfunctions *)                    
      {λ, f} /. sol[[1]] /. _c -> 1, {n, 3, 12}]

The eigenfunctions are just the Hermite polynomials and the eigenvalues are ±1 and ±i [1185✶], [1102✶], [84✶], [996✶], [1671✶]. (In some cases, the above procedure could produce superpositions of various eigenfunctions belonging to the same eigenvalue.)

Table[(FourierTransform[HermiteH[k, x] Exp[-x^2/2], x, y]/
      Exp[-y^2/2]/HermiteH[k, y]) // Cancel, {k, 12}]

For the general form of functions that are their equal to their Fourier transform, see [1123✶] and [885✶]. For the eigenvalues and eigenvectors of the discrete Fourier transform, see [1099✶], [434✶], [707✶], [1119✶], [1276✶], and [89✶].

θ[x_, ϵ_] = 1/(Exp[-x/ϵ] + 1);

The following pictures shows a 3D plot of (Subscript[θ, ϵ])(x).

Plot3D[θ[x, ϵ], {x, -3, 3}, {ϵ, 10^-6, 1},
       PlotPoints -> 60, Mesh -> False, ViewPoint -> {-1, -2, 1}]

For (Subscript[δ, ϵ])(x), we make a related choice. The additional parameter εs is a small shift that (later) vanishes together with ε.

δ[x_, ε_, εs_] = D[1/(Exp[-x/ε - εs] + 1), x]

Here is a picture that shows the convergence to a peak of area 1 concentrated at x=1.

Plot3D[δ[x, ε, 3 ε], {x, -3, 3}, {ε, 0.01, 1},
       PlotPoints -> 60, Mesh -> False,
       ViewPoint -> {-1, -2, 1}, PlotRange -> All]

For a fixed ε and εs a multiple of ε we see how the maximum of δ shifts with respect to θ. For εs being a negative multiple of ε, the peak of δ is within the area where θ is 1. For εs being a positive multiple of ε, the peak of δ is within the area where θ is 0.

With[{ε = 0.1},
Show[Table[
Plot[Evaluate[{δ[x, ε, k ε], θ[x, ε]}], 
     {x, -1, 1}, PlotRange -> All, DisplayFunction -> Identity,
     Frame -> True, Axes -> False,
     PlotStyle -> {{Thickness[0.002], Hue[(k + 50)/100 0.2]},
                   {Thickness[0.002], Hue[0.7]}}],
         {k, -50, 50, 5}], DisplayFunction -> $DisplayFunction]]

Choosing  ϵ=ε=e, we can easily evaluate the integral (∫_(-∞)^∞)(Subscript[δ, ε])(x)(Subscript[θ, ϵ])(x)dx. We let εs be es.

overlap[e_, es_] = 
    Integrate[θ[y, 1] δ[y, 1, es/e], {y, -Infinity, Infinity}]

If we let es = k e, we obtain the following e-independent result for the overlap.

overlap[e, k e] // PowerExpand

The overlap integral can take on any value between 0 and 1.

Plot[Evaluate[%], {k, -4, 4}]

For some similar, not well-defined expressions of the form (∫_(-∞)^∞)δ(x)f(x)dx, see [697✶]; for a well defined limit of this type, see [1156✶].

Derivative[0][δ][f] = δ[x - ξ]/Abs[f'[ξ]]

The first derivative then takes the following form.

d1 = Derivative[1][δ][f] = 1/f'[x] D[Derivative[0][δ][f], x]

To eliminate the x-dependence of the factor 1/f'(x), we implement the identity

g (x) ((δ )^((n))) (x-ξ)=(∑_(k=0)^n)(((-1))^k) (({{n}, {k}})) (g^((k)))(ξ) (δ^((n-k)))(x-ξ)

which transforms the x-dependence of the prefactor to a ξ-dependence.

Derivative /: 
g_?(MemberQ[#, x, {0, Infinity}]&)*Derivative[n_][δ][x - ξ] :=
(Sum[(-1)^k Binomial[n, k] (D[g, {x, k}] /. x -> ξ) *
     Derivative[n - k][δ][x - ξ], {k, 0, n}])

Using this rule, δ'(f(x)) takes on the following form.

d1

Now let us look at the second derivative.

Derivative[2][δ][f] = 1/f'[x] D[Derivative[1][δ][f], x]

The above rule for Derivative did not go into effect because the expression was not of the form of a product of something x-dependent with (δ^((k)))(x-ξ). To get the rule working, we must expand the expression.

Expand[%]

d2 = Simplify[%]

For f(x)=x, we get an identity.

d2 /. f -> Function[x, x]

To “numerically” check the formula for d2, we use a smoothed version of the Dirac δ distribution.

smoothδ[x_, δ_] := 1/Sqrt[Pi δ]Exp[-x^2/δ]

This smoothed version can be easily integrated by NIntegrate.

With[{δ = 0.001},
NIntegrate[Evaluate[Derivative[2, 0][smoothδ][x^3 - 1, δ]], 
           {x, 0, 3}, MaxRecursion -> 10]]

Comparing with the symbolic result, we see a good agreement.

{#, N[#]}&[Integrate[d2 /. f -> Function[x, x^3 - 1] /.
                   ξ -> 1 /. δ -> DiracDelta, {x, 0, 3}]]

Here is another function used for the check.

{With[{δ = 0.001},
      NIntegrate[Evaluate[Derivative[2, 0][smoothδ][Cos[x], δ]], 
                 {x, 1, 2}, MaxRecursion -> 10]],
 Integrate[d2 /. f -> Function[x, Cos[x]] /.
                   ξ -> Pi/2 /. δ -> DiracDelta, {x, 0, 3}]}

Now let us continue and calculate higher orders.

Derivative[2][δ][f] = d2

Derivative[3][δ][f] = Together[Expand[1/f'[x] D[Derivative[2][δ][f], x]]]

For a nicer looking output, we implement a function collect that determines the (Subscript[c, k]) in (δ^((n)))(f (x))=(∑_(k=0)^n)(Subscript[c, k])(ξ) (δ^((k)))(x-ξ) explicitly.

collect[expr_] := 
With[{aux = Together[expr]},
Collect[Numerator[expr], (* the derivatives of δ *)
        Table[Derivative[i][δ][x - ξ], 
        {i, 0, Max[#[[0, 0, 1]]& /@ Cases[aux, 
                    Derivative[_][δ][x - ξ], Infinity]]}],
        Factor]/Denominator[aux]]

collect[Derivative[4][δ][f] = 
        Together[Expand[1/f'[x] D[Derivative[3][δ][f], x]]]]

Continuing in this way, we can calculate expressions for any n  in (δ^((n)))(f(x)) the following expression.

Do[Derivative[k + 1][δ][f] = 
        Together[Expand[1/f'[x] D[Derivative[k][δ][f], x]]],
   {k, 4, 9}];

Here is the (already large) result for (δ^((10)))(f(x)). For shortness, we write (Subscript[f, k]) for (f^((k)))(ξ).

collect[Derivative[10][δ][f]] /. 
         Derivative[n_][f_][_] -> Subscript[f, n]

For f being the identity function, the last expression simplifies to (δ^((10)))(x-ξ).

Derivative[10][δ][f] /. f -> Function[x, x]

Let us check a second example numerically, (δ^((6)))(x). Here is the exact result for f(x)=(x^3)-1.

Integrate[Derivative[6][δ][f] /. f -> Function[x, x^3 - 1] /.
                   ξ -> 1 /. δ -> DiracDelta, {x, 0, 3}] // N

Here is a plot of the smoothed function. The function values are in the order (10^19); so to find an integral of the order (10^2) we cannot use machine arithmetic to carry out the integration.

With[{δ = 10^-5},
     Plot[Evaluate[Derivative[6, 0][smoothδ][x^3 - 1, δ]], 
          {x, 0.995, 1.005}, PlotRange -> All,
          Frame -> True, Axes -> False]]

Using high-precision arithmetic, we obtain a good agreement with the exact value.

With[{δ = 10^-5},
     NIntegrate[Evaluate[Derivative[6, 0][smoothδ][x^3 - 1, δ]], 
                {x, 0, 2}, MaxRecursion -> 15,
                PrecisionGoal -> 6, WorkingPrecision -> 30]]

θSimplify[expr_] := 
With[{θ = UnitStep}, Expand[expr] /. θ[x_, y_] :> θ[x] θ[y] /.
       θ[x_]^n_ :> θ[x] //. 
       θ[z + n1_.] θ[z + n2_.] :> θ[z + Min[n1, n2]] //.
       θ[n1_. - z] θ[n2_. - z] :>  θ[Min[n1, n2] - z] //. 
       (θ[z + n1_.] θ[n2_. - z] :> 0 /; n2 <= -n1)]

Now we implement the double integration that yields the probability distribution for a sum. This is nearly straightforward. The probability distribution 𝓅[n][z] will be a piecewise-defined function. Integrate would return an answer containing an If statement and would give only one branch explicitly. To get all branches, we explicitly sum over all pieces and give the corresponding assumptions in Integrate.

Off[RuleDelayed::rhs];

(* uniform probability distribution in [0, 1] *)
𝓅[1][z_] := UnitStep[z] UnitStep[1 - z];

(* probability distribution for sum of n variables *)
𝓅[n_][z_] := 𝓅[n][z_] = 
Module[{res},
       (* carry out the double integration *)
       res = θSimplify[Sum[UnitStep[z - ξ] UnitStep[(ξ + 1) - z] *
        Integrate[𝓅[1][y] 𝓅[n - 1][z - y]
        (* 𝓅[n - 1][z - y] arises from
           Integrate[DiracDelta[z - x - y] 𝓅[n - 1][x], 
                     {x, -Infinity, Infinity}] *), 
                  {y, -Infinity, Infinity},
                  Assumptions -> ξ < z < ξ + 1], {ξ, 0, n - 1}]];
      (* write result in nice form *)    
      Collect[res, Union[#/(# /. _UnitStep -> 1)&[List @@ res]], Factor]]

Finally, for better readability of the result, we introduce the characteristic function (Subscript[χ, a,b]) that is 1 inside the interval [a, b] and zero everywhere else.

toχRule = UnitStep[n1_ - z] UnitStep[z + n2_.] :> Subscript[χ, -n2, n1];

So we arrive at the following expressions for the probability densities for n random variables with uniform distribution.

𝓅[2][z] /. toχRule

𝓅[3][z] /. toχRule

𝓅[4][z] /. toχRule

𝓅[5][z] /. toχRule

All probability densities are properly normalized.

Table[Integrate[𝓅[k][z], {z, 0, k}], {k, 1, 5}]

Here are plots of the calculated probability densities.

Show[GraphicsArray[Table[
Plot[Evaluate[𝓅[k][z]], {z, -1, k + 1}, Frame -> True, Axes -> False, 
PlotRange -> All, DisplayFunction -> Identity], {k, 1, 5}]]]

Another possibility to generate the probability distributions for sums consists of using the characteristic function of the starting probability distribution [1178✶], [1549✶], [678✶]. The next input uses InverseFourierTransform to generate the centered versions of the first 21 distribution functions.

With[{o = 20}, 
(* center all curves at z == 0 *)
Plot[Evaluate[Table[Sqrt[2/Pi] InverseFourierTransform[(Sin[ω]/ω)^j, ω, t],
                    {j, 0, o}]],
     {t, -o/2, o/2}, PlotRange -> All, Frame -> True, Axes -> False,
     PlotStyle -> Table[Hue[0.8 j/o], {j, 0, o}]]]

In the limit n->∞, the 𝓅[n][z] become Gaussian [966✶]. After rescaling, they approach (((2π))^(-1/2))exp(-(x^2)/2). Here this is demonstrated.

(* scale height and horizontal width *)
scaled𝓅[n_, x_] := Sqrt[n/(6 Pi)] *
          InverseFourierTransform[(Sin[ω]/ω)^n, ω, x] /. 
                                     {x -> x Sqrt[n/3]}

With[{o = 20}, 
(* show relative error compared to Gaussian limit *)
Plot[Evaluate[Table[scaled𝓅[j, x] /(1/Sqrt[2 Pi] Exp[-1/2 x^2]),
                    {j, 2, o}]],
     {x, -o/4, o/4}, PlotRange -> {1/4, 3/2}, Frame -> True, 
     Axes -> False, PlotStyle -> Table[Hue[0.8 j/o], {j, 2, o}]]]

For the distribution of products of random variables, see [1418✶].

Integrate[DiracDelta[x - a11 a22], {a11, 0, 1}]

Integrate[%, {a22, 0, 1}]

Obviously, the probability density for the product (Subscript[a, 12])(Subscript[a, 21]) also is -θ(x)θ(1-x)ln(x).

f[aa_] = -UnitStep[aa] UnitStep[1 - aa] Log[aa]

Using this result we can calculate a closed form expression for the probability distribution of the determinant, this means of the difference of the two product terms.

Integrate[Integrate[DiracDelta[x - a11a22 + a12a21] *
          Log[a11a22] Log[a12a21], {a11a22, 0, 1}], {a12a21, 0, 1}]

Mathematica was able to carry out the integral in closed form. It contains a special function, the dilog function (Subscript[Li, 2]). The last result is only correct for negative x. Because of the symmetry of the problem, we add the mirrored part for positive x.

(# + (# /. x -> -x))&[UnitStep[-x] %[[2]]]

pdf[x_] = 
(2 - 2x + (Pi^2 x)/6 + (-1 + x) Log[1 - x] + x Log[x] (1 + Log[-1/x]) - 
    x PolyLog[2, 1/x]) UnitStep[1 - x] UnitStep[x] + 
(2 + 2x - (Pi^2 x)/6 - (1 + x) Log[1 + x] - x Log[-x] (1 + Log[1/x]) + 
    x PolyLog[2, -1/x]) UnitStep[-x] UnitStep[1 + x]

Here is a graphic of the probability distribution.

exactPdfGraphic = 
Plot[pdf[x], {x, -3/2, 3/2}, Frame -> True, Axes -> False,
     PlotStyle -> {Thickness[0.006], Hue[0]}]

We carry out a numerical simulation using (10^6) random 2×2 matrices. The data agree very well with the theoretical distribution.

Module[{data = Table[Det[Table[Random[], {2}, {2}]], {10^6}],
        binSize = (* optimal bin size *) 0.0084},
Show[{Graphics[(* make histogram *)        
Apply[Polygon[{{#1, 0}, {#1, #3}, {#2, #3}, {#2, 0}}]&, 
      (* bin the data *)
      {First[#] binSize, (First[#] + 1) binSize, 
       Length[#]/Length[data]/binSize}& /@
              Split[Quotient[Sort[data], binSize]], {1}],
       Frame -> True], (* exact distribution *) exactPdfGraphic},
      PlotRange -> {-0.2, 2.2}]]

For probability densities of determinants of matrices with Gaussian distributions, see [337✶].

iDomains[n_] := Table[{t[k + 1], 0, 1 - Sum[t[i], {i, k}]}, 
                      {k, n - 2, 0, -1}]

startIntegrand[n_] :=  
Derivative[n - 1][f][Array[t, n].Array[x, n]] /.
                  t[n] -> 1 - Sum[t[i], {i, n - 1}]

𝒹𝒹Int1[x_, n_] := Fold[Integrate, startIntegrand[n], iDomains[n]]

((𝒹𝒹Int1[x, 5] // Timing) /. x[k_] :> Subscript[x, k]) // Short[#, 6]&

We can speed up the integration by a factor of two by calculating only the indefinite integral and substituting the limits.

integrate[f_, {x_, xl_, xu_}] := 
      ((# /. x -> xu) - (# /. x -> xl))&[Integrate[f, x]]

𝒹𝒹Int2[x_, n_] := Fold[integrate, startIntegrand[n], iDomains[n]]

𝒹𝒹Int2[x, 5]; // Timing

Simplifying the functions after each integration step can speed up the calculation even more.

𝒹𝒹Int3[x_, n_] :=
        Fold[Together[integrate[##]]&, startIntegrand[n], iDomains[n]]

𝒹𝒹Int3[x, 5]; // Timing

Pulling out factors that do not depend on the integration variables and integrating sums termwise yields a further speed-up.

iStep[{_, f_}, {x_, xl_, xu_}] := 
Module[{f1 = Together[f], num, den},
       {num, den} = {Expand[Numerator[f1]], Denominator[f1]};
       (* thread over sums *)
       {den, If[Head[num] === Plus,
                integrate[#, {x, xl, xu}]& /@ num,
                integrate[num, {x, xl, xu}]]}]

𝒹𝒹Int4[x_, n_] := (1/(Times @@ (First /@ #)) #[[-1, 2]])&[
             FoldList[iStep, {1, startIntegrand[n]}, iDomains[n]]]

𝒹𝒹Int4[x, 5]; // Timing

The results of the various 𝒹𝒹Inti agree.

𝒹𝒹[{x0_, x1_}, f_] := (f[x0] - f[x1])/(x0 - x1)

𝒹𝒹[xl_List, f_] := (* direct definition *)
      (𝒹𝒹[Drop[xl, -1], f] - 𝒹𝒹[Drop[xl, 1], f])/(First[xl] - Last[xl])

𝒹𝒹[Array[x, 5], f]; // Timing

𝒹𝒹[Array[x, 5], f] // Together; // Timing

𝒹𝒹[Array[x, 5], f] -  𝒹𝒹Int4[x, 5] // Together

Together[𝒹𝒹[Array[x, 5], f] - #]& /@ 
           {𝒹𝒹Int4[x, 5], 𝒹𝒹Int3[x, 5], 𝒹𝒹Int2[x, 5], 𝒹𝒹Int1[x, 5]}

𝒹𝒹Int4[x, 8]; // Timing

For computational efficient methods to calculate divided differences, see [1329✶].

f[ε_, ξ_][x_] := Exp[I Pi/4]/(2 Sqrt[Pi] Sqrt[1 - ε])*
                 Exp[-I/2 (ε x^2 - 2 ξ x + ε ξ^2)/(1 - ε)]

The first limit (lim_(ε->0))(Subscript[f, ε]^((ξ)))(x) is straightforward to carry out; the result is an exponential function.

Limit[f[ε, ξ][x], ε -> 0]

The built-in Limit cannot find the second limit.

Limit[f[ε, ξ][x], ε -> 1]

The last result indicates that the limit is not a function. So we will search the limit as a generalized function. We start by investigating the limiting behavior of the argument of the exponential function.

Series[-I/2 (ε x^2 - 2 ξ x + ε ξ^2)/(1 - ε), {ε, 1, 1}] // Simplify

g(x)=(e^(i π/4))(2^(-1))(((π^(-1/2))(1-ε))^(1/2))exp(i (ζ^2)/(2(1-ε))) is a highly oscillating function. In the limit ε->1 the oscillations increase indefinitely. But the saddle point ζ=0 is exceptional. Independently of ε, around ζ≈0 the function is stationary and grows as ε->0. (∫_(-∞)^∞)g(ζ)dζ tends to 1 as ε tends to 1. This means (∫_(-∞)^∞)(Subscript[f, ε]^((ξ)))(x)h(x)dx tends to h(ξ) as ε->1. So we have (lim_(ε->1))(Subscript[f, ε]^((ξ)))(x)=δ(x-ξ).

Integrate[Exp[I Pi/4]/(2 Sqrt[Pi] Sqrt[1 - ε])*
          Exp[I/2 (x - ξ)^2/(2 (ε - 1))], 
          {x, -Infinity, Infinity},
          Assumptions -> 0 < ε < 1] // FullSimplify[#, 0 < ε < 1]&

This means (∫_(-∞)^∞)(Subscript[f, ε]^((ξ)))(x)h(x)dx tends to h(ξ) as ε->1. So we have (lim_(ε->1))(Subscript[f, ε]^((ξ)))(x)=δ(x-ξ).
Now let us look for differential equations for (Subscript[f, ε]^((ξ)))(x). The first-order differential equation

(Subscript[f, ε]^(((ξ))'))(x)=-((i (2 x ε-2 ξ))/(2 (1-ε)))(Subscript[f, ε]^((ξ)))(x)

follows immediately after differentiation.

D[f[ε, ξ][x], x]/f[ε, ξ][x]

To derive an x-free differential equation, we differentiate (Subscript[f, ε]^((ξ)))(x) multiple times. The we algebraize the resulting equations by replacing exponentials involving x by new variables ϵ1 and ϵ2.

eqs = Table[Numerator[Together[Derivative[j][𝒻[ε, ξ]] - D[f[ε, ξ][x], {x, j}]]], 
      {j, 0, 3}] /. (* make algebraic system *)
       {Exp[I x ξ/(1 - ε)] :> ϵ1,
        Exp[I x^2 ε/(2 (1 - ε)) + r_] :> ϵ2 Exp[r]}

Eliminating ϵ1, ϵ2, and x yields the following polynomials.

gb = GroebnerBasis[(* eliminate ϵ1 *)
      Cases[Factor[Resultant[First[eqs], #, ϵ1]& /@ Rest[eqs]], 
            _Plus, {2}], {}, (* eliminate ϵ2 and x *){ϵ2, x},
              MonomialOrder -> EliminationOrder] // Factor;

Here are two of the possible differential equations, a second-order and a third-order one.

{gb[[1, -1]], gb[[3, -1]]} // Simplify

We end with a check of the correctness of the derived differential equations.

% /.  Derivative[j_][𝒻[ε, ξ]] :> D[f[ε, ξ][x], {x, j}] /. 
      𝒻[ε, ξ] :> f[ε, ξ][x] // Simplify

(Subscript[F, o]^((L)))(k)=(1/(Sqrt[2π]))(∫_(-∞)^∞)exp(i k x) (Subscript[f, o])(x)dx =(1/(Sqrt[2π]))(∑_(j=-o)^o)(∫_(j 2L-L)^(j 2L+L))exp(i k x) f(x+2j L)dx
   =(1/(Sqrt[2π]))(∑_(j=-o)^o)(∫_(-L)^L)exp(i k( ξ-2j L)) f(ξ)dξ =((∑_(j=-o)^o)exp(-2i k j L))×(1/(Sqrt[2π]))(∫_(-L)^L)exp(i k ξ) f(ξ)dξ
=csc(k L) sin(k L (2 o+1))(F^((L)))(k).

(For other representation of Fourier transforms as infinite sums, see [45✶], [171✶].)
We implement the definitions of the (Subscript[c, n]^((L))). The evaluated integrals contain the error function erf(ξ).

f[x_] := Exp[-x^2];

{c[L_][n_] = 1/(2L) Integrate[f[x] Exp[I n x/L Pi], {x, -L, L},
                              Assumptions -> L > 0] // Simplify,

 c[L_][0]  = 1/(2L) Integrate[f[x] Exp[I 0 x/L Pi], {x, -L, L},
                             Assumptions -> L > 0] // Simplify}

(F^((L)))(k) is defined similarly. Formally, we have (Subscript[c, n]^((L)))=(Sqrt[π/2])/L (F^((L)))(n π/L), (Here (Subscript[c, n]^((L))) is defined for integer n only.)

F[L_][k_]  = 1/Sqrt[2 Pi] Integrate[f[x] Exp[I k x], {x, -L, L},
                                    Assumptions -> L > 0] // Simplify;

The formula for (Subscript[F, o]^((L)))(k) contains the oscillating function csc(ξ) sin(ξ η).

δ[ξ_, η_] := Csc[ξ] Sin[ξ η]
F[L_][o_, k_] = δ[k L, 2 o + 1] F[L][k];

The left graphic shows the original functions f(x) together with its truncated Fourier sum. The right graphic shows the logarithm of the relative error. The error is quite small in the interval [-5,5] and increases outside because the Fourier sum defines a periodic function versus the single-bump function f(x).

Show[GraphicsArray[
Block[{L = 4, m = 12, $DisplayFunction = Identity},
     {(* original function and Fourier sum *)
      Plot[Evaluate[{f[x], (* Fourier sum in red *)
           Sum[c[L][n] Exp[-I n x/L Pi], {n, -m, m}]}],
                {x, -2L, 2L}, PlotStyle -> {GrayLevel[0], Hue[0]},
                PlotRange -> All, Frame -> True, Axes -> False],
      (* relative error plot *)
      Plot[Evaluate[Log[Abs[f[x] -
           Sum[c[L][n] Exp[-I n x/L Pi], {n, -m, m}]]]], {x, -2L, 2L},
                PlotRange -> All, Frame -> True, Axes -> False]}]]]

The next two graphics show 25 Fourier series coefficients (Subscript[c, n]^((L))) and |(Subscript[F, o]^((L)))(k)| for L=4 and o=4. A qualitative similarity between the two graphics exists, but the scales in horizontal and vertical direction disagree.

Show[GraphicsArray[
Block[{L = 4, m = 12, o = 4, $DisplayFunction = Identity},
  {(* the Fourier series coefficients *)
   fourierSeriesGraphic = Graphics[{Hue[0],
                   Table[Line[{{n, 0}, {n, Abs[c[L][n]]}}],
                        {n, -m, m}]}, 
         PlotRange -> All, Frame -> True, Axes -> False],
   (* the Fourier transform *)
   Plot[Abs[F[L][o, k]], {k, -o, o}, 
        PlotPoints -> 200, PlotRange -> All,
        Frame ->  True, Axes -> False]}]]]

Now we will consider the limit o->∞. The function δ(ξ,η)=csc(ξ) sin(ξ η) converges to a sequence of delta functions in the limit η->∞. This can be most easily seen by observing that (lim_(η->∞))δ(0,η)=∞ and (lim_(η->∞))(∫_(-π/2)^(π/2))δ(ξ,η)dξ=π. The following two graphics demonstrate this.

Show[GraphicsArray[
Block[{$DisplayFunction = Identity},
{(* δ[ξ, η] gets large spikes at ξ - j π *)
 Plot3D[δ[ξ, η], {ξ, -3, 3}, {η, 0, 12}, 
        PlotPoints -> 200, Mesh -> False, 
        ClipFill -> None, PlotRange -> {-5, 12}],
 (* the integral converges to π *)
 Plot[Evaluate[Integrate[δ[ξ, η], {ξ, -Pi/2, Pi/2}]],
      {η, 10, 200}, PlotPoints -> 200]}]]]

Using (∑_(j=-∞)^∞)exp(-2i k j L)=π(∑_(n=-∞)^∞)δ( k L-n π) we see that in the limit o->∞ the following identity holds:

(Subscript[F, ∞]^((L)))(k)=π(∑_(n=-∞)^∞)δ( k L-n π) (F^((L)))(k)=(Sqrt[2π])(∑_(n=-∞)^∞)δ( k -((n π)/L)) (Subscript[c, n]^((L))).

This means that in the large o limit (Subscript[F, o]^((L)))(k) converges to a series of delta functions. These delta functions are located at n π/L and their strength is exactly the Fourier series coefficient. Using the inverse Fourier transform and integrating out the Dirac delta functions shows that we recover the Fourier series representation.

f(x)=(1/(Sqrt[2π]))(∫_(-∞)^∞)(e^(-i k x))(Subscript[F, ∞]^((L)))(k)=(∑_(n=-∞)^∞)exp(-i n π (x/L))(Subscript[c, n]^((L)))

For small ξ we have δ(ξ,η)≈η. This enables us to normalize (Subscript[F, o]^((L)))(k) in such a way that the maxima of (Subscript[F, o]^((L)))(n π/L)/(2o+1) are located at integer n and the height of the maxima approaches the values (Subscript[c, n]^((L))).

Block[{L = 4, m = 6, o = 4},
Show[{Plot[Abs[Sqrt[Pi/2] F[L][o, n Pi/L]/L/(2o + 1)], {n, -m, m}, 
           PlotPoints -> 500, DisplayFunction -> Identity],
      (* discrete Fourier transform *) fourierSeriesGraphic},
     DisplayFunction -> $DisplayFunction,
     PlotRange -> {{-6, 6}, All}, Frame ->  True, 
     Axes -> False, AspectRatio -> 1/4]]

ℱ𝒟[functional_, f_[y_], SimplifyFunction -> 𝒮_] := 
Module[{x, s1, s2, s3}, 
  (* definition *)
  s1 = ((functional /. f :> Function[x, f[x] + 
                ε DiracDelta[x - y]]) - functional)/ε;
  (* simplify integrals *)
  s2 = s1 //. α_. Integrate[a_, b_] + β_. Integrate[c_, b_] :> 
                            Integrate[Expand[α a + β c], b] //. 
              Integrate[a_ (ε d_DiracDelta + c_), b_] :>     
              Integrate[Expand[a ε d], b] + Integrate[a c, b];                            
  (* expand around ε == 0 *)
  s3 = Limit[Normal[Series[#, {ε, 0, 1}]]& //@ s2, ε -> 0] ;
  (* (maybe) simplify result *) 𝒮[s3]]

By default we will not carry out any simplification.

(* no simplification by default *)
ℱ𝒟[functional_, f_[y_]] := 
  ℱ𝒟[functional, f[y], SimplifyFunction -> Identity]

Here is a first example, the functional derivative of (∫_(-∞)^∞)((f(x))^2)dx with respect to f(y).

ℱ𝒟[Integrate[f[y]^2, {y, -Infinity, Infinity}], f[x]]

For the identity functional F[f(x)]=f(x) we get δ f(x)/δ f(y)=δ(x-y).

ℱ𝒟[f[y], f[x]]

For a functional of the form F[f(x)]=(∫_(-∞)^∞)L(f(x),f'(x))dx, the functional derivative is, of course, just the classical Euler–Lagrange equation ∂L/∂f(x)-∂(∂L/∂f'(x))/∂x [1240✶].

ℱ𝒟[Integrate[F[f[y], f'[y]], {y, -Infinity, Infinity}], f[x]] -
(* the Lagrange equations *)
(D[F[f[x], f'[x]], f[x]] - D[D[F[f[x], f'[x]], f'[x]], x])

Here is a special case—the equation for the density of 1D quantum system [1259✶], [1391✶], [1392✶].

ℱ𝒟[Integrate[1/4 𝓃'[y]^2/𝓃[y] + 1/4/𝓃[y] - ν[y] 𝓃[y], 
             {y, -Infinity, Infinity}], 𝓃[x]] // Expand

For the functional F[f(x)]=(∫_a^b)((f(x))^2)dx, the functional derivative is nonvanishing only in the interval [a,b]; this corresponds to the two Heaviside functions in the next result.

ℱ𝒟[Integrate[f[x]^2, {x, a, b}], f[y]]

The Lagrange equation for a point mass in a potential V(x) follow from the functional F[x(t)]=T[x(t)]-V(x(t)).

ℱ𝒟[Integrate[1/2 x'[t]^2 - V[x[t]], 
             {t, -Infinity, Infinity}], x[τ]]

Now let us deal with F[f(x)]=((f(x))^3) ((f'(x))^2) f''(x). Without explicit simplification, we get an integral containing derivatives of the Dirac delta function.

ℱ𝒟[Integrate[f[x]^3 f'[x]^2 f''[x], 
             {x, -Infinity, Infinity}], f[ξ]]

Because such-type integrals can be evaluated via partial integration, we implement a corresponding rule: (∫_(-∞)^∞)f(x)(δ^((n)))(x-ξ)dx=(((-1))^n)(f^((n)))(ξ).

δIntegrateSimplify = (ExpandAll[#] //.
{Integrate[p_Plus, d_] :> (Integrate[#, d]& /@ p),
 Integrate[f_ Derivative[n_][DiracDelta][x_ + ξ_.], 
           {x_, -Infinity, Infinity}] :> 
                 ((-1)^n D[f, {x, n}] /. x -> -ξ)})&;

Now we get a fully integrated result.

ℱ𝒟[Integrate[f[x]^3 f'[x]^2 f''[x], 
             {x, -Infinity, Infinity}], f[ξ],
   SimplifyFunction -> δIntegrateSimplify] // Expand

Here is the Euler–Lagrange equation for a functional of the form F[f(x)]=(∫_(-∞)^∞)L(f(x),f'(x),f''(x))dx.

(el2 = ℱ𝒟[Integrate[F[f[y], f'[y], f''[y]], 
             {y, -Infinity, Infinity}], f[x],
             SimplifyFunction -> δIntegrateSimplify]) /.
 (* shorten result *)
 (h:(Derivative[__][F]))[__] :> h // Simplify

The function VariationalD from the package Calculus`VariationalMethods` calculates the Euler–Lagrange equation from the above integrand.

Needs["Calculus`VariationalMethods`"]
Expand[VariationalD[F[f[x], f'[x], f''[x]], f[x], x] - el2]

Now we show that the Korteweg–de Vries bracket vanishes. These are the (Subscript[𝒬, i]).

𝒬[0] := Integrate[u[x], {x, -Infinity, Infinity}]
𝒬[1] := Integrate[u[x]^2/2, {x, -Infinity, Infinity}]
𝒬[2] := Integrate[-u[x]^3 + u'[x]^2/2, {x, -Infinity, Infinity}]
𝒬[3] := Integrate[5/2 u[x]^4 - 5 u[x] u'[x]^2 + u''[x]^2/2, 
                  {x, -Infinity, Infinity}]

The function KdVBracket implements the Korteweg–de Vries bracket.

KdVBracket[cq1_, cq2_] := 
Module[{q1, q2, integrand, yIndefIntegral, yDefIntegral},
 {q1, q2} = ℱ𝒟[#, u[y], SimplifyFunction -> δIntegrateSimplify]& /@
               {cq1, cq2};
 integrand = q1 D[q2, y];
 yIndefIntegral = Integrate[integrand, y];     
 If[FreeQ[yIndefIntegral, Integrate, {0, Infinity}, Heads -> True],     
    (* substitute for completeness; integral must vanish now *)
    yDefIntegral = (yIndefIntegral /. y -> +Infinity) -
                   (yIndefIntegral /. y -> -Infinity);
    (* u and its derivatives vanish at ±∞ *)
    yDefIntegral /. {u[+Infinity] -> 0, Derivative[k_][u][+Infinity] -> 0, 
                     u[-Infinity] -> 0, Derivative[k_][u][-Infinity] -> 0},
   yIndefIntegral]]

All of the {(Subscript[𝒬, i]),(Subscript[𝒬, j])} vanish.

Table[KdVBracket[𝒬[i], 𝒬[j]], {i, 0, 3}, {j, 0, 3}] // Flatten

It is straightforward to implement repeated functional differentation.

(* multiple differentiation *)
ℱ𝒟[functional_, f1_, fs__, Simplifyer -> 𝒮_] :=
 ℱ𝒟[ℱ𝒟[functional, f1, SimplifyFunction -> 𝒮], 
    fs, SimplifyFunction -> 𝒮]

(* multiple differentiation; no simplification *)
ℱ𝒟[functional_, f1_, fs__] := ℱ𝒟[ℱ𝒟[functional, f1], fs] /;
                         FreeQ[{fs}, Rule | RuleDelayed, {1}]

Here are again two examples.

ℱ𝒟[Integrate[f[y]^2, {y, -Infinity, Infinity}], f[x], f[z]]

ℱ𝒟[Integrate[f[y] f'[y]^2, {y, -Infinity, Infinity}], f[x], f[z]]

The second functional derivative of the above-used point particle action is -((∂^2)./∂(Subscript[τ, 2]^2)+V(x((Subscript[τ, 1]))))δ((Subscript[τ, 1])-(Subscript[τ, 2]))..

ℱ𝒟[Integrate[1/2 x'[t]^2 - V[x[t]], 
             {t, -Infinity, Infinity}], x[τ1], x[τ2]]

For F[f(x)]=(∫_(-∞)^∞)f(x)h(x)dx, we have the general result (δ^n)F/(δ f((Subscript[y, 1]))⋯  δ f((Subscript[y, n])))=F[f]  h((Subscript[y, 1]))⋯ h((Subscript[y, n])). Here is the case n=3 is explicitly calculated.

ℱ𝒟[Exp[Integrate[f[y] h[y], {y, -Infinity, Infinity}]], 
   f[x], f[z], f[w]]

For functional differentiation with nontrivial constraints, see [613✶].

For a more concise and more easily to read output in the following, all operators will carry a hat and operator products will be indicated by ⊗.

We start by defining some properties for the operator product ⊗. It should self-denest, be linear, expand out sums and products, and be linear over nonoperator quantities. We will write operators with a hat, implementing these quantities in the form OverHat[operator]. The functions operatorQ and notOperatorQ determine if an expression is considered to be an operator. (This implementation is similar to the ones from the solution of Exercise 8 of Chapter 5 of the Programming volume [1559✶] of the GuideBooks.)

a___ ⊗ (⊗b___) ⊗ c___ := a ⊗ b ⊗ c; 
a___ ⊗ (b_ + c_) ⊗ d___ := a ⊗ b ⊗ d + a ⊗ c ⊗ d; 
⊗ x_?notOperatorQ := x; 
a___ ⊗ x_?notOperatorQ ⊗ b___ := x (a ⊗ b); 
a___ ⊗ (x__?notOperatorQ y_) ⊗ b___ := x(a ⊗ y ⊗ b); 
a___ ⊗ b_Plus^n_ ⊗ c___ := (a ⊗ ## ⊗ c)& @@ Table[b, {n}]; 
a___ ⊗ OverHat[A_]^n_. ⊗ OverHat[A_]^(m_.) ⊗ c___ := 
       a ⊗ OverHat[A]^(n + m) ⊗ c; 
       
notOperatorQ[φ_] := FreeQ[φ, _OverHat]; 

operatorQ[φ_] :=  !notOperatorQ[φ];

Next we define an operator 𝔗 acting on the exponential of an expression Ψ (containing operators); it gives the Taylor series expansion to order ℴ around t=0.

𝔗[E^Ψ_?operatorQ, ℴ_:4] := Sum[⊗ (Ψ^i/i!), {i, 0, ℴ}]

Using 𝔗, we calculate the first few terms in the series expansion of exp(t((OverHat[A])+(OverHat[B]))). Here, OverHat[A] and OverHat[B] are the two (in general noncommuting) operators.

lhs = 𝔗[E^(t (OverHat[A] + OverHat[B]))]

To calculate the first few terms of exp(t((OverHat[A])+(OverHat[B]))), we define a function 𝔓 that gives the series of a product of terms that come from 𝔗. To avoid accumulating unnecessary high-order terms, after every multiplication, we delete the terms of order greater than ℴ in t.

SetAttributes[𝔓, HoldFirst]

𝔓[⊗ Ψ__, t_, ℴ_:4] := Fold[DeleteCases[⊗ ##, t^i_?(#1 > ℴ&)  _] &, 
                          First[{Ψ}], Rest[{Ψ}]]

So we can calculate the first terms of exp(t((OverHat[A])+(OverHat[B]))).

(rhs = 𝔓[𝔗[E^(t Subscript[ω, 1] OverHat[A])] ⊗ 
         𝔗[E^(t Subscript[ω, 2] OverHat[B])] ⊗ 
         𝔗[E^(t Subscript[ω, 3] OverHat[A])] ⊗ 
         𝔗[E^(t Subscript[ω, 4] OverHat[B])] ⊗ 
         𝔗[E^(t Subscript[ω, 5] OverHat[A])] ⊗ 
         𝔗[E^(t Subscript[ω, 6] OverHat[B])] ⊗ 
         𝔗[E^(t Subscript[ω, 7] OverHat[A])], t]) // Short[#, 6]&

Up to order 4 in t, the difference between right-hand side and left-hand side should vanish identically.

(shouldBeZero = rhs - lhs) // Short[#, 12]&

For generic, noncommuting operators (OverHat[A]) and (OverHat[B]), we have the following independent operator products in shouldBeZero.

allOperators = Union[Cases[shouldBeZero, _CircleTimes, {0, Infinity}]]

We take the c-number coefficients with respect to these operators—they should vanish.

(operatorCoefficients = 
       Coefficient[shouldBeZero, #]& /@ allOperators) // Short[#, 6]&

For every power of t, we extract the corresponding coefficients. This leads to the following, quite complicated, polynomial system of nonlinear equations for (Subscript[ω, 1]),(Subscript[ω, 2]),(Subscript[ω, 3]),(Subscript[ω, 4]),(Subscript[ω, 5]),(Subscript[ω, 6]), and (Subscript[ω, 7]).

(algebraicEquations = 
   DeleteCases[Union[Flatten[Map[Numerator[Together[#]]&, 
                       CoefficientList[#, t]& /@ operatorCoefficients, 
                                 {2}]]], 0]);

Short[algebraicEquations, 12]

Using GroebnerBasis, we transform the last set of equations into a much nicer looking set of just seven equations in triangular form. On a vintage year 2002 computer, this main step in the whole computation takes less than a second.

ωs = Table[Subscript[ω, i], {i, 7}];

TableForm[gb = GroebnerBasis[algebraicEquations, ωs]]

Now it is straightforward to explicitly calculate all five (that there are five solutions is immediately visible from the first equation of gb) solutions for (Subscript[ω, 1]),(Subscript[ω, 2]),(Subscript[ω, 3]),(Subscript[ω, 4]),(Subscript[ω, 5]),(Subscript[ω, 6]), and (Subscript[ω, 7]).

(sol = Solve[# == 0& /@ gb, ωs]) // Short[#, 6]&

Using Root-objects, the last result can be written in a more compact form as follows.

RootReduce[%]

The solution with all the (Subscript[ω, i])  real is the most interesting one.

Simplify[Select[sol, And @@ (# == 0&) /@ Im[ωs /. #1] & ]]

So we finally arrive at the following result.

(CircleTimes @@ MapThread[E^(t Subscript[ω, #1] OverHat[#2])&, 
                          {Range[7], {A, B, A, B, A, B, A}}]) /. 
                                         First[%] // TraditionalForm

For similar formulas for evolution loops, see [1130✶].

p1 = {r1, 0}; p2 = {x2, y2}; p3 = {x3, y3};

This yields the following expression for the area of the triangle as a function of the coordinates of the vertices p2 and p3.

areaSquared = Cross[{x2, y2, 0} - {r1, 0, 0}, 
                    {x3, y3, 0} - {r1, 0, 0}][[3]]^2/4

The constraint that the vertices p2 and p3 are lying on circles we take into account using Lagrange multipliers.

Λ = areaSquared + λ (p2.p2 - r2^2) + μ (p3.p3 - r3^2)

For the maximal area, we so get the following system of six equations.

eqs = Factor[D[Λ, #]]& /@ {x2, y2, x3, y3, λ, μ}

Denoting by A2 the square of the maximal triangle area, it is straightforward to eliminate all the not needed variables to obtain A2 as a function of r1, r2, and r3.

gb = GroebnerBasis[Flatten[{A2 - areaSquared, eqs}],
                   {A, r1, r2, r3}, {x2, y2, λ, μ, x3, y3},
                   MonomialOrder -> EliminationOrder]

For the special radii given the last formula leads to the following maximal area.

rRules = {r1 -> 1, r2 -> 2, r3 -> 3};

Solve[(gb[[1]] /. rRules) == 0, A2] // Simplify

N[%, 22]

Let us compare the last result with a direct maximization of the area. (We use FindMinimum on the negative of the area.) We consider x2 and x3 the independent variables and express y2 and y3 piecewise as functions of x2 and x3.

Apply[Function[{pm1, pm2},
FindMinimum[Evaluate[(* substitute y2 and y3; use ± *)
-areaSquared /. {y2 -> pm1 Sqrt[r2^2 - x2^2], 
                 y3 -> pm2 Sqrt[r3^2 - x3^2]} /. rRules],
            {x2, 1/2, -2, 2}, {x3, -1/2, -3, 3}]],
      {{1, 1}, {1, -1}, {-1, 1}, {-1, -1}}, {1}]

This confirms the above result. 
Because we expect A2 to be a symmetric function of r1, r2, and r3, we use the function SymmetricReduction (from the standard package Algebra`SymmetricPolynomials`) to rewrite gb in a more symmetric way. Let s[i] be the ith symmetric polynomial in r1, r2, and r3.

Needs["Algebra`SymmetricPolynomials`"]

simpl[coeff_] := 
 With[{sr = SymmetricReduction[coeff, 
              {r1, r2, r3}, {s[1], s[2], s[3]}]},
       If[sr[[2]] === 0, Simplify[sr[[1]]], $Failed]]

Collect[gb[[1]], A2, simpl]

p1 = {0, 0, 0};  p2 = {p2x, 0, 0};  p3 = {p3x, p3y, 0}; 
p4 = {p4x, p4y, p4z};

The oriented volume v of the tetrahedron and the square of the areas aSijk of the four faces can then be expressed through the coordinates by using formulas from elementary geometry. aSijk is the square of the area of the face bounded by the vertices p[i], p[j], and p[k].

v = 1/6 Det[Append[#, 1]& /@  {p1, p2, p3, p4}]

𝓃𝓈 = #.#/4&[][Cross[##]]&

aS123 = #.#/4&[Cross[p2 - p1, p3 - p1]]

aS124 = #.#/4&[Cross[p2 - p1, p4 - p1]] // Simplify

aS134 = #.#/4&[Cross[p3 - p1, p4 - p1]] // Simplify

aS234 = #.#/4&[Cross[p3 - p2, p4 - p2]] // Simplify

The volume, via the determinantal formula, is not positive definite. That is why we will use its square in the following. To determine the maximal volume, we proceed in the most natural way—we calculate the extremal value of the square of the maximal volume V2 under the restriction of given values for aS123, aS124, aS134, and aS234. These conditions are incorporated into the function to be minimized using Lagrange multipliers λ1, λ2, λ3, and λ4. The four constraints are φi, where aSijk is the square of the area of a face expressed through the coordinates of the vertices and is the given value of the faces ASijk.

{φ1, φ2, φ3, φ4} = 
  {(AS123 - aS123), (AS124 - aS124), (AS134 - aS134), (AS234 - aS234)};

So we arrive at the following function L to minimize.

L = v^2 + λ1 φ1 + λ2 φ2 + λ3 φ3 + λ4 φ4;

Technically, the problem of finding the maximal volume now reduces to the elimination of the variables λ1, λ2, λ3, λ4, p2x, p3x, p3y, p4x, p4y, and p4z from the following 11 equations.

eqs = {V2 - v^2, (* derivative wrt coordinates *)
	   D[L, p2x], D[L, p3x], D[L, p3y], 
	   D[L, p4x], D[L, p4y], D[L, p4z],
	   (* derivative wrt Lagrange multipliers *)
	   D[L, λ1], D[L, λ2], D[L, λ3], D[L, λ4]}

A direct call to Solve or Eliminate will not give an answer in any reasonable amount of time. One of the reasons is that besides the maximum we are interested in, degenerate cases (meaning some of the coordinates are equal to zero) will appear. So we will simplify the problem a bit by “ hand work”. In solving a complicated system of polynomial equations it is often a good idea to eliminate variables that appear linearly. All of the λis appear linearly in L. This is obvious from the construction of L, and later, we care about eventually vanishing denominators. Here are the degrees of the 11 equations in the variables λi.

Exponent[#,	{λ1, λ2, λ3, λ4}]& /@ eqs

We start by eliminating λ1.

sol1 = Solve[eqs[[2]] == 0, λ1]

p2x and p3y cannot vanish for a nondegenerate solution, and so we arrive at the following 10 equations.

eqs1 = Factor[Numerator[Together[Delete[eqs, 2] /. sol1[[1]]]]]

Two of the resulting equations are products.

Position[eqs1, _Times, {1}]

{eqs1[[4]], eqs1[[6]]}

Again, p3y and p4z cannot vanish for nondegenerate solutions, and this allows us to simplify eqs1.

eqs1a = If[Head[#] === Plus, #, 
           Cases[#, _Plus, {1}][[1]]]& /@ eqs1

In eqs1a, the Lagrange multiplier λ2 appears linearly in the third equation.

Exponent[#,	{λ2, λ3, λ4}]& /@ eqs1a

Under the previously stated nondegeneracy condition, we can solve for λ2.

sol2 = Solve[eqs1a[[3]] == 0, λ2]

Backsubstitution of this equation gives the following system of nine equations.

eqs2 = Factor[Numerator[Together[Delete[eqs1a, 3] /. sol2[[1]]]]]

This time we do not have any products.

Position[eqs2, _Times, {1}]

Exponent[#,	{λ3, λ4}]& /@ eqs2

We proceed as above and eliminate λ3.

sol3 = Solve[eqs2[[2]] == 0, λ3]

eqs3 = Factor[Numerator[Together[Delete[eqs2, 2] /. sol3[[1]]]]]

This time three of the resulting equations factor. We eliminate the factors p2x, p3y, p4z that cannot vanish for a nondegenerate tetrahedron.

Position[eqs3, _Times, {1}]

{eqs3[[2]], eqs3[[3]], eqs3[[4]]}

eqs3a = If[Head[#] === Plus, #, Cases[#, _Plus, {1}][[1]]]& /@ eqs3

From eqs3[[2]], the condition p4x = p3x follows. (This result afterward justifies the assumption that the denominator in sol3 does not vanish.)

eqs3b = Delete[Factor[eqs3a /. p4x -> p3x], 2]

Now only one Lagrange multiplier is left to eliminate : λ4.

Exponent[#,	{λ4}]& /@ eqs3b

sol4 = Solve[eqs3b[[3]] == 0, λ4]

eqs4 = Factor[Numerator[Together[Delete[eqs3b, 3] /. sol4[[1]]]]]

Now, after elimination of all four Lagrange multipliers, we have a nontrivial product.

Position[eqs4, _Times, {1}]

eqs4[[2]]

In agreement with the assumption about the nonvanishing of the denominator in sol3, we assume that p2x p3x - p3x^2 - p3y p4y must vanish.

eqs4a = MapAt[#/(p3y p4y - p4y^2 - p4z^2)&, eqs4, 2]

By now, we have reduced the number of variables to be eliminated from ten to five (we have eliminated the four Lagrange multipliers and the identity p3x=p4x came as a freebie this way), and we also have excluded some degenerate cases. The resulting system of six polynomials has the following structure.

Exponent[#,	{p2x, p3x, p3y, p4y, p4z}]& /@ eqs4a

GroebnerBasis is now able to eliminate the remaining variables, and we arrive at the following system of polynomials.

gb = GroebnerBasis[eqs4a, {}, {p2x, p3x, p3y, p4y, p4z},
                   MonomialOrder -> EliminationOrder];

As to be expected, the resulting Gröbner basis has just one element.

Length[gb]

The polynomial gb[[1]] is quite large.

Length[poly = gb[[1]]]

Here are its first terms.

Take[poly, 10]

We rewrite the polynomial in the square of the volume v2 in a more symmetric form. The coefficients of v2 are symmetric in AS123, AS124, AS134, and AS234. Using this symmetry by introducing the elementary symmetric polynomials, we arrive at the following final result. We denote the kth elementary symmetric polynomial in AS123, AS124, AS134, and AS234 by S[k].

Needs["Algebra`SymmetricPolynomials`"]

writeSymmetric[f_] := 
 First[SymmetricReduction[f, {AS123, AS124, AS134, AS234}]] //.
 Append[Table[SymmetricPolynomial[{AS123, AS124, AS134, AS234}, k] -> 
               S[k], {k, 3}],
        AS123^e_. AS124^e_. AS134^e_. AS234^e_. -> S[4]^e]

Collect[poly, v2, writeSymmetric]

Now we substitute actual numerical values for the areas of the faces.

rules = {AS123 ->  9/10, AS124 -> 10/10, 
         AS134 -> 11/10, AS234 -> 12/10};

poly /. rules

The polynomial has a unique positive root for v2.

Select[V2 /. {ToRules[Roots[% == 0, V2, Quartics -> False]]}, Positive]

N[%, 22]

We compare the last result with a numerical solution using FindRoot. We select random start values and repeat the FindRoot call until it finds a solution within the specified restrictions. We calculate five values.

numSols = Table[
While[Check[
      nsol = FindRoot[Evaluate[# == 0 & /@ 
                      (Rest[eqs] /. rules)], Evaluate[
        Sequence @@ ({#, Random[Real, {0, 2}]}&) /@ 
          {p2x, p3x, p3y, p4x, p4y, p4z, λ1, λ2, λ3, λ4}], 
          MaxIterations -> 30], $Failed] === $Failed, Null]; 
nsol, {5}]

This result agrees with the above one.

v^2 /. numSols

When all four faces have the same area, the resulting volume is the same as that the regular polyhedron.

poly /. {AS123 -> 1, AS124 -> 1, AS134 -> 1, AS234 -> 1}

Select[V2 /. {ToRules[Roots[% == 0, V2, Quartics -> False]]},
       Positive]

Here are the vertices of a regular tetrahedron with faces of area 1.

P1 = {0, 0, 0}; 
P2 = {2/3^(1/4), 0, 0}; 
P3 = {1/3^(1/4), 3^(1/4), 0}; 
P4 = {1/3^(1/4), 1/3^(3/4), 2 2^(1/2)/3^(3/4)};

{#.#/4&[Cross[P2 - P1, P3 - P1]], #.#/4&[Cross[P2 - P1, P4 - P1]],
 #.#/4&[Cross[P3 - P1, P4 - P1]], #.#/4&[Cross[P3 - P2, P4 - P2]]}

This is the square of its volume.

(1/6 Det[Append[#, 1]& /@  {P1, P2, P3, P4}])^2