Cobweb diagram of the Lorenz map

A more general code compared to numerics_9g.nb (includes the tent map)

Clear[x0,r,z,iter]
cobweb[r_,z_,x0_,iter_]:=Quiet[Module[{data1,data2}, 
With[{p=NestList[(r (1-((Abs[#])^z))/2-1)&,x0,iter]}, 
data1=Union[{{0,p[[1]],0}}, Table[{2i-1,p[[i]],p[[i+1]]},{i,1,Length[p]-1,1}], Table[{2i,p[[i+1]],p[[i+1]]},{i,1,Length[p]-1,1}]];
data2=Table[{data1[[i,2]],data1[[i, 3]]},{i,1,Length[data1]-1,1}]]]];
Manipulate[Quiet[Module[{gr1,gr2,gr3},
gr1=Plot[{x,r (1-((Abs[x])^z))/2-1},{x,-1,1},PlotRange->{{-1,1},{-1,1}},PlotStyle->{{Blue},{Thickness[0.008],Red}}];
gr2=ListPlot[cobweb[r,z,x0,iter],Joined->True,PlotStyle->{GrayLevel[0.],Opacity[0.35]}];
gr3=ListLinePlot[NestList[r (1-((Abs[#])^z))/2-1&,x0,iter],FrameLabel->{"n","(Subscript[z, max])"},PlotRange->{-1,1},DataRange->{0,iter},Frame->True,Mesh->All,MeshStyle->{PointSize[Large],Red},PlotStyle->Gray,AspectRatio->0.8,ImageSize->430,LabelStyle->18];
Row[{Show[gr1,gr2,Frame->True,FrameLabel->{"(Subscript[z, n])","(Subscript[z, n + 1])"},AspectRatio-> 0.8,ImageSize->430,LabelStyle->18],gr3},"      "]]
], 
Control[{{r,4,"Parameter value, r"},1,4,0.0001,ImageSize->Large,Appearance->"Labeled"}],
Control[{{z,0.5,"Unimodality, z"},0.5,6.0,0.001,ImageSize->Large,Appearance->"Labeled"}],
Control[{{x0,-0.5,"Initial value, (Subscript[x, 0])"},-1,1,0.0001,ImageSize -> Large,Appearance->"Labeled"}],
Control[{{iter,50,"Iterations, n"},1,500,1,ImageSize->Large,Appearance->"Labeled"}],
FrameMargins-> None,ControlPlacement->Bottom,SaveDefinitions->True]

The Lyapunov exponent as a function of parameter r, the logistic map

Manipulate[Module[{rg1},
Quiet@ListPlot[{#,lyapListCF[#,n]}&/@Range[Max[-2,a[[1]]-0.2/magH],Min[4,a[[1]]+0.2/magH],ControlActive[1,0.55]/magH/pts],PlotLabel->Style["Lyapunov exponent λ",20],Joined->True,PlotRange->{{a[[1]]-0.2/magH,a[[1]]+0.2/magH},Full},Ticks->{Automatic,{0}},ImageSize->500,Frame->True,FrameLabel->{"r", "λ"},LabelStyle->19]],
{{a,{2.0,0}},Locator},
Style["Zoom",Bold],
"horizontal",
{{magH,0.1,""},.1,15,.1,VerticalSlider},
Delimiter,
{{n,1000,"number of iterates"},ControlType->None},
{{pts,2000,"number of r values"},ControlType->None},
Button["Reset",a={2.0,0.1};magH=.1;n=1000;pts=2000],
Button["More detail",n=2000;pts=4000],
Button["More detail 2",n=4000;pts=8000],
ControlPlacement->Left,
TrackedSymbols:>{a,magH,n,pts},
Initialization:>(lyapListCF=Compile[{{r,_Real},{n,_Integer}},
Mean[Log[Abs[r-2 r #]]&/@NestList[r # (1.-#)&,r/4,n]]])]

Lyapunov exponent, the logistic map

Clear[r]
D[ r x (1-x),x]
Simplify[%]

Clear[r,n]
Lyapunov=Compile[{{r,_Real},{n,_Integer}},
Mean[Log[Abs[r-2 r #]]&/@NestList[r # (1.-#)&,r/4,n]]];
Plot[Lyapunov[r,5000],{r,-2,4},AxesLabel->{r,"Lyapunov exponent λ"},LabelStyle->19]

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