(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 5.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[ 27375, 979]*) (*NotebookOutlinePosition[ 28159, 1006]*) (* CellTagsIndexPosition[ 28115, 1002]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell["What happens when you take f[f[f[f[...f[x]...]]]]?", "Title"], Cell["(Based on a lecture by Prof. L. Polvani; Spring, 1997)", "Subsubtitle"], Cell[CellGroupData[{ Cell["Introduction", "Section"], Cell[TextData[{ "I assume you all are comfortable with some level of calculus. For a \ function ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "] one is traditionally concerned with \"limits\", for instance the limit \ of ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "] as ", StyleBox["x", FontSlant->"Italic"], "\[Rule]\[Infinity]. Here, were a going to study another limit, a bit \ perverse perhaps. Suppose we are given the function ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "] and we consider the sequence ", StyleBox["x", FontSlant->"Italic"], ", ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "], ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "]], ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "]]], ", StyleBox["etc", FontSlant->"Italic"], ". This is easy to do in ", StyleBox["Mathematica", FontSlant->"Italic"], " with the function", StyleBox[" ", Background->None], StyleBox["Nest[f,x,n]", "Input", Background->None], ". Suppose we want to iterate 3 times; then we just do" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Nest[f, \ x, \ 3]\), "Input"]], "Input", CellLabel->"In[1]:="], Cell[TextData[{ "We call this the 3rd iterate of", StyleBox[" f", FontSlant->"Italic"], ". Now, the name of the game here is to find the limit of", StyleBox[" ", Background->None], StyleBox["Nest[f,x,n]", "Input", Background->None], StyleBox[", given ", Background->None], "a function ", StyleBox["f,", FontSlant->"Italic"], " as ", StyleBox["n", FontSlant->"Italic"], "\[Rule]\[Infinity]. This turns out to be a very hard and extremely \ interesting mathematical problem, and is one of the by-now-classic \"chaos\" \ problems that was the rage about a decade or so ago. The best way to get us \ started is to play around with a specific (and very interesting) function ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "], the so-called \"logistic\" function. " }], "Text", TextAlignment->Left, TextJustification->1] }, Closed]], Cell[CellGroupData[{ Cell["The Logistic Map", "Section"], Cell["The logistic map is simply the quadratic function defined by", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(\(Logistic[r_]\)[x_]\ := \ r\ x\ \((1\ - \ x)\)\), "Input"]], "Input", CellLabel->"In[2]:="], Cell[TextData[{ "where ", StyleBox["r", FontSlant->"Italic"], " is a parameter; if we choose 0 < ", StyleBox["r ", FontSlant->"Italic"], "< 4. ", StyleBox["Logistic", "Input", Background->None], " takes the interval [0,1] into itself; in other words it maps [0,1] into \ [0,1]; this is why we call it a map. Let's plot this map to see what it \ looks like, say when ", StyleBox["r", FontSlant->"Italic"], "=3:" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[\(Logistic[3]\)[x], {x, 0, 1}, \ PlotRange -> {0, 1}, Frame -> True];\), "Input"]], "Input", CellLabel->"In[3]:="], Cell[TextData[{ "As you can see, ", StyleBox["Logistic[r][x]", "Input"], " is just a simple parabola with ", StyleBox["a single control parameter, r", FontSlant->"Italic"], "." }], "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Iterates of Logistic Map", "Section"], Cell[TextData[{ "Now let's look at a few iterates of the logistic map. Let's start with \ the second iterate, i.e. ", StyleBox["Logistic[Logistic[", FontWeight->"Bold"], StyleBox["x", FontWeight->"Bold", FontSlant->"Italic"], StyleBox["]]", FontWeight->"Bold"] }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ RowBox[{ RowBox[{ StyleBox["Plot", "Input"], StyleBox["[", "Input"], RowBox[{ StyleBox[\(Nest[Logistic[3], x, 2]\), "Input"], StyleBox[",", "Input"], StyleBox[\({x, 0, 1}\), "Input"], StyleBox[",", "Input"], " ", \(PlotRange -> {0, .8}\), ",", \(Frame -> True\)}], "]"}], ";"}]], "Input", CellLabel->"In[4]:="], Cell[TextData[{ "OK, that's a simple quartic (", StyleBox["i.e", FontSlant->"Italic"], ". a polynomial of degree 4). Now let's look at the 4th iterate" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[Nest[Logistic[3], x, 4], {x, 0, 1}, \ PlotRange -> {0, .8}, Frame -> True];\), "Input"]], "Input", CellLabel->"In[5]:="], Cell["\<\ OK, just a bit more wiggly. Let's keep going; this is the 6th \ iterate:\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[ Nest[Logistic[3], x, 6], {x, 0, 1}, \ \ PlotRange -> {0.4, .8}, Frame -> True, \ PlotPoints -> 100];\), "Input"]], "Input", CellLabel->"In[6]:="], Cell["\<\ It does not seem to be very different from the 4th iterate. Let's \ be brave and look at the 14th iterate!\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[ Nest[Logistic[3], x, 14], {x, 0, 1}, \ \ PlotRange -> {0.4, .8}, Frame -> True, \ PlotPoints -> 100];\), "Input"]], "Input", CellLabel->"In[7]:="], Cell["\<\ Again, it looks very similar to the 4th and 6th iterates. However, \ let's look more carefully at what is happening near the edges. How many \ wiggles are near the edges? Let's look closer...\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[Nest[Logistic[3], x, 14], {x, 0, 0.1}, PlotRange -> {0.4, .8}, Frame -> True, \ PlotPoints -> 100];\), "Input"]], "Input", CellLabel->"In[8]:="], Cell["OK, let's blow up some more...", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[Nest[Logistic[3], x, 14], {x, 0, 0.01}, PlotRange -> {0.4, .8}, Frame -> True, \ PlotPoints -> 100];\), "Input"]], "Input", CellLabel->"In[9]:="], Cell["\<\ Something weird is happening! This function looks the same in the interval \ [0,0.01] as in the interval [0,0.1]; how can that be? Let's blow up some \ more...\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[Nest[Logistic[3], x, 14], {x, 0, 0.001}, PlotRange -> {0.4, .8}, Frame -> True, \ PlotPoints -> 100];\), "Input"]], "Input", CellLabel->"In[10]:="], Cell["\<\ This is really weird! Now matter how close we look, this function looks the \ same! Lets blow up once more...\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Plot[Nest[Logistic[3], x, 14], {x, 0, 0.0001}, PlotRange -> {0.4, .8}, Frame -> True, \ PlotPoints -> 100];\), "Input"]], "Input", CellLabel->"In[11]:="], Cell[TextData[{ StyleBox["OK!", FontColor->RGBColor[1, 0, 0]], " What crazy function is this any way? How bad can it be? All we did was \ iterating a quadratic a mere 14 times. Let's look at the iterates in \ functional form. Start with the first non trivial iterate:" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Nest[Logistic[3], x, 2]\), "Input"]], "Input", CellLabel->"In[12]:="], Cell[TextData[{ "Well, this is not too illuminating; let's make a polynomial out of this; \ we can do this with the function ", StyleBox["Expand", "Input"], "." }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Expand[Nest[Logistic[3], x, 2]]\), "Input"]], "Input", CellLabel->"In[13]:="], Cell["\<\ OK, so the second iterate is a polynomial of degree 4; that what \ we'd expect from the figure (see above); how about the third iterate?\ \>", \ "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Expand[Nest[Logistic[3], x, 3]]\), "Input"]], "Input", CellLabel->"In[14]:="], Cell["\<\ Wow! It jumps to a polynomial of degree 8! How about the fourth \ iterate?\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Expand[Nest[Logistic[3], x, 4]]\), "Input"]], "Input", CellLabel->"In[15]:="], Cell[TextData[{ StyleBox["Ouch!", FontColor->RGBColor[1, 0, 0]], " We are starting to get the picture... every time we iterate we get a \ polynomial of twice the degree as the previous iterate" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(Expand[Nest[Logistic[3], x, 5]]\), "Input"]], "Input", CellLabel->"In[16]:="], Cell[TextData[{ StyleBox["OK, this is getting ridiculous!", FontColor->RGBColor[1, 0, 0]], " Can we figure out the order of the polynomial corresponding to the 14th \ iterate (that's the function we were looking at before)? Well for the 2nd \ iterate the polynomial has degree 4, for the 3rd iterate degree 8, for the \ 4th iterate degree 16, so it's pretty clear that for the nth iterate of the \ simple logistic function is actually a polynomial of degree ", Cell[BoxData[ \(TraditionalForm\`2\^n\)]], ". This means that the 14th iterate of a simple parabola (that what our \ logistic function is) is a polynomial of degree..." }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ StyleBox[\(2^14\), "Input"]], "Input", CellLabel->"In[17]:="], Cell[TextData[{ "So the 14th iterate of a parabola is a polynomial of degree 16,384, ", StyleBox["WOW!!!", FontColor->RGBColor[1, 0, 0]], " Now you see why we said we are playing a ", StyleBox["pretty perverse", FontColor->RGBColor[0, 0, 1]], " game, especially if the name of the game is really want to look at ", StyleBox["Nest[f,x,n]", "Input"], " in the limit ", StyleBox["n", FontSlant->"Italic"], "\[Rule]\[Infinity]! For a number as small as ", StyleBox["n", FontSlant->"Italic"], "=100, which is not exactly close to Infinity, our function has become a \ polynomial of degree " }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ \(2^100\)], "Input", CellLabel->"In[18]:="], Cell["Looks big! How big is this number? ", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ \(N[2^100]\)], "Input", CellLabel->"In[19]:="], Cell[TextData[{ "So if we take only the first 100 steps, we have a polynomial with more \ than one thousand billion billion billions terms! It looks like there's no \ hope for us to do this problem. ", StyleBox["But in fact there is...", FontSlant->"Italic"] }], "Text", TextAlignment->Left, TextJustification->1] }, Closed]], Cell[CellGroupData[{ Cell["Point-wise exploration", "Section"], Cell["\<\ Obviously, the function becomes extremely complicated as the number \ of iteration grows. Suppose try to be more humble, and look at what each \ point is doing as the number of iterations goes to infinity. That may be \ simpler than studying the whole function... \ \>", "Text"], Cell[CellGroupData[{ Cell["Small r\[Ellipsis]", "Subsection"], Cell[TextData[{ "So consider, for instance, looking at the value ", StyleBox["r", FontSlant->"Italic"], "=2.5 and seeing what happens there..." }], "Text"], Cell[BoxData[ \(NestList[Logistic[2.4], 0.1, 10]\)], "Input", CellLabel->"In[20]:="], Cell["Notice that it seems to be converging... try to go further", "Text"], Cell[BoxData[ \(NestList[Logistic[2.4], 0.1, 20]\)], "Input", CellLabel->"In[21]:="], Cell["\<\ Well, it seems to be going to the same point. No matter which x we \ pick in [0,1] f(f(f(f(...f(x))))) is equal to \ \>", "Text"], Cell[BoxData[ \(N[Last[NestList[Logistic[2.4], .1, 500]], 10]\)], "Input", CellLabel->"In[22]:="], Cell[BoxData[ \(N[Last[NestList[Logistic[2.4], .2, 500]], 10]\)], "Input", CellLabel->"In[23]:="], Cell[BoxData[ \(N[Last[NestList[Logistic[2.4], .5, 500]], 10]\)], "Input", CellLabel->"In[24]:="], Cell[TextData[{ "OK. From the figures it is pretty clear that no matter which x we pick in \ [0,1] the iteration converges to the point where ", StyleBox["Logistic[", FontWeight->"Bold"], StyleBox["x", FontWeight->"Bold", FontSlant->"Italic"], StyleBox["] == ", FontWeight->"Bold"], StyleBox["x", FontWeight->"Bold", FontSlant->"Italic"], "; we can solve for this using the function ", StyleBox["Solve", "Input"] }], "Text"], Cell[BoxData[ \(N[Solve[r\ x\ \((1 - x)\)\ == \ x\ /. \ r\ \[Rule] \ 2.4, \ x], 10]\)], "Input", CellLabel->"In[25]:="], Cell[TextData[{ "Yup, that's exactly it. So, ", StyleBox["for this value of ", FontColor->RGBColor[0, 0, 1]], StyleBox["r", FontSlant->"Italic", FontColor->RGBColor[0, 0, 1]], StyleBox[" we the answer is actually easy", FontColor->RGBColor[0, 0, 1]], ": as n\[Rule]\[Infinity] the iterates converge to a very simple function, \ namely the function ", StyleBox["f", FontSlant->"Italic"], "[", StyleBox["x", FontSlant->"Italic"], "] = 5833333333... which is just a constant function." }], "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Medium r\[Ellipsis]", "Subsection"], Cell[TextData[{ "Of course the question now becomes: what happens if we change ", StyleBox["r", FontSlant->"Italic"], "? Does the iteration give an easy function as well? Let's try the value ", StyleBox["r", FontSlant->"Italic"], "=3.05." }], "Text"], Cell["\<\ Hum... after 1000 iterations, it seems to be converging very \ slowly... may it is not converging at all... perhaps we should look at the \ numbers...\ \>", "Text"], Cell[BoxData[ \(NestList[Logistic[3.05], 0.1, 100]\)], "Input", CellLabel->"In[26]:="], Cell[TextData[{ "Wow! It seems that for this new value of ", StyleBox["r ", FontSlant->"Italic"], "the iterates are bouncing between two numbers. Let's plot these points \ versus the iteration number n, so we get a better feeling for what is \ happening..." }], "Text"], Cell[BoxData[ \(\(ListPlot[NestList[Logistic[3.05], 0.1, 40], \ PlotJoined\ -> \ True, \ PlotRange -> { .5, .8}];\)\)], "Input", CellLabel->"In[27]:="], Cell[TextData[{ "OK, very nice. This kind of behavior is called a ", StyleBox["limit cycle", FontColor->RGBColor[0, 0, 1]], ". The iterates oscillate between the two values 0.590164... and \ 0.737705... The name of this behavior is called a \"limit cycle\", " }], "Text"], Cell["\<\ OK, very nice. Now we should worry:does this limit cycle depend on \ where we start? Suppose we start at x=.5\ \>", "Text"], Cell[BoxData[ \(\(ListPlot[ Drop[NestList[Logistic[3.05], 0.5, 100], 20], \n\t\ PlotRange -> {0, 1}, \ Frame -> True, \n\t PlotStyle -> RGBColor[0, 0, 1]];\)\)], "Input", CellLabel->"In[28]:="], Cell[BoxData[ \(Drop[NestList[Logistic[3.05], 0.5, 100], 90]\)], "Input", CellLabel->"In[29]:="], Cell[TextData[{ "As for the case ", StyleBox["r", FontSlant->"Italic"], "=2.4, it does not seem that the final values of the iterates depend on the \ initial value of ", StyleBox["x", FontSlant->"Italic"], ". So in summary this is the story: ", StyleBox["independent of the initial value of x", FontSlant->"Italic"], ", for ", StyleBox["r", FontSlant->"Italic"], "=2.4 the iteration goes to a single number while for ", StyleBox["r", FontSlant->"Italic"], "=3.05 the iteration oscillates between two numbers. Hence there is a \ point, let's call it ", Cell[BoxData[ \(TraditionalForm\`r\_1\)]], "where the behavior changes drastically. This is called a ", StyleBox["bifurcation", FontColor->RGBColor[0, 0, 1]], ", a fancy word for saying the something has split into two. You will have \ to find the value of ", Cell[BoxData[ \(TraditionalForm\`r\_1\)]], "in your assignment." }], "Text", TextAlignment->Left, TextJustification->1] }, Closed]], Cell[CellGroupData[{ Cell["Larger r\[Ellipsis]", "Subsection"], Cell[TextData[{ "Let increase ", StyleBox["r", FontSlant->"Italic"], " some more and play more games. Consider the case ", StyleBox["r", FontSlant->"Italic"], "=3.5" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ \(Drop[NestList[Logistic[3.5], 0.5, 100], 88]\)], "Input", CellLabel->"In[30]:="], Cell[TextData[{ "Well, there seem to be ", StyleBox["four", FontColor->RGBColor[1, 0, 0]], " numbers here! Let's plot them to see what's happening" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ \(\(ListPlot[ Drop[NestList[Logistic[3.5], 0.5, 500], 100], \n\t\ PlotRange -> {0, 1}, PlotJoined -> False, \ Frame -> True, \n\t\tPlotStyle -> RGBColor[0, 0, 1]];\)\)], "Input", CellLabel->"In[31]:="], Cell[TextData[{ "This is ", StyleBox["a limit cycle with twice the period", FontColor->RGBColor[0, 0, 1]], " (it take 4 iterations to get back to a given point, instead of two as \ before). So as we go from ", StyleBox["r", FontSlant->"Italic"], "=3.05 to ", StyleBox["r", FontSlant->"Italic"], "=3.5 ", StyleBox["another bifurcation", FontColor->RGBColor[1, 0, 0]], " has occurred, at some point which we call ", Cell[BoxData[ \(TraditionalForm\`r\_2\)]], ". In this case the bifurcation leads from an oscillation between 2 \ numbers to an oscillation between 4 numbers. Hence the period of the \ oscillation is doubled." }], "Text", TextAlignment->Left, TextJustification->1] }, Closed]], Cell[CellGroupData[{ Cell["Still larger r\[Ellipsis]", "Subsection"], Cell[TextData[{ "OK, let increase ", StyleBox["r", FontSlant->"Italic"], " a bit more and try ", StyleBox["r", FontSlant->"Italic"], "=3.55" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[{ \(\(r\ = \ 3.55;\)\), "\n", \(\(ListPlot[ Drop[NestList[Logistic[3.5], 0.5, 500], 100], \n\t\ PlotRange -> {0, 1}, PlotJoined -> False, \ Frame -> True, \n\t\t\tPlotStyle -> RGBColor[0, 0, 1]];\)\)}], "Input",\ CellLabel->"In[32]:="], Cell["\<\ Again this is a limit cycle with twice the period (it take 8 \ iterations to get back to a given point, instead of 4 as before). To make \ sure of this, look closely and you will see that there are 8 different \ numbers that keep repeating. If we blow up the plot between 0.8 and 1 it's \ clear that there are 4 distinct points there.\ \>", "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ \(\(ListPlot[ Drop[NestList[Logistic[3.5], 0.5, 500], 100], \n\t\ PlotRange -> {0.8, 0.9}, PlotJoined -> False, \ Frame -> True, \n\t\t\tPlotStyle -> RGBColor[0, 0, 1]];\)\)], "Input",\ CellLabel->"In[34]:="], Cell[TextData[{ "So between ", StyleBox["r=", FontSlant->"Italic"], "3.5 and ", StyleBox["r", FontSlant->"Italic"], "=3.55 ", StyleBox["another bifurcation", FontColor->RGBColor[1, 0, 0]], " has occurred. Let's call this point ", Cell[BoxData[ \(TraditionalForm\`r\_3\)]], "." }], "Text", TextAlignment->Left, TextJustification->1] }, Closed]], Cell[CellGroupData[{ Cell["\<\ Onset of chaos for r > 3.5699456\[Ellipsis]\ \>", "Subsection"], Cell[TextData[{ "This period doubling scenario goes on until the magic point ", Cell[BoxData[ \(TraditionalForm\`r\_\[Infinity]\)]], "=3.5699456... after which point? well beyond ", Cell[BoxData[ \(TraditionalForm\`r\_\[Infinity]\)]], " let's say that", StyleBox[" \"hell breaks lose\"", FontWeight->"Bold", FontSlant->"Italic", FontColor->RGBColor[1, 0, 1]], ". What happens then is that the numbers that come out are completely \ random. Wonna see? Here are the first 5000 points at ", StyleBox["r", FontSlant->"Italic"], "=0.8" }], "Text", TextAlignment->Left, TextJustification->1], Cell[BoxData[ \(\(ListPlot[ NestList[Logistic[3.8], 0.5, 5000], \n\t\ PlotRange -> {0, 1}, PlotJoined -> False, \ Frame -> True, \n\t\t\tPlotStyle -> RGBColor[0, 0, 1]];\)\)], "Input",\ CellLabel->"In[35]:="], Cell[TextData[{ "Pretty amazing, eh? Well what we have talked about, is ", StyleBox["the famous period-doubling-route to CHAOS", FontColor->RGBColor[1, 0, 0]], ", discovered by Feigenbaum in the late 1970s. That's just 30 years \ ago..." }], "Text", TextAlignment->Left, TextJustification->1] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Sensitivity to Initial Conditions", "Section"], Cell[TextData[{ "One important characteristic of a chaotic system is it's the sensitivity \ to initial conditions. If you start a sequence of the logistic map for small \ ", StyleBox["r", FontSlant->"Italic"], ", then the sequence will converge to the same fixed point ", StyleBox["independent of the initial condition", FontSlant->"Italic"], ". However, when ", StyleBox["r ", FontSlant->"Italic"], "> 3.57, then the sequence changes dramatically depending upon the initial \ condition. As you will see, two chaotic trajectories that are initially ", StyleBox["infinitesimally close", FontSlant->"Italic"], " become ", StyleBox["exponentially separated ", FontSlant->"Italic"], "as the sequence is iterated! " }], "Text"], Cell["Let's examine two cases.", "Text"], Cell[BoxData[ \(\(Needs["\"];\)\)], "Input", CellLabel->"In[80]:="], Cell[CellGroupData[{ Cell["Small r", "Subsection"], Cell[BoxData[{ \(\(listA\ = \ NestList[Logistic[2.7], \ 0.5, \ 50];\)\), "\[IndentingNewLine]", \(\(listB\ = \ NestList[Logistic[2.7], \ 0.5 + \ 0.0001, \ 50];\)\), "\[IndentingNewLine]", \(\(\[CapitalDelta]\ = \ listB\ - \ listA;\)\)}], "Input", CellLabel->"In[81]:="], Cell[BoxData[ \(\(LogListPlot[Abs[\[CapitalDelta]], \ PlotRange\ \[Rule] \ All, \ PlotStyle\ \[Rule] \ {RGBColor[1, 0, 0], PointSize[0.02]}, \ GridLines\ \[Rule] \ True, \ Frame\ \[Rule] \ True, \ PlotLabel\ \[Rule] \ "\"];\)\)], "Input", CellLabel->"In[84]:="] }, Closed]], Cell[CellGroupData[{ Cell["Large r", "Subsection"], Cell[BoxData[{ \(\(listA\ = \ NestList[Logistic[3.7], \ 0.5, \ 50];\)\), "\[IndentingNewLine]", \(\(listB\ = \ NestList[Logistic[3.7], \ 0.5 + \ 0.0001, \ 50];\)\), "\[IndentingNewLine]", \(\(\[CapitalDelta]\ = \ listB\ - \ listA;\)\)}], "Input", CellLabel->"In[85]:="], Cell[BoxData[ \(\(LogListPlot[Abs[\[CapitalDelta]], \ PlotRange\ \[Rule] \ All, \ PlotStyle\ \[Rule] \ {RGBColor[1, 0, 0], PointSize[0.02]}, \ GridLines\ \[Rule] \ True, \ Frame\ \[Rule] \ True, \ PlotLabel\ \[Rule] \ "\"];\)\)], "Input", CellLabel->"In[88]:="] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["Summary", "Section"], Cell[TextData[{ "The Logistic Map illustrates ", StyleBox["deterministic chaos ", FontSlant->"Italic"], "when the single control parameter, ", StyleBox["r", FontSlant->"Italic"], ", exceeds a critical value (approximately 3.57.) For small values of ", StyleBox["r", FontSlant->"Italic"], ", the trajectory converges to a single value ", StyleBox["independent of the initial condition.", FontSlant->"Italic"], " As ", StyleBox["r", FontSlant->"Italic"], " increases, the trajectory follows a ", StyleBox["limit cycle", FontSlant->"Italic"], " of increasing complexity until ", StyleBox["chaotic behavior", FontSlant->"Italic"], " results at a critical control parameter." }], "Text"], Cell["\<\ A nice summary plot of the limiting behavior of the Logistic Map is \ shown below.\ \>", "Text"], Cell[BoxData[ \(\(logisticSummary\ = \ Table[Transpose[{Table[r, \ {201}], Drop[NestList[Logistic[r], 0.5, 500], 300]}], \ {r, \ 1, \ 4, \ 0.001}]\ // \ Flatten[#, 1] &;\)\)], "Input", CellLabel->"In[36]:="], Cell[BoxData[ \(Dimensions[logisticSummary]\)], "Input", CellLabel->"In[37]:="], Cell[BoxData[ \(\(ListPlot[logisticSummary, \ Frame\ \[Rule] \ True];\)\)], "Input", CellLabel->"In[38]:="], Cell[BoxData[ \(\(Show[%, PlotRange\ \[Rule] \ {{2.8, 3.8}, All}];\)\)], "Input", CellLabel->"In[39]:="], Cell[BoxData[ \(\(Show[%%, PlotRange\ \[Rule] \ {{3.3, 3.7}, {0.25, \ 0.6}}];\)\)], "Input", CellLabel->"In[40]:="], Cell[BoxData[ \(\(Show[%%%, PlotRange\ \[Rule] \ {{3.5, 3.6}, {0.45, \ 0.58}}];\)\)], "Input", CellLabel->"In[41]:="] }, Closed]] }, Open ]] }, FrontEndVersion->"5.2 for Macintosh", ScreenRectangle->{{0, 1600}, {0, 967}}, ScreenStyleEnvironment->"Working", WindowToolbars->{}, WindowSize->{723, 800}, WindowMargins->{{23, Automatic}, {Automatic, 1}}, PrintingCopies->1, PrintingPageRange->{1, Automatic}, StyleDefinitions -> "TutorialBook.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[CellGroupData[{ Cell[1776, 53, 67, 0, 118, "Title"], Cell[1846, 55, 77, 0, 32, "Subsubtitle"], Cell[CellGroupData[{ Cell[1948, 59, 31, 0, 92, "Section"], Cell[1982, 61, 1545, 69, 89, "Text"], Cell[3530, 132, 99, 3, 29, "Input"], Cell[3632, 137, 918, 29, 89, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[4587, 171, 35, 0, 60, "Section"], Cell[4625, 173, 123, 2, 28, "Text"], Cell[4751, 177, 131, 3, 29, "Input"], Cell[4885, 182, 506, 18, 49, "Text"], Cell[5394, 202, 167, 4, 49, "Input"], Cell[5564, 208, 202, 7, 29, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[5803, 220, 43, 0, 60, "Section"], Cell[5849, 222, 344, 12, 28, "Text"], Cell[6196, 236, 486, 17, 49, "Input"], Cell[6685, 255, 220, 7, 28, "Text"], Cell[6908, 264, 174, 4, 49, "Input"], Cell[7085, 270, 143, 5, 28, "Text"], Cell[7231, 277, 210, 5, 49, "Input"], Cell[7444, 284, 178, 5, 28, "Text"], Cell[7625, 291, 211, 5, 49, "Input"], Cell[7839, 298, 265, 6, 48, "Text"], Cell[8107, 306, 198, 4, 49, "Input"], Cell[8308, 312, 93, 2, 28, "Text"], Cell[8404, 316, 199, 4, 49, "Input"], Cell[8606, 322, 231, 6, 48, "Text"], Cell[8840, 330, 201, 4, 49, "Input"], Cell[9044, 336, 182, 5, 28, "Text"], Cell[9229, 343, 202, 4, 49, "Input"], Cell[9434, 349, 339, 8, 48, "Text"], Cell[9776, 359, 106, 3, 29, "Input"], Cell[9885, 364, 225, 7, 29, "Text"], Cell[10113, 373, 114, 3, 29, "Input"], Cell[10230, 378, 209, 6, 48, "Text"], Cell[10442, 386, 114, 3, 29, "Input"], Cell[10559, 391, 147, 5, 28, "Text"], Cell[10709, 398, 114, 3, 29, "Input"], Cell[10826, 403, 261, 7, 48, "Text"], Cell[11090, 412, 114, 3, 29, "Input"], Cell[11207, 417, 708, 14, 108, "Text"], Cell[11918, 433, 87, 3, 29, "Input"], Cell[12008, 438, 684, 19, 69, "Text"], Cell[12695, 459, 63, 2, 29, "Input"], Cell[12761, 463, 99, 2, 28, "Text"], Cell[12863, 467, 66, 2, 29, "Input"], Cell[12932, 471, 327, 8, 48, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[13296, 484, 41, 0, 60, "Section"], Cell[13340, 486, 290, 5, 68, "Text"], Cell[CellGroupData[{ Cell[13655, 495, 40, 0, 41, "Subsection"], Cell[13698, 497, 165, 5, 28, "Text"], Cell[13866, 504, 90, 2, 29, "Input"], Cell[13959, 508, 74, 0, 28, "Text"], Cell[14036, 510, 90, 2, 29, "Input"], Cell[14129, 514, 140, 3, 28, "Text"], Cell[14272, 519, 104, 2, 29, "Input"], Cell[14379, 523, 104, 2, 29, "Input"], Cell[14486, 527, 104, 2, 29, "Input"], Cell[14593, 531, 462, 15, 49, "Text"], Cell[15058, 548, 135, 3, 29, "Input"], Cell[15196, 553, 537, 17, 48, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[15770, 575, 41, 0, 41, "Subsection"], Cell[15814, 577, 268, 8, 48, "Text"], Cell[16085, 587, 174, 4, 48, "Text"], Cell[16262, 593, 92, 2, 29, "Input"], Cell[16357, 597, 280, 7, 48, "Text"], Cell[16640, 606, 168, 3, 49, "Input"], Cell[16811, 611, 283, 6, 48, "Text"], Cell[17097, 619, 134, 3, 28, "Text"], Cell[17234, 624, 226, 5, 69, "Input"], Cell[17463, 631, 102, 2, 29, "Input"], Cell[17568, 635, 1009, 31, 108, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[18614, 671, 41, 0, 41, "Subsection"], Cell[18658, 673, 243, 10, 28, "Text"], Cell[18904, 685, 101, 2, 29, "Input"], Cell[19008, 689, 217, 7, 28, "Text"], Cell[19228, 698, 249, 5, 69, "Input"], Cell[19480, 705, 728, 22, 88, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[20245, 732, 47, 0, 41, "Subsection"], Cell[20295, 734, 217, 10, 28, "Text"], Cell[20515, 746, 289, 7, 89, "Input"], Cell[20807, 755, 407, 8, 68, "Text"], Cell[21217, 765, 257, 6, 89, "Input"], Cell[21477, 773, 372, 16, 28, "Text"] }, Closed]], Cell[CellGroupData[{ Cell[21886, 794, 73, 2, 41, "Subsection"], Cell[21962, 798, 637, 19, 68, "Text"], Cell[22602, 819, 241, 6, 69, "Input"], Cell[22846, 827, 308, 8, 48, "Text"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[23203, 841, 52, 0, 60, "Section"], Cell[23258, 843, 764, 20, 88, "Text"], Cell[24025, 865, 40, 0, 28, "Text"], Cell[24068, 867, 94, 2, 29, "Input"], Cell[CellGroupData[{ Cell[24187, 873, 29, 0, 41, "Subsection"], Cell[24219, 875, 318, 7, 69, "Input"], Cell[24540, 884, 321, 5, 89, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[24898, 894, 29, 0, 41, "Subsection"], Cell[24930, 896, 318, 7, 69, "Input"], Cell[25251, 905, 321, 5, 89, "Input"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell[25621, 916, 26, 0, 60, "Section"], Cell[25650, 918, 740, 23, 88, "Text"], Cell[26393, 943, 106, 3, 28, "Text"], Cell[26502, 948, 256, 5, 89, "Input"], Cell[26761, 955, 85, 2, 29, "Input"], Cell[26849, 959, 114, 2, 29, "Input"], Cell[26966, 963, 111, 2, 29, "Input"], Cell[27080, 967, 131, 3, 29, "Input"], Cell[27214, 972, 133, 3, 29, "Input"] }, Closed]] }, Open ]] } ] *) (******************************************************************* End of Mathematica Notebook file. *******************************************************************)