(************** Content-type: application/mathematica **************

                    Mathematica-Compatible Notebook

This notebook can be used with any Mathematica-compatible
application, such as Mathematica, MathReader or Publicon. The data
for the notebook starts with the line containing stars above.

To get the notebook into a Mathematica-compatible application, do
one of the following:

* Save the data starting with the line of stars above into a file
  with a name ending in .nb, then open the file inside the
  application;

* Copy the data starting with the line of stars above to the
  clipboard, then use the Paste menu command inside the application.

Data for notebooks contains only printable 7-bit ASCII and can be
sent directly in email or through ftp in text mode.  Newlines can be
CR, LF or CRLF (Unix, Macintosh or MS-DOS style).

NOTE: If you modify the data for this notebook not in a Mathematica-
compatible application, you must delete the line below containing
the word CacheID, otherwise Mathematica-compatible applications may
try to use invalid cache data.

For more information on notebooks and Mathematica-compatible 
applications, contact Wolfram Research:
  web: http://www.wolfram.com
  email: info@wolfram.com
  phone: +1-217-398-0700 (U.S.)

Notebook reader applications are available free of charge from 
Wolfram Research.
*******************************************************************)

(*CacheID: 232*)


(*NotebookFileLineBreakTest
NotebookFileLineBreakTest*)
(*NotebookOptionsPosition[     27833,        799]*)
(*NotebookOutlinePosition[     28532,        823]*)
(*  CellTagsIndexPosition[     28488,        819]*)
(*WindowFrame->Normal*)



Notebook[{

Cell[CellGroupData[{
Cell["Critical Points and Lagrange Multipliers", "Title",
  TextAlignment->Center,
  Background->RGBColor[0, 1, 0]],

Cell["\<\
This notebook is by Steven Amgott.  Please send any questions or comments to \
samgott1@swarthmore.edu.  Feel free to use and distribute this notebook, but \
keep this author information in any copy you use or distribute.\
\>", "SmallText"],

Cell[TextData[{
  "In general, in this notebook, anything in ",
  StyleBox["magenta",
    FontColor->RGBColor[1, 0, 1]],
  " is something you can, and possibly should, change."
}], "Text"],

Cell["\<\
Suppose we want to find the candidates for the maximum and minimum of a \
function f[x,y] on a region.  For this notebook we will assume the region is \
bounded by a curve given by g[x,y]=c.  We can search for candidates for the \
maximum and minimum using both critical point methods (on the interior of the \
region) and by the method of Lagrange multipliers (on the boundary of the \
region).  (Note:  If the region is closed and bounded, and the function is \
continuous on the region, then we are sure that there is both a maximum and a \
minimum on the region, each located at at least one of the candidates we \
find.  This will be the case for our default example.)  \
\>", "Text"],

Cell[CellGroupData[{

Cell["\<\
Initialization.  (Can be skipped, if you answer \"Yes\" to the initialization \
request.)\
\>", "Section"],

Cell[TextData[{
  "The gradient plots below require the Graphics`PlotField package to be \
loaded.  The next cell does that.  It also includes two ",
  StyleBox["Off",
    FontColor->RGBColor[1, 0, 0]],
  " commands to prevent a few annoying warning messages."
}], "Text"],

Cell[BoxData[{
    \(Needs["\<Graphics`PlotField`\>"]\), "\[IndentingNewLine]", 
    \(\(Off[General::"\<spell\>"];\)\), "\n", 
    \(\(Off[General::"\<spell1\>"];\)\)}], "Input",
  InitializationCell->True],

Cell[TextData[{
  "The next function extracts only the real solutions from the output of a ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " function ",
  StyleBox["Solve",
    FontColor->RGBColor[1, 0, 0]],
  " in the sections below."
}], "Text"],

Cell[BoxData[
    \(extractReal[a_] := 
      Extract[a, Position[N[{x, y} /. a], {_Real, _Real}]]\)], "Input",
  InitializationCell->True]
}, Closed]],

Cell[CellGroupData[{

Cell["Some graphs to guide us.", "Section"],

Cell[TextData[{
  "The cell below produces two plots.  One is the (surface) graph of the \
function itself, and the other superimposes contours of the function, a \
gradient field for the function, and our constraint curve.  ",
  StyleBox["f[x,y]",
    FontColor->RGBColor[1, 0, 1]],
  " is the function to be maximized or minimized and ",
  StyleBox["g[x,y]",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox["=",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox["c",
    FontColor->RGBColor[1, 0, 1]],
  " is the constraint curve.  In the second plot the constraint curve is in \
",
  StyleBox["red",
    FontColor->RGBColor[1, 0, 0]],
  ", and the contours of f[x,y] are in ",
  StyleBox["green",
    FontColor->RGBColor[0, 1, 0]],
  ".  The x-y plot region in both is given by ",
  StyleBox["xmin",
    FontColor->RGBColor[1, 0, 1]],
  ", ",
  StyleBox["xmax",
    FontColor->RGBColor[1, 0, 1]],
  ", ",
  StyleBox["ymin",
    FontColor->RGBColor[1, 0, 1]],
  ", and ",
  StyleBox["ymax",
    FontColor->RGBColor[1, 0, 1]],
  "."
}], "Text"],

Cell[BoxData[{\(Clear[f, g, c, x, y, xmin, xmax, ymin, ymax, contourPlot, 
      constraintPlot, gradPlot]\), "\n", 
    RowBox[{\(f[x_, y_]\), ":=", 
      StyleBox[" ",
        FontColor->RGBColor[1, 0, 1]], 
      StyleBox[\(x\^3 + 3\ x\ y\^2 - 3\ x\^2 - 3\ y\^2 + 7\),
        FontColor->RGBColor[1, 0, 1]]}], "\n", 
    RowBox[{\(g[x_, y_]\), ":=", 
      StyleBox[\(x\^2 + \ y\^2\),
        FontColor->RGBColor[1, 0, 1]]}], "\n", 
    RowBox[{
      RowBox[{"c", "=", 
        StyleBox["4",
          FontColor->RGBColor[1, 0, 1]]}], ";"}], "\n", 
    RowBox[{
      RowBox[{"xmin", "=", 
        RowBox[{"-", 
          StyleBox["3",
            FontColor->RGBColor[1, 0, 1]]}]}], ";"}], "\n", 
    RowBox[{
      RowBox[{"xmax", "=", 
        StyleBox["3",
          FontColor->RGBColor[1, 0, 1]]}], ";"}], "\n", 
    RowBox[{
      RowBox[{"ymin", "=", 
        StyleBox[\(-3\),
          FontColor->RGBColor[1, 0, 1]]}], ";"}], "\n", 
    RowBox[{
      RowBox[{"ymax", "=", 
        StyleBox["3",
          FontColor->RGBColor[1, 0, 1]]}], ";"}], "\n", 
    RowBox[{
      RowBox[{
        RowBox[{"Plot3D", "[", 
          RowBox[{\(f[x, y]\), ",", \({x, xmin, xmax}\), ",", 
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "ymin", ",", "ymax"}], "}"}], 
            ",", \(AxesLabel \[Rule] {"\<x\>", "\<y\>", "\<z\>"}\)}], "]"}], 
        ";"}], "\t\t"}], "\n", 
    RowBox[{
      RowBox[{"gradPlot", "=", 
        RowBox[{"PlotGradientField", "[", 
          RowBox[{\(f[x, y]\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "xmin", ",", "xmax"}], "}"}], ",",
             
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "ymin", ",", "ymax"}], "}"}], 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], ";"}], "\n",
   
    RowBox[{
      RowBox[{"contourPlot", "=", 
        RowBox[{"ContourPlot", "[", 
          RowBox[{\(f[x, y]\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "xmin", ",", "xmax"}], "}"}], ",",
             
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "ymin", ",", "ymax"}], "}"}], ",",
             
            RowBox[{"Contours", "\[Rule]", 
              StyleBox["30",
                FontColor->RGBColor[1, 0, 1]]}], ",", 
            RowBox[{"PlotPoints", "\[Rule]", 
              StyleBox["30",
                FontColor->RGBColor[1, 0, 1]]}], 
            ",", \(ContourShading -> False\), 
            ",", \(ContourStyle \[Rule] RGBColor[0, 1, 0]\), 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], ";"}], "\n",
   
    RowBox[{
      RowBox[{"constraintPlot", "=", 
        RowBox[{"ContourPlot", "[", 
          RowBox[{\(g[x, y]\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "xmin", ",", "xmax"}], "}"}], ",",
             
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "ymin", ",", "ymax"}], "}"}], 
            ",", \(Contours -> {c}\), ",", \(PlotPoints \[Rule] 30\), 
            ",", \(ContourShading -> False\), 
            ",", \(ContourStyle \[Rule] RGBColor[1, 0, 0]\), 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], 
      ";"}], "\n", \(Show[gradPlot, contourPlot, constraintPlot, 
        DisplayFunction \[Rule] $DisplayFunction];\)}], "Input"],

Cell[TextData[{
  StyleBox["Try to use the second plot to find where the candidates for the \
maximum and minimum of the function on the region are located.",
    FontColor->RGBColor[1, 0, 1]],
  "    Remember that candidates in the interior should be critical points of \
f[x,y], while candidates on the boundary should be located at places on the \
constraint curve where the contours of f[x,y] are tangent to the constraint \
curve, or equivalently where the gradient field of f[x,y] is perpendicular to \
the curve.  (A critical point on the boundary is also a candidate; if we use \
Lagrange multipliers to find such a point, what should the value of the \
multiplier \[Lambda] be there?)  Keep in mind that only a representative \
sample of countours of f[x,y] are being drawn."
}], "Text"],

Cell[TextData[{
  "In the sections below, the ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " syntax will only find critical points where the partial derivatives are \
0.  If the function f[x,y] is not differentiable on the region, it will not \
necessarily find the maximum and minimum of f[x,y]."
}], "Text",
  FontColor->RGBColor[0.500008, 0, 0.996109]]
}, Closed]],

Cell[CellGroupData[{

Cell["Critical points in the interior.", "Section"],

Cell[TextData[{
  StyleBox["(Make sure the cells in the \"Some graphs...\" section above have \
been evaluated during your current ",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox["Mathematica",
    FontSlant->"Italic",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox[" session before proceeding with this section.)",
    FontColor->RGBColor[1, 0, 1]]
}], "Text"],

Cell[TextData[{
  "To find the critical points for the function f[x,y] we need to set all the \
partial derivatives equal to zero, and solve the equations simultaneously.   \
",
  StyleBox["On paper, write down these equations.",
    FontColor->RGBColor[1, 0, 1]],
  "  In case you forgot what f[x,y] is, you can use the next cell to remind \
yourself."
}], "Text"],

Cell[BoxData[
    \(f[x, y]\)], "Input"],

Cell[TextData[{
  "We can have ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " check our work.  The next cell gives us the equations we need to solve."
}], "Text"],

Cell[BoxData[
    \({\[PartialD]\_x\ f[x, y]\  == \ 0, \[PartialD]\_y\ f[x, y]\  \[Equal] 
        0}\)], "Input"],

Cell[TextData[{
  StyleBox["Try to solve these equations on paper.",
    FontColor->RGBColor[1, 0, 1]],
  "  (In the default example they should not be too difficult to solve.  You \
might start with the second equation.)"
}], "Text"],

Cell[TextData[{
  "We can use ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " to solve these equations and find the critical points of the function for \
us."
}], "Text"],

Cell[BoxData[{
    \(Clear[csol]\), "\n", 
    \(csol = 
      extractReal[
        Solve[{\[PartialD]\_x\ f[x, y]\  == \ 
              0, \[PartialD]\_y\ f[x, y]\  \[Equal] 0}, {x, y}]]\)}], "Input"],

Cell[TextData[{
  "In our default example, all of these points are in the region.  Note that \
if you cannot get exact solutions using ",
  StyleBox["Solve",
    FontColor->RGBColor[1, 0, 0]],
  " you can get approximate solutions by various methods, including the ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " command ",
  StyleBox["FindRoot.  ",
    FontColor->RGBColor[1, 0, 0]],
  "You can also use the notebook ",
  ButtonBox["Gradient_Search.nb",
    ButtonData:>{"Gradient_Search.nb", None},
    ButtonStyle->"Hyperlink"],
  ", available in the same location as this notebook, to hunt for critical \
points for a function."
}], "Text"],

Cell["\<\
We can display the result as a list of ordered pairs using the next cell.\
\>", "Text"],

Cell[BoxData[
    \({x, y} /. csol\)], "Input"],

Cell["\<\
We need to substitute all these points into the function in order to find the \
function values there.  The next cell does this for us.\
\>", "Text"],

Cell[BoxData[
    \(f[x, y] /. csol\)], "Input"],

Cell["\<\
The largest value of f[x,y] is the candidate for the maximum of f[x,y] in the \
interior, and the smallest the candidate for the minimum of f[x,y] in the \
interior.  (Notice the use of the word candidate; we don't know if there is a \
maximum and/or a minimum in the interior.)\
\>", "Text"],

Cell["\<\
We can plot these points on top of the gradient field using the next cell.\
\>", "Text"],

Cell[BoxData[{
    \(Clear[pointPlot]\), "\n", 
    \(\(pointPlot = 
        ListPlot[{x, y} /. csol, PlotStyle \[Rule] PointSize[ .025], 
          PlotRange \[Rule] {{xmin, xmax}, {ymin, ymax}}, Axes \[Rule] False, 
          DisplayFunction \[Rule] Identity];\)\), "\n", 
    \(\(Show[gradPlot, pointPlot, 
        DisplayFunction \[Rule] $DisplayFunction];\)\)}], "Input"],

Cell[TextData[StyleBox["Try to decide from the plot which critical points are \
places where f[x,y] has local minima, local maxima, and saddle points.",
  FontColor->RGBColor[1, 0, 1]]], "Text"]
}, Closed]],

Cell[CellGroupData[{

Cell["Lagrange multipliers on the boundary.", "Section"],

Cell[TextData[{
  StyleBox["(Make sure the cells in the \"Some graphs...\" section above have \
been evaluated during your current ",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox["Mathematica",
    FontSlant->"Italic",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox[" session before proceeding with this section.)",
    FontColor->RGBColor[1, 0, 1]]
}], "Text"],

Cell[TextData[{
  "For the Lagrange multiplier method we need to set the gradient of our \
f[x,y] equal to a multiple \[Lambda] of the gradient of our constraint \
function g.    This gives a set of equations to which we add the constraint \
equation.  ",
  StyleBox["On paper, write down the equations we need to solve.",
    FontColor->RGBColor[1, 0, 1]],
  "  In case you forgot what f[x,y], g[x,y], and c are, you can use the next \
cell to remind yourself."
}], "Text"],

Cell[BoxData[{
    \(f[x, y]\), "\n", 
    \(g[x, y] \[Equal] c\)}], "Input"],

Cell[TextData[{
  "We can have ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " check our work.  The next cell gives us the equations we need to solve."
}], "Text"],

Cell[BoxData[
    \({\[PartialD]\_x\ 
          f[x, y]\  == \ \[Lambda]\ \[PartialD]\_x\ g[x, y], \[PartialD]\_y\ 
          f[x, y]\  == \ \[Lambda] \[PartialD]\_y\ g[x, y], 
      g[x, y]\  \[Equal] c}\)], "Input"],

Cell[TextData[{
  StyleBox["Try to solve these equations on paper.",
    FontColor->RGBColor[1, 0, 1]],
  "  (In the default example they are not trivial to solve, but they should \
not be too difficult.  One way is to start by multiplying the first equation \
by y and the second by x, and then subtracting the second from the first.  \
Don't forget that the constraint equation says that ",
  Cell[BoxData[
      \(x\^2 + y\^2\)]],
  " can be replaced by the number 4.)"
}], "Text"],

Cell[TextData[{
  "Here's how to solve the equations with ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  "."
}], "Text"],

Cell[BoxData[{
    \(Clear[lsol]\), "\n", 
    \(lsol = 
      extractReal[
        Solve[{\[PartialD]\_x\ 
                f[x, y]\  == \ \[Lambda]\ \[PartialD]\_x\ 
                  g[x, y], \[PartialD]\_y\ 
                f[x, y]\  == \ \[Lambda] \[PartialD]\_y\ g[x, y], 
            g[x, y]\  \[Equal] c}, {x, y, \[Lambda]}]]\)}], "Input"],

Cell["\<\
We can extract the {x,y} coordinate pairs from this using the next cell.\
\>", "Text"],

Cell[BoxData[
    \({x, y} /. lsol\)], "Input"],

Cell["\<\
We need to substitute all these points into the function in order to find the \
function values there.  The next cell does this for us.\
\>", "Text"],

Cell[BoxData[
    \(f[x, y] /. lsol\)], "Input"],

Cell["\<\
Finally we can put together the points and the function values in a list.\
\>", "Text"],

Cell[BoxData[
    \({x, y, f[x, y]} /. lsol\)], "Input"],

Cell["\<\
The largest value of f[x,y] is the candidate for the maximum of f[x,y] \
subject to the constraint (i.e. on the boundary curve), and the smallest the \
candidate for the minimum of f[x,y] subject to the constraint.  You should \
note that these are the candidates on the boundary curve only, and the \
maximum and/or minimum for the function on the region may be in the interior, \
or may not even exist.  (For our default example we know that there is a \
maximum and a minimum on the region, as the function is continuous and the \
region is closed and bounded.  Each is located at one or more of the critical \
points we found in the previous section or at one of the points we just found \
using Lagrange multipliers.  We even know that there is a maximum and a \
minimum of f[x,y] subject to the constraint, that is, on the boundary, and \
each is located at one or more of the points we found using Lagrange \
multipliers.) \
\>", "Text"],

Cell["\<\
We can put the points we have found onto the graph, and draw the specific \
contours of f[x,y] which are tangent to the constraint curve using the cell \
below.\
\>", "Text"],

Cell[BoxData[{\(Clear[contourPlot, pointPlot]\), "\n", 
    RowBox[{
      RowBox[{"contourPlot", "=", 
        RowBox[{"ContourPlot", "[", 
          RowBox[{\(f[x, y]\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "xmin", ",", "xmax"}], "}"}], ",",
             
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], "ymin", ",", "ymax"}], "}"}], 
            ",", \(Contours \[Rule] \((f[x, y] /. lsol)\)\), 
            ",", \(PlotPoints \[Rule] 30\), ",", \(ContourShading -> False\), 
            ",", \(ContourStyle \[Rule] RGBColor[0, 1, 0]\), 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], 
      ";"}], "\n", \(pointPlot = 
        ListPlot[{x, y} /. lsol, PlotStyle \[Rule] PointSize[ .025], 
          PlotRange \[Rule] {{xmin, xmax}, {ymin, ymax}}, Axes \[Rule] False, 
          DisplayFunction \[Rule] Identity];\), "\n", \(Show[gradPlot, 
        contourPlot, constraintPlot, pointPlot, 
        DisplayFunction \[Rule] $DisplayFunction];\)}], "Input"],

Cell[TextData[StyleBox["Does everything seem reasonable?",
  FontColor->RGBColor[1, 0, 1]]], "Text"],

Cell[CellGroupData[{

Cell["Some explanations about the contours in the default example.", \
"Subsection"],

Cell[TextData[{
  "In the default example, where ",
  StyleBox["f[x,y] = ",
    FontFamily->"Times New Roman"],
  Cell[BoxData[
      \(x\^3 + 3\ x\ y\^2 - 3\ x\^2 - 3\ y\^2 + 7\)],
    FontFamily->"Times New Roman"],
  StyleBox[" and the constraint curve is ",
    FontFamily->"Times New Roman"],
  Cell[BoxData[
      \(x\^2 + \ y\^2\)],
    FontFamily->"Times New Roman"],
  StyleBox["=4, two of the contours need some explanation.  Let's take a \
closer look at them.",
    FontFamily->"Times New Roman"]
}], "Text"],

Cell[TextData[{
  StyleBox["The point a",
    FontFamily->"Times New Roman"],
  "t (2,0) is one of our critical points, and the function value there is 3.  \
Here we will only show the contour where f[x,y] = 3."
}], "Text"],

Cell[BoxData[{\(Clear[gradPlot, contourPlot, constraintPlot, 
      gradPlot]\), "\n", 
    RowBox[{
      RowBox[{"gradPlot", "=", 
        RowBox[{"PlotGradientField", "[", 
          RowBox[{\(x\^3 + 3\ x\ y\^2 - 3\ x\^2 - 3\ y\^2 + 7\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], ",", 
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], ";"}], "\n",
   
    RowBox[{
      RowBox[{"contourPlot", "=", 
        RowBox[{"ContourPlot", "[", 
          RowBox[{\(x\^3 + 3\ x\ y\^2 - 3\ x\^2 - 3\ y\^2 + 7\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], ",", 
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], 
            ",", \(Contours \[Rule] {3}\), ",", \(PlotPoints \[Rule] 30\), 
            ",", \(ContourShading -> False\), 
            ",", \(ContourStyle \[Rule] RGBColor[0, 1, 0]\), 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], ";"}], "\n",
   
    RowBox[{
      RowBox[{"constraintPlot", "=", 
        RowBox[{"ContourPlot", "[", 
          RowBox[{\(x\^2 + \ y\^2\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], ",", 
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], 
            ",", \(Contours -> {4}\), ",", \(PlotPoints \[Rule] 30\), 
            ",", \(ContourShading -> False\), 
            ",", \(ContourStyle \[Rule] RGBColor[1, 0, 0]\), 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], 
      ";"}], "\n", \(pointPlot = 
        ListPlot[{{2, 0}}, PlotStyle \[Rule] PointSize[ .025], 
          PlotRange \[Rule] {{\(-3\), 3}, {\(-3\), 3}}, Axes \[Rule] False, 
          DisplayFunction \[Rule] Identity];\), "\n", \(Show[gradPlot, 
        contourPlot, constraintPlot, pointPlot, 
        DisplayFunction \[Rule] $DisplayFunction];\)}], "Input"],

Cell[TextData[{
  "Notice that the curve pictured in ",
  StyleBox["green",
    FontColor->RGBColor[0, 1, 0]],
  " doesn't pass through the point.  At (2,0) we have a local minimum (how \
can we tell this from the gradient field?), so the horizontal slice that \
produces the contour is tangent to the surface at that point, and doesn't \
produce a curve passing through the point.  The slice does hit the surface \
again, producing the ",
  StyleBox["green",
    FontColor->RGBColor[0, 1, 0]],
  " curve."
}], "Text"],

Cell[TextData[{
  "The other contour of interest is the one passing through the points ",
  Cell[BoxData[
      StyleBox[\({\@2, \(-\@2\)}\ and {\@2, \@2}\),
        FontFamily->"Times New Roman"]], "Output"],
  ".  There the function value is -5+8",
  Cell[BoxData[
      \(TraditionalForm\`\@2\)]],
  ".  Here is the plot."
}], "Text"],

Cell[BoxData[{\(Clear[contourPlot, pointPlot]\), "\n", 
    RowBox[{
      RowBox[{"contourPlot", "=", 
        RowBox[{"ContourPlot", "[", 
          RowBox[{\(x\^3 + 3\ x\ y\^2 - 3\ x\^2 - 3\ y\^2 + 7\), ",", 
            RowBox[{"{", 
              RowBox[{"x", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], ",", 
            RowBox[{"{", 
              RowBox[{"y", 
                StyleBox[",",
                  FontColor->GrayLevel[0]], \(-3\), ",", "3"}], "}"}], 
            ",", \(Contours \[Rule] {\(-5\) + 8\ \@2}\), 
            ",", \(PlotPoints \[Rule] 30\), ",", \(ContourShading -> False\), 
            ",", \(ContourStyle \[Rule] RGBColor[0, 1, 0]\), 
            ",", \(DisplayFunction \[Rule] Identity\)}], "]"}]}], 
      ";"}], "\n", \(pointPlot = 
        ListPlot[{{\@2, \(-\@2\)}, {\@2, \@2}}, 
          PlotStyle \[Rule] PointSize[ .025], 
          PlotRange \[Rule] {{\(-3\), 3}, {\(-3\), 3}}, Axes \[Rule] False, 
          DisplayFunction \[Rule] Identity];\), "\n", \(Show[gradPlot, 
        contourPlot, constraintPlot, pointPlot, 
        DisplayFunction \[Rule] $DisplayFunction];\)}], "Input"],

Cell["\<\
Notice that this contour comes in two pieces, only one of which touches the \
constraint curve.\
\>", "Text"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{

Cell["The maximum and the minimum.", "Section"],

Cell[TextData[{
  StyleBox["(Make sure the cells in the \"Some graphs...,\" Critical \
points...,\" and \"Lagrange multipliers...\" sections, as well as the \
initialization, have been evaluated during your current ",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox["Mathematica",
    FontSlant->"Italic",
    FontColor->RGBColor[1, 0, 1]],
  StyleBox[" session, using a single definition for each of f[x,y], g[x,y], \
and c, before proceeding with this section.)",
    FontColor->RGBColor[1, 0, 1]]
}], "Text"],

Cell["\<\
We can now find the candidate for the maximum of f[x,y] on the region bounded \
by g[x,y]=c and the candidate for the minimum of f[x,y] on the region.  First \
we can remind ourselves what f[x,y], g[x,y], and c are using the next cell.\
\>", "Text"],

Cell[BoxData[{
    \(f[x, y]\), "\n", 
    \(g[x, y] \[Equal] c\)}], "Input"],

Cell["\<\
The candidates for the locations of the maximum and the minimum in the \
interior were\
\>", "Text"],

Cell[BoxData[
    \({x, y} /. csol\)], "Input"],

Cell["The candidates on the boundary were", "Text"],

Cell[BoxData[
    \({x, y} /. lsol\)], "Input"],

Cell["\<\
We would like to evaluate f[x,y] at each of these points.  We can do this \
using\
\>", "Text"],

Cell[BoxData[{
    \(Clear[candidates]\), "\n", 
    \(candidates = f[x, y] /. Union[csol, lsol]\)}], "Input"],

Cell["The candidate for the maximum is", "Text"],

Cell[BoxData[
    \(Max[candidates]\)], "Input"],

Cell["and for the minimum is", "Text"],

Cell[BoxData[
    \(Min[candidates]\)], "Input"],

Cell["\<\
For our default example these would be the maximum and minimum on the region \
respectively (and will be in any situation where we know a maximum and a \
minimum exist).  Using the next list of points with function values, we can \
pick out the points where each is located.\
\>", "Text"],

Cell[BoxData[{
    \(Clear[points]\), "\n", 
    \(points = {x, y, f[x, y]} /. Union[csol, lsol]\)}], "Input"],

Cell[TextData[{
  "Here's how to get ",
  StyleBox["Mathematica",
    FontSlant->"Italic"],
  " to do this last bit of work for us.  First we find the positions of the \
maximum and the minimum in the list of candidates (i.e. function values at \
our points)."
}], "Text"],

Cell[BoxData[{
    \(Clear[maxPosition]\), "\n", 
    \(maxPosition = Position[candidates, Max[candidates], 1]\)}], "Input"],

Cell[BoxData[{
    \(Clear[minPosition]\), "\n", 
    \(minPosition = Position[candidates, Min[candidates], 1]\)}], "Input"],

Cell[TextData[{
  "We need to find the points at these postions in our list of points with \
function values from above.  We can do this using ",
  StyleBox["Extract",
    FontColor->RGBColor[1, 0, 0]],
  ".  First we find the place(s) where the maximum occurs (provided we know \
there is a maximum)."
}], "Text"],

Cell[BoxData[
    \(Extract[points, maxPosition]\)], "Input"],

Cell["\<\
Finally we find the place(s) where the minimum occurs (provided we know there \
is a minimum).\
\>", "Text"],

Cell[BoxData[
    \(Extract[points, minPosition]\)], "Input"],

Cell["We're done!", "Text"]
}, Closed]]
}, Open  ]]
},
FrontEndVersion->"4.1 for Microsoft Windows",
ScreenRectangle->{{0, 1024}, {0, 722}},
AutoGeneratedPackage->None,
WindowToolbars->"EditBar",
WindowSize->{682, 663},
WindowMargins->{{-1, Automatic}, {Automatic, 0}}
]

(*******************************************************************
Cached data follows.  If you edit this Notebook file directly, not
using Mathematica, you must remove the line containing CacheID at
the top of  the file.  The cache data will then be recreated when
you save this file from within Mathematica.
*******************************************************************)

(*CellTagsOutline
CellTagsIndex->{}
*)

(*CellTagsIndex
CellTagsIndex->{}
*)

(*NotebookFileOutline
Notebook[{

Cell[CellGroupData[{
Cell[1727, 52, 115, 2, 186, "Title"],
Cell[1845, 56, 250, 4, 44, "SmallText"],
Cell[2098, 62, 188, 5, 33, "Text"],
Cell[2289, 69, 699, 10, 128, "Text"],

Cell[CellGroupData[{
Cell[3013, 83, 116, 3, 59, "Section"],
Cell[3132, 88, 272, 6, 52, "Text"],
Cell[3407, 96, 207, 4, 70, "Input",
  InitializationCell->True],
Cell[3617, 102, 256, 8, 33, "Text"],
Cell[3876, 112, 139, 3, 30, "Input",
  InitializationCell->True]
}, Closed]],

Cell[CellGroupData[{
Cell[4052, 120, 43, 0, 39, "Section"],
Cell[4098, 122, 1039, 33, 90, "Text"],
Cell[5140, 157, 3760, 98, 390, "Input"],
Cell[8903, 257, 796, 12, 128, "Text"],
Cell[9702, 271, 367, 8, 52, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[10106, 284, 51, 0, 39, "Section"],
Cell[10160, 286, 361, 9, 52, "Text"],
Cell[10524, 297, 365, 8, 71, "Text"],
Cell[10892, 307, 40, 1, 30, "Input"],
Cell[10935, 310, 174, 5, 33, "Text"],
Cell[11112, 317, 114, 2, 30, "Input"],
Cell[11229, 321, 234, 5, 52, "Text"],
Cell[11466, 328, 181, 6, 33, "Text"],
Cell[11650, 336, 201, 5, 50, "Input"],
Cell[11854, 343, 655, 17, 71, "Text"],
Cell[12512, 362, 97, 2, 33, "Text"],
Cell[12612, 366, 47, 1, 30, "Input"],
Cell[12662, 369, 159, 3, 33, "Text"],
Cell[12824, 374, 48, 1, 30, "Input"],
Cell[12875, 377, 302, 5, 71, "Text"],
Cell[13180, 384, 98, 2, 33, "Text"],
Cell[13281, 388, 376, 7, 90, "Input"],
Cell[13660, 397, 194, 2, 33, "Text"]
}, Closed]],

Cell[CellGroupData[{
Cell[13891, 404, 56, 0, 39, "Section"],
Cell[13950, 406, 361, 9, 52, "Text"],
Cell[14314, 417, 474, 9, 71, "Text"],
Cell[14791, 428, 77, 2, 50, "Input"],
Cell[14871, 432, 174, 5, 33, "Text"],
Cell[15048, 439, 217, 4, 30, "Input"],
Cell[15268, 445, 484, 10, 71, "Text"],
Cell[15755, 457, 130, 5, 33, "Text"],
Cell[15888, 464, 346, 8, 90, "Input"],
Cell[16237, 474, 96, 2, 33, "Text"],
Cell[16336, 478, 47, 1, 30, "Input"],
Cell[16386, 481, 159, 3, 33, "Text"],
Cell[16548, 486, 48, 1, 30, "Input"],
Cell[16599, 489, 97, 2, 33, "Text"],
Cell[16699, 493, 56, 1, 30, "Input"],
Cell[16758, 496, 954, 14, 166, "Text"],
Cell[17715, 512, 184, 4, 52, "Text"],
Cell[17902, 518, 1152, 23, 170, "Input"],
Cell[19057, 543, 100, 1, 33, "Text"],

Cell[CellGroupData[{
Cell[19182, 548, 84, 1, 47, "Subsection"],
Cell[19269, 551, 520, 15, 52, "Text"],
Cell[19792, 568, 223, 5, 52, "Text"],
Cell[20018, 575, 2443, 54, 276, "Input"],
Cell[22464, 631, 518, 12, 71, "Text"],
Cell[22985, 645, 337, 9, 52, "Text"],
Cell[23325, 656, 1187, 23, 179, "Input"],
Cell[24515, 681, 119, 3, 33, "Text"]
}, Closed]]
}, Closed]],

Cell[CellGroupData[{
Cell[24683, 690, 47, 0, 39, "Section"],
Cell[24733, 692, 509, 11, 71, "Text"],
Cell[25245, 705, 259, 4, 52, "Text"],
Cell[25507, 711, 77, 2, 50, "Input"],
Cell[25587, 715, 110, 3, 33, "Text"],
Cell[25700, 720, 47, 1, 30, "Input"],
Cell[25750, 723, 51, 0, 33, "Text"],
Cell[25804, 725, 47, 1, 30, "Input"],
Cell[25854, 728, 105, 3, 33, "Text"],
Cell[25962, 733, 110, 2, 50, "Input"],
Cell[26075, 737, 48, 0, 33, "Text"],
Cell[26126, 739, 48, 1, 30, "Input"],
Cell[26177, 742, 38, 0, 33, "Text"],
Cell[26218, 744, 48, 1, 30, "Input"],
Cell[26269, 747, 298, 5, 71, "Text"],
Cell[26570, 754, 110, 2, 50, "Input"],
Cell[26683, 758, 272, 7, 52, "Text"],
Cell[26958, 767, 124, 2, 50, "Input"],
Cell[27085, 771, 124, 2, 50, "Input"],
Cell[27212, 775, 314, 7, 52, "Text"],
Cell[27529, 784, 61, 1, 30, "Input"],
Cell[27593, 787, 118, 3, 33, "Text"],
Cell[27714, 792, 61, 1, 30, "Input"],
Cell[27778, 795, 27, 0, 33, "Text"]
}, Closed]]
}, Open  ]]
}
]
*)



(*******************************************************************
End of Mathematica Notebook file.
*******************************************************************)