The logistic map

Cobweb diagram and map iterates

Manipulate[
Row[{
Show[Plot[{Nest[r# - r((#)^2) &, x,k],r x - r (x^2),x},{x,0,1},PlotStyle->{Blue,{Thickness[0.007],Red},Blue},Frame->True,PlotRange->{{0,1},{0,1}},AspectRatio->0.8,FrameLabel->{"(Subscript[x, n])","(Subscript[x, n + 1])"}],Graphics[Flatten[MapIndexed[{Opacity[0.39],Line[{{#,If[#==x0,0,#]},{#,r #-r ((#)^2)}}],Line[{{#,r #-r ((#)^2)},{r #-r ((#)^2),r #-r ((#)^2)}}]}& ,NestWhileList[r #-r ((#)^2)&,x0,#1≠r #2-r ((#2)^2)&,2,n]]]],ImageSize->{320,320},LabelStyle->18],
ListLinePlot[NestList[r #-r ((#)^2)&,x0,n],FrameLabel->{"n","(Subscript[x, n])"},DataRange->{0,n},PlotRange->{0,1},Frame->True,Mesh->All,MeshStyle->{PointSize[Large],Red},PlotStyle->Gray,AspectRatio->0.8,ImageSize->{320,320},LabelStyle->18]},"    "](*can also use RecurranceTable[]*),
{k,{1,2,3,4,5,6},ControlType->Setter},
{{n,30},1,400,1,ImageSize->Large,Appearance->"Labeled"}, 
{{r,3.6},0,4,ImageSize->Large,Appearance->"Labeled"},  
{{x0,0.15, "(Subscript[x, 0])"},0,1,ImageSize->Large,Appearance->"Labeled"}]

Orbit diagram

Clear[r,x]
iter = 500;
x1=0;x2=1;dx=0.0025;
r1=0.9;r2=4.;dr=0.0005;

ListPlot[ParallelTable[Thread[{r,Nest[r # (1-#)&,Range[x1,x2,dx],iter]}],{r,r1,r2,dr}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{r,x},AspectRatio->1.0,ImageSize->600,LabelStyle->20]

Period doubling

Clear[r,x]
iter = 500;
x1=0;x2=1;dx=0.0025;
r1=3.3;r2=3.57;dr=0.0001;

ListPlot[ParallelTable[Thread[{r,Nest[r # (1-#)&,Range[x1,x2,dx],iter]}],{r,r1,r2,dr}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{r,x},AspectRatio->1.0,ImageSize->600,LabelStyle->20]

Period-3 window

Clear[r,x]
iter = 500;
x1=0;x2=1;dx=0.0025;
r1=3.8;r2=3.9;dr=0.00005;
ListPlot[ParallelTable[Thread[{r,Nest[r # (1-#)&,Range[x1,x2,dx],iter]}],{r,r1,r2,dr}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{r,x},AspectRatio->1.0,ImageSize->600,LabelStyle->18]

Intuitive code for the logistic map iterates

Clear[x,r,n,nmax]
r=3.6;
nmax=25;
RecurrenceTable[{
x[n+1]==r x[n] (1-x[n]),
x[0]==0.3},
x,{n,1,nmax}];
ListLinePlot[%,Mesh->All,PlotMarkers->{"•", 19},DataRange->{0,nmax},PlotRange->All,AxesLabel->{n,(Subscript[x, n])},LabelStyle->18,ImageSize->Large]

Creation of this notebook was supported by IT Academy program of Information Technology Foundation for Education (HITSA).