(*^ ::[ Information = "This is a Mathematica Notebook file. It contains ASCII text, and can be transferred by email, ftp, or other text-file transfer utility. It should be read or edited using a copy of Mathematica or MathReader. If you received this as email, use your mail application or copy/paste to save everything from the line containing (*^ down to the line containing ^*) into a plain text file. On some systems you may have to give the file a name ending with ".ma" to allow Mathematica to recognize it as a Notebook. The line below identifies what version of Mathematica created this file, but it can be opened using any other version as well."; FrontEndVersion = "NeXT Mathematica Notebook Front End Version 2.2"; NeXTStandardFontEncoding; fontset = title, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e8, 24, "Times"; ; fontset = subtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e6, 18, "Times"; ; fontset = subsubtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, L1, e6, 14, "Times"; ; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, L1, a20, 18, "Times"; ; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, L1, a15, 14, "Times"; ; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, L1, a12, 12, "Times"; ; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 10, "Times"; ; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L1, 12, "Courier"; ; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; ; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, L1, 12, "Courier"; ; fontset = name, inactive, noPageBreakInGroup, nohscroll, preserveAspect, M7, italic, B65535, L1, 10, "Times"; ; fontset = header, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, L1, 12, "Times"; ; fontset = leftheader, 12; fontset = footer, inactive, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, italic, L1, 12, "Times"; ; fontset = leftfooter, 12; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12, "Courier"; ; fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; paletteColors = 128; automaticGrouping; magnification = 125; currentKernel; ] :[font = title; inactive; noKeepOnOnePage; preserveAspect; startGroup] FEIGEXT: Feigenbaum Diagrams and Extensions for Cantor Sets :[font = section; inactive; noKeepOnOnePage; preserveAspect; startGroup] BRIEF ABSTRACT :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; endGroup] The goal of this problem set is to familiarize students with bifurcations of maps. The problems require knowledge of the derivative, and are appropriate for a course in chaos, discrete math, or calculus (given about a week to spare.) Students are motivated through the beauty of various types of bifurcation diagrams. :[font = section; inactive; Cclosed; noKeepOnOnePage; preserveAspect; startGroup] GENERAL INFORMATION :[font = subsection; inactive; noKeepOnOnePage; preserveAspect] FileName: FEIGEXT :[font = subsection; inactive; noKeepOnOnePage; preserveAspect] Full title: Feigenbaum Diagrams and Extensions for Cantor Sets. :[font = subsection; inactive; preserveAspect] Last Update: 8/29/96 :[font = subsection; inactive; noKeepOnOnePage; preserveAspect] Developer: Aaron Klebanoff, Department of Mathematics, Rose-Hulman Institute of Technology, Terre Haute IN 47803 USA. E-mail: Aaron.Klebanoff@Rose-Hulman.Edu. Phone: 812-877-8151. FAX: 812-877-3198. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect] Contact: Aaron Klebanoff, Department of Mathematics, Rose-Hulman Institute of Technology, Terre Haute IN 47803 USA. E-mail: Aaron.Klebanoff@Rose-Hulman.Edu. Phone: 812-877-8151. FAX: 812-877-3198. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; endGroup] Support: The production of this material is supported by the National Science Foundation under Division of Undergraduate Education grant DUE-9352849: Development Site for Complex, Technology-Based Problems in Calculus with Applications in Science and Engineering and the Arvin Foundation of Columbus IN. :[font = section; inactive; Cclosed; noKeepOnOnePage; preserveAspect; startGroup] STATEMENT OF PROBLEM :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Logistic Map and Iterations. :[font = text; inactive; preserveAspect] The parametrized family of functions given by :[font = input; preserveAspect] ClearAll[f, a, x]; f[x_, a_] = a x (1 - x); :[font = text; inactive; preserveAspect] is called the logistic family of maps, and is probably the most famous one dimensional maps in the study of chaotic dynamics. For each fixed a between 0 and 4, a member of the logistic family maps the interval between 0 and 1 into itself. Here are plots of f[a,x] for a = 1, 2, 3, and 4. :[font = input; preserveAspect; startGroup] Plot[Evaluate[Table[f[x, a], {a, 0, 4}]], {x, 0, 1}, FrameLabel -> {"x", "y"}, AspectRatio -> Automatic, Frame -> True] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] We'll be interested in a process called iteration in which the output of a map is fed back into itself over and over again. That is, after choosing some value for a along with a starting value x between 0 and 1, we compute f[x, a], f[f[x, a], a], ... as shown below. :[font = input; preserveAspect] a = 3; x = 0.5; :[font = input; preserveAspect; startGroup] f[x, a] f[f[x, a], a] :[font = output; output; inactive; preserveAspect] 0.75 ;[o] 0.75 :[font = output; output; inactive; preserveAspect; endGroup] 0.5625 ;[o] 0.5625 :[font = text; inactive; preserveAspect] This process is accomplished compactly using the Mathematica function FoldList. With a = 3, here are the first 20 iterations of the point x = .5 (including the seed, 0.5.) :[font = input; preserveAspect; startGroup] FoldList[f, .5, Table[3, {20}]] :[font = output; output; inactive; preserveAspect; endGroup] {0.5, 0.75, 0.5625, 0.73828125, 0.5796661376953125, 0.7309599195141346, 0.5899725467340735, 0.725714822502555, 0.5971584567079204, 0.7216807028704056, 0.602572997924649, 0.71843634029025, 0.6068566957218064, 0.715744939738252, 0.6103623629320141, 0.7134604465441872, 0.6133039132834687, 0.7114866697039567, 0.6158201656125886, 0.7097570677124177, 0.6180059176340648} ;[o] {0.5, 0.75, 0.5625, 0.738281, 0.579666, 0.73096, 0.589973, 0.725715, 0.597158, 0.721681, 0.602573, 0.718436, 0.606857, 0.715745, 0.610362, 0.71346, 0.613304, 0.711487, 0.61582, 0.709757, 0.618006} :[font = text; inactive; preserveAspect] Notice that this seems to be settling into a repetitive pattern of period 2. Let's increase the value of a. :[font = input; preserveAspect; startGroup] FoldList[f, .5, Table[3.5, {20}]] :[font = output; output; inactive; preserveAspect; endGroup] {0.5, 0.875, 0.3828125, 0.826934814453125, 0.5008976948447526, 0.87499717950388, 0.3828199037744718, 0.826940887670016, 0.5008837958933973, 0.874997266166866, 0.3828196762858185, 0.826940701069839, 0.500884222943868, 0.874997263524249, 0.3828196832226364, 0.826940706759849, 0.5008842099217976, 0.87499726360485, 0.3828196830110619, 0.826940706586302, 0.5008842103189738} ;[o] {0.5, 0.875, 0.382812, 0.826935, 0.500898, 0.874997, 0.38282, 0.826941, 0.500884, 0.874997, 0.38282, 0.826941, 0.500884, 0.874997, 0.38282, 0.826941, 0.500884, 0.874997, 0.38282, 0.826941, 0.500884} :[font = text; inactive; preserveAspect; endGroup] Now we get a repeating pattern of period 4. If a were decreases, points would be attracted to a single value x satisfying x = f[x, a] called a fixed point. However, if a were increased again, we would see period 8, and then period 16, etc. This process is called period doubling and culminates at the Feigenbaum Point (about a = 3.5699456718...). :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Graphical Analysis :[font = subsubsection; inactive; preserveAspect; startGroup] A word on notation :[font = text; inactive; preserveAspect; endGroup] We will write f(x) in comments rather than f[x, a]. :[font = subsubsection; inactive; preserveAspect; startGroup] What it is. :[font = text; inactive; preserveAspect; endGroup] Graphical analysis is a simple technique for seeing how trajectories evolve over many iterations. It exploits the fact that the output of the last iterate y is the input to the next x, so that we can use the line y = x to guide us from one iteration to the next. The fixed points are where the line y = x crosses f(x). Furthermore, as you will show in an exercise, a fixed point x0 of the map f(x) is attracting (attracts nearby points) if |f'(x0)| < 1 and repelling if |f'(x0)| > 1. Since the line y = x has slope one and crosses the fixed point at x0, it is trivial to check the stability by inspection with graphical analysis. We provide 2 examples below. The first shows a stable fixed point for f(x). Note that f(x) has smaller slope than the line y = x. The second shows an attracting period-2 point. Again note how the function (and its composition) crosses the line y = x. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Example 1 :[font = text; inactive; preserveAspect] Enter the function to iterate, the seed, x0, and the number of iterates, n. :[font = input; preserveAspect] g[x_] = f[x, 2.8]; x0 = 0.45; n = 100; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagram :[font = input; preserveAspect] pts = Table[0, {i, 1, 2n + 1}]; pts[[1]] = {x0, g[x0]}; Do[x0 = g[x0]; pts[[i]] = {x0, x0}; pts[[i + 1]] = {x0, g[x0]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot = ListPlot[pts, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect; endGroup] Show[iterateplot, mapplot, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction]; :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] Example 2 :[font = text; inactive; preserveAspect] Enter the function to iterate, the seed, x0, and the number of iterates, n. :[font = input; preserveAspect] g[x_] = f[x, 3.3]; h[x_] = f[f[x, 3.3], 3.3]; x0 = 0.01; n = 100; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagrams for both f(x) and f(f(x)) :[font = input; preserveAspect] pts1 = Table[0, {i, 1, 2n + 1}]; pts2 = Table[0, {i, 1, 2n + 1}]; x1 = x0; pts1[[1]] = {x0, g[x0]}; pts2[[1]] = {x1, h[x1]}; Do[x0 = g[x0]; x1 = h[x1]; pts1[[i]] = {x0, x0}; pts2[[i]] = {x1, x1}; pts1[[i + 1]] = {x0, g[x0]}; pts2[[i + 1]] = {x1, h[x1]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot1 = ListPlot[pts1, PlotJoined -> True, DisplayFunction -> Identity]; :[font = input; preserveAspect] iterateplot2 = ListPlot[pts2, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot1 = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = input; preserveAspect] mapplot2 = Plot[{x, h[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect] Show[iterateplot1, mapplot1, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction]; :[font = text; inactive; preserveAspect] By graphing the second-iterate map, f(f(x)), we see four fixed points. Two of them correspond to the unstable fixed points of f(x), and the other two fixed points are attracting period-2 points of f(x). :[font = input; preserveAspect; endGroup; endGroup] Show[iterateplot2, mapplot2, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction]; :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Feigenbaum Diagram :[font = text; inactive; preserveAspect] We use a Feigenbaum diagram to summarize the limiting behavior of iterations. It is a plot of the iterates as a function of the parameter value taken after the iterates have "settled down". The command LogistFeig[] defined below creates the points in a Feigenbaum diagram over the a-interval [min, max] with the parameter a sampled at m equally spaced points and with n iterations plotted after the first k iterations are run. The Mathematica command Fold takes the last element in the iteration list that FoldList would create. Also, the logistic map, f[x, a] = a x (1 - x) is entered as a compiled function to improve performance. :[font = input; preserveAspect] LogistFeig[min_Real, max_Real, k_Integer, n_Integer, m_Integer] := Module[{f, a, astep, i, j, x, seed}, seed = 0.223; f = Compile[{x, a}, Evaluate[a x (1 - x)]]; astep = (max - min)/m; Partition[ Flatten[ Table[ a = min + j astep; Table[{a, Fold[f, seed, Table[a, {k+i}]]}, {i, 1, n} ], {j, 0, m} ] ], 2 ] ] :[font = text; inactive; preserveAspect] Below is a graph of the Feigenbaum diagram for the logistic map with a running from [3, 4]. :[font = input; preserveAspect; startGroup] ListPlot[LogistFeig[3., 4., 50, 50, 200]] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] In the exercises, you will see that the bifurcation diagram appears empty if a > 4. While one might be tempted to think that this means that nothing interesting happens to the dynamics of the map for this range of parameter values, actually, nothing could be further from the truth! :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Divergence Diagrams (Extensions of Feigenbaum Diagrams for viewing Cantor Sets.) :[font = text; inactive; preserveAspect] Below, we use another method for graphing the limiting behavior of iterations. But, rather than waiting for iterates to "settle down", we determine for every point in the (a, x) plane how many iterations it takes before the iterates leave the x-interval [0, 1] (since all iterates outside of [0, 1] diverge.) :[font = input; preserveAspect] GetColor[a_Real, x_Real] := Module[{i, initx, newx}, i = 0; initx = x; While[i > -10 && initx < 1, i--; newx = a*initx*(1 - initx); initx = newx; ]; Return[i] ]; :[font = text; inactive; preserveAspect] Each point represents a Color or GreyScale for a (a, x) coordinate. We want the smallest numbers (in magnitude) to have the lightest shade, so we count down from 0 since Mathematica makes the largest numbers light. ;[s] 3:0,0;171,1;182,2;215,-1; 3:1,11,8,Times,0,12,0,0,0;1,10,8,Times,2,12,0,0,0;1,11,8,Times,0,12,0,0,0; :[font = input; preserveAspect; startGroup] ContourPlot[GetColor[a, x], {a, 4., 5.}, {x, 0., 1.}, PlotPoints -> {200, 200}, FrameLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] ContourGraphics["<<>>"] ;[o] -ContourGraphics- :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Problem. Part I. A study of the logistic map f(x) = a x ( 1 - x ). Do all computations with the parameter a as an arbitrary number between 0 and 4 inclusive unless indicated otherwise and concentrate on values of x in [0, 1]. :[font = subsubsection; inactive; preserveAspect] 1) Verify that for all 1 <= a <= 4, if x0 > 1 or x0 < 0, then the orbit of x0 diverges to negative infinity. :[font = subsubsection; inactive; preserveAspect] 2) Compute the fixed points of f(x). :[font = subsubsection; inactive; preserveAspect] 3) Compute the slope of f(x) at each fixed point. :[font = subsubsection; inactive; preserveAspect] 4) Verify by example that fixed points xbar repel when |f'(xbar)| >1 and attract when |f'(xbar)| <1. Further, verify by example that if f'(xbar) < 0, then orbits cycle near xbar and when f'(xbar) > 0, orbits staircase near xbar. :[font = subsubsection; inactive; preserveAspect] 5) Find the a-value (bifurcation value) for which the "trivial" fixed point switches from attracting to repelling. :[font = subsubsection; inactive; preserveAspect] 6) Find the a-value for which the "nontrivial" fixed points switches from attracting to repelling. :[font = subsubsection; inactive; preserveAspect] 7) Graph f^2(x) = f(f(x)) along with x for various values of a between 0 and 4. Can you tell for what a-value two period-2 points of f(x) emerge? :[font = subsubsection; inactive; preserveAspect] 8) Determine formulas for the period-2 points of f(x) (i.e., the new fixed points of f^2(x) which are not fixed points of f(x).) :[font = subsubsection; inactive; preserveAspect] 9) Verify by example that periodic points xbar repel when |(f^2)'(xbar)| > 1 and attract when |(f^2)'(xbar)| < 1. :[font = subsubsection; inactive; preserveAspect] 10) Find the a-value(s) for which the period-2 points switch(s) from attracting to repelling. :[font = subsubsection; inactive; preserveAspect; endGroup] 11) Let a = 3.55 and plot f^3(x), f^4(x), f^5(x), f^6(x), f^7(x), f^8(x) along with the replacement line y = x. List how many periodic points f(x) has of every period less than or equal to 8. Do you think that f(x) has any higher periodic orbits (when a = 3.55?) Why or why not? :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Problem. Part II. A study of the quadratic map Q(x) = x^2 + b. Do all computations with the parameter b as an arbitrary number between -2 and 1/4 inclusive unless indicated otherwise and concentrate on values of x in the interval [-(1 + Sqrt[1 - 4 b])/2, (1 + Sqrt[1 - 4 b])/2]. :[font = subsubsection; inactive; preserveAspect] 1) Compute the fixed points of Q(x). :[font = subsubsection; inactive; preserveAspect] 2) Compute the slope of Q(x) at each fixed point. :[font = subsubsection; inactive; preserveAspect] 3) Verify that for all -2 <= b <= 1/4, if |x0| > (1 + Sqrt[1 - 4 b])/2 then the orbit of x0 will diverge to positive infinity. :[font = subsubsection; inactive; preserveAspect] 4) A bifurcation occurs at b = 1/4. Describe the dynamics of ALL orbits (consider all real numbers x0) for b close to and on both sides of 1/4. :[font = subsubsection; inactive; preserveAspect] 5) Let p+ > p- be the two fixed points which exist for all b < 1/4. Find the b-values (for b < 1/4) where each fixed point switches stability (if any.) :[font = subsubsection; inactive; preserveAspect] 6) Graph Q^2(x) = Q(Q(x)) along with x for various values of b between -2 and 1/4. Can you tell for what b-value two period-2 points of Q(x) emerge? :[font = subsubsection; inactive; preserveAspect] 7) Determine formulas for the period-2 points of Q(x) (i.e., the new fixed points of Q^2(x) which are not fixed points of Q(x).) :[font = subsubsection; inactive; preserveAspect] 8) Find the b-value(s) for which the period-2 points switch(s) from attracting to repelling. :[font = subsubsection; inactive; preserveAspect; endGroup] 9) Let b=-1.3 and plot Q(x), Q^2(x), Q^3(x), and Q^4(x) along with the replacement line y = x. List how many periodic points Q(x) has of every period less than or equal to 4. Do you think that Q(x) has any higher periodic orbits (when b = -1.3?) Why or why not? :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Problem. Part III. A study of the Feigenbaum diagrams for the logistic family. Do all computations with parameter and state variable ranges as described in part I. :[font = subsubsection; inactive; preserveAspect] 1) a) Determine the period-2 bifurcation value for the logistic map, call this a2. b) Determine the period-4 bifurcation value for the logistic map, call this a4. :[font = subsubsection; inactive; preserveAspect] 2) The curves that you see in the bifurcation diagram are the attracting fixed and periodic points as a function of the parameter. a) Find and graph the curve of fixed points for a in [0, 1]. b) Find and graph the curve of fixed points for a in [1, a2]. c) Find and graph the curves of period-2 points for a in [a2, a4]. d) Display the graphs of (a) -- (c) together on [0, a4] and compare them to the Feigenbaum diagram graphed on [0, a4]. :[font = subsubsection; inactive; preserveAspect] 3) By using the bifurcation diagram for the logistic map, estimate the value for the period-8 bifurcation point. Try to find the next period doubling bifurcation value after that! :[font = subsubsection; inactive; preserveAspect] 4) Suppose a point in an orbit hits very VERY close to a repelling fixed point. It will be repelled, but it may take many iterations before it can escape from that fixed point. Explain, in light of this fact, what causes the dark bands running through the Feigenbaum diagram. :[font = subsubsection; inactive; preserveAspect] 5) The curves that you graphed in problem 2 correspond to attracting fixed and periodic points. While they are not attracting outside of the intervals graphed in the problem, the fixed and periodic points don't just disappear. Graph all of the fixed, period-2, and period-4 points of the logistic map for a in [0, 4]. Compare this graph to the Feigenbaum diagram for the logistic map on [0, 4]. :[font = subsubsection; inactive; preserveAspect] 6) While the formulas for the periodic points of the logistic map may be quite messy, you should be able to tell that the the curves are well defined for arbitrarily large values of a. In particular, while they are not attracting outside of the intervals graphed in problem 2, the fixed and periodic points still remain for a > 4. Verify this by plotting the curves from the last problem on the interval [0, 5]. :[font = subsubsection; inactive; preserveAspect; endGroup] 7) In light of the result in the last problem, any guesses as to why the Feigenbaum diagram cannot be plotted for a > 4? (You should verify that indeed the Feigenbaum diagram appears empty for all a > 4.) :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Problem. Part IV. A study of the Feigenbaum diagrams for the quadratic family. Do all computations with parameter and state variable ranges as described in part II. :[font = subsubsection; inactive; preserveAspect] 1) Write a program that draws a Feigenbaum diagram for the quadratic family Q(x) = x^2 + b. Draw the diagram for -2 <= b <= 1/4 and -2 <= x <= 2. :[font = subsubsection; inactive; preserveAspect] 2) a) Determine the period-2 bifurcation value for the quadratic map, call this b2. b) Determine the period-4 bifurcation value for the quadratic map, call this b4. :[font = subsubsection; inactive; preserveAspect] 3) The curves that you see in the bifurcation diagram are the attracting fixed and periodic points as a function of the parameter. a) Find and graph the curve of fixed points for b in [b2, 1/4]. b) Find and graph the curves of period-2 points for a in [b4, b2]. c) Display the graphs of (a) and (b) together on [b4, 1/4] and compare them to the Feigenbaum diagram graphed on [b4, 1/4]. :[font = subsubsection; inactive; preserveAspect] 4) The curves that you graphed in problem 3 correspond to attracting fixed and periodic points. While they are not attracting outside of the intervals graphed in the problem, the fixed and periodic points don't just disappear. Graph all of the fixed and period-2 points of the quadratic map for b in [-2, 1/4]. Compare this graph to the Feigenbaum diagram for the quadratic map on [-2, 1/4]. :[font = subsubsection; inactive; preserveAspect] 5) While the formulas for the periodic points of the quadratic map may be quite messy, you should be able to tell that the the curves are well defined for arbitrarily large values of b. In particular, while they are not attracting outside of the intervals graphed in problem 3, the fixed and periodic points still remain for b < -2. Verify this by plotting the curves from the last problem on the interval [-3, 1/4]. :[font = subsubsection; inactive; preserveAspect; endGroup] 6) In light of the result in number 5, any guesses as to why the Feigenbaum diagram cannot be plotted for b < -2? (You should verify that indeed the Feigenbaum diagram appears empty for all b < -2.) :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] The Problem. Part V. Divergence Diagrams (extensions of Feigenbaum diagrams.) The divergence diagram for the logistic map provides a way to see periodic points that still remain when a > 4. Each shade (color) corresponds to the number of iterates before x > 1 (after which the orbit will clearly diverge to negative infinity.) Refer to the Divergence Diagram given in the background materials preceding the problem sets. :[font = subsubsection; inactive; preserveAspect] 1) Find the equations of the boundary curves for the largest region in which orbits diverge after one iteration. Plot the curves and compare with the divergence diagram. :[font = subsubsection; inactive; preserveAspect] 2) Find the equations of the boundary curves for the two regions in which orbits diverge after two iterations. Plot these curves along with the curves found in the first problem and compare to the divergence diagram. :[font = subsubsection; inactive; preserveAspect] 3) Find the equations of the boundary curves for the four regions in which orbits diverge after three iterations. Plot these curves along with the curves found in the first two problems and compare to the divergence diagram. :[font = subsubsection; inactive; preserveAspect; endGroup; endGroup] 4) Note that other than the largest region, the other regions each have a maximum width. Find the a-value for which the boundary curves found in problem 2 are the widest. :[font = section; inactive; Cclosed; noKeepOnOnePage; preserveAspect; startGroup] KEYWORDS :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; endGroup] Discrete Dynamical Systems, Chaos, Bifurcations, Difference Equations, Feigenbaum Diagrams, Cantor sets, Derivatives. :[font = section; inactive; Cclosed; noKeepOnOnePage; preserveAspect; startGroup] TEACHER NOTES :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; startGroup] ISSUES RELATED TO THE PROBLEM :[font = subsubsection; inactive; preserveAspect; endGroup] The problems are designed to be worked with a computer algebra system and are not appropriate for "by-hands" work. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; startGroup] Prerequisites :[font = subsubsection; inactive; preserveAspect; endGroup] An understanding of the derivative. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; startGroup] Time allotment - time management :[font = subsubsection; inactive; preserveAspect; endGroup] Each part is a complete lesson requiring appropriately 1 to 1 and a half 50 minute periods each. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; startGroup] Expectations :[font = subsubsection; inactive; preserveAspect; endGroup] My students had high success working through these problem sets. Expect success as long as the students are familiar with the computer algebra system that they are using. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; startGroup] Future payoffs :[font = subsubsection; inactive; preserveAspect; endGroup] By the time students complete some or all of these exercises, they have a much better understanding of what a bifurcation diagram is and how to interpret it. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; startGroup] Extensions :[font = subsubsection; inactive; preserveAspect; endGroup] Encourage students to develop more efficient code for producing Feigenbaum and Divergence Diagrams. Have the students study various other famous families of maps such as the tent and doubling families. Better yet, encourage the students to make up their own families of maps. :[font = subsection; inactive; noKeepOnOnePage; preserveAspect; endGroup] References and Sources :[font = section; inactive; Cclosed; noKeepOnOnePage; preserveAspect; startGroup] POSSIBLE SOLUTION(S) :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Part I. The Logistic Family: f(x) = a x ( 1 - x ). :[font = subsubsection; inactive; preserveAspect; startGroup] 1) Verify that orbits of x0 > 1 or x0 < 0 diverge to negative infinity (for a in (0, 4].) :[font = text; inactive; preserveAspect; endGroup] Note that if x0 > 1, then f(x0) < 0. Thus, it suffices to show that orbits of x0<0 tend to negative infinity. But a x (1 - x) - x = x ( a - 1 - a x ) < 0 for all x < 0 implying that f(x) < x for all x < 0 (since a >= 1.) So, all orbits must tend to negative infinity. :[font = subsubsection; inactive; preserveAspect; startGroup] 2) Compute the fixed points of f(x) = a x (1 - x). :[font = input; preserveAspect; startGroup] f[x_] = a x ( 1 - x ) :[font = output; output; inactive; preserveAspect; endGroup] a*(1 - x)*x ;[o] a (1 - x) x :[font = input; preserveAspect; startGroup] fps = Solve[f[t]==t, t] :[font = output; output; inactive; preserveAspect; endGroup] {{t -> 0}, {t -> (-1 + a)/a}} ;[o] -1 + a {{t -> 0}, {t -> ------}} a :[font = input; preserveAspect; startGroup] fp1 = t /. fps[[1]] :[font = output; output; inactive; preserveAspect; endGroup] 0 ;[o] 0 :[font = input; preserveAspect; startGroup] fp2 = t /. fps[[2]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] (-1 + a)/a ;[o] -1 + a ------ a :[font = subsubsection; inactive; preserveAspect; startGroup] 3) Compute the slope of f(x) at each fixed point. :[font = input; preserveAspect; startGroup] f'[fp1] :[font = output; output; inactive; preserveAspect; endGroup] a ;[o] a :[font = input; preserveAspect; startGroup] Simplify[f'[fp2]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] 2 - a ;[o] 2 - a :[font = subsubsection; inactive; preserveAspect; startGroup] 4) Verify by example that fixed points xbar repel when |f'(xbar)| >1 and attract when |f'(xbar)| <1. Further, verify by example that if f'(xbar) < 0, then orbits cycle near xbar and when f'(xbar) > 0, orbits staircase near xbar. :[font = text; inactive; preserveAspect; endGroup] For the trivial fixed point, we'll compare the functions with a = 0.5 and a = 1.5. In each of these cases, we see a staircase either towards or away from the fixed point. For the nontrivial fixed point, we'll compare the function with a = 2.7 to see that spirals occur near the fixed point when the slope is negative. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] a = 0.5 :[font = input; preserveAspect] g[x_] = 0.5 x (1 - x); x0 = 0.45; n = 6; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagram :[font = input; preserveAspect] pts = Table[0, {i, 1, 2n + 1}]; pts[[1]] = {x0, g[x0]}; Do[x0 = g[x0]; pts[[i]] = {x0, x0}; pts[[i + 1]] = {x0, g[x0]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot = ListPlot[pts, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect] Show[iterateplot, mapplot, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = text; inactive; preserveAspect; endGroup] The orbit started at x = 0.45 and is moving towards the origin. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] a = 1.5 :[font = input; preserveAspect] g[x_] = 1.5 x (1 - x); x0 = 0.01; n = 6; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagram :[font = input; preserveAspect] pts = Table[0, {i, 1, 2n + 1}]; pts[[1]] = {x0, g[x0]}; Do[x0 = g[x0]; pts[[i]] = {x0, x0}; pts[[i + 1]] = {x0, g[x0]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot = ListPlot[pts, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect] Show[iterateplot, mapplot, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = text; inactive; preserveAspect; endGroup] The orbit started at x = 0.01 and is moving away from the origin. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] a = 2.7. :[font = input; preserveAspect] g[x_] = 2.7 x (1 - x); x0 = 0.45; n = 6; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagram :[font = input; preserveAspect] pts = Table[0, {i, 1, 2n + 1}]; pts[[1]] = {x0, g[x0]}; Do[x0 = g[x0]; pts[[i]] = {x0, x0}; pts[[i + 1]] = {x0, g[x0]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot = ListPlot[pts, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect] Show[iterateplot, mapplot, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = text; inactive; preserveAspect; endGroup] The orbit started at x = 0.45 and is spiraling towards the origin. :[font = subsubsection; inactive; preserveAspect; startGroup] 5) Find the a-value (bifurcation value) for which the "trivial" fixed point switches from attracting to repelling. :[font = text; inactive; preserveAspect; endGroup] Since f'(0) = a, by inspection a = 1 is the desired bifurcation value. :[font = subsubsection; inactive; preserveAspect; startGroup] 6) Find the a-value for which the "nontrivial" fixed points switches from attracting to repelling. :[font = text; inactive; preserveAspect; endGroup] Since f'((a-1)/a) = 2 - a, a = 3 by inspection. NOTE: We do not choose a = 1 since the fixed point a-1/a is really the trivial fixed point for that value of a. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 7) Graph f^2(x) = f(f(x)) along with x for various values of a between 0 and 4. Can you tell for what a-value two period-2 points of f(x) emerge? :[font = input; preserveAspect] ClearAll[g, h, a, x]; g[a_, x_] = a x (1 - x); h[a_, x_] = g[a, g[a, x]]; :[font = text; inactive; preserveAspect] Below are graphs of the second iterate map, f(f(x)), for a = 1, 2, 3, 4 along with the replacement line y = x. :[font = input; preserveAspect; startGroup] p1 = Plot[Evaluate[Table[h[a, x], {a, 1, 4}]], {x, 0, 1}, DisplayFunction -> Identity]; p2 = Plot[x, {x, 0, 1}, DisplayFunction -> Identity]; Show[p1, p2, AxesLabel -> {"x", "y"}, AspectRatio -> Automatic, DisplayFunction -> $DisplayFunction] :[font = postscript; PostScript; formatAsPostScript; output; inactive; preserveAspect; pictureLeft = 34; pictureWidth = 282; pictureHeight = 282] %! %%Creator: Mathematica %%AspectRatio: 1 MathPictureStart %% Graphics /Courier findfont 10 scalefont setfont % Scaling calculations 0.02381 0.952381 0.02381 0.952381 [ [(0.2)] .21429 .02381 0 2 Msboxa [(0.4)] .40476 .02381 0 2 Msboxa [(0.6)] .59524 .02381 0 2 Msboxa [(0.8)] .78571 .02381 0 2 Msboxa [(1)] .97619 .02381 0 2 Msboxa [(x)] 1.025 .02381 -1 0 Msboxa [(0.2)] .01131 .21429 1 0 Msboxa [(0.4)] .01131 .40476 1 0 Msboxa [(0.6)] .01131 .59524 1 0 Msboxa [(0.8)] .01131 .78571 1 0 Msboxa [(1)] .01131 .97619 1 0 Msboxa [(y)] .02381 1 0 -4 Msboxa [ -0.001 -0.001 0 0 ] [ 1.001 1.001 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath [ ] 0 setdash 0 g p p .002 w .21429 .02381 m .21429 .03006 L s P [(0.2)] .21429 .02381 0 2 Mshowa p .002 w .40476 .02381 m .40476 .03006 L s P [(0.4)] .40476 .02381 0 2 Mshowa p .002 w .59524 .02381 m .59524 .03006 L s P [(0.6)] .59524 .02381 0 2 Mshowa p .002 w .78571 .02381 m .78571 .03006 L s P [(0.8)] .78571 .02381 0 2 Mshowa p .002 w .97619 .02381 m .97619 .03006 L s P [(1)] .97619 .02381 0 2 Mshowa p .001 w .0619 .02381 m .0619 .02756 L s P p .001 w .1 .02381 m .1 .02756 L s P p .001 w .1381 .02381 m .1381 .02756 L s P p .001 w .17619 .02381 m .17619 .02756 L s P p .001 w .25238 .02381 m .25238 .02756 L s P p .001 w .29048 .02381 m .29048 .02756 L s P p .001 w .32857 .02381 m .32857 .02756 L s P p .001 w .36667 .02381 m .36667 .02756 L s P p .001 w .44286 .02381 m .44286 .02756 L s P p .001 w .48095 .02381 m .48095 .02756 L s P p .001 w .51905 .02381 m .51905 .02756 L s P p .001 w .55714 .02381 m .55714 .02756 L s P p .001 w .63333 .02381 m .63333 .02756 L s P p .001 w .67143 .02381 m .67143 .02756 L s P p .001 w .70952 .02381 m .70952 .02756 L s P p .001 w .74762 .02381 m .74762 .02756 L s P p .001 w .82381 .02381 m .82381 .02756 L s P p .001 w .8619 .02381 m .8619 .02756 L s P p .001 w .9 .02381 m .9 .02756 L s P p .001 w .9381 .02381 m .9381 .02756 L s P [(x)] 1.025 .02381 -1 0 Mshowa p .002 w 0 .02381 m 1 .02381 L s P p .002 w .02381 .21429 m .03006 .21429 L s P [(0.2)] .01131 .21429 1 0 Mshowa p .002 w .02381 .40476 m .03006 .40476 L s P [(0.4)] .01131 .40476 1 0 Mshowa p .002 w .02381 .59524 m .03006 .59524 L s P [(0.6)] .01131 .59524 1 0 Mshowa p .002 w .02381 .78571 m .03006 .78571 L s P [(0.8)] .01131 .78571 1 0 Mshowa p .002 w .02381 .97619 m .03006 .97619 L s P [(1)] .01131 .97619 1 0 Mshowa p .001 w .02381 .0619 m .02756 .0619 L s P p .001 w .02381 .1 m .02756 .1 L s P p .001 w .02381 .1381 m .02756 .1381 L s P p .001 w .02381 .17619 m .02756 .17619 L s P p .001 w .02381 .25238 m .02756 .25238 L s P p .001 w .02381 .29048 m .02756 .29048 L s P p .001 w .02381 .32857 m .02756 .32857 L s P p .001 w .02381 .36667 m .02756 .36667 L s P p .001 w .02381 .44286 m .02756 .44286 L s P p .001 w .02381 .48095 m .02756 .48095 L s P p .001 w .02381 .51905 m .02756 .51905 L s P p .001 w .02381 .55714 m .02756 .55714 L s P p .001 w .02381 .63333 m .02756 .63333 L s P p .001 w .02381 .67143 m .02756 .67143 L s P p .001 w .02381 .70952 m .02756 .70952 L s P p .001 w .02381 .74762 m .02756 .74762 L s P p .001 w .02381 .82381 m .02756 .82381 L s P p .001 w .02381 .8619 m .02756 .8619 L s P p .001 w .02381 .9 m .02756 .9 L s P p .001 w .02381 .9381 m .02756 .9381 L s P [(y)] .02381 1 0 -4 Mshowa p .002 w .02381 0 m .02381 1 L s P P 0 0 m 1 0 L 1 1 L 0 1 L closepath clip newpath p p p p .004 w .02381 .02381 m .06349 .06032 L .10317 .091 L .14286 .11658 L .18254 .13771 L .22222 .15498 L .2619 .1689 L .30159 .17992 L .34127 .18842 L .36111 .19182 L .38095 .19471 L .40079 .1971 L .42063 .19903 L .44048 .20051 L .4504 .20108 L .46032 .20155 L .47024 .20192 L .4752 .20206 L .48016 .20217 L .48512 .20226 L .4876 .2023 L .49008 .20233 L .49256 .20235 L .4938 .20236 L .49504 .20237 L .49628 .20237 L .49752 .20238 L .49876 .20238 L .5 .20238 L .50124 .20238 L .50248 .20238 L .50372 .20237 L .50496 .20237 L .5062 .20236 L .50744 .20235 L .50992 .20233 L .5124 .2023 L .51488 .20226 L .51984 .20217 L .5248 .20206 L .52976 .20192 L .53968 .20155 L .5496 .20108 L .55952 .20051 L .57937 .19903 L .59921 .1971 L .61905 .19471 L .65873 .18842 L .69841 .17992 L .7381 .1689 L Mistroke .77778 .15498 L .81746 .13771 L .85714 .11658 L .89683 .091 L .93651 .06032 L .97619 .02381 L Mfstroke P P p p .004 w .02381 .02381 m .06349 .16378 L .10317 .27036 L .14286 .34933 L .1627 .38012 L .18254 .40594 L .22222 .44486 L .24206 .45901 L .2619 .47024 L .28175 .47899 L .30159 .48565 L .32143 .49058 L .33135 .49251 L .34127 .49412 L .36111 .49655 L .37103 .49744 L .38095 .49814 L .39087 .49869 L .40079 .4991 L .41071 .49941 L .42063 .49963 L .4256 .49972 L .43056 .49978 L .43552 .49984 L .44048 .49988 L .44544 .49992 L .4504 .49994 L .45536 .49996 L .45784 .49997 L .46032 .49998 L .46528 .49999 L .46776 .49999 L .47024 .49999 L .47272 .49999 L .4752 .5 L .47768 .5 L .48016 .5 L .4814 .5 L .48264 .5 L .48388 .5 L .48512 .5 L .48636 .5 L .4876 .5 L .48884 .5 L .49008 .5 L .49132 .5 L .49256 .5 L .4938 .5 L .49504 .5 L .49628 .5 L Mistroke .49752 .5 L .49876 .5 L .5 .5 L .50124 .5 L .50248 .5 L .50372 .5 L .50496 .5 L .5062 .5 L .50744 .5 L .50868 .5 L .50992 .5 L .51116 .5 L .5124 .5 L .51364 .5 L .51488 .5 L .51612 .5 L .51736 .5 L .51984 .5 L .52108 .5 L .52232 .5 L .5248 .5 L .52728 .49999 L .52976 .49999 L .53224 .49999 L .53472 .49999 L .5372 .49998 L .53968 .49998 L .54464 .49996 L .5496 .49994 L .55456 .49992 L .55952 .49988 L .56448 .49984 L .56944 .49978 L .57937 .49963 L .58433 .49953 L .58929 .49941 L .59921 .4991 L .60913 .49869 L .61905 .49814 L .62897 .49744 L .63889 .49655 L .64881 .49546 L .65873 .49412 L .67857 .49058 L .69841 .48565 L .71825 .47899 L .7381 .47024 L .75794 .45901 L .77778 .44486 L .81746 .40594 L Mistroke .8373 .38012 L .85714 .34933 L .89683 .27036 L .93651 .16378 L .97619 .02381 L Mfstroke P P p p .004 w .02381 .02381 m .04365 .18796 L .06349 .32507 L .08333 .43776 L .10317 .52852 L .12302 .59974 L .14286 .65369 L .1627 .69252 L .17262 .7069 L .18254 .71825 L .19246 .72682 L .19742 .73013 L .20238 .73282 L .20734 .73493 L .20982 .73577 L .2123 .73648 L .21478 .73706 L .21726 .7375 L .2185 .73768 L .21974 .73782 L .22098 .73793 L .22222 .73802 L .22346 .73807 L .2247 .73809 L .22594 .73809 L .22718 .73805 L .22842 .73799 L .22966 .7379 L .2309 .73778 L .23214 .73763 L .2371 .73679 L .23958 .73621 L .24206 .73553 L .25198 .7319 L .2619 .72693 L .28175 .71368 L .30159 .6971 L .34127 .65873 L .38095 .62021 L .42063 .58805 L .44048 .57587 L .4504 .57096 L .46032 .56689 L .47024 .56368 L .4752 .56242 L .48016 .56138 L .48512 .56057 L .4876 .56025 L .49008 .55999 L .49256 .55979 L Mistroke .4938 .55971 L .49504 .55964 L .49628 .55959 L .49752 .55955 L .49876 .55953 L .5 .55952 L .50124 .55953 L .50248 .55955 L .50372 .55959 L .50496 .55964 L .5062 .55971 L .50744 .55979 L .50992 .55999 L .5124 .56025 L .51488 .56057 L .51984 .56138 L .5248 .56242 L .52976 .56368 L .53968 .56689 L .55952 .57587 L .57937 .58805 L .61905 .62021 L .65873 .65873 L .69841 .6971 L .71825 .71368 L .72817 .7208 L .7381 .72693 L .74802 .7319 L .75298 .7339 L .75794 .73553 L .76042 .73621 L .7629 .73679 L .76538 .73726 L .76786 .73763 L .7691 .73778 L .77034 .7379 L .77158 .73799 L .77282 .73805 L .77406 .73809 L .7753 .73809 L .77654 .73807 L .77778 .73802 L .77902 .73793 L .78026 .73782 L .7815 .73768 L .78274 .7375 L .7877 .73648 L .79018 .73577 L .79266 .73493 L .79762 .73282 L Mistroke .80258 .73013 L .80754 .72682 L .81746 .71825 L .82738 .7069 L .8373 .69252 L .85714 .65369 L .87698 .59974 L .89683 .52852 L .91667 .43776 L .93651 .32507 L .97619 .02381 L Mfstroke P P p p .004 w .02381 .02381 m .04365 .30929 L .06349 .53509 L .08333 .7074 L .09325 .77537 L .10317 .83216 L .1131 .87848 L .12302 .915 L .12798 .9298 L .13294 .9424 L .1379 .95287 L .14286 .96131 L .14782 .96778 L .1503 .9703 L .15278 .97237 L .15526 .97397 L .1565 .97461 L .15774 .97514 L .15898 .97556 L .16022 .97587 L .16146 .97608 L .1627 .97618 L .16394 .97618 L .16518 .97607 L .16642 .97586 L .16766 .97556 L .17014 .97464 L .17138 .97404 L .17262 .97334 L .17758 .96961 L .18254 .96443 L .19246 .95001 L .20238 .93062 L .22222 .879 L .2619 .7381 L .30159 .57036 L .34127 .40006 L .38095 .24702 L .42063 .12669 L .44048 .0824 L .4504 .0647 L .46032 .05008 L .47024 .03863 L .4752 .03412 L .48016 .03041 L .48512 .02753 L .4876 .02639 L .49008 .02546 L .49256 .02474 L .4938 .02446 L Mistroke .49504 .02422 L .49628 .02404 L .49752 .02391 L .49876 .02384 L .5 .02381 L .50124 .02384 L .50248 .02391 L .50372 .02404 L .50496 .02422 L .5062 .02446 L .50744 .02474 L .50992 .02546 L .5124 .02639 L .51488 .02753 L .51984 .03041 L .5248 .03412 L .52976 .03863 L .53968 .05008 L .55952 .0824 L .57937 .12669 L .61905 .24702 L .65873 .40006 L .69841 .57036 L .7381 .7381 L .75794 .81359 L .77778 .879 L .7877 .90678 L .79762 .93062 L .80754 .95001 L .81746 .96443 L .82242 .96961 L .8249 .97166 L .82738 .97334 L .82862 .97404 L .82986 .97464 L .8311 .97515 L .83234 .97556 L .83358 .97586 L .83482 .97607 L .83606 .97618 L .8373 .97618 L .83854 .97608 L .83978 .97587 L .84102 .97556 L .84226 .97514 L .84474 .97397 L .84722 .97237 L .8497 .9703 L .85218 .96778 L .85714 .96131 L Mistroke .8621 .95287 L .86706 .9424 L .87698 .915 L .8869 .87848 L .89683 .83216 L .91667 .7074 L .93651 .53509 L .95635 .30929 L .97619 .02381 L Mfstroke P P P p p .004 w .02381 .02381 m .06349 .06349 L .10317 .10317 L .14286 .14286 L .18254 .18254 L .22222 .22222 L .2619 .2619 L .30159 .30159 L .34127 .34127 L .38095 .38095 L .42063 .42063 L .46032 .46032 L .5 .5 L .53968 .53968 L .57937 .57937 L .61905 .61905 L .65873 .65873 L .69841 .69841 L .7381 .7381 L .77778 .77778 L .81746 .81746 L .85714 .85714 L .89683 .89683 L .93651 .93651 L .97619 .97619 L s P P P % End of Graphics MathPictureEnd :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] Something seems to be happening near a = 3, so below we plot f^2(x) for a = 2.8, 3, 3.2 with progressively thicker curves to distinguish them from each other. It appears that just above a = 3, the graph of f^2(x) crosses y = x in two more places which implies a period doubling bifurcation for f(x) occurs there. :[font = input; preserveAspect; startGroup] Plot[{x, h[2.8, x], h[3, x], h[3.2, x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[0],AbsoluteThickness[2], AbsoluteThickness[3],AbsoluteThickness[4]}, AxesLabel -> {"x", "y"}, AspectRatio -> Automatic] :[font = postscript; PostScript; formatAsPostScript; output; inactive; preserveAspect; pictureLeft = 34; pictureWidth = 282; pictureHeight = 282] %! %%Creator: Mathematica %%AspectRatio: 1 MathPictureStart %% Graphics /Courier findfont 10 scalefont setfont % Scaling calculations 0.02381 0.952381 0.02381 0.952381 [ [(0.2)] .21429 .02381 0 2 Msboxa [(0.4)] .40476 .02381 0 2 Msboxa [(0.6)] .59524 .02381 0 2 Msboxa [(0.8)] .78571 .02381 0 2 Msboxa [(1)] .97619 .02381 0 2 Msboxa [(x)] 1.025 .02381 -1 0 Msboxa [(0.2)] .01131 .21429 1 0 Msboxa [(0.4)] .01131 .40476 1 0 Msboxa [(0.6)] .01131 .59524 1 0 Msboxa [(0.8)] .01131 .78571 1 0 Msboxa [(1)] .01131 .97619 1 0 Msboxa [(y)] .02381 1 0 -4 Msboxa [ -0.001 -0.001 0 0 ] [ 1.001 1.001 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath [ ] 0 setdash 0 g p p .002 w .21429 .02381 m .21429 .03006 L s P [(0.2)] .21429 .02381 0 2 Mshowa p .002 w .40476 .02381 m .40476 .03006 L s P [(0.4)] .40476 .02381 0 2 Mshowa p .002 w .59524 .02381 m .59524 .03006 L s P [(0.6)] .59524 .02381 0 2 Mshowa p .002 w .78571 .02381 m .78571 .03006 L s P [(0.8)] .78571 .02381 0 2 Mshowa p .002 w .97619 .02381 m .97619 .03006 L s P [(1)] .97619 .02381 0 2 Mshowa p .001 w .0619 .02381 m .0619 .02756 L s P p .001 w .1 .02381 m .1 .02756 L s P p .001 w .1381 .02381 m .1381 .02756 L s P p .001 w .17619 .02381 m .17619 .02756 L s P p .001 w .25238 .02381 m .25238 .02756 L s P p .001 w .29048 .02381 m .29048 .02756 L s P p .001 w .32857 .02381 m .32857 .02756 L s P p .001 w .36667 .02381 m .36667 .02756 L s P p .001 w .44286 .02381 m .44286 .02756 L s P p .001 w .48095 .02381 m .48095 .02756 L s P p .001 w .51905 .02381 m .51905 .02756 L s P p .001 w .55714 .02381 m .55714 .02756 L s P p .001 w .63333 .02381 m .63333 .02756 L s P p .001 w .67143 .02381 m .67143 .02756 L s P p .001 w .70952 .02381 m .70952 .02756 L s P p .001 w .74762 .02381 m .74762 .02756 L s P p .001 w .82381 .02381 m .82381 .02756 L s P p .001 w .8619 .02381 m .8619 .02756 L s P p .001 w .9 .02381 m .9 .02756 L s P p .001 w .9381 .02381 m .9381 .02756 L s P [(x)] 1.025 .02381 -1 0 Mshowa p .002 w 0 .02381 m 1 .02381 L s P p .002 w .02381 .21429 m .03006 .21429 L s P [(0.2)] .01131 .21429 1 0 Mshowa p .002 w .02381 .40476 m .03006 .40476 L s P [(0.4)] .01131 .40476 1 0 Mshowa p .002 w .02381 .59524 m .03006 .59524 L s P [(0.6)] .01131 .59524 1 0 Mshowa p .002 w .02381 .78571 m .03006 .78571 L s P [(0.8)] .01131 .78571 1 0 Mshowa p .002 w .02381 .97619 m .03006 .97619 L s P [(1)] .01131 .97619 1 0 Mshowa p .001 w .02381 .0619 m .02756 .0619 L s P p .001 w .02381 .1 m .02756 .1 L s P p .001 w .02381 .1381 m .02756 .1381 L s P p .001 w .02381 .17619 m .02756 .17619 L s P p .001 w .02381 .25238 m .02756 .25238 L s P p .001 w .02381 .29048 m .02756 .29048 L s P p .001 w .02381 .32857 m .02756 .32857 L s P p .001 w .02381 .36667 m .02756 .36667 L s P p .001 w .02381 .44286 m .02756 .44286 L s P p .001 w .02381 .48095 m .02756 .48095 L s P p .001 w .02381 .51905 m .02756 .51905 L s P p .001 w .02381 .55714 m .02756 .55714 L s P p .001 w .02381 .63333 m .02756 .63333 L s P p .001 w .02381 .67143 m .02756 .67143 L s P p .001 w .02381 .70952 m .02756 .70952 L s P p .001 w .02381 .74762 m .02756 .74762 L s P p .001 w .02381 .82381 m .02756 .82381 L s P p .001 w .02381 .8619 m .02756 .8619 L s P p .001 w .02381 .9 m .02756 .9 L s P p .001 w .02381 .9381 m .02756 .9381 L s P [(y)] .02381 1 0 -4 Mshowa p .002 w .02381 0 m .02381 1 L s P P 0 0 m 1 0 L 1 1 L 0 1 L closepath clip newpath p p p 0 Mabswid .02381 .02381 m .06349 .06349 L .10317 .10317 L .14286 .14286 L .18254 .18254 L .22222 .22222 L .2619 .2619 L .30159 .30159 L .34127 .34127 L .38095 .38095 L .42063 .42063 L .46032 .46032 L .5 .5 L .53968 .53968 L .57937 .57937 L .61905 .61905 L .65873 .65873 L .69841 .69841 L .7381 .7381 L .77778 .77778 L .81746 .81746 L .85714 .85714 L .89683 .89683 L .93651 .93651 L .97619 .97619 L s P P p p 2 Mabswid .02381 .02381 m .04365 .16742 L .06349 .28862 L .10317 .47218 L .12302 .53852 L .14286 .59037 L .1627 .6295 L .17262 .64481 L .18254 .65755 L .19246 .66792 L .20238 .67609 L .20734 .67942 L .2123 .68226 L .22222 .68659 L .22718 .68811 L .22966 .68873 L .23214 .68925 L .23462 .68967 L .2371 .69 L .23834 .69013 L .23958 .69024 L .24082 .69033 L .24206 .6904 L .2433 .69045 L .24454 .69047 L .24578 .69048 L .24702 .69046 L .24826 .69043 L .2495 .69037 L .25198 .6902 L .25322 .69009 L .25446 .68996 L .25694 .68965 L .2619 .68881 L .26687 .68771 L .27183 .68636 L .28175 .683 L .30159 .67406 L .34127 .65064 L .38095 .62537 L .42063 .60354 L .44048 .59516 L .4504 .59176 L .46032 .58893 L .47024 .58671 L .48016 .5851 L .48512 .58454 L .4876 .58432 L .49008 .58413 L .49256 .58399 L Mistroke .4938 .58394 L .49504 .58389 L .49628 .58386 L .49752 .58383 L .49876 .58381 L .5 .58381 L .50124 .58381 L .50248 .58383 L .50372 .58386 L .50496 .58389 L .5062 .58394 L .50744 .58399 L .50992 .58413 L .5124 .58432 L .51488 .58454 L .51984 .5851 L .52976 .58671 L .53968 .58893 L .55952 .59516 L .57937 .60354 L .61905 .62537 L .65873 .65064 L .69841 .67406 L .70833 .67885 L .71825 .683 L .72817 .68636 L .73313 .68771 L .7381 .68881 L .74306 .68965 L .74554 .68996 L .74678 .69009 L .74802 .6902 L .74926 .6903 L .7505 .69037 L .75174 .69043 L .75298 .69046 L .75422 .69048 L .75546 .69047 L .7567 .69045 L .75794 .6904 L .75918 .69033 L .76042 .69024 L .7629 .69 L .76538 .68967 L .76786 .68925 L .77282 .68811 L .77778 .68659 L .7877 .68226 L .79266 .67942 L .79762 .67609 L Mistroke .81746 .65755 L .82738 .64481 L .8373 .6295 L .85714 .59037 L .87698 .53852 L .89683 .47218 L .93651 .28862 L .95635 .16742 L .97619 .02381 L Mfstroke P P p p 3 Mabswid .02381 .02381 m .04365 .18796 L .06349 .32507 L .08333 .43776 L .10317 .52852 L .12302 .59974 L .14286 .65369 L .1627 .69252 L .17262 .7069 L .18254 .71825 L .19246 .72682 L .19742 .73013 L .20238 .73282 L .20734 .73493 L .20982 .73577 L .2123 .73648 L .21478 .73706 L .21726 .7375 L .2185 .73768 L .21974 .73782 L .22098 .73793 L .22222 .73802 L .22346 .73807 L .2247 .73809 L .22594 .73809 L .22718 .73805 L .22842 .73799 L .22966 .7379 L .2309 .73778 L .23214 .73763 L .2371 .73679 L .23958 .73621 L .24206 .73553 L .25198 .7319 L .2619 .72693 L .28175 .71368 L .30159 .6971 L .34127 .65873 L .38095 .62021 L .42063 .58805 L .44048 .57587 L .4504 .57096 L .46032 .56689 L .47024 .56368 L .4752 .56242 L .48016 .56138 L .48512 .56057 L .4876 .56025 L .49008 .55999 L .49256 .55979 L Mistroke .4938 .55971 L .49504 .55964 L .49628 .55959 L .49752 .55955 L .49876 .55953 L .5 .55952 L .50124 .55953 L .50248 .55955 L .50372 .55959 L .50496 .55964 L .5062 .55971 L .50744 .55979 L .50992 .55999 L .5124 .56025 L .51488 .56057 L .51984 .56138 L .5248 .56242 L .52976 .56368 L .53968 .56689 L .55952 .57587 L .57937 .58805 L .61905 .62021 L .65873 .65873 L .69841 .6971 L .71825 .71368 L .72817 .7208 L .7381 .72693 L .74802 .7319 L .75298 .7339 L .75794 .73553 L .76042 .73621 L .7629 .73679 L .76538 .73726 L .76786 .73763 L .7691 .73778 L .77034 .7379 L .77158 .73799 L .77282 .73805 L .77406 .73809 L .7753 .73809 L .77654 .73807 L .77778 .73802 L .77902 .73793 L .78026 .73782 L .7815 .73768 L .78274 .7375 L .7877 .73648 L .79018 .73577 L .79266 .73493 L .79762 .73282 L Mistroke .80258 .73013 L .80754 .72682 L .81746 .71825 L .82738 .7069 L .8373 .69252 L .85714 .65369 L .87698 .59974 L .89683 .52852 L .91667 .43776 L .93651 .32507 L .97619 .02381 L Mfstroke P P p p 4 Mabswid .02381 .02381 m .04365 .20976 L .06349 .36347 L .08333 .4881 L .10317 .58668 L .12302 .66211 L .13294 .69201 L .14286 .71714 L .15278 .73783 L .1627 .75439 L .17262 .76711 L .17758 .77213 L .18254 .77631 L .1875 .77967 L .19246 .78226 L .19494 .78327 L .19742 .7841 L .1999 .78476 L .20114 .78502 L .20238 .78524 L .20362 .78542 L .20486 .78555 L .2061 .78565 L .20734 .7857 L .20858 .78571 L .20982 .78569 L .21106 .78562 L .2123 .78552 L .21478 .7852 L .21602 .78498 L .21726 .78473 L .22222 .78336 L .22718 .78145 L .23214 .77902 L .24206 .77273 L .2619 .75524 L .30159 .70661 L .34127 .64989 L .38095 .59524 L .42063 .55056 L .44048 .53381 L .4504 .52707 L .46032 .52149 L .47024 .51711 L .4752 .51538 L .48016 .51396 L .48512 .51286 L .4876 .51242 L .49008 .51206 L .49256 .51179 L Mistroke .4938 .51168 L .49504 .51159 L .49628 .51152 L .49752 .51147 L .49876 .51144 L .5 .51143 L .50124 .51144 L .50248 .51147 L .50372 .51152 L .50496 .51159 L .5062 .51168 L .50744 .51179 L .50992 .51206 L .5124 .51242 L .51488 .51286 L .51984 .51396 L .5248 .51538 L .52976 .51711 L .53968 .52149 L .55952 .53381 L .57937 .55056 L .61905 .59524 L .65873 .64989 L .69841 .70661 L .71825 .73266 L .7381 .75524 L .75794 .77273 L .7629 .7761 L .76786 .77902 L .77282 .78145 L .77778 .78336 L .78026 .78412 L .78274 .78473 L .78398 .78498 L .78522 .7852 L .78646 .78538 L .7877 .78552 L .78894 .78562 L .79018 .78569 L .79142 .78571 L .79266 .7857 L .7939 .78565 L .79514 .78555 L .79638 .78542 L .79762 .78524 L .8001 .78476 L .80258 .7841 L .80506 .78327 L .80754 .78226 L .8125 .77967 L Mistroke .81746 .77631 L .82738 .76711 L .8373 .75439 L .84722 .73783 L .85714 .71714 L .87698 .66211 L .89683 .58668 L .91667 .4881 L .93651 .36347 L .97619 .02381 L Mfstroke P P P % End of Graphics MathPictureEnd :[font = output; output; inactive; preserveAspect; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = subsubsection; inactive; preserveAspect; startGroup] 8) Determine formulas for the period-2 points of f(x) (i.e., the new fixed points of f^2(x) which are not fixed points of f(x).) :[font = input; preserveAspect] a = .; :[font = input; preserveAspect; startGroup] pps = Solve[h[a, x]==x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> 0}, {x -> -((1 - a)/a)}, {x -> (-((-1 - a)*a) - ((-1 - a)^2*a^2 - 4*a^2*(1 + a))^(1/2))/ (2*a^2)}, {x -> (-((-1 - a)*a) + ((-1 - a)^2*a^2 - 4*a^2*(1 + a))^(1/2))/ (2*a^2)}} ;[o] 1 - a {{x -> 0}, {x -> -(-----)}, a 2 2 2 -((-1 - a) a) - Sqrt[(-1 - a) a - 4 a (1 + a)] {x -> -------------------------------------------------}, 2 2 a 2 2 2 -((-1 - a) a) + Sqrt[(-1 - a) a - 4 a (1 + a)] {x -> -------------------------------------------------}} 2 2 a :[font = input; preserveAspect; startGroup] pp1 = Simplify[x /. pps[[3]]] pp2 = Simplify[x /. pps[[4]]] :[font = output; output; inactive; preserveAspect] (a + a^2 - (a^2*(-3 - 2*a + a^2))^(1/2))/(2*a^2) ;[o] 2 2 2 a + a - Sqrt[a (-3 - 2 a + a )] --------------------------------- 2 2 a :[font = output; output; inactive; preserveAspect; endGroup; endGroup] (a + a^2 + (a^2*(-3 - 2*a + a^2))^(1/2))/(2*a^2) ;[o] 2 2 2 a + a + Sqrt[a (-3 - 2 a + a )] --------------------------------- 2 2 a :[font = subsubsection; inactive; preserveAspect; startGroup] 9) Verify by example that periodic points xbar repel when |(f^2)'(xbar)| > 1 and attract when |(f^2)'(xbar)| < 1. :[font = text; inactive; preserveAspect; endGroup] We contrast the cases of a = 3.2 in which |(f^2)'(x)| < 1 and a = 3.5 in which |(f^2)'(x)| > 1. In the first, we see that f^2 has an attracting fixed point corresponding to an attracting period-2 orbit. In the second, we see that f^2 has a repelling fixed point (about which there is cycling) and the corresponding period-2 orbit is no longer attracting. The derivatives (which had to be the same) are given for the period-2 map at the period-2 points. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] a = 3.2 :[font = input; preserveAspect; startGroup] Simplify[D[h[a, x], x] /. x -> pp1] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 2*a - a^2 ;[o] 2 4 + 2 a - a :[font = text; inactive; preserveAspect] Enter the function to iterate, the seed, x0, and the number of iterates, n. :[font = input; preserveAspect] a = 3.2; g[x_] = a x ( 1 - x ); h[x_] = g[g[x]]; x0 = 0.01; n = 100; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagrams for both f(x) and f(f(x)) :[font = input; preserveAspect] pts1 = Table[0, {i, 1, 2n + 1}]; pts2 = Table[0, {i, 1, 2n + 1}]; x1 = x0; pts1[[1]] = {x0, g[x0]}; pts2[[1]] = {x1, h[x1]}; Do[x0 = g[x0]; x1 = h[x1]; pts1[[i]] = {x0, x0}; pts2[[i]] = {x1, x1}; pts1[[i + 1]] = {x0, g[x0]}; pts2[[i + 1]] = {x1, h[x1]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot1 = ListPlot[pts1, PlotJoined -> True, DisplayFunction -> Identity]; :[font = input; preserveAspect] iterateplot2 = ListPlot[pts2, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot1 = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = input; preserveAspect] mapplot2 = Plot[{x, h[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect; startGroup] Show[iterateplot1, mapplot1, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] Plot the Orbit Diagram for the 2nd Iterate Map. :[font = input; preserveAspect; startGroup] Show[iterateplot2, mapplot2, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] a = 3.5 :[font = text; inactive; preserveAspect] Enter the function to iterate, the seed, x0, and the number of iterates, n. :[font = input; preserveAspect] a = 3.5; g[x_] = a x ( 1 - x ); h[x_] = g[g[x]]; x0 = 0.7; n = 100; :[font = text; inactive; preserveAspect] Create a list of Points on the Orbit Diagrams for both f(x) and f(f(x)) :[font = input; preserveAspect] pts1 = Table[0, {i, 1, 2n + 1}]; pts2 = Table[0, {i, 1, 2n + 1}]; x1 = x0; pts1[[1]] = {x0, g[x0]}; pts2[[1]] = {x1, h[x1]}; Do[x0 = g[x0]; x1 = h[x1]; pts1[[i]] = {x0, x0}; pts2[[i]] = {x1, x1}; pts1[[i + 1]] = {x0, g[x0]}; pts2[[i + 1]] = {x1, h[x1]}, {i, 2, 2 n, 2}]; :[font = text; inactive; preserveAspect] Plot the Points :[font = input; preserveAspect] iterateplot1 = ListPlot[pts1, PlotJoined -> True, DisplayFunction -> Identity]; :[font = input; preserveAspect] iterateplot2 = ListPlot[pts2, PlotJoined -> True, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Map along with the Replacement Line :[font = input; preserveAspect] mapplot1 = Plot[{x, g[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = input; preserveAspect] mapplot2 = Plot[{x, h[x]}, {x, 0, 1}, PlotStyle -> {AbsoluteThickness[1], AbsoluteThickness[2]}, AspectRatio -> Automatic, PlotRange -> {0, 1}, DisplayFunction -> Identity]; :[font = text; inactive; preserveAspect] Plot the Orbit Diagram :[font = input; preserveAspect; startGroup] Show[iterateplot1, mapplot1, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] Plot the Orbit Diagram for the 2nd Iterate Map. :[font = input; preserveAspect; startGroup] Show[iterateplot2, mapplot2, AspectRatio -> Automatic, PlotRange -> {{0, 1}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 10) Find the a-value(s) for which the period-2 points switch(s) from attracting to repelling. :[font = text; inactive; preserveAspect] In the solution to number 9, we saw clearly that a bifurcation occurred between a = 3.2 and a = 3.5. To find the bifurcation a-value, we must find out precisely when (f^2)'(xbar) = 1 where xbar is one of the periodic points (of period 2.) :[font = text; inactive; preserveAspect] Below we determine the slope of the period-2 map, f(f(x)) and where it crosses through 1 and -1. :[font = input; preserveAspect] ClearAll[f, g, x, a] :[font = input; preserveAspect] f[x_] = a x (1 - x); g[x_] = f[f[x]]; :[font = input; preserveAspect; startGroup] derf21 = Simplify[g'[x] /. x -> pp1] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 2*a - a^2 ;[o] 2 4 + 2 a - a :[font = input; preserveAspect; startGroup] derf22 = Simplify[g'[x] /. x -> pp2] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 2*a - a^2 ;[o] 2 4 + 2 a - a :[font = input; preserveAspect; startGroup] Plot[{1, -1, derf21}, {a, 0, 4}, PlotRange -> All, AxesLabel -> {"a", "slope of f(f(x)) at the period-2 points"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] bifvals1 = Solve[derf21 == 1, a] :[font = output; output; inactive; preserveAspect; endGroup] {{a -> -1}, {a -> 3}} ;[o] {{a -> -1}, {a -> 3}} :[font = input; preserveAspect; startGroup] bifvals2 = Solve[derf21 == -1, a] :[font = output; output; inactive; preserveAspect; endGroup] {{a -> (2 - 2*6^(1/2))/2}, {a -> (2 + 2*6^(1/2))/2}} ;[o] 2 - 2 Sqrt[6] 2 + 2 Sqrt[6] {{a -> -------------}, {a -> -------------}} 2 2 :[font = text; inactive; preserveAspect] Since we know the desired bifurcation value lies between 3.2 and 3.5, our only choice among the previous four choices is :[font = input; preserveAspect; startGroup] bifvalue = a /. bifvals2[[2]] :[font = output; output; inactive; preserveAspect; endGroup] (2 + 2*6^(1/2))/2 ;[o] 2 + 2 Sqrt[6] ------------- 2 :[font = input; preserveAspect; startGroup] Print["The bifurcation value is ", N[bifvalue]] :[font = print; inactive; preserveAspect; endGroup] The bifurcation value is 3.44949 :[font = input; preserveAspect; startGroup] Plot[{x, f[x] /. a -> bifvalue}, {x, 0, 1}, AxesLabel -> {"x", "f(x)"}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Plot[{x, g[x] /. a -> bifvalue}, {x, 0, 1}, AxesLabel -> {"x", "f(f(x))"}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Plot[{x, f[f[f[x]]] /. a -> bifvalue}, {x, 0, 1}, AxesLabel -> {"x", "f(f(f(x)))"}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Plot[{x, g[g[x]] /. a -> bifvalue}, {x, 0, 1}, AxesLabel -> {"x", "f(f(f(f(x))))"}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Note that we appear to be about to pick up a period 4 orbit, but that there is certainly is no period 3 orbit about to form. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 11) Let a = 3.55 and plot f^3(x), f^4(x), f^5(x), f^6(x), f^7(x), f^8(x) along with the replacement line y = x. List how many periodic points f(x) has of every period less than or equal to 8. Do you think that f(x) has any higher periodic orbits (when a = 3.55?) Why or why not? :[font = input; preserveAspect] ClearAll[a, f, g, h] :[font = input; preserveAspect] a = 3.55; f[x_] = a x ( 1 - x ); g[x_] = f[f[x]]; h[x_] = g[g[x]]; i[x_] = h[h[x]]; :[font = input; preserveAspect; startGroup] Plot[{x, f[x], g[x], g[f[x]], h[x]}, {x, 0, 1}, AspectRatio -> Automatic, PlotStyle -> {AbsoluteThickness[0], AbsoluteThickness[4], AbsoluteThickness[3], AbsoluteThickness[2], AbsoluteThickness[1]}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Plot[{x, h[f[x]], h[g[x]], h[g[f[x]]], i[x]}, {x, 0, 1}, AspectRatio -> Automatic, PlotStyle -> {AbsoluteThickness[0], AbsoluteThickness[4], AbsoluteThickness[3], AbsoluteThickness[2], AbsoluteThickness[1]}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Plot[{x, i[x]}, {x, 0.34, 0.38}, PlotRange -> {0.34, 0.38}, AspectRatio -> Automatic, PlotStyle -> {AbsoluteThickness[0], AbsoluteThickness[2]}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup; endGroup] If there is a period-8 orbit, then the graph above should show three crossings -- the middle fixed point corresponding to a period-4 point and the other two corresponding to period-8 points. We further note that the slope of the period-8 map is less than one at the period-8 points, so we conjecture that there are no more doubled periods since the period-8 orbit is attracting. So, there are 8 period-8 points (one period-8 orbit) which is attracting, 4 period-4 points (one period-4 orbit) which is repelling, 2 period-2 points (one period-2 orbit) which is repelling, and 2 fixed points which are repelling as well. There are no periodic points of any other period. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Part II. A study of the quadratic map Q(x) = x^2 + b. :[font = subsubsection; inactive; preserveAspect; startGroup] 1) Compute the fixed points of Q(x). :[font = input; preserveAspect] Q[x_] = x^2 + b; :[font = input; preserveAspect; startGroup] Solve[Q[x] == x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (1 - (1 - 4*b)^(1/2))/2}, {x -> (1 + (1 - 4*b)^(1/2))/2}} ;[o] 1 - Sqrt[1 - 4 b] 1 + Sqrt[1 - 4 b] {{x -> -----------------}, {x -> -----------------}} 2 2 :[font = input; preserveAspect; startGroup] fp1 = x /. %[[1]] :[font = output; output; inactive; preserveAspect; endGroup] (1 - (1 - 4*b)^(1/2))/2 ;[o] 1 - Sqrt[1 - 4 b] ----------------- 2 :[font = input; preserveAspect; startGroup] fp2 = x /. %%[[2]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] (1 + (1 - 4*b)^(1/2))/2 ;[o] 1 + Sqrt[1 - 4 b] ----------------- 2 :[font = subsubsection; inactive; preserveAspect; startGroup] 2) Compute the slope of Q(x) at each fixed point. :[font = input; preserveAspect; startGroup] s1 = Q'[fp1] :[font = output; output; inactive; preserveAspect; endGroup] 1 - (1 - 4*b)^(1/2) ;[o] 1 - Sqrt[1 - 4 b] :[font = input; preserveAspect; startGroup] s2 = Q'[fp2] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] 1 + (1 - 4*b)^(1/2) ;[o] 1 + Sqrt[1 - 4 b] :[font = subsubsection; inactive; preserveAspect; startGroup] 3) Verify that for all -2 <= b <= 1/4, if |x0| > (1 + Sqrt[1 - 4 b])/2 then the orbit of x0 will diverge to positive infinity. :[font = text; inactive; preserveAspect; endGroup] Since Q is an even function, Q(-x) = Q(x). So, any negative input has the same dynamics as the corresponding positive input. Thus, it suffices to consider the orbits corresponding to x0 > (1 + Sqrt[1 - 4 b])/2. Noting that Q'(x) > 1 for all x > fp2, we must have Q(x) > x for all x > fp2. Thus, the orbits diverge to positive infinity. :[font = subsubsection; inactive; preserveAspect; startGroup] 4) A bifurcation occurs at b = 1/4. Describe the dynamics of ALL orbits (consider all real numbers x0) for b close to and on both sides of 1/4. :[font = text; inactive; preserveAspect; endGroup] b > 1/4, all points diverge to positive infinity. b = 1/4, if |x0| > 1/2 then diverge to infinity otherwise attracted to the fixed point 1/2 (x0=1/2 is already fixed, and x0=-1/2 is "eventually fixed" after 1 iteration.) b < 1/4, if |x0| > (1 + Sqrt[1 - 4 b])/2 then diverge to infinity if x0 is a fixed point, then the orbit is fixed if x0 is between the fixed points |x0| < (1 + Sqrt[1 - 4 b])/2 the orbit is attracted to fp1. :[font = subsubsection; inactive; preserveAspect; startGroup] 5) Let p+ > p- be the two fixed points which exist for all b < 1/4. Find the b-values (for b < 1/4) where each fixed point switches stability (if any.) :[font = text; inactive; preserveAspect] The fixed point p+ = fp2 doesn't change stability since the slope s2 > 1 for all b < 1/4. However, we see that the fixed point p- = fp1 switches stability when :[font = input; preserveAspect; startGroup] Solve[s1 == -1, b] :[font = output; output; inactive; preserveAspect; endGroup] {{b -> -3/4}} ;[o] 3 {{b -> -(-)}} 4 :[font = input; preserveAspect; startGroup] b2 = b /. %[[1]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] -3/4 ;[o] 3 -(-) 4 :[font = subsubsection; inactive; preserveAspect; startGroup] 6) Graph Q^2(x) = Q(Q(x)) along with x for various values of b between -2 and 1/4. Can you tell for what b-value two period-2 points of Q(x) emerge? :[font = input; preserveAspect; startGroup] q2[x_] = Q[Q[x]] :[font = output; output; inactive; preserveAspect; endGroup] b + (b + x^2)^2 ;[o] 2 2 b + (b + x ) :[font = input; preserveAspect] q21 = q2[x] /. b -> 1/4; q22 = q2[x] /. b -> 0; q23 = q2[x] /. b -> -3/4; q24 = q2[x] /. b -> -3/2; q25 = q2[x] /. b -> -2; :[font = input; preserveAspect; startGroup] Plot[{q21, q22, q23, q24, q25, x}, {x, -2, 2}, AspectRatio -> Automatic, PlotRange -> {-2, 2}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Period-2 points appear to emerge as b decreases through b = -3/4. :[font = subsubsection; inactive; preserveAspect; startGroup] 7) Determine formulas for the period-2 points of Q(x) (i.e., the new fixed points of Q^2(x) which are not fixed points of Q(x).) :[font = input; preserveAspect; startGroup] per2 = Solve[q2[x]==x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (1 - (1 - 4*b)^(1/2))/2}, {x -> (1 + (1 - 4*b)^(1/2))/2}, {x -> (-1 - (1 - 4*(1 + b))^(1/2))/2}, {x -> (-1 + (1 - 4*(1 + b))^(1/2))/2}} ;[o] 1 - Sqrt[1 - 4 b] 1 + Sqrt[1 - 4 b] {{x -> -----------------}, {x -> -----------------}, 2 2 -1 - Sqrt[1 - 4 (1 + b)] -1 + Sqrt[1 - 4 (1 + b)] {x -> ------------------------}, {x -> ------------------------}} 2 2 :[font = input; preserveAspect; startGroup] p21 = x /. per2[[3]] p22 = x /. per2[[4]] :[font = output; output; inactive; preserveAspect] (-1 - (1 - 4*(1 + b))^(1/2))/2 ;[o] -1 - Sqrt[1 - 4 (1 + b)] ------------------------ 2 :[font = output; output; inactive; preserveAspect; endGroup; endGroup] (-1 + (1 - 4*(1 + b))^(1/2))/2 ;[o] -1 + Sqrt[1 - 4 (1 + b)] ------------------------ 2 :[font = subsubsection; inactive; preserveAspect; startGroup] 8) Find the b-value(s) for which the period-2 points switch(s) from attracting to repelling. :[font = text; inactive; preserveAspect] Let's first note that both points have the same stability property. :[font = input; preserveAspect; startGroup] slope = Simplify[q2'[p21]] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 4*b ;[o] 4 + 4 b :[font = input; preserveAspect; startGroup] Simplify[q2'[p22]] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 4*b ;[o] 4 + 4 b :[font = text; inactive; preserveAspect] Now, we want to know when the slope goes through 1 in magnitude. It's clear from the graphs in number 6 that we are particularly interested in when the slope is negative 1. :[font = input; preserveAspect; startGroup] per4 = Solve[slope == -1, b] :[font = output; output; inactive; preserveAspect; endGroup] {{b -> -5/4}} ;[o] 5 {{b -> -(-)}} 4 :[font = input; preserveAspect; startGroup] b4 = b /. per4[[1]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] -5/4 ;[o] 5 -(-) 4 :[font = subsubsection; inactive; preserveAspect; startGroup] 9) Let b=-1.3 and plot Q(x), Q^2(x), Q^3(x), and Q^4(x) along with the replacement line y = x. List how many periodic points Q(x) has of every period less than or equal to 4. Do you think that Q(x) has any higher periodic orbits (when b = -1.3?) Why or why not? :[font = input; preserveAspect; startGroup] b = -1.3; Plot[{Q[x], q2[x], q2[Q[x]], q2[q2[x]], x}, {x, -2, 2}, AspectRatio -> Automatic, PlotRange -> {-2, 2}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup; endGroup] The period-4 map does appear to have unique fixed points which cross the replacement line with a slope of less than one in magnitude. Thus, there must be 4 attracting period-4 points (all on the same orbit), 2 repelling period-2 points (on the same orbit), and two repelling fixed points. There are no periodic points of any other period. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Part III. A study of the Feigenbaum diagrams for the logistic family. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 1) a) Determine the period-2 bifurcation value for the logistic map, call this a2. b) Determine the period-4 bifurcation value for the logistic map, call this a4. :[font = text; inactive; preserveAspect] Note that a period doubling bifurcation occurs when the slope of the map goes through -1. :[font = input; preserveAspect] ClearAll[f, x, a]; :[font = input; preserveAspect] f[x_] = a x ( 1 - x ); :[font = input; preserveAspect; startGroup] fps = Solve[f[x]==x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> 0}, {x -> (-1 + a)/a}} ;[o] -1 + a {{x -> 0}, {x -> ------}} a :[font = input; preserveAspect; startGroup] fp2 = x /. fps[[2]] :[font = output; output; inactive; preserveAspect; endGroup] (-1 + a)/a ;[o] -1 + a ------ a :[font = input; preserveAspect; startGroup] a2 = a /. Solve[f'[fp2] == -1, a][[1, 1]] :[font = output; output; inactive; preserveAspect; endGroup] 3 ;[o] 3 :[font = input; preserveAspect; startGroup] per2points = Solve[f[f[x]]==x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> 0}, {x -> -((1 - a)/a)}, {x -> (-((-1 - a)*a) - ((-1 - a)^2*a^2 - 4*a^2*(1 + a))^(1/2))/ (2*a^2)}, {x -> (-((-1 - a)*a) + ((-1 - a)^2*a^2 - 4*a^2*(1 + a))^(1/2))/ (2*a^2)}} ;[o] 1 - a {{x -> 0}, {x -> -(-----)}, a 2 2 2 -((-1 - a) a) - Sqrt[(-1 - a) a - 4 a (1 + a)] {x -> -------------------------------------------------}, 2 2 a 2 2 2 -((-1 - a) a) + Sqrt[(-1 - a) a - 4 a (1 + a)] {x -> -------------------------------------------------}} 2 2 a :[font = input; preserveAspect; startGroup] pp21 = Simplify[x /. per2points[[3]]] pp22 = Simplify[x /. per2points[[4]]] :[font = output; output; inactive; preserveAspect] (a + a^2 - (a^2*(-3 - 2*a + a^2))^(1/2))/(2*a^2) ;[o] 2 2 2 a + a - Sqrt[a (-3 - 2 a + a )] --------------------------------- 2 2 a :[font = output; output; inactive; preserveAspect; endGroup] (a + a^2 + (a^2*(-3 - 2*a + a^2))^(1/2))/(2*a^2) ;[o] 2 2 2 a + a + Sqrt[a (-3 - 2 a + a )] --------------------------------- 2 2 a :[font = input; preserveAspect; startGroup] derf2atpp = Simplify[D[f[f[x]], x] /. x -> pp21] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 2*a - a^2 ;[o] 2 4 + 2 a - a :[font = input; preserveAspect; startGroup] a4 = a /. Solve[derf2atpp == -1, a][[2, 1]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] (2 + 2*6^(1/2))/2 ;[o] 2 + 2 Sqrt[6] ------------- 2 :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 2) The curves that you see in the bifurcation diagram are the attracting fixed and periodic points as a function of the parameter. a) Find and graph the curve of fixed points for a in [0, 1]. b) Find and graph the curve of fixed points for a in [1, a2]. c) Find and graph the curves of period-2 points for a in [a2, a4]. d) Display the graphs of (a) -- (c) together on [0, a4] and compare them to the Feigenbaum diagram graphed on [0, a4]. :[font = input; preserveAspect; startGroup] p1 = Plot[0, {a, 0, 1}, PlotRange -> {0, 1}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p2 = Plot[fp2, {a, 1, a2}, PlotRange -> {0, 1}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p3 = Plot[{pp21, pp22}, {a, a2, a4}, PlotRange -> {0, 1}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Show[p1, p2, p3, PlotRange -> {0, 1}] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = subsubsection; inactive; preserveAspect; startGroup] 3) By using the bifurcation diagram for the logistic map, estimate the value for the period-8 bifurcation point. Try to find the next period doubling bifurcation value after that! :[font = text; inactive; preserveAspect; endGroup] Period 8 appears to be around a8 = 3.545, period-16 is about a16 = 3.565. :[font = subsubsection; inactive; preserveAspect; startGroup] 4) Suppose a point in an orbit hits very VERY close to a repelling fixed point. It will be repelled, but it may take many iterations before it can escape from that fixed point. Explain, in light of this fact, what causes the dark bands running through the Feigenbaum diagram. :[font = text; inactive; preserveAspect; endGroup] When very close to a fixed point, f(x) is approximately x meaning that the output is close to the input. So, it takes a while to be repelled. Since iterates close to fixed points remain nearby for a while, the dark bands in the Feigenbaum diagram must represent points very close to repelling periodic and fixed points. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 5) The curves that you graphed in problem 2 correspond to attracting fixed and periodic points. While they are not attracting outside of the intervals graphed in the problem, the fixed and periodic points don't just disappear. Graph all of the fixed, period-2, and period-4 points of the logistic map for a in [0, 4]. Compare this graph to the Feigenbaum diagram for the logistic map on [0, 4]. :[font = text; inactive; preserveAspect] For contrast, we graph the attracting fixed and periodic points below. This looks just like the Feigenbaum diagram. :[font = input; preserveAspect; startGroup] Show[p1, p2, p3, AspectRatio -> Automatic, PlotRange -> {{0, 4}, {0, 1}}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p1 = Plot[0, {a, 0, 4}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}, PlotRange -> {{0, 4}, {0, 1}}, DisplayFunction -> Identity]; p2 = Plot[fp2, {a, 1, 4}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}, PlotRange -> {{0, 4}, {0, 1}}, DisplayFunction -> Identity]; p3 = Plot[{pp1, pp2}, {a, 3, 4}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}, PlotRange -> {{0, 4}, {0, 1}}, DisplayFunction -> Identity]; Show[p1, p2, p3, AspectRatio -> Automatic, PlotRange -> {{0, 4}, {0, 1}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Of course, the requested graph agrees with the Feigenbaum diagram wherever the fixed points are stable. The point of this exercise is to remind ourselves that the fixed and periodic points don't disappear upon bifurcations, but rather switch their stability characteristics. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 6) While the formulas for the periodic points of the logistic map may be quite messy, you should be able to tell that the the curves are well defined for arbitrarily large values of a. In particular, while they are not attracting outside of the intervals graphed in problem 2, the fixed and periodic points still remain for a > 4. Verify this by plotting the curves from the last problem on the interval [0, 5]. :[font = input; preserveAspect; startGroup] p1 = Plot[0, {a, 0, 5}, PlotRange -> {0, 1}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p2 = Plot[fp2, {a, 1, 5}, PlotRange -> {0, 1}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p3 = Plot[{pp21, pp22}, {a, a2, 5}, PlotRange -> {0, 1}, AspectRatio -> Automatic, AxesLabel -> {"a", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Show[p1, p2, p3, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Remark: This problem is really no different than the last except that usually students are warned not to produce Feigenbaum diagrams beyond a = 4. :[font = subsubsection; inactive; preserveAspect; startGroup] 7) In light of the result in the last problem, any guesses as to why the Feigenbaum diagram cannot be plotted for a > 4? (You should verify that indeed the Feigenbaum diagram appears empty for all a > 4.) :[font = text; inactive; preserveAspect; endGroup; endGroup] While there are infinitely many repelling fixed points, most (an uncountable set of points of measure 0 remains!) of the other points diverge. So, even if you are lucky enough to choose a periodic point when a > 4, error in floating point calculations will ultimately take you off into a diverging orbit. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Part IV. A study of the Feigenbaum diagrams for the quadratic family. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 1) Write a program that draws a Feigenbaum diagram for the quadratic family Q(x) = x^2 + b. Draw the diagram for -2 <= b <= 1/4 and -2 <= x <= 2. :[font = text; inactive; preserveAspect] Remark: The program should really be written in a more efficient language such as C or PASCAL. However, for sake of completeness and continuity, we provide a solution in Mathematica below. Students who wish to do all of their work in Mathematica can mimic the code found in the section on Feigenbaum Diagrams preceding the problems. ;[s] 5:0,0;172,1;183,2;237,3;248,4;335,-1; 5:1,11,8,Times,0,12,0,0,0;1,10,8,Times,2,12,0,0,0;1,11,8,Times,0,12,0,0,0;1,10,8,Times,2,12,0,0,0;1,11,8,Times,0,12,0,0,0; :[font = input; preserveAspect] LogistQuad[min_Real, max_Real, k_Integer, n_Integer, m_Integer] := Module[{f, a, astep, i, j, x, seed}, seed = 0.223; f = Compile[{x, a}, Evaluate[x x + a]]; astep = (max - min)/m; Partition[ Flatten[ Table[ a = min + j astep; Table[{a, Fold[f, seed, Table[a, {k+i}]]}, {i, 1, n} ], {j, 0, m} ] ], 2 ] ] :[font = text; inactive; preserveAspect] Below is a graph of the Feigenbaum diagram for the quadratic map. :[font = input; preserveAspect; startGroup] ListPlot[LogistQuad[-2., 0.25, 15, 32, 200], AxesLabel -> {"b", "x"}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 2) a) Determine the period-2 bifurcation value for the quadratic map, call this b2. b) Determine the period-4 bifurcation value for the quadratic map, call this b4. :[font = text; inactive; preserveAspect] Note that a period doubling bifurcation occurs when the slope of the map goes through -1. :[font = input; preserveAspect] ClearAll[f, x, b]; :[font = input; preserveAspect] f[x_] = x^2 + b; :[font = input; preserveAspect; startGroup] fps = Solve[f[x]==x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (1 - (1 - 4*b)^(1/2))/2}, {x -> (1 + (1 - 4*b)^(1/2))/2}} ;[o] 1 - Sqrt[1 - 4 b] 1 + Sqrt[1 - 4 b] {{x -> -----------------}, {x -> -----------------}} 2 2 :[font = text; inactive; preserveAspect] Here are the fixed points, fp1 and fp2. :[font = input; preserveAspect; startGroup] fp1 = x /. fps[[1]] :[font = output; output; inactive; preserveAspect; endGroup] (1 - (1 - 4*b)^(1/2))/2 ;[o] 1 - Sqrt[1 - 4 b] ----------------- 2 :[font = input; preserveAspect; startGroup] fp2 = x /. fps[[2]] :[font = output; output; inactive; preserveAspect; endGroup] (1 + (1 - 4*b)^(1/2))/2 ;[o] 1 + Sqrt[1 - 4 b] ----------------- 2 :[font = input; preserveAspect; startGroup] Solve[f'[fp1] == -1, b] :[font = output; output; inactive; preserveAspect; endGroup] {{b -> -3/4}} ;[o] 3 {{b -> -(-)}} 4 :[font = input; preserveAspect; startGroup] b2 = b /. %[[1, 1]] :[font = output; output; inactive; preserveAspect; endGroup] -3/4 ;[o] 3 -(-) 4 :[font = input; preserveAspect; startGroup] per2points = Solve[f[f[x]]==x, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (1 - (1 - 4*b)^(1/2))/2}, {x -> (1 + (1 - 4*b)^(1/2))/2}, {x -> (-1 - (1 - 4*(1 + b))^(1/2))/2}, {x -> (-1 + (1 - 4*(1 + b))^(1/2))/2}} ;[o] 1 - Sqrt[1 - 4 b] 1 + Sqrt[1 - 4 b] {{x -> -----------------}, {x -> -----------------}, 2 2 -1 - Sqrt[1 - 4 (1 + b)] -1 + Sqrt[1 - 4 (1 + b)] {x -> ------------------------}, {x -> ------------------------}} 2 2 :[font = input; preserveAspect; startGroup] pp21 = Simplify[x /. per2points[[3]]] pp22 = Simplify[x /. per2points[[4]]] :[font = output; output; inactive; preserveAspect] (-1 - (-3 - 4*b)^(1/2))/2 ;[o] -1 - Sqrt[-3 - 4 b] ------------------- 2 :[font = output; output; inactive; preserveAspect; endGroup] (-1 + (-3 - 4*b)^(1/2))/2 ;[o] -1 + Sqrt[-3 - 4 b] ------------------- 2 :[font = input; preserveAspect; startGroup] derf2atpp = Simplify[D[f[f[x]], x] /. x -> pp21] :[font = output; output; inactive; preserveAspect; endGroup] 4 + 4*b ;[o] 4 + 4 b :[font = input; preserveAspect; startGroup] Solve[derf2atpp == -1, b] :[font = output; output; inactive; preserveAspect; endGroup] {{b -> -5/4}} ;[o] 5 {{b -> -(-)}} 4 :[font = input; preserveAspect; startGroup] b4 = b /. %[[1, 1]] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] -5/4 ;[o] 5 -(-) 4 :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 3) The curves that you see in the bifurcation diagram are the attracting fixed and periodic points as a function of the parameter. a) Find and graph the curve of fixed points for b in [b2, 1/4]. b) Find and graph the curves of period-2 points for a in [b4, b2]. c) Display the graphs of (a) and (b) together on [b4, 1/4] and compare them to the Feigenbaum diagram graphed on [b4, 1/4]. :[font = input; preserveAspect; startGroup] p1 = Plot[fp1, {b, b2, 1/4}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p2 = Plot[fp2, {b, b2, 1/4}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p3 = Plot[{pp21, pp22}, {b, b4, b2}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] Show[p1, p2, p3, PlotRange -> {-2, 2}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Except for the top branch of the curve of fixed points, this looks like the beginning of the Feigenbaum diagram for the quadratic map. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4) The curves that you graphed in problem 3 correspond to attracting fixed and periodic points. While they are not attracting outside of the intervals graphed in the problem, the fixed and periodic points don't just disappear. Graph all of the fixed and period-2 points of the quadratic map for b in [-2, 1/4]. Compare this graph to the Feigenbaum diagram for the quadratic map on [-2, 1/4]. :[font = text; inactive; preserveAspect] For contrast, we graph the attracting fixed and periodic points below. This looks just like the Feigenbaum diagram. :[font = input; preserveAspect; startGroup] Show[p1, p3, AspectRatio -> Automatic, PlotRange -> {{-2, 1/4}, {-2, 2}}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] p1 = Plot[{fp1, fp2}, {b, -2, 1/4}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}, PlotRange -> {{-2, 1/4}, {-2, 2}}, DisplayFunction -> Identity]; p2 = Plot[{pp21, pp22}, {b, -2, b2}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}, PlotRange -> {{-2, 1/4}, {-2, 2}}, DisplayFunction -> Identity]; Show[p1, p2, AspectRatio -> Automatic, PlotRange -> {{-2, 1/4}, {-2, 2}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Of course, the requested graph agrees with the Feigenbaum diagram wherever the fixed points are stable. The point of this exercise is to remind ourselves that the fixed and periodic points don't disappear upon bifurcations, but rather switch their stability characteristics. :[font = subsubsection; inactive; preserveAspect; startGroup] 5) While the formulas for the periodic points of the quadratic map may be quite messy, you should be able to tell that the the curves are well defined for arbitrarily large values of b. In particular, while they are not attracting outside of the intervals graphed in problem 3, the fixed and periodic points still remain for b < -2. Verify this by plotting the curves from the last problem on the interval [-3, 1/4]. :[font = input; preserveAspect; startGroup] p1 = Plot[{fp1, fp2}, {b, -3, 1/4}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}, PlotRange -> {{-3, 1/4}, {-2, 3}}, DisplayFunction -> Identity]; p2 = Plot[{pp21, pp22}, {b, -3, b2}, AspectRatio -> Automatic, AxesLabel -> {"b", "x"}, PlotRange -> {{-3, 1/4}, {-2, 3}}, DisplayFunction -> Identity]; Show[p1, p2, AspectRatio -> Automatic, PlotRange -> {{-3, 1/4}, {-2, 3}}, DisplayFunction -> $DisplayFunction] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] Remark: This problem is really no different than the last except that usually students are warned not to produce Feigenbaum diagrams beyond b = -2. :[font = subsubsection; inactive; preserveAspect; startGroup] 6) In light of the result in number 5, any guesses as to why the Feigenbaum diagram cannot be plotted for b < -2? (You should verify that indeed the Feigenbaum diagram appears empty for all b < -2.) :[font = text; inactive; preserveAspect; endGroup; endGroup] While there are infinitely many repelling fixed points, most (an uncountable set of points of measure 0 remains!) of the other points diverge. So, even if you are lucky enough to choose a periodic point when b < -2, error in floating point calculations will ultimately take you off into a diverging orbit. :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Part V. Divergence Diagrams (extensions of Feigenbaum diagrams.) :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 1) Find the equations of the boundary curves for the largest region in which orbits diverge after one iteration. Plot the curves and compare with the divergence diagram. :[font = text; inactive; preserveAspect] Iterates of a seed, 0 < x0 < 1 diverge in a single iteration if f(x0) > 1 and do not diverge within a single iteration if f(x0) < 1. So, the boundary curve satisfies f(x) = 1. :[font = input; preserveAspect] Clear[a, x, f]; :[font = input; preserveAspect] f[x_] = a x (1 - x); :[font = input; preserveAspect; startGroup] curves = Solve[f[x] == 1, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (a - (-4*a + a^2)^(1/2))/(2*a)}, {x -> (a + (-4*a + a^2)^(1/2))/(2*a)}} ;[o] 2 2 a - Sqrt[-4 a + a ] a + Sqrt[-4 a + a ] {{x -> -------------------}, {x -> -------------------}} 2 a 2 a :[font = input; preserveAspect; startGroup] TopCurve = x /. curves[[2, 1]] :[font = output; output; inactive; preserveAspect; endGroup] (a + (-4*a + a^2)^(1/2))/(2*a) ;[o] 2 a + Sqrt[-4 a + a ] ------------------- 2 a :[font = input; preserveAspect; startGroup] BotCurve = x /. curves[[1, 1]] :[font = output; output; inactive; preserveAspect; endGroup] (a - (-4*a + a^2)^(1/2))/(2*a) ;[o] 2 a - Sqrt[-4 a + a ] ------------------- 2 a :[font = input; preserveAspect; startGroup] p1 = Plot[{TopCurve, BotCurve}, {a, 4, 5}, AxesLabel -> {"a", "x"}, PlotRange -> {0, 1}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] As expected, the curve matches beautifully with the divergence diagram shown in the background materials preceding the problem set. :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 2) Find the equations of the boundary curves for the two regions in which orbits diverge after two iterations. Plot these curves along with the curves found in the first problem and compare to the divergence diagram. :[font = text; inactive; preserveAspect] Continuing from number 1, we now seek the curves where f(f(x)) = 1. :[font = input; preserveAspect; startGroup] curves = Solve[f[f[x]] == 1, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (2*a^3 - (4*a^6 - 8*a^3*(a^2 - (-4*a^3 + a^4)^(1/2)))^ (1/2))/(4*a^3)}, {x -> (2*a^3 + (4*a^6 - 8*a^3*(a^2 - (-4*a^3 + a^4)^(1/2)))^(1/2))/ (4*a^3)}, {x -> (2*a^3 - (4*a^6 - 8*a^3*(a^2 + (-4*a^3 + a^4)^(1/2)))^(1/2))/ (4*a^3)}, {x -> (2*a^3 + (4*a^6 - 8*a^3*(a^2 + (-4*a^3 + a^4)^(1/2)))^(1/2))/ (4*a^3)}} ;[o] 3 6 3 2 3 4 2 a - Sqrt[4 a - 8 a (a - Sqrt[-4 a + a ])] {{x -> ------------------------------------------------}, 3 4 a 3 6 3 2 3 4 2 a + Sqrt[4 a - 8 a (a - Sqrt[-4 a + a ])] {x -> ------------------------------------------------}, 3 4 a 3 6 3 2 3 4 2 a - Sqrt[4 a - 8 a (a + Sqrt[-4 a + a ])] {x -> ------------------------------------------------}, 3 4 a 3 6 3 2 3 4 2 a + Sqrt[4 a - 8 a (a + Sqrt[-4 a + a ])] {x -> ------------------------------------------------}} 3 4 a :[font = input; preserveAspect] Curve21 = x /. curves[[1, 1]]; Curve22 = x /. curves[[2, 1]]; Curve23 = x /. curves[[3, 1]]; Curve24 = x /. curves[[4, 1]]; :[font = text; inactive; preserveAspect] Below is a graph of the boundary curves for the regions in which seeds diverge in two iterations. :[font = input; preserveAspect; startGroup] p2 = Plot[{Curve21, Curve22, Curve23, Curve24}, {a, 4, 5}, AxesLabel -> {"a", "x"}, PlotRange -> {0, 1}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] And below, we combine the graphs from the first two problems. :[font = input; preserveAspect; startGroup] Show[p1, p2] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] We can see the divergence diagram forming before our eyes! :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 3) Find the equations of the boundary curves for the four regions in which orbits diverge after three iterations. Plot these curves along with the curves found in the first two problems and compare to the divergence diagram. :[font = text; inactive; preserveAspect] Continuing again from number 2, we now seek the curves where f(f(f(x))) = 1. :[font = input; preserveAspect; startGroup] curves = Solve[f[f[f[x]]] == 1, x] :[font = output; output; inactive; preserveAspect; endGroup] {{x -> (2*a^6 - (4*a^12 - 8*a^6* (a^5 - (-2*a^9 + a^10 - 2*a^6*(-4*a^5 + a^6)^(1/2))^ (1/2)))^(1/2))/(4*a^6)}, {x -> (2*a^6 + (4*a^12 - 8*a^6*(a^5 - (-2*a^9 + a^10 - 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} , {x -> (2*a^6 - (4*a^12 - 8*a^6*(a^5 + (-2*a^9 + a^10 - 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} , {x -> (2*a^6 + (4*a^12 - 8*a^6*(a^5 + (-2*a^9 + a^10 - 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} , {x -> (2*a^6 - (4*a^12 - 8*a^6*(a^5 - (-2*a^9 + a^10 + 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} , {x -> (2*a^6 + (4*a^12 - 8*a^6*(a^5 - (-2*a^9 + a^10 + 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} , {x -> (2*a^6 - (4*a^12 - 8*a^6*(a^5 + (-2*a^9 + a^10 + 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} , {x -> (2*a^6 + (4*a^12 - 8*a^6*(a^5 + (-2*a^9 + a^10 + 2*a^6*(-4*a^5 + a^6)^(1/2))^(1/2)))^(1/2))/(4*a^6)} } ;[o] 6 12 {{x -> (2 a - Sqrt[4 a - 6 5 9 10 6 5 6 8 a (a - Sqrt[-2 a + a - 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a + Sqrt[4 a - 8 a 5 9 10 6 5 6 (a - Sqrt[-2 a + a - 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a - Sqrt[4 a - 8 a 5 9 10 6 5 6 (a + Sqrt[-2 a + a - 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a + Sqrt[4 a - 8 a 5 9 10 6 5 6 (a + Sqrt[-2 a + a - 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a - Sqrt[4 a - 8 a 5 9 10 6 5 6 (a - Sqrt[-2 a + a + 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a + Sqrt[4 a - 8 a 5 9 10 6 5 6 (a - Sqrt[-2 a + a + 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a - Sqrt[4 a - 8 a 5 9 10 6 5 6 (a + Sqrt[-2 a + a + 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}, {x -> 6 12 6 (2 a + Sqrt[4 a - 8 a 5 9 10 6 5 6 (a + Sqrt[-2 a + a + 2 a Sqrt[-4 a + a ]])]) / 6 (4 a )}} :[font = text; inactive; preserveAspect] As expected, there are 8 such curves... :[font = input; preserveAspect; startGroup] Length[curves] :[font = output; output; inactive; preserveAspect; endGroup] 8 ;[o] 8 :[font = input; preserveAspect] Curve31 = x /. curves[[1, 1]]; Curve32 = x /. curves[[2, 1]]; Curve33 = x /. curves[[3, 1]]; Curve34 = x /. curves[[4, 1]]; Curve35 = x /. curves[[5, 1]]; Curve36 = x /. curves[[6, 1]]; Curve37 = x /. curves[[7, 1]]; Curve38 = x /. curves[[8, 1]]; :[font = text; inactive; preserveAspect] Below is a graph of the boundary curves for the regions in which seeds diverge in two iterations. :[font = input; preserveAspect; startGroup] p3 = Plot[{Curve31, Curve32, Curve33, Curve34, Curve35, Curve36, Curve37, Curve38}, {a, 4, 5}, AxesLabel -> {"a", "x"}, PlotRange -> {0, 1}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] And below, we combine the graphs from the first three problems. :[font = input; preserveAspect; startGroup] Show[p1, p2, p3] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect; endGroup] We can really see the divergence diagram forming before our eyes! :[font = subsubsection; inactive; preserveAspect; startGroup] 4) Note that other than the largest region, the other regions each have a maximum width. Find the a-value for which the boundary curves found in problem 2 are the widest. :[font = text; inactive; preserveAspect] We'll concentrate on the top branch: :[font = input; preserveAspect; startGroup] Plot[{Curve22, Curve24}, {a, 4, 5}, AxesLabel -> {"a", "x"}, PlotRange -> {0, 1}, AspectRatio -> Automatic] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] The width is given by :[font = input; preserveAspect; startGroup] Width = Simplify[Curve22 - Curve24] :[font = output; output; inactive; preserveAspect; endGroup] (-(-2*a^5 + a^6 - 2*a^3*((-4 + a)*a^3)^(1/2))^(1/2) + (-2*a^5 + a^6 + 2*a^3*((-4 + a)*a^3)^(1/2))^(1/2))/(2*a^3) ;[o] 5 6 3 3 (-Sqrt[-2 a + a - 2 a Sqrt[(-4 + a) a ]] + 5 6 3 3 3 Sqrt[-2 a + a + 2 a Sqrt[(-4 + a) a ]]) / (2 a ) :[font = text; inactive; preserveAspect] and is maximized when the derivative is zero. Since the function is messy, we'll graph the derivative and then determine its zero numerically. :[font = input; preserveAspect] derWidth = D[Width, a]; :[font = input; preserveAspect; startGroup] Plot[derWidth, {a, 5, 6}] :[font = output; output; inactive; preserveAspect; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = input; preserveAspect; startGroup] FindRoot[derWidth, {a, 5.5}] :[font = output; output; inactive; preserveAspect; endGroup] {a -> 5.552799107410558} ;[o] {a -> 5.5528} :[font = input; preserveAspect; startGroup] acrit = a /. % :[font = output; output; inactive; preserveAspect; endGroup; endGroup; endGroup; endGroup] 5.552799107410558 ;[o] 5.5528 :[font = section; inactive; Cclosed; noKeepOnOnePage; preserveAspect; startGroup] ISSUES IN SOLUTION :[font = subsection; inactive; preserveAspect; endGroup; endGroup] By including similar problems for different maps, some repetitiveness is built into the problems. Students have a much easier time working through the problems for the second map and improve their understanding of the problem. ^*)