(************** 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[ 18202, 519]*) (*NotebookOutlinePosition[ 18943, 544]*) (* CellTagsIndexPosition[ 18899, 540]*) (*WindowFrame->Normal*) Notebook[{ Cell["\<\ Your write-up must respond to all the questions in red. In addition I want to \ see a summary in paragraph form relating the contours to the curves followed, \ as well as the connections between the maximum and minimums found in this lab \ and the lab on directional derivative.\ \>", "Text"], Cell[CellGroupData[{ Cell["Lagrange Goes Skateboarding: How High Does He Go? ", "Title"], Cell[TextData[StyleBox["Chapter 11, Section 8", FontFamily->"Arial", FontSize->16, FontWeight->"Bold"]], "Text"], Cell[CellGroupData[{ Cell["Introduction", "Section"], Cell[TextData[{ "OBJECTIVE: Learn how to maximize or minimize a function subject to a set \ of constraints using ", StyleBox["Mathematica", FontSlant->"Italic"], "." }], "Text"], Cell["\<\ How do you maximize or minimize a function subject to constraints? The \ skateboarder from the directional derivative project returns, and this time \ it's Lagrange himself. He will use his multipliers to determine precisely \ where along the figure-8 he reaches the high and low points of the surface. \ You will also investigate the role of the directional derivative.\ \>", "Text"], Cell[CellGroupData[{ Cell["Technology Guidelines", "Subsection", CellDingbat->"\[LightBulb]"], Cell[TextData[{ StyleBox["NOTE: If you have just finished a module, restart ", CellFrame->True, Background->None], StyleBox["Mathematica", CellFrame->True, FontSlant->"Italic", Background->None], StyleBox[ " before executing a new module.\nTO OPEN CELLS, put your cursor on the \ right cell bracket and double click.", CellFrame->True, Background->None], "\nTO STOP AN EXECUTION\n\tSelect the ", StyleBox["Kernel", FontSlant->"Italic"], " pull-down menu and click on ", StyleBox["Abort Evaluation.\n", FontSlant->"Italic"], "ORDER OF EXECUTION\n\tExecute cells in the order given. Do not skip any \ Input cells within a given notebook.\nSAVING NOTEBOOKS\n\tYou can save \ anytime to any directory you choose, and it is wise to save often.\n\t\ However, before you do your final save, delete all your output by selecting \ the \n\t ", StyleBox["Delete All Output", FontSlant->"Italic"], " selection under the ", StyleBox["Kernel", FontSlant->"Italic"], " pull-down menu.\nEXPERIENCING MAJOR PROBLEMS\n\tSave if appropriate, and \ then shut down ", StyleBox["Mathematica", FontSlant->"Italic"], " and start it up again." }], "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Part I: Revisiting the Skateboarder Problem", "Section"], Cell[CellGroupData[{ Cell["The Figure-8 Path", "Subsection"], Cell["\<\ In the project on the directional derivative, you looked at the rate of \ change of the height of a skateboarder who was tracing out a figure-8 on \ different surfaces. For this project, you will use the method of Lagrange \ multipliers to determine the points on the figure-8 path where the \ skateboarder's height reaches a maximum or a minimum. Then, you will revisit \ the graph of the directional derivative to help you interpret the results. \ \>", "Text"], Cell[TextData[{ "This function is best analyzed in rectangular coordinates; therefore, we \ will define position, velocity, and unit tangent vectors parametrically in ", StyleBox["x", FontSlant->"Italic"], " and ", StyleBox["y", FontSlant->"Italic"], ". To show the direction of movement along the figure-8, we place arrows on \ the graph, which requires reading in a special graphics arrow package. \ Remember that you ", StyleBox["must", FontWeight->"Bold"], " read in the package before you execute a command within the package. The \ package should be read in only once during a worksession." }], "Text"], Cell[BoxData[ \(<< Graphics`Arrow`\)], "Input"], Cell[BoxData[{ \(Off[General::spell]\ \), "\n", \(Off[General::spell1]\), "\n", \(Clear[x, y, t, f]\), "\n", \(\(x1[t_] = 16 \( Sin[t]\^2\) Cos[t];\)\), "\n", \(\(y1[t_] = 16 Sin[t]\^3;\)\), "\n", \(\(pp8 = ParametricPlot[{x1[t], y1[t]}, {t, 0, 2 \[Pi]}, AspectRatio -> Automatic, PlotStyle -> RGBColor[1, 0, 0], AxesLabel -> {"\", "\"}, Epilog \[Rule] {Arrow[{x1[1], y1[1]}, {x1[1.1], y1[1.1]}, HeadScaling \[Rule] Absolute], Arrow[{x1[2.5], y1[2.5]}, {x1[2.6], y1[2.6]}, HeadScaling \[Rule] Absolute], Arrow[{x1[4], y1[4]}, {x1[4.1], y1[4.1]}, HeadScaling \[Rule] Absolute], Arrow[{x1[5.5], y1[5.5]}, {x1[5.6], y1[5.6]}, HeadScaling \[Rule] Absolute]}];\)\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["The Ramp", "Subsection"], Cell["\<\ First, we look at the three-dimensional plot and contour plot of the ramp, \ both showing the figure-8. Can you estimate the points of maximum and minimum \ height, even before you solve the problem analytically?\ \>", "Text"], Cell[BoxData[{ \(Clear[x, y, t]\), "\n", \(\(ramp[x_, y_] = .1 x + .2 y;\)\), "\n", \(\(p8ramp = ParametricPlot3D[{x1[t], y1[t], ramp[x1[t], y1[t]], RGBColor[1, 0, 0]}, {t, 0, 2 \[Pi]}, AxesLabel -> {x, y, z}, DisplayFunction -> Identity];\)\), "\n", \(\(pramp = Plot3D[ramp[x, y], {x, \(-10\), 10}, {y, \(-20\), 20}, DisplayFunction -> Identity];\)\), "\n", \(\(Show[p8ramp, pramp, DisplayFunction -> $DisplayFunction];\)\), "\n", \(\(ctramp = ContourPlot[ramp[x, y], {x, \(-10\), 10}, {y, \(-20\), 20}, ContourShading -> False, DisplayFunction -> Identity];\)\), "\n", \(\(Show[pp8, ctramp, DisplayFunction -> $DisplayFunction];\)\)}], "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["You Try It: Part I", "Section"], Cell["\<\ Recall the bowl surface we explored in the directional derivative module. Now \ we will look at it again to estimate the locations where the skateboarder \ reaches the high and the low points.\ \>", "Text"], Cell[BoxData[{ \(\(bowl[x_, y_] = .02 x\^2 + .05 y\^2;\)\), "\n", \(\(p8bowl = ParametricPlot3D[{x1[t], y1[t], bowl[x1[t], y1[t]], {RGBColor[1, 0, 0]}}, {t, 0, 2 \[Pi]}, AxesLabel -> {x, y, z}, DisplayFunction -> Identity];\)\), "\n", \(\(pbowl = Plot3D[bowl[x, y] - .1, {x, \(-10\), 10}, {y, \(-20\), 20}, AxesLabel -> {x, y, z}, \ DisplayFunction -> Identity];\)\), "\n", \(\(Show[pbowl, p8bowl, DisplayFunction -> $DisplayFunction];\)\), "\n", \(\(ctbowl = ContourPlot[bowl[x, y], {x, \(-10\), 10}, {y, \(-20\), 20}, ContourShading -> False, DisplayFunction -> Identity];\)\), "\n", \(\(Show[ctbowl, pp8, DisplayFunction -> $DisplayFunction];\)\)}], "Input"], Cell[TextData[{ "As we noted in the directional derivative module, the surface is plotted \ just under where it should be so that the figure-8 shows up on top of it. \n\n\ ", StyleBox["From the geometry of the problem, indicate where you will reach \ the high and low points along the figure-8 inside the bowl.", FontWeight->"Bold", FontColor->RGBColor[1, 0, 0]] }], "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Part II: Applying the Method of Lagrange Multipliers", "Section"], Cell[TextData[{ "The figure-8 will be our constraint function, we will need to write it in \ non-parametric form. This is not a trivial step. You cannot eliminate the \ parameter ", StyleBox["t", FontSlant->"Italic"], " in many parametric expressions. For this figure-8, however, we can \ eliminate ", StyleBox["t,", FontSlant->"Italic"], " and the Cartesian form of the path can be written as ", StyleBox["(", FontSlant->"Italic"], Cell[BoxData[ \(TraditionalForm\`x\^2\)]], "+ ", Cell[BoxData[ \(TraditionalForm\`y\^2\)]], ")", Cell[BoxData[ \(TraditionalForm\`\(\ \^3\)\)]], Cell[BoxData[ \(TraditionalForm\`\(\ \(-\ \((4 y)\)\^4\)\)\)]], StyleBox["= 0.", FontSlant->"Italic"], "\nThe surfaces we consider are the ramp and the elliptical paraboloid \ (bowl). We will define the gradient in the usual fashion here." }], "Text"], Cell[BoxData[{ \(\(eight[x_, y_] = \((x\^2 + y\^2)\)\^3 - \((4 y)\)\^4;\)\), "\n", \(gradient[f_] := {D[f, x], D[f, y]}\)}], "Input"], Cell[TextData[ "Next, we set the gradient of the surface function equal to a product of a \ parameter, \[Lambda], times the gradient of the constraint function, and we \ also require that the constraint be satisfied."], "Text"], Cell[BoxData[{ \(Clear[x, y, \[Lambda]]\), "\n", \(solutionramp = Solve[{gradient[ ramp[x, y]] == \[Lambda]\ gradient[ eight[x, y]], \[IndentingNewLine]\ \ \ \ \ \ \ \ \ \ \ \ \ \ \ eight[ x, y] == 0}, \[IndentingNewLine]{x, y, \[Lambda]}]\)}], "Input"], Cell[TextData[{ "The solutions you just found are summarized in the table below where we \ indicate the ", StyleBox["x", FontSlant->"Italic"], ", ", StyleBox["y", FontSlant->"Italic"], ", and ", StyleBox["z", FontSlant->"Italic"], " coordinates of the critical points." }], "Text"], Cell[BoxData[{ \(\(results = Table[{solutionramp[\([i, 2, 2]\)], solutionramp[\([i, 3, 2]\)], ramp[solutionramp[\([i, 2, 2]\)], solutionramp[\([i, 3, 2]\)]]}, {i, 1, Length[solutionramp]}];\)\), "\n", \(display = PrependTo[results, {"\", "\", "\"}] // TableForm\)}], "Input"], Cell[TextData[{ "Contrast the values you find here to the values for ", StyleBox["x", FontSlant->"Italic"], " and ", StyleBox["y", FontSlant->"Italic"], " we found in the directional derivative module that occur when the \ directional derivative is 0." }], "Text"], Cell[BoxData[ TagBox[GridBox[{ {"\<\"x\"\>", "\<\"y\"\>", "\<\"z\"\>"}, {"2.44066983108720947`", "15.4168013273632897`", "3.32742724858137872`"}, {\(-1.38986303224366981`\), "0.440065091871244629`", \(-0.0509732848501180413`\)}, {\(-2.44066186681993224`\), \(-15.416805309487529`\), \(-3.32742724857949889`\)}, {"1.38986303045863547`", \(-0.440065090978727546`\), "0.0509732848501180235`"} }, RowSpacings->1, ColumnSpacings->3, RowAlignments->Baseline, ColumnAlignments->{Left}], (TableForm[ #]&)]], "Output"], Cell[TextData[StyleBox["What is the connection?", FontColor->RGBColor[1, 0, 0]]], "Text", FontWeight->"Bold"], Cell[TextData[StyleBox["Using the results above, identify the points on the \ contour and surface plots below that represent a maximum or minimum. ", FontColor->RGBColor[1, 0, 0]]], "Text", FontWeight->"Bold"], Cell[BoxData[{ \(\(Show[pp8, ctramp, DisplayFunction -> $DisplayFunction];\)\), "\n", \(\(Show[p8ramp, pramp, DisplayFunction -> $DisplayFunction];\)\)}], "Input"], Cell[TextData[StyleBox["What do you notice about the slope of the contours \ compared to the slope of the figure-8 curve at the critical points? What do \ these slopes have to do with the gradients? \nPrint out your plot and sketch \ the gradient of the ramp and of the figure-8 at both the critical points and \ a few other points. What do you notice?", FontColor->RGBColor[1, 0, 0]]], "Text", FontWeight->"Bold"] }, Closed]], Cell[CellGroupData[{ Cell["You Try It: Part II", "Section"], Cell[TextData[{ StyleBox[ "Now, follow the same steps for the bowl-shaped surface. Find all the \ values of "], StyleBox[Cell[BoxData[ \(TraditionalForm\`\({x, y}\ \ \)\)]]], StyleBox[ "that make the gradient of the bowl equal to a multiple (\[Lambda]) of the \ gradient of the figure-8 constraint. When you execute this command, you may \ get a warning that the "], StyleBox["Solve", FontWeight->"Bold"], StyleBox[ " command may not have given all solutions, however, it gives all the real \ solutions that you need here."] }], "Text"], Cell[BoxData[{ \(Clear[x, y, \[Lambda]]\), "\n", \(solutionbowl = Solve[{gradient[bowl[x, y]] == \[Lambda]\ gradient[eight[x, y]], eight[x, y] == 0}, {x, y, \[Lambda]}]\)}], "Input"], Cell[TextData[{ StyleBox["You can extract the solutions above and determine the "], StyleBox["z", FontSlant->"Italic"], StyleBox["-coordinate on the bowl at each of these points."] }], "Text"], Cell[BoxData[{ \(\(resultsbowl = Table[{solutionbowl[\([i, 2, 2]\)], solutionbowl[\([i, 3, 2]\)], bowl[solutionbowl[\([i, 2, 2]\)], solutionbowl[\([i, 3, 2]\)]]}, {i, 2, Length[solutionbowl]}];\)\), "\n", \(\(PrependTo[resultsbowl, {0, 0, 0}];\)\), "\n", \(displaybowl = PrependTo[resultsbowl, {"\", "\", "\"}] // TableForm\)}], "Input"], Cell["\<\ Again, let's contrast this to the results we found with the directional \ derivative.\ \>", "Text"], Cell[BoxData[ FormBox[ TagBox[GridBox[{ {"\<\"x\"\>", "\<\"y\"\>", "\<\"z\"\>"}, {"1.57619399585851667`*^-6", "15.9999999999997655`", "12.799999999999676`"}, {\(-0.0000104272856113163592`\), "8.41777135112082852`*^-9", "2.17456924734303047`*^-12"}, {\(-2.93905524917370541`*^-15\), \(-16.0000000000000008`\), "12.8000000000000024`"} }, RowSpacings->1, ColumnSpacings->3, RowAlignments->Baseline, ColumnAlignments->{Left}], (TableForm[ #]&)], TextForm]], "Text"], Cell[TextData[StyleBox["Identify the points on the contour plot and surface \ plot that resulted in a maximum or minimum. ", FontColor->RGBColor[1, 0, 0]]], "Text", FontWeight->"Bold"], Cell[BoxData[{ \(\(Show[pbowl, p8bowl, DisplayFunction -> $DisplayFunction];\)\), "\n", \(\(Show[ctbowl, pp8, DisplayFunction -> $DisplayFunction];\)\)}], "Input"], Cell[TextData[StyleBox["What do you notice about the slope of the contours \ compared to the slope of the figure-8 curve at the critical points? What do \ these slopes have to do with the gradients?\nSketch the gradient of the ramp \ and of the figure-8 at both the critical points and a few other points. What \ do you notice?", FontColor->RGBColor[1, 0, 0]]], "Text", FontWeight->"Bold"] }, Closed]], Cell[CellGroupData[{ Cell["You Try It: Take a Ride on a Roller Coaster", "Section"], Cell["\<\ S elect a surface of your own. Check out the following roller coaster in the form of a cubic.\ \>", "Text"], Cell[BoxData[{\(parx[t_] = 16 \( Sin[t]\^2\) Cos[t];\), "\n", \(pary[t_] = 16 Sin[t]\^3;\), "\n", \(path[x_, y_] := \((x\^2 + y\^2)\)\^3 - \((4 y)\)\^4\), "\n", RowBox[{\(rc[x_, y_]\), "=", StyleBox[\(x^3\), FontColor->RGBColor[1, 0, 0]]}], "\n", \(p8rc = ParametricPlot3D[{parx[t], pary[t], rc[parx[t], pary[t]], RGBColor[1, 0, 0]}, {t, 0, 2 \[Pi]}, AxesLabel -> {x, y, z}, DisplayFunction -> Identity];\), "\n", \(prc = Plot3D[rc[x, y] - 10, {x, \(-10\), 10}, {y, \(-20\), 20}, AxesLabel -> {x, y, z}, \ PlotRange -> All, DisplayFunction -> Identity];\), "\n", \(Show[prc, p8rc, DisplayFunction -> $DisplayFunction];\), "\n", \(ctrc = ContourPlot[rc[x, y], {x, \(-10\), 10}, {y, \(-20\), 20}, ContourShading -> False, DisplayFunction -> Identity];\), "\n", \(Show[pp8, ctrc, DisplayFunction -> $DisplayFunction];\)}], "Input"], Cell[BoxData[{ \(Clear[x, y]\), "\n", \(solutionrc = Solve[{gradient[rc[x, y]] == \[Lambda]\ gradient[eight[x, y]], eight[x, y] == 0}, {x, y, \[Lambda]}] // N\)}], "Input"], Cell[TextData[{ "The ", StyleBox["z", FontSlant->"Italic"], "-coordinates on the roller coaster that correspond to these ", StyleBox["x", FontSlant->"Italic"], "- and ", StyleBox["y", FontSlant->"Italic"], "-coordinates are determined." }], "Text"], Cell[BoxData[ \(rc[x, y] /. solutionrc\)], "Input"], Cell[TextData[StyleBox["How many critical points do you have? Locate these \ points on your contour and surface plots to determine which represent \ maximums or minimums.", FontColor->RGBColor[1, 0, 0]]], "Text", FontWeight->"Bold"] }, Closed]] }, Open ]] }, FrontEndVersion->"4.1 for Microsoft Windows", ScreenRectangle->{{0, 1024}, {0, 695}}, WindowSize->{573, 354}, WindowMargins->{{88, Automatic}, {Automatic, 16}}, PrintingCopies->1, PrintingPageRange->{Automatic, Automatic}, StyleDefinitions -> "Default.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[1705, 50, 302, 5, 71, "Text"], Cell[CellGroupData[{ Cell[2032, 59, 68, 0, 225, "Title"], Cell[2103, 61, 118, 3, 37, "Text"], Cell[CellGroupData[{ Cell[2246, 68, 31, 0, 59, "Section"], Cell[2280, 70, 187, 6, 52, "Text"], Cell[2470, 78, 394, 6, 90, "Text"], Cell[CellGroupData[{ Cell[2889, 88, 74, 1, 47, "Subsection"], Cell[2966, 91, 1209, 34, 242, "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[4224, 131, 62, 0, 39, "Section"], Cell[CellGroupData[{ Cell[4311, 135, 39, 0, 47, "Subsection"], Cell[4353, 137, 472, 7, 109, "Text"], Cell[4828, 146, 634, 15, 109, "Text"], Cell[5465, 163, 51, 1, 30, "Input"], Cell[5519, 166, 865, 17, 330, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[6421, 188, 30, 0, 47, "Subsection"], Cell[6454, 190, 236, 4, 71, "Text"], Cell[6693, 196, 758, 14, 230, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[7500, 216, 37, 0, 39, "Section"], Cell[7540, 218, 216, 4, 52, "Text"], Cell[7759, 224, 769, 13, 210, "Input"], Cell[8531, 239, 386, 8, 109, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[8954, 252, 71, 0, 39, "Section"], Cell[9028, 254, 899, 27, 109, "Text"], Cell[9930, 283, 143, 2, 52, "Input"], Cell[10076, 287, 227, 3, 52, "Text"], Cell[10306, 292, 332, 7, 110, "Input"], Cell[10641, 301, 307, 12, 52, "Text"], Cell[10951, 315, 362, 8, 110, "Input"], Cell[11316, 325, 282, 9, 52, "Text"], Cell[11601, 336, 663, 16, 89, "Output"], Cell[12267, 354, 113, 2, 33, "Text"], Cell[12383, 358, 213, 3, 52, "Text"], Cell[12599, 363, 181, 3, 50, "Input"], Cell[12783, 368, 418, 6, 90, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[13238, 379, 38, 0, 39, "Section"], Cell[13279, 381, 562, 15, 90, "Text"], Cell[13844, 398, 209, 4, 90, "Input"], Cell[14056, 404, 202, 5, 33, "Text"], Cell[14261, 411, 429, 9, 130, "Input"], Cell[14693, 422, 109, 3, 33, "Text"], Cell[14805, 427, 624, 15, 91, "Text"], Cell[15432, 444, 188, 3, 33, "Text"], Cell[15623, 449, 172, 2, 50, "Input"], Cell[15798, 453, 393, 6, 90, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[16228, 464, 62, 0, 39, "Section"], Cell[16293, 466, 118, 3, 52, "Text"], Cell[16414, 471, 982, 16, 292, "Input"], Cell[17399, 489, 201, 4, 90, "Input"], Cell[17603, 495, 274, 11, 33, "Text"], Cell[17880, 508, 55, 1, 30, "Input"], Cell[17938, 511, 236, 4, 52, "Text"] }, Closed]] }, Open ]] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)