MATH332 — Assignment 5, 2015

Exercise 1: tent map, μ = 2

tent[μ_,x_]:=μ  x/;x≤(1/2);
tent[μ_,x_]:=μ  (1-x)/;x≥(1/2)

μ = 2:  fixed-points, 2-cycles, 3-cycles

Plot a few iterates:

Table[Plot[Evaluate[Nest[(tent[μ,#]/.{μ->2})&,x,j]],{x,0,1},PlotStyle->{Red,Thickness[.01]}
,Frame->True,PlotRange->{0,1},AspectRatio->1, Background->White
,Epilog->{Thickness[.008],Hue[5/6],Line[{{0,0},{1,1}}]}
,GridLines->{{0,(1/2),(2/3),1},{0,(1/2),1}}],{j,1,3}]//Row

fixed-points

Solve/@{{x==2x},{x==2-2x}}

There are 2 unstable fixed points.

2-cycles

Solve/@{{x==2(2x)},{x==2-2(2x)},{x==2-2(2-2x)},{x==2(2-2x)}}

There is a primitive 2-cycle. It is clearly unstable, as the slope is  ±(2^2)=±4.

3-cycles

Solve/@{{x==2(2(2x))},{x==2(2(2-2x))},{x==2(2-2(2x))},{x==2(2-2(2-2x))},{x==2-2(2(2x))},{x==2-2(2(2-2x))},{x==2-2(2-2(2x))},{x==2-2(2-2(2-2x))}}

There are 2 primitive 3-cycles. They are clearly unstable, as the slope is  ±(2^3)=±8.

k-cycles

For arbitrary k ϵ ℕ the lines get steeper, with slopes of  ±(2^k), each having an intersection corresponding to a point on a k-cycle. Some of these need not be primitive k-cycles, but some must be, as not all the intersects can be at places for a lower period. Indeed, the values are at the rational numbers having an even numerator and odd denominator, as discussed in a lecture.

Exercise 2:  parametrized tent map, μ < 2

Plot a few possibilities:

Plot[Evaluate[Table[tent[μ,x],{μ,0.2`,2,0.15`}]],{x,0,1},PlotStyle->{Red},Frame->True,PlotRange->{0,1},AspectRatio->1, Background->White, Epilog->{Green,Line[{{0,0},{1,1}}]},GridLines->{{0,(1/2),1},{0,1}}]

Manipulate[Plot[tent[μ,x],{x,0,1},Frame->True,PlotRange->{0,1},PlotStyle->{Red},AspectRatio->1,Epilog->{Green,Line[{{0,0},{1,1}}]},GridLines->{{0,(1/2),1},{0,1}}],{{μ,1},0,2}]

μ < 1:  nothing much of interest, stable fixed-point at 0.

Block[{μ=.9},
Table[Plot[Evaluate[Nest[(tent[μ,#])&,x,j]],{x,0,1},PlotStyle->{Red,Thickness[.01]}
,Frame->True,PlotRange->{0,1},AspectRatio->1,Background->White
,Epilog->{Thickness[.008],Magenta,Line[{{0,0},{1,1}}]}
,GridLines->{{0,(1/2),1},{0,(1/2)μ,(1/2)(μ^2),(1/2)(μ^3),1}}
],{j,1,3}]//Row]

Upon iteration, the tent just lowers to a height of (1/2)(μ^k).

Manipulate[Block[{μ=(Subscript[μ, 1])},
Table[Plot[Evaluate[Nest[(tent[μ,#])&,x,j]],{x,0,1},PlotStyle->{Red,Thickness[.01]}
,Frame->True,PlotRange->{0,1},AspectRatio->1,Background->White
,Epilog->{Thickness[.008],Magenta,Line[{{0,0},{1,1}}]}
,GridLines->{{0,(1/2),1},{0,(1/2)μ,(1/2)(μ^2),(1/2)(μ^3),1}}
],{j,1,3}]//ColumnForm],{{(Subscript[μ, 1]),.75},.1,1}]

μ = 1:  tent map is idempotent

Table[Plot[Evaluate[Nest[(tent[μ,#]/.{μ->1})&,x,j]],{x,0,1},PlotStyle->{Red,Thickness[.01]}
,Frame->True,PlotRange->{0,1},AspectRatio->1,Background->White
,Epilog->{Thickness[.008],Magenta,Line[{{0,0},{1,1}}]}
,GridLines->{{0,(1/2),1},{0,(1/2),1}}],{j,1,2}]//Row

1< μ < 2:  fixed-points, 2-cycles, 3-cycles

Plot a few iterates for a particular value of μ :

Block[{μ=GoldenRatio},
Table[Plot[Evaluate[Nest[(tent[μ,#])&,x,j]],{x,0,1},PlotStyle->{Red,Thickness[.01]}
,Frame->True,PlotRange->{0,1},AspectRatio->1,Background->White
,Epilog->{Thickness[.008],Magenta,Line[{{0,0},{1,1}}]}
,GridLines->{{0,(1/(2(μ^2))),(1/(2μ)),((2-(1/μ))/(2μ)),(1/2),1-((2-(1/μ))/(2μ)),1-(1/(2μ)),1-(1/(2(μ^2))),1},{0,μ-(1/2)(μ^2),(1/2),(((μ^2)(μ-2))/2),(1/2)μ,1}}
],{j,1,3}]//Row]

Manipulate[Table[Plot[Evaluate[Nest[(tent[μ,#])&,x,j]],{x,0,1},PlotStyle->{Red,Thickness[.01]}
,Frame->True,PlotRange->{0,1},AspectRatio->1,Background->White
,Epilog->{Thickness[.008],Magenta,Line[{{0,0},{1,1}}]}
,GridLines->{{0,(1/(2(μ^2))),(1/(2μ)),((2-(1/μ))/(2μ)),(1/2),1-((2-(1/μ))/(2μ)),1-(1/(2μ)),1-(1/(2(μ^2))),1},{0,μ-(1/2)(μ^2),(1/2),(((μ^2)(μ-2))/2),(1/2)μ,1}}],{j,1,3}]//ColumnForm,{{μ,GoldenRatio},1,2}]

Fixed-points can occur only in the upper-half of [0,1] :

Solve[μ(1- x)==x,x]//Simplify

These are always unstable, as the slope of the graph of the tent-map is -μ which is steeper than  -1 .

Note where the 2nd-iterate reaches the maximum value:

(Solve[#,x]&/@{{μ x==(1/2)},{μ(1- x)==(1/2)}})//Simplify

...then drops down to:

μ(1-(1/2)μ)//Expand

...which is always less than (1/2)for μ>1; viz.

μ(1-(1/2)μ)-(1/2)//Simplify

Thus an unstable 2-cycle always exists for  μ>1.

{Solve[μ(μ(1- x))==x,x],Solve[μ(1- μ x)==x,x]}//Simplify

The 3rd-iterate reaches the maximum value 4 times:

(Solve[#,x]&/@{{(μ^2) x==(1/2)},{μ(1-μ x)==(1/2)},{μ(1-μ (1- x))==(1/2)},{(μ^2)(1- x)==(1/2)}})//Simplify

... with local minima in between of:

{μ (1-x)/.{x->(1/(2 μ))},μ x/.{x->1-(1/(2 μ))},(μ^2)(1-(1/2)μ)}//Expand

If the latter of these is too large (i.e., >(1/2)) there are no primitive 3-cycles:

Solve[(μ^2)-((μ^3)/2)==(1/2)]

The latter value is the Golden Ratio; hence this is where the emergence of  3-cycles begins.

Solve[(((z^3)-2(z^2)+1)/(z-1))==0,z]

(((z^3)-2(z^2)+1)/(z-1))//Factor

(((μ^2)(2-μ))/2)/.{μ->1.618034}

?GoldenRatio

N[GoldenRatio,20]

When 3-cycles exist — that is, for ϕ≤μ≤2 — then there are of 2 kinds of 3-cycle: those where two elements of the 3-cycle are less than (1/2), and those where only 1 element is small. Suppose x<(1/2) to be the smallest element within the 3-cycle for a value of μ. 
For the 1st kind we can presume μ x<(1/2) and (μ^2)x>(1/2). The 3-cycle is then given by the following triple:

{x,μ x,(μ^2)x}/.Solve[μ(1-(μ^2)x)==x,{x}]

In the 2nd case we must have that μ x>(1/2) and also  μ (1-μ x)>(1/2). The 3-cycle is then given by the following triple:

{x,μ x,μ(1-μ x)}/.Solve[μ(1-μ(1-μ x))==x,{x}]//Simplify

Note that if μ x>(1/2) and  μ (1-μ x)<(1/2), then we need this latter number to be less than x, so that multiplication by μ completes the 3-cycle by being equal to x. But then x is not the smallest element in the 3-cycle. 
Indeed we get that x=(μ^2) (1-μ x), implying x=((μ^2)/(1+(μ^3))), and we are back with the same 3-cycle as for the 1st case.

When μ=2 we recover the 3-cycles from Question 1.

{({x,μ x,(μ^2)x}/.Solve[μ(1-(μ^2)x)==x,{x}])
,({x,μ x,μ(1-μ x)}/.Solve[μ(1-μ(1-μ x))==x,{x}])}/.{μ->2}

Bifurcation diagrams

SetDirectory["~/Courses/MATH332/2015"]

<<GraphicalAnalysis.m

Bifurcation[tent[μ,x],{x,(1/2)},{μ,0.9,2}, Iterations -> 1000, Background->White,Transients->500, Slices-> 600, Frame->True,PlotRange->{0,1}]

Q-curves

Bifurcation[tent[μ,x],{x,(1/2)},{μ,0.9,2}, Iterations -> 12, Transients->0, Slices-> 1000, Frame->True,PlotRange->{0,1},Background->White,GridLines->{{1,(Sqrt[2]),GoldenRatio,2},{0,1}}]

Exercise 3:  5-cycle, no 3-cycle

f5[1] = 3;f5[2]=5;f5[3]=4;f5[4]=2;f5[5]=1;

f5[x_]:=f5[Floor[x]]+(x-Floor[x])*(f5[Floor[x]+1]-f5[Floor[x]])

f5[1.3]

Plot[f5[x],{x,1,5},PlotStyle->{Thickness[0.007`],Red},Frame->True,Axes->False,AspectRatio->1,PlotRange->{{0.5`,5.5`},{0.5`,5.5`}},GridLines->{None,Range[5]},Background->White,Epilog->{{Blue,PointSize[0.02`],Point/@Transpose[{Range[5],f5/@Range[5]}]},{Magenta,Line[{{0,0},{6,6}}]}}]

Plot the first few iterates:

Table[Plot[Nest[f5,x,k],{x,1,5}
,PlotStyle->{Thickness[.007],Hue[0]}
,Frame->True,Axes->False,AspectRatio->1
,PlotRange->{{.5,5.5},{.5,5.5}},GridLines->{None,Range[5]},Background->White
,Epilog->{
{Blue,PointSize[.02],Point/@({Range[5],Nest[f5,#,k]&/@Range[5]}//Transpose)}
,{Magenta,Line[{{0,0},{6,6}}]}
}],{k,0,5}]//Row

Clearly there are non-trivial 2-cycles and 4-cycles, as well as the obvious 5-cycle; but no 3-cycles.

Exercise 4:  10-cycle, no 6-cycle

f10[1]=3+8;f10[2]=5+8;f10[3]=4+8;f10[4]=2+8;f10[5]=1+8;
f10[9]=1;f10[10]=2;f10[11]=3;f10[12]=4;f10[13]=5;
 f10[6]=7;f10[7]=5;f10[8]=3; 
f10[x_]:=f10[Floor[x]]+(x-Floor[x])*(f10[Floor[x]+1]-f10[Floor[x]])

Plot[f10[x],{x,1,13},PlotStyle->{Thickness[0.007`],Hue[0]},Frame->True,Axes->False,AspectRatio->1,PlotRange->{{0.5`,13.5`},{0.5`,13.5`}},GridLines->{None,Range[1,13,2]},Background->White,Epilog->{{Hue[(2/3)],PointSize[0.02`],Point/@Transpose[{Range[1,13],f10/@Range[1,13]}]},{Hue[(5/6)],Line[{{0,0},{14,14}}]}}]

Plot the first 10 iterates:

Table[Plot[Nest[f10,x,k],{x,1,13}
,PlotStyle->{Thickness[.007],Hue[0]}
,Frame->True,Axes->False,AspectRatio->1
,PlotRange->{{.5,13.5},{.5,13.5}},GridLines->{None,Range[1,13,2]},Background->White
,Epilog->{
{Hue[2/3],PointSize[.02],Point/@({Range[13],Nest[f10,#,k]&/@Range[13]}//Transpose)}
,{Hue[5/6],Line[{{0,0},{14,14}}]}
}],{k,1,10}]

There are no odd cycles, apart from the obvious fixed-point.
The only 6-cycles are from the fixed-point and 2-cycle.
There is the obvious 10-cycle, as well as period-doubling producing non-trivial 4-cycles and 8-cycles.

Note that the 2nd-iterate recovers exactly f on the interval [1,5], and also 8+f(x-8) on the interval [9,13]. This is the origin of the naming of ff as the 'double' of f. On the interval (5,9) we have that ff is linear with slope -2, repelling away from the unstable fixed-point. Indeed it maps bijectively onto the entire interval (1,13), so any point other than the fixed-point is ultimately repelled into (1,5] and/or [9,13) so becoming determined by what happens with f. 
Thus non-trivial cycles for ff correspond exactly to cycles for f of half the period.

Plot more even iterates, up to 20:

Table[Plot[Nest[f10,x,k],{x,1,13}
,PlotStyle->{Thickness[.007],Hue[0]}
,Frame->True,Axes->False,AspectRatio->1
,PlotRange->{{.5,13.5},{.5,13.5}},GridLines->{None,Range[1,13,2]}
,Epilog->{
{Hue[2/3],PointSize[.02],Point/@({Range[13],Nest[f10,#,k]&/@Range[13]}//Transpose)}
,{Hue[5/6],Line[{{0,0},{14,14}}]}
}],{k,12,20,2}]

These do give new primitive cycles, as expected from the Sharkovski ordering.

Exercise 5:  Mandelbrot Set and Logistic Map

(Subscript[M, c])[z_]:=(z^2)+c;   (* Mandelbrot Set map  *)
(Subscript[Q, λ])[x_]:=λ x(1-x)   (*  Logistic Map  *)

(a) — equivalence of these quadratic systems

Convert the Mandelbrot Set map into the logistic map, via a linear change of coordinates z=α x+β, for appropriate α and β in terms of λ. Do this by writing (Subscript[M, c])[z] in terms of x in two different ways, as follows:

{(Subscript[M, c])[z],α (Subscript[Q, λ])[x]+β }/.z->α x +β//Expand

(%//First)-(%//Last)

CoefficientList[%,x]

Putting β=(1/2)λ and α=-λ kills the coefficients of x and (x^2), allowing c to be expressed in terms of λ:

%/.{β->(1/2)λ,α->-λ}

Solve[%==0,c]

(b) — interesting range of parameter values

The range 1≤λ≤4 corresponds to (1/4)≥c≥-2, along the real axis of the complex plane.

c[λ_]:=(1/4)λ(2-λ)

TableForm[{
{1,c[1],"stable fixed point starts"},{2,c[2],"superstable fixed point"},{3,c[3],"bifurcation into 2-cycles"},{4,c[4],"end of trapped continuum"}
},TableHeadings->{{},{"λ","c","description"}}]

(c) — super-critical value is x=(1/2), Q-curves

(α x+β)/.{β->(1/2)λ,α->-λ}

%/.{x->(1/2)}

Q-curves are formed by starting at the super-critical value, and plotting this under successive iterations.
That is, start at z=0, so we have successive iterations starting at 0 for different values of c.

(Qcurves=NestList[(Subscript[M, c]),0,8])//ColumnForm

Plot[Qcurves,{c,-2,(1/4)}]

(d) — discover the Mandelbrot Set

The image in Figure 1 below shows how the parameter values for the logistic map line up with the c values in the Mandelbrot Set, along the real axis.
One sees that where there is stability (stable fixed-point, 2-cycle, 4-cycle, … , stable 3-cycle) evident in the bifurcation diagram, the correspoding c-values are within the interior (black blobs) of the Mandelbrot Set. Conversely the regions of partial (or complete) chaos in the Bifurcation diagram lie along the thin ‘antenna’ along the negative real axis, terminating finally at c=-2. Each of the ‘windows’ of stability in the Bifurcation diagram corresponds to a ‘mini-Mandelbrot Set’ located along the negative real axis.

Image downloaded from:  https://upload.wikimedia.org/wikipedia/commons/b/b4/Verhulst-Mandelbrot-Bifurcation.jpg

This correspondence between being in the interior of the Mandelbrot Set and stability in the logistic map is better understood using the Julia Set (Subscript[J, c]) for iteration of the quadratic map z↦(z^2)+c in the complex plane, which always has 2 fixed-points. When c is in the interior of the Mandelbrot set, then there is an attracting fixed-point or k-cycle for some integer k∈ℕ; the Julia Set (Subscript[J, c]) is connected, dividing the complex plane into a region that is attracted to the stable cycle, and an exterior region attracted to infinity. Having attraction is an open condition on c∈ℂ, meaning that neighbouring parameter values also have attraction — it takes more than an infinitesimal step to become non-attractive; hence c is in the interior of the Mandelbrot Set.

Extra examples

1-μ (x^2)

p[μ_,x_]:= 1-μ (x^2)

Plot[Evaluate[Table[p[μ,x],{μ,0.2`,2,0.15`}]],{x,-1,1},PlotStyle->{Red},Frame->True,PlotRange->{-1,1},AspectRatio->1,Epilog->{Green,Line[{{-1,-1},{1,1}}]},GridLines->{{-1,0,1},{0,1}},Background->White]

Fixed points

μQuad=p[μ,x]-x

(Subscript[fixed, μ])=Solve[μQuad==0,x]

(Subscript[deriv, μ])=D[p[μ,x],x]

(Subscript[deriv, μ])/.((Subscript[fixed, μ])//Last)

Solve/@{%==1,%==-1}

This system has a stable fixed-point for -(1/4)<μ<(3/4), after which bifurcation occurs.

2-cycles

(Subscript[cycle2, x])=(((p[μ,p[μ,x]]-x)/(p[μ,x]-x)))//Simplify

(Subscript[cycle2, μ])=Solve[(Subscript[cycle2, x])==0,x]//Simplify

Slopes at the points on the 2-cycle are just -2μ x=-1±(Sqrt[4μ-3]), so for the doubly iterated map it is the product of these:

(Solve[4(1-μ)==#])&/@{1,-1}

Thus 2-cycles are stable for (3/4)<μ<(5/4).

μ sin(π x)

gg[μ_,x_]:=μ Sin[π x]

Plot[Evaluate[Table[gg[μ,x],{μ,0.1`,1,0.15`}]],{x,0,1},PlotStyle->{Red},Frame->True,PlotRange->{0,1},AspectRatio->1,Epilog->{Green,Line[{{0,0},{1,1}}]},GridLines->{{0,(1/2),1},{0,1}},Background->White]

Fixed points

gg[μ,x]-x

(Subscript[deriv, gg])=D[gg[μ,x],x]

μ arctan(x)

gn[μ_,x_]:=μ ArcTan[ x]

Plot[Evaluate[Table[gn[μ,x],{μ,0.5`,4,0.5`}]],{x,-5,5},PlotStyle->{Red},Frame->True,PlotRange->{-5,5},AspectRatio->1,Epilog->{Green,Line[{{-5,-5},{5,5}}]},GridLines->{{0},{0}},Background->White]