(************** Content-type: application/mathematica **************
                     CreatedBy='Mathematica 5.0'

                    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[     14766,        412]*)
(*NotebookOutlinePosition[     15466,        436]*)
(*  CellTagsIndexPosition[     15422,        432]*)
(*WindowFrame->Normal*)



Notebook[{
Cell[BoxData[
    \(<< Graphics`Arrow`\)], "Input"],

Cell[CellGroupData[{

Cell[TextData[StyleBox["Function",
  FontSize->24]], "Text"],

Cell[BoxData[{
    \(\(Clear[iterations, f, x, k, old, \ new, \ grad, CurrentGradient, 
        BasePlot, Pointlist, 
        newarrow];\)\[IndentingNewLine]\[IndentingNewLine]\), "\
\[IndentingNewLine]", 
    \(\(\(grad[
          g_] := {\[PartialD]\_x\ g, \[PartialD]\_y\ 
            g};\)\(\[IndentingNewLine]\)
    \)\), "\[IndentingNewLine]", 
    \(GradientSearch[start_, x1_, x2_, y1_, 
        y2_] := \ {\[IndentingNewLine]Pointlist = {}; \
\[IndentingNewLine]arrowlist = {}; \[IndentingNewLine]CurrentGradient[x_, 
            y_] = grad[f[x, y]]; \[IndentingNewLine]old = 
          start; \[IndentingNewLine]\[IndentingNewLine]BasePlot = 
          ContourPlot[
            f[x, y], {x, x1, x2}, {y, y1, 
              y2}]; \[IndentingNewLine]oldfunctionvalue = 
          f[old[\([1]\)], 
            old[\([2]\)]]; \[IndentingNewLine]newfunctionvalue = 
          oldfunctionvalue + 
            1; \[IndentingNewLine]\[IndentingNewLine]While[
              Abs[newfunctionvalue - 
                    oldfunctionvalue] >= \  .01, \[IndentingNewLine]\
\[IndentingNewLine] (*Solve\ for\ k*) \[IndentingNewLine]newk = \(-1\); \
\[IndentingNewLine]a = 0; \[IndentingNewLine]While[
                newk < 0, \t\[IndentingNewLine]new = 
                  old + k*
                      CurrentGradient[old[\([1]\)], 
                        old[\([2]\)]]; \[IndentingNewLine]\t
                dfdk = D[f[new[\([1]\)], new[\([2]\)]], 
                    k]; \[IndentingNewLine]\t
                sol = FindRoot[dfdk == 0, {k, a}, 
                    MaxIterations \[Rule] 50]; \[IndentingNewLine]\t
                newk = sol[\([1, 
                      2]\)]; \[IndentingNewLine]\(++a\);\[IndentingNewLine]]; \
\[IndentingNewLine]\[IndentingNewLine] (*find\ new\ solution\
*) \[IndentingNewLine]\t
              newsolution = 
                old + newk*
                    CurrentGradient[old[\([1]\)], 
                      old[\([2]\)]]; \[IndentingNewLine]Print["\<The Current \
gradient is \>", 
                newk*\ CurrentGradient[old[\([1]\)], 
                    old[\([2]\)]]]; \[IndentingNewLine]\[IndentingNewLine] \
(*set\ some\ variables*) \[IndentingNewLine]\t
              old = newsolution; \[IndentingNewLine]\t
              Pointlist = 
                Append[Pointlist, newsolution]; \[IndentingNewLine]\t
              oldfunctionvalue = 
                newfunctionvalue // N; \t\[IndentingNewLine]\t
              newfunctionvalue = 
                f[newsolution[\([1]\)] // N, 
                  newsolution[\([2]\)] // 
                    N]; \[IndentingNewLine]\t\tPrint["\<hey i'm the \
newfunctvalue \>", \ 
                newfunctionvalue];\[IndentingNewLine]]\[IndentingNewLine]lp = 
          ListPlot[Pointlist]; \[IndentingNewLine]\[IndentingNewLine]For[
            i = 1, i \[LessEqual] \ 
              Length[Pointlist] - 1, \(++i\), \[IndentingNewLine]newarrow = 
              Graphics[
                Arrow[Pointlist[\([i]\)], 
                  Pointlist[\([i + 1]\)]]]; \[IndentingNewLine]arrowlist = 
              Append[arrowlist, 
                newarrow];\[IndentingNewLine]]\[IndentingNewLine]Show[
            BasePlot, arrowlist];\[IndentingNewLine]}\)}], "Input"]
}, Open  ]],

Cell[TextData[StyleBox["Problem #1",
  FontSize->24]], "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((x/\((1 + Exp[ .1*x])\))\) - \((\((y - 
                  5)\)^2)\);\)\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{0, 0}, \(-3\), 13, 0, 8];\)\)}], "Input"],

Cell["\<\
The maximum by using the starting point (0, 0) of this function is 2.78318.  \
\
\>", "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((x/\((1 + Exp[ .1*x])\))\) - \((\((y - 
                  5)\)^2)\);\)\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{2, 2}, \(-3\), 13, 0, 8];\)\)}], "Input"],

Cell["\<\
The maximum using the point (2, 2), is 2.78303.
Therefore, we can conclude that with a tolerance of .01, our maximum is \
2.783.   \
\>", "Text"],

Cell[TextData[StyleBox["Problem #2",
  FontSize->24]], "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((2*x*y + 2  y - x\^2 - 
            2  y\^2)\);\)\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{0, 0}, 0, 3, 0, 2];\)\)}], "Input"],

Cell["\<\
a)  Starting at the point (0, 0), we find out maximum to be .992188 with a \
tolerance of .01.\
\>", "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((2*x*y + 2  y - x\^2 - 
            2  y\^2)\);\)\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{1.5,  .5}, \(-1\), 3, 0, 2];\)\)}], "Input"],

Cell["\<\
b)  Starting at the point (0, 0), we find out maximum to be .992188 with a \
tolerance of .01.  By looking at the contour diagram we can see that a \
starting point of (1.5, .5) will converge in one step.  We picked this point \
because any point that we pick that is on gradient that flows along the major \
or minor axis will always be perpendicular to the ellpis.  Therefore, it will \
converge in one step.  

  \
\>", "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((2*x*y + 2  y - x\^2 - 
            2  y\^2)\);\)\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{1.5,  .5}, \(-1\), 3, 0, 2];\)\)}], "Input"],

Cell["\<\
c)  In order to find a starting point that leads to convergence in two steps, \
we look for a point that perpendicular to the major and minor axis.  We know \
that the first step would get us to the major or minor axis, and from the \
problem above we also know that once we are on a major or minor axis we will \
be lead to the maximum in just one step, so we will always converge in two \
steps.  \
\>", "Text"],

Cell[TextData[StyleBox["Problem 3",
  FontSize->24]], "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((Sin[x\^2]*Cos[y] - 
            Cos[x]*Sin[y\^2])\);\)\), "\[IndentingNewLine]", 
    \(Plot3D[
      f[x, y], {x, \(-3\), 3}, {y, \(-3\), 3}]\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{\(- .8\),  .1}, \(-3\), 3, \(-4\), 4];\)\)}], "Input"],

Cell["\<\
If we start at the point (0, 0) we will end up at (0, 0).  This is because we \
are in a saddle point and if we start at that point we cannot get go \
anywhere.  \
\>", "Text"],

Cell["\<\
We first notice that we have to make sure that k is always positive, this \
will increase the chance that we find a maximum, because a negative k will go \
in the opposite direcdtion of the gradient.  \
\>", "Text"],

Cell["\<\
Now, there's a technique to this that we haven't quite mastered yet, but we \
are a work in progress and we have a general idea.  The arrows will always \
make perpendicular moves, so, you must select a path that ends up \
perpendicular to the contours of the global maximum at some point. Once the \
search has reached that point, it will converge to it.  Notice that after 5 \
iterations, our arrow is close to perpendicular to a contour line and thus \
converges to an optimal point.  Starting point={-.8,.1} and our function \
value was converging to 1, the optimal value.\
\>", "Text"],

Cell[TextData[StyleBox["Problem #4",
  FontSize->24,
  FontWeight->"Bold"]], "Text"],

Cell[BoxData[{
    \(\(f[x_, y_] = \((x - 2)\)\^4 + \((x - 2  y)\)\^2 - 
          5;\)\), "\[IndentingNewLine]", 
    \(\(g[x_, y_] = x\^2 - y;\)\)}], "Input"],

Cell["a)", "Text"],

Cell["\<\
In this heuristic we will implore the Distance formula.  Now, the optimal \
solution will be where all of these functions intersect i.e. where the \
distance between their respective points is 0.  Below is our Dist formula \
which takes the sqaure root of the difference in the square of the functions.\
\
\>", "Text"],

Cell[BoxData[{
    \(\(\(Dist[x_, 
          y_] = \@\((f[x, y] - g[x, y])\)\^2;\)\(\[IndentingNewLine]\)
    \) (*ContourPlot[Dist[x, y], {x, \(-5\), 10}, {y, \(-5\), 10}, \ 
        ContourShading \[Rule] False, 
        Contours \[Rule] 60]*) \), "\[IndentingNewLine]", 
    \(gradient = grad[Dist[x, y]]\), "\[IndentingNewLine]", 
    \(gary = Solve[{gradient == 0}, {x, y}] // N\)}], "Input"],

Cell["\<\
The optimal point in the distance formula is (3.12913, 1.43956).  This is the \
point where the distance between the two functions is the greatest.  It \
doesnt' really tell us to much, but it'll tell us our worst solution.\
\>", "Text"],

Cell[BoxData[
    \(ted = Solve[Dist[x, y] \[Equal] 0, y] // N\)], "Input"],

Cell[BoxData[
    \(ted /. x \[Rule] 2\)], "Input"],

Cell["\<\
We now solve the distance formula, equal to 0, for y.  This will be where the \
graphs are touching and give us a plethera of optimal points that lie on the \
region graphed by the above two equations.  We now solve the optimal points \
when x=2.    This gives us the y associated with an x value of 2 that will \
make our solution optimal.  We find that the points (2, -.544727), and (2, \
2.29473) will be our optimal points.  \
\>", "Text"],

Cell[BoxData[{
    \(Dist[2, \(- .0544727\)]\), "\[IndentingNewLine]", 
    \(Dist[2, 2.29473]\)}], "Input"],

Cell["\<\
We can plug the two points we get into Dist to get an answer.  It appears \
that the distance is zero and wil be an optimal point, so we do an exact \
check for both.  \
\>", "Text"],

Cell[CellGroupData[{

Cell[BoxData[
    \(\(Dist[x, y] /. ted\) /. x \[Rule] 2 // N\)], "Input"],

Cell["\<\
This proves that these are our optimal points because the distance between \
them is 0 and they lie on the border that encompasses all of the optimal \
points.  \
\>", "Text"],

Cell[BoxData[{
    \(\(plt1 = 
        Plot[{ted[\([1, 1, 2]\)]}, {x,  .2, 5}, 
          PlotStyle \[Rule] RGBColor[0, 0, 1]];\)\), "\[IndentingNewLine]", 
    \(\(plt2 = 
        Plot[{ted[\([2, 1, 2]\)]}, {x,  .2, 5}, 
          PlotStyle \[Rule] RGBColor[0, 1, 1]];\)\)}], "Input"]
}, Open  ]],

Cell[BoxData[
    \(Show[plt1, plt2]\)], "Input"],

Cell["\<\
These plots show our optimal region, on which we can find points to optimize \
the two functions we are looking for.  \
\>", "Text"],

Cell[BoxData[""], "Input"],

Cell[BoxData[{
    \(\(ab = 
        Plot3D[f[x, y], {x,  .5, 2.5}, {y, \(-5\), 
            5}];\)\), "\[IndentingNewLine]", 
    \(\(cd = 
        Plot3D[g[x, y], {x,  .5, 2.5}, {y, \(-5\), 5}, 
          Shading \[Rule] False];\)\)}], "Input"],

Cell[BoxData[
    \(Show[ab, cd, ViewPoint -> {3.344, \ 0, \ 3}]\)], "Input"],

Cell["\<\
This is another graph of the region in which our optimal points lie.  We can \
see the peanut shaped region above will be our optimal and we simply solve \
like we did above to find a point on that region.  \
\>", "Text"],

Cell["\<\
b.  Here is a simple way we actually know how to do, and we hope will also \
work!\
\>", "Text"],

Cell["\<\
Just solve one of the functions for a variable and plug it into the other!  \
We got q.\
\>", "Text"],

Cell[BoxData[
    \(q[x_] = f[x, y] /. y \[Rule] x\^2\)], "Input"],

Cell[BoxData[
    \(Plot[q[x], {x, 0, 2.5}]\)], "Input"],

Cell[BoxData[{
    \(\(dqdx = D[q[x], x];\)\), "\[IndentingNewLine]", 
    \(Solve[dqdx \[Equal] 0, x] // N\)}], "Input"],

Cell[BoxData[
    \( .945583\^2\)], "Input"],

Cell[BoxData[
    \(f[ .945583,  .894127]\)], "Input"],

Cell["The optimal point is (0.945583, .894127)", "Text"],

Cell[TextData[StyleBox["Problem 5",
  FontSize->24]], "Text"],

Cell[BoxData[{
    \(\(f[x_, 
          y_] = \((2*x*y + 2  y - x\^2 - 
            2  y\^2)\);\)\), "\[IndentingNewLine]", 
    \(\(GradientSearch[{0, 0}, 0, 3, 0, 2];\)\)}], "Input"],

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

Cell["a)", "Text"],

Cell[BoxData[
    \({0, 0.5`} . {0.5`, 0.`}\)], "Input"],

Cell[TextData[{
  "We can see from the calculation above that the gradient at ",
  Cell[BoxData[
      \(TraditionalForm\`x\^0\)]],
  " dotted with the gradient at ",
  Cell[BoxData[
      \(TraditionalForm\`x\^1\)]],
  " is 0, which means that they are perpendicular or orthogonal to each \
other."
}], "Text"],

Cell[BoxData[""], "Input"],

Cell["\<\
b)  This results holds in general for the direction vectors in a gradient \
search because of the way in which the search works.  We first go in the \
direction of the gradient times k until we find our max or max out in that \
direction.  Therefore, we have to pick a new direction to go.  Since we have \
already maxed out in the direction of our original k, the only direction that \
could lead to a higher value would be perpendicular to our original \
direction.  It is sort of like climbing a mountain peak.  If we have climbed \
in one direction as high as we can go, we know that if we go backwards at \
all, our function value will be decreasing.  Also, if we go forwards at all, \
our function value will be decreasing because we are at the max for that \
direction.  Therefore, the only possible solutions are to go in a direction \
perpendicular to the original direction.  This gives us the chance of finding \
a better max.    \
\>", "Text"]
},
FrontEndVersion->"5.0 for Microsoft Windows",
ScreenRectangle->{{0, 1024}, {0, 692}},
CellGrouping->Manual,
WindowSize->{927, 644},
WindowMargins->{{0, Automatic}, {Automatic, 0}},
StyleDefinitions -> "DemoText.nb"
]

(*******************************************************************
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[1754, 51, 51, 1, 40, "Input"],

Cell[CellGroupData[{
Cell[1830, 56, 60, 1, 41, "Text"],
Cell[1893, 59, 3242, 64, 960, "Input"]
}, Open  ]],
Cell[5150, 126, 62, 1, 45, "Text"],
Cell[5215, 129, 211, 4, 50, "Input"],
Cell[5429, 135, 103, 3, 33, "Text"],
Cell[5535, 140, 211, 4, 50, "Input"],
Cell[5749, 146, 155, 4, 52, "Text"],
Cell[5907, 152, 62, 1, 45, "Text"],
Cell[5972, 155, 184, 4, 51, "Input"],
Cell[6159, 161, 118, 3, 33, "Text"],
Cell[6280, 166, 193, 4, 51, "Input"],
Cell[6476, 172, 440, 9, 109, "Text"],
Cell[6919, 183, 193, 4, 51, "Input"],
Cell[7115, 189, 423, 7, 71, "Text"],
Cell[7541, 198, 61, 1, 45, "Text"],
Cell[7605, 201, 297, 6, 71, "Input"],
Cell[7905, 209, 186, 4, 33, "Text"],
Cell[8094, 215, 225, 4, 52, "Text"],
Cell[8322, 221, 600, 9, 90, "Text"],
Cell[8925, 232, 84, 2, 44, "Text"],
Cell[9012, 236, 160, 3, 50, "Input"],
Cell[9175, 241, 18, 0, 33, "Text"],
Cell[9196, 243, 328, 6, 52, "Text"],
Cell[9527, 251, 397, 7, 93, "Input"],
Cell[9927, 260, 247, 4, 52, "Text"],
Cell[10177, 266, 75, 1, 30, "Input"],
Cell[10255, 269, 51, 1, 30, "Input"],
Cell[10309, 272, 453, 7, 71, "Text"],
Cell[10765, 281, 108, 2, 50, "Input"],
Cell[10876, 285, 192, 4, 33, "Text"],

Cell[CellGroupData[{
Cell[11093, 293, 74, 1, 30, "Input"],
Cell[11170, 296, 185, 4, 33, "Text"],
Cell[11358, 302, 285, 6, 50, "Input"]
}, Open  ]],
Cell[11658, 311, 49, 1, 30, "Input"],
Cell[11710, 314, 142, 3, 33, "Text"],
Cell[11855, 319, 26, 0, 30, "Input"],
Cell[11884, 321, 246, 6, 50, "Input"],
Cell[12133, 329, 77, 1, 30, "Input"],
Cell[12213, 332, 231, 4, 52, "Text"],
Cell[12447, 338, 106, 3, 33, "Text"],
Cell[12556, 343, 111, 3, 33, "Text"],
Cell[12670, 348, 66, 1, 30, "Input"],
Cell[12739, 351, 56, 1, 30, "Input"],
Cell[12798, 354, 121, 2, 50, "Input"],
Cell[12922, 358, 44, 1, 30, "Input"],
Cell[12969, 361, 54, 1, 30, "Input"],
Cell[13026, 364, 56, 0, 33, "Text"],
Cell[13085, 366, 61, 1, 45, "Text"],
Cell[13149, 369, 184, 4, 51, "Input"],
Cell[13336, 375, 35, 1, 30, "Input"],
Cell[13374, 378, 18, 0, 33, "Text"],
Cell[13395, 380, 56, 1, 30, "Input"],
Cell[13454, 383, 311, 9, 33, "Text"],
Cell[13768, 394, 26, 0, 30, "Input"],
Cell[13797, 396, 965, 14, 109, "Text"]
}
]
*)



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