(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 4.2' 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[ 17657, 458]*) (*NotebookOutlinePosition[ 18324, 481]*) (* CellTagsIndexPosition[ 18280, 477]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell["Exponential Growth", "Title"], Cell["Joshua Socolar", "Subsubtitle"], Cell[CellGroupData[{ Cell["Background and Copyright", "Subsubsection"], Cell[TextData[{ "This ", StyleBox["Mathematica", FontSlant->"Italic"], " Notebook was written by Joshua Socolar (Physics Department, Duke \ University) for use in a course he taught.." }], "Text"], Cell[TextData[{ StyleBox["This Mathematica Notebook is Copyright", FontWeight->"Bold"], " ", StyleBox["Joshua Socolar, 1999", FontWeight->"Bold"], ". It may be freely used by individuals, and by classes at academic \ institutions, provided:\n1. Credit is given to Joshua Socolar as the original \ author; and\n2. It is not bought or sold or exchanged for profit, or \ incorporated into material that is bought or sold or exchanged for profit.\n\ Any other use requires the written permission of Joshua Socolar, Dept. of \ Physics, Box 90305, Duke University, Durham, NC 27708, USA. Email: socolar \ at phy.duke.edu." }], "Text"] }, Open ]], Cell[CellGroupData[{ Cell["Exponential Divergence in General", "Subtitle"], Cell[CellGroupData[{ Cell["Linear Growth", "Subsection"], Cell[TextData[{ "Consider the following trivial situation: A ball at rest on flat ground \ is given a kick, after which it rolls (without friction) at constant speed. \ Suppose we want to predict the position of the ball after some time ", StyleBox["t", FontSlant->"Italic"], ". That's easy! Just multiply the speed of the ball by ", StyleBox["t", FontSlant->"Italic"], " and you will have the distance the ball traveled. If you know the \ direction the ball was kicked, you have a prediction for where it will be at \ the designated time. " }], "Text"], Cell[TextData[{ "But what if we don't know the exact speed resulting from the kick? (We \ should also discuss the direction of the kick, but, for the sake of \ simplicity, let's assume we know that exactly.) Let's say we can measure (or \ predict) the speed to within one meter per second. And let's further \ stipulate that our prediction for the position at time t is only good if we \ are sure that it is not off by more than 10 meters. The relevant question \ becomes \"How large can ", StyleBox["t", FontSlant->"Italic"], " get before our prediction becomes untrustworthy?\" Let's denote this \ maximum time by ", StyleBox["T", FontSlant->"Italic"], ". " }], "Text"], Cell[TextData[{ "To calculate ", StyleBox["T,", FontSlant->"Italic"], " we consider two cases: first where the ball goes as fast as possible, and \ second where it goes as slow as possible. Each of these possible motions of \ the ball is called a \"trajectory\". The real ball follows one particular \ trajectory -- the one that results from its actual, originally unknown, \ speed. The difference in the possible ball speeds is one meter per second, \ so after ", StyleBox["t", FontSlant->"Italic"], " seconds the difference in the ball positions on the two trajectories is \ ", StyleBox["t", FontSlant->"Italic"], " meters. Thus our power to predict the position to within 10 meters fails \ after ", StyleBox["T", FontSlant->"Italic"], "=10 seconds. So far, so good, I hope." }], "Text"], Cell["\<\ Just for fun, let's make a plot that illustrates the situation: \ We'll look at the two hypothetical trajectories, plotting the ball's position \ every two seconds. \ \>", "Text"], Cell["\<\ In the cell below, the first two lines define functions describing \ the two trajectories, with xn being the ball's position (distance from the \ kicking point) and t being the time. x1 and x2 correspond to initial speeds \ of 4m/s and 5m/s, respectively. The rest is just a way of getting a nice \ picture of the trajectories. \"Table\" makes a list of {t,x} pairs for the \ values of t specified as {t, initial t, final t, stepsize} and \"ListPlot\" \ plots the points in a list. Don't worry about understanding the options to \ ListPlot. The two commands invoking ListPlot create graphics objects that \ are not displayed. The Show command joins those graphics objects in a single \ plot.\ \>", "Text"], Cell[BoxData[{ \(Clear[x1, x2, y, t, traj1, traj2, traj3, traj4, traj5, lp1, lp2, lp3, lp4, lp5]\), "\n", \(\(x1[t_] := 4\ t;\)\), "\n", \(\(x2[t_] := 5\ t;\)\), "\n", \(\(traj1 = Table[{t, x1[t]}, {t, 0, 14, 2}];\)\), "\n", \(\(traj2 = Table[{t, x2[t]}, {t, 0, 14, 2}];\)\), "\n", \(\(lp1 = ListPlot[traj1, PlotStyle \[Rule] {RGBColor[1.0, 0.0, 0.0], PointSize[0.03]}, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(lp2 = ListPlot[traj2, PlotStyle \[Rule] {RGBColor[0.2, 0.0, 0.2], PointSize[0.03]}, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(Show[{lp1, lp2}, DisplayFunction \[Rule] $DisplayFunction, GridLines \[Rule] Automatic];\)\)}], "Input"], Cell["\<\ Notice that after 10 seconds the trajectories have diverged by more \ than 10 meters.\ \>", "Text"], Cell["\<\ Instead of plotting both trajectories, it might be easier to see \ what is going on if we just plot the difference between them. Make sure you \ understand the next cell and its output (except for the options to ListPlot).\ \ \>", "Text"], Cell[BoxData[{ \(\(y[t_] := x2[t] - x1[t];\)\), "\n", \(\(traj3 = Table[{t, y[t]}, {t, 0, 14, 2}];\)\), "\n", \(\(lp3 = ListPlot[traj3, PlotStyle \[Rule] {RGBColor[0.0, 0.2, 0.0], PointSize[0.03]}, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(Show[{lp3}, DisplayFunction \[Rule] $DisplayFunction, GridLines \[Rule] Automatic];\)\)}], "Input"], Cell[TextData[{ "Now suppose we could improve the accuracy with which we measure the ball's \ initial speed. Let's say we could measure it to within a centimeter per \ second instead of just a meter per second. How would ", StyleBox["T", FontSlant->"Italic"], " change? We can easily make a plot to see. We just redefine x1 and x2 to \ correspond to trajectories with speeds differing by 0.01m/s instead of 1m/s. \ We also have to go to much longer times to see when the trajectories have \ diverged by 10 meters." }], "Text"], Cell[BoxData[{ \(\(x1[t_] := 4.99\ t;\)\), "\n", \(\(x2[t_] := 5\ t;\)\), "\n", \(\(traj4 = Table[{t, y[t]}, {t, 0, 1400, 2}];\)\), "\n", \(\(lp4 = ListPlot[traj4, PlotStyle \[Rule] {RGBColor[0.0, 0.2, 0.0], PointSize[0.003]}, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(Show[{lp4}, DisplayFunction \[Rule] $DisplayFunction, GridLines \[Rule] Automatic];\)\)}], "Input"], Cell["\<\ Not surprising. Improving the accuracy with which we know the \ initial conditions by a factor of 100, allows us to make good predictions \ over times 100 times longer. \ \>", "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Exponential growth", "Subsection"], Cell[TextData[{ "Consider now a different type of system -- one in which the variable y, \ representing the difference between two trajectories, grows exponentially in \ time. It is not so easy to give a simple example of a physical system that \ does this, so we'll just consider the mathematical possibility for now. \ Consider a system for which ", StyleBox["x", FontSlant->"Italic"], " grows according to " }], "Text"], Cell[BoxData[ \(x = x\_0\ \(\(e\^\(t/t0\)\)\(.\)\)\)], "DisplayFormula", FontSize->16], Cell["\<\ Note that when t=0, we have x=x0; i.e., x0 is just the initial \ value of x. Look at the following plot, which shows the difference between \ two trajectories with values of x0 that differ by 0.1.\ \>", "Text"], Cell[BoxData[{ \(\(t0 = 2;\)\), "\n", \(\(x0 = 2;\)\), "\n", \(\(error = 0.1;\)\), "\n", \(\(tfinal = 12;\)\), "\n", \(\(x1[t_] := x0\ Exp[t/t0];\)\), "\n", \(\(x2[t_] := \((x0 + error)\) Exp[t/t0];\)\), "\n", \(\(y[t_] := x2[t] - x1[t];\)\), "\n", \(\(traj5 := Table[{t, y[t]}, {t, 0, tfinal, 2}];\)\), "\n", \(\(lp5 := ListPlot[traj5, PlotStyle \[Rule] {RGBColor[0.0, 0.2, 0.0], PointSize[0.03]}, PlotRange -> All, DisplayFunction \[Rule] Identity];\)\), "\n", \(\(Show[{lp5}, DisplayFunction \[Rule] $DisplayFunction, GridLines \[Rule] Automatic];\)\)}], "Input"], Cell["\<\ Notice that our ability to predict accurately last about 9 seconds. \ (In other words, T=9s). After that, the difference between the two \ trajectories exceeds our agreed upon limit of 10 meters. \ \>", "Text"], Cell[TextData[{ StyleBox["EXERCISE 1: ", FontColor->RGBColor[1, 0, 0]], " By changing the values of \"error\" and \"tfinal\" below, make plots that \ enable you to determine (roughly) the accuracy required to extend T by a \ factor of 2. You have to change \"error\" until you get the graph to cross \ 10 meters at about t=18. Copy your plot to the notebook you will hand \ in." }], "Text"], Cell[BoxData[{ \(\(error = 0.1;\)\), "\n", \(\(tfinal = 12;\)\), "\n", \(\(Show[{lp5}, DisplayFunction \[Rule] $DisplayFunction, GridLines \[Rule] Automatic];\)\)}], "Input"], Cell[TextData[{ StyleBox["EXERCISE 2: ", FontColor->RGBColor[1, 0, 0]], " Now try again, this time aiming for T=35 (another factor of 2). Add \ this plot to your notebook." }], "Text"], Cell["\<\ Surprised? Even though I know full well how to calculate the \ tolerable error for this system, I am always a little surprised about what it \ really means. There are three things to note about this system: (1) It is extremely hard to increase T by obtaining more accurate knowledge \ of the initial condition. The tremendous effort required to increase the \ accuracy by several orders of magnitude only results in an increase of a \ factor of two in T for the case we just looked at. (2) The situation gets worse as we strive for higher accuracy. You would \ need to improve the accuracy by even more orders of magnitude in order to get \ the next factor of two in T. Note that the first factor of 2 (from T=9 to \ 18) required reducing the error by only a couple of orders of magnitude, but \ the next (from T=18 to 35), required substantially more. (3) There is a \"time scale\" in this problem. In order for the exponential \ function to make sense, we had to divide t by some time, which we called t0. \ It would not make sense to raise e to the power \"t\", if t represents a \ length of time. What units should you use for measuring t? The time t0 \ effectively tells us the relevant units for measuring t. \ \>", "Text"], Cell[TextData[{ StyleBox["EXERCISE 3:", FontColor->RGBColor[1, 0, 0]], " One last detail: The plots above can be a little hard to read because \ the numbers are so small at short times. It almost looks like nothing at all \ is happening until the trajectories suddenly split off. We can get a better \ picture by plotting the logarithm of y on the vertical axis, instead of y \ itself. On this \"linear-log\" plot, exponential divergence comes out as a \ straight line, making it easy to identify. Evaluate the next cell, then \ evaluate the cell that made your plot showing T=35 again. Copy this plot to \ your notebook. " }], "Text"], Cell[BoxData[{ \(\(Needs["\"];\)\), "\n", \(lp5 = LogListPlot[traj5, PlotStyle \[Rule] {RGBColor[0.5, 0.2, 0.2], PointSize[0.03]}, PlotRange -> All]\n\)}], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Summary", "Subsection"], Cell["\<\ We can summarize the results of this section as follows: In systems where nearby trajectories diverge exponentially, there is a \ natural time scale that sets an effective limit on how far into the future \ they remain predictable. Attempts to extend the prediction time beyond three \ or four times the natural time scale require fantastically accurate \ measurements of the initial conditions. \ \>", "Text"], Cell["\<\ The big question now is this: \"How likely are we to find \ exponential trajectory divergence in nature?\" The answer is: \"Very likely. \ It is everywhere.\" We'll next take a look at a simple system that has this \ feature hidden in it.\ \>", "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Exponential Divergence in the Logistic Map", "Subtitle"], Cell[TextData[{ "We now want to see that the Logistic Map in the chaotic regime is \ unpredictable for long times due to exponential divergence of trajectories. \ The following cell defines a function for plotting the difference between two \ trajectories that start at slightly different points. The difference in \ initial conditions is specified by ", StyleBox["de", FontFamily->"Courier", FontWeight->"Bold"], ", which is the third argument to the function \"timeerror\". Evaluate the \ cell." }], "Text"], Cell[BoxData[{ \(Clear[a, y, de, r, s, timeerror, smarterror, logsmarterror]\), "\n", \(timeerror[a_, y_, de_] := Module[{r = y, s = y + de}, \n ListPlot[ Table[r\ = \ a\ r\ \((1 - r)\), {30}] - Table[s\ = \ a\ s \((1 - s)\), {30}], PlotStyle -> {RGBColor[0.5, 0.2, 0.2], PointSize[0.03]}, PlotRange -> {\(-1\), 1}]]\), "\n", \(\(timeerror[3.9, 0.4, 0.0001];\)\)}], "Input"], Cell["\<\ You can see that something funny happens around n=10. The two \ trajectories appear very different after that. Could this be due to \ exponential divergence? Let's check.\ \>", "Text"], Cell["\<\ We know that the exponential divergence cannot last forever, since \ the logistic map only produces values between zero and one. To see the \ exponential divergence, we will have to look more carefully at the early \ times, before n=10. The next cell defines a function similar to the one \ above, but smart enough to stop when the error gets too big. Evaluate \ it.\ \>", "Text"], Cell[BoxData[{ \(smarterror[a_, y_, de_] := Module[{r = y, s = y + de, t = 0}, \[IndentingNewLine]While[ Abs[r - s] < 0.1\ && \ t < 100, r\ = \ a\ r\ \((1 - r)\); s\ = \ a\ s \((1 - s)\); t = t + 1]; \n\t\tr = y; s = y + de; \n ListPlot[ Abs[Table[r\ = \ a\ r\ \((1 - r)\), {t}] - Table[s\ = \ a\ s \((1 - s)\), {t}]], PlotStyle -> {RGBColor[0.5, 0.2, 0.2], PointSize[0.03]}, PlotRange -> {\(-1\), 1}]]\), "\n", \(\(smarterror[3.9, 0.4, 0.0001];\)\)}], "Input"], Cell["\<\ To see the exponential buried in there, let's make a linear-log \ plot of the same data. Note that we have to take the absolute value of the \ differences since you can't take the log of a negative number. (The actual \ differences oscillate in sign.)\ \>", "Text"], Cell[BoxData[{ \(logsmarterror[a_, y_, de_] := Module[{r = y, s = y + de, t = 0}, \[IndentingNewLine]While[ Abs[r - s] < 0.1\ && \ t < 100, r\ = \ a\ r\ \((1 - r)\); s\ = \ a\ s \((1 - s)\); t = t + 1]; \n\t\tr = y; s = y + de; \n LogListPlot[ Abs[Table[r\ = \ a\ r\ \((1 - r)\), {t}] - Table[s\ = \ a\ s \((1 - s)\), {t}]], PlotStyle -> {RGBColor[0.5, 0.2, 0.2], PointSize[0.03]}, PlotRange -> Automatic]]\), "\n", \(\(logsmarterror[3.9, 0.4, 0.000001];\)\)}], "Input"], Cell[TextData[{ "There you have it! It is not a perfect straight line, but it clearly \ follow a straight line trend. \.13\n\n", StyleBox["EXERCISE 4:", FontColor->RGBColor[1, 0, 0]], " Modify ", StyleBox["de", FontFamily->"Courier", FontWeight->"Bold"], " in the previous cell (in the last line) and describe the changes in the \ outcome. Turn in your plot and your description." }], "Text"] }, Closed]] }, Open ]] }, FrontEndVersion->"4.2 for X", ScreenRectangle->{{0, 1280}, {0, 1024}}, ScreenStyleEnvironment->"Working", WindowSize->{485, 575}, WindowMargins->{{230, Automatic}, {Automatic, 207}} ] (******************************************************************* 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[1776, 53, 35, 0, 120, "Title"], Cell[1814, 55, 37, 0, 53, "Subsubtitle"], Cell[CellGroupData[{ Cell[1876, 59, 49, 0, 42, "Subsubsection"], Cell[1928, 61, 206, 6, 50, "Text"], Cell[2137, 69, 646, 13, 158, "Text"] }, Open ]], Cell[CellGroupData[{ Cell[2820, 87, 53, 0, 64, "Subtitle"], Cell[CellGroupData[{ Cell[2898, 91, 35, 0, 45, "Subsection"], Cell[2936, 93, 578, 12, 70, "Text"], Cell[3517, 107, 695, 15, 70, "Text"], Cell[4215, 124, 828, 21, 70, "Text"], Cell[5046, 147, 191, 4, 70, "Text"], Cell[5240, 153, 721, 11, 70, "Text"], Cell[5964, 166, 775, 16, 70, "Input"], Cell[6742, 184, 109, 3, 70, "Text"], Cell[6854, 189, 249, 5, 70, "Text"], Cell[7106, 196, 406, 8, 70, "Input"], Cell[7515, 206, 541, 10, 70, "Text"], Cell[8059, 218, 440, 9, 70, "Input"], Cell[8502, 229, 195, 4, 70, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[8734, 238, 40, 0, 70, "Subsection"], Cell[8777, 240, 434, 9, 70, "Text"], Cell[9214, 251, 92, 2, 70, "DisplayFormula"], Cell[9309, 255, 221, 4, 70, "Text"], Cell[9533, 261, 655, 14, 70, "Input"], Cell[10191, 277, 223, 4, 70, "Text"], Cell[10417, 283, 403, 8, 70, "Text"], Cell[10823, 293, 197, 4, 70, "Input"], Cell[11023, 299, 194, 5, 70, "Text"], Cell[11220, 306, 1252, 18, 70, "Text"], Cell[12475, 326, 651, 11, 70, "Text"], Cell[13129, 339, 219, 5, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[13385, 349, 29, 0, 70, "Subsection"], Cell[13417, 351, 422, 7, 70, "Text"], Cell[13842, 360, 266, 5, 70, "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[14157, 371, 62, 0, 82, "Subtitle"], Cell[14222, 373, 526, 11, 70, "Text"], Cell[14751, 386, 450, 9, 70, "Input"], Cell[15204, 397, 197, 4, 70, "Text"], Cell[15404, 403, 393, 7, 104, "Text"], Cell[15800, 412, 558, 10, 187, "Input"], Cell[16361, 424, 277, 5, 68, "Text"], Cell[16641, 431, 567, 10, 187, "Input"], Cell[17211, 443, 418, 11, 104, "Text"] }, Closed]] }, Open ]] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)