4  How Low Can You Go?

It is not hard to see that the global minimum is at least as low as FormBox[RowBox[{-, 3.24}], TraditionalForm], and it then follows from the structure of the function (two of the six terms have easy-to-measure positive values; the sines are never less then –1 or, in one case, –0.84) that the true minimum lies inside the unit circle. Then we used a root-finding method to find all the critical points and choose the correct one. The root-finding method was developed by Wagon in 1996 for the VisualDSolve project in differential equations, and uses data from a contour plot to find all solutions to a pair of equations. We can get 500 digits easily. The answer to 100 digits is
  FormBox[RowBox[{-, 0.330686864747523728007611377089851565716648236147628821750129308549630919983788829503582548807528350}], TraditionalForm].
Here is a solution that finds all the critical poiunts by using the FindAllCrossings function just alluded to.

f[x_, y_] := (x^2 + y^2)/4 + ^Sin[50 x] + Sin[60 ^y] + Sin[70 Sin[x]] + Sin[Si ...  y)] ; f[{x_, y_}] := f[x, y] ; fx = ∂_xf[x, y] ;    fy = ∂_yf[x, y] ;

RowBox[{Min, [, RowBox[{Flatten, [, RowBox[{Table, [,  , RowBox[{f[x, y], ,,  , RowBox[{{, Row ... -1, ,, 1, ,, 0.01}], }}], ,,  , RowBox[{{, RowBox[{y, ,, -1, ,, 1, ,, 0.01}], }}]}], ]}], ]}], ]}]

RowBox[{-, 3.24646}]

We now find all critical points (there are 2720 in the unit square), keeping any for which the function value is under FormBox[RowBox[{-, 3.2}], TraditionalForm]. We used a collection of 64 subsquares of the 2×2 square around the origin, to save memory. And by increasing the resolution and watching the results, we gain evidence for the completeness of the count. We include here the complete code for FindAllCrossings2D (from Wagon's book, Mathematica in Action, chap. 12), which finds all solutions to two equations in an interval. The resolution is controlled by the PlotPoints option which controls the resolution of the contour plot used to get started. We did not attempt to prove that a certain resolution was enough for the problem at hand, but we did examine images of the crossing contours and that convinced us that we had all the roots.

Needs["Utilities`FilterOptions`"] ; <br /> Options[FindAllCrossings2D] = {PlotPoints ... ;  xmin<#〚1〛<xmax∧ymin<#〚2〛<ymax &]]]

We call the functions with a high resolution setting (160, chosen so that the number of roots is stable; that is, we used higher settings too and it appears certain that we have found all the critical points).

RowBox[{Do, [, RowBox[{cps = {}, ;, , RowBox[{Do, [, RowBox[{RowBox[{RowBox[{cpsnew, = ... 75, ,, 0.25}], }}], ,,  , RowBox[{{, RowBox[{j, ,,  , -1, ,,  , 0.75, ,, 0.25}], }}]}], ]}]}], ]}]

Length[cps]

2720

Get the global minimum.

lowest = Sort[cps, f[#1] < f[#2] &][[1]] f[lowest]

RowBox[{{, RowBox[{RowBox[{-, 0.0244031}], ,, 0.210612}], }}]

RowBox[{-, 3.30687}]

And now it is easy to zoom in to a more precise value.

RowBox[{RowBox[{FindMinimum, [, RowBox[{f[x, y], ,, RowBox[{{, RowBox[{x, ,, RowBox[{-, 0.02}]}], }}], ,, RowBox[{{, RowBox[{y, ,, 0.21}], }}]}], ]}], 〚, 1, 〛}]

-3.3068686475

Here is an alternative solution (code is for Mathematica 4.2) using a combinatorial search technique that we learned about for problem 5. This is not the ideal way, but it gets the answer very quickly; the contour-based root-finding given above is better, but the root-finder (code not given here) takes a little programming. The SimulatedAnnealing setting to Method also works for this problem.

Needs["NumericalMath`NMinimize`"] NMinimize[{f[x, y], x^2 + y^2≤1}, {x, y}, MethodDifferentialEvolution]

{-3.306868647, {x-0.02440307923, y0.2106124261}}

Our methods described here do not provide proof of correctness. The Wolfram Research team devleoped a method using interval arithmetic that does provide such proof.


Created by Mathematica  (June 27, 2004)