1o Σχημα

ClearAll["Global`*"]

f[x_]:=R (x^(1/3))(1-x)

R=2;
s1=Plot[f[x],{x,0,1},PlotStyle->Thick];
s2=Plot[1,{x,0,1},PlotStyle->Directive[Black,Thick]];
s3=Graphics[{Thick,Line[{{1,0},{1,1}}]}];

x[i_]:=f[x[i-1]]
P[j_]:=If[Not[j==1],If[EvenQ[j],{x[(j/2)-1],x[(j/2)]},{x[((j-1)/2)],x[((j-1)/2)]}],{x[0],0}]

x[0]=0.05;

s4=Graphics[{Thick,Red,Arrowheads[{0,0.04,0,0.04,0.04,0.04,0,0.04,0.04,0.04,0,0.04,0.04,0,0.04,0,0.04,0,0.04,0,0.04,0}],Arrow[Table[P[j],{j,17}]]}];
s5=Plot[x,{x,0,1},PlotStyle->Directive[Black,Thick]];

Arrowheads[Table[0.04,{22}]];

X[j_]:={P[j][[1]],0}
s8[j_]:=Graphics[{Dashed,Line[{P[j],X[j]}]}]

graph=Show[{s1,s2,s3,s4,s5,s8[4],s8[5],s8[8],s8[9],s8[12],s8[13],s8[16],s8[17]},PlotRange->{0,1},AspectRatio->1,AxesLabel->{"x","f(x)"},AxesStyle->Thick,TicksStyle->Directive[Plain,14],LabelStyle->Directive[Italic,14],Ticks->{{{x[0],(Subscript[x, 0])},{x[1],(Subscript[x, 1])},{x[2],(Subscript[x, 2])},{x[3],(Subscript[x, 3])},{x[4],(Subscript[x, 4])},{x[5],(Subscript[x, 5])},{x[6],(Subscript[x, 6])},{x[7],(Subscript[x, 7])},{x[8],(Subscript[x, 8])}},None}]

Export["c:\\aa\\map1D_grtraj.eps",graph]

2o Σχημα

ClearAll["Global`*"]

f[x_]:=R x(1-x)

R=2.9;
s1=Plot[f[x],{x,0,1},PlotStyle->Thick];
s2=Plot[1,{x,0,1},PlotStyle->Directive[Black,Thick]];
s3=Graphics[{Thick,Line[{{1,0},{1,1}}]}];

x[i_]:=f[x[i-1]]
P[j_]:=If[Not[j==1],If[EvenQ[j],{x[(j/2)-1],x[(j/2)]},{x[((j-1)/2)],x[((j-1)/2)]}],{x[0],0}]

x[0]=0.01;

s4=Graphics[{Thick,Red,Arrowheads[{0,0,0.04,0.04,0,0.04,0,0.04,0,0.04,0,0.04,0,0,0,0,0,0,0,0,0,0,0,0,0}],Arrow[Table[P[j],{j,26}]]}];
s5=Plot[x,{x,0,1},PlotStyle->Directive[Black,Thick]];

Arrowheads[Table[0.04,{25}]];

graph=Show[{s1,s2,s3,s4,s5},PlotRange->{0,1},AspectRatio->1,AxesLabel->{"x","f(x)"},AxesStyle->Thick,TicksStyle->Directive[Plain,12],LabelStyle->Directive[Italic,14]]

Export["c:\\aa\\map1D_logist1.eps",graph]

3o Σχημα

ClearAll["Global`*"]

f[x_]:=R x(1-x)

F[x_,n_]:=Nest[f,x,n]

x0=Solve[F[x,2]==x,x]

R=3.2;
s1=Plot[f[x],{x,0,1},PlotStyle->Thick];
s2=Plot[1,{x,0,1},PlotStyle->Directive[Black,Thick]];
s3=Graphics[{Thick,Line[{{1,0},{1,1}}]}];

x[i_]:=f[x[i-1]]
P[j_]:=If[Not[j==1],If[EvenQ[j],{x[(j/2)-1],x[(j/2)]},{x[((j-1)/2)],x[((j-1)/2)]}],{x[0],0}]

x[0]=x0[[2,1,2]]+0.015;

s4=Graphics[{Thick,Red,Arrowheads[{0,0.04,0,0,0,0,0.04,0.04,0,0,0.04,0,0,0,0.04}],Arrow[Table[P[j],{j,32}]]}];
s5=Plot[x,{x,0,1},PlotStyle->Directive[Black,Thick]];
s6=Graphics[{Dashed,Line[{{((R-1)/R),((R-1)/R)},{((R-1)/R),0}}]}];

Arrowheads[Table[0.04,{15}]];

s7=Graphics[{Dashed,Line[{{x0[[3,1,2]],f[x0[[3,1,2]]]},{x0[[3,1,2]],0}}]}];
s9=Graphics[{Dashed,Line[{{x0[[4,1,2]],x0[[4,1,2]]},{x0[[4,1,2]],0}}]}];

s10=Plot[F[x,2],{x,0,1},PlotStyle->Directive[Green,Thick]];

graph=Show[{s1,s2,s3,s4,s5,s7,s9,s10},PlotRange->{0,1},AspectRatio->1,AxesLabel->{"x","f(x)"},AxesStyle->Thick,TicksStyle->Directive[Plain,12],LabelStyle->Directive[Italic,14]]

Export["c:\\aa\\map1D_logist2.eps",graph]

4o Σχημα

ClearAll["Global`*"]

f[x_]:=R x(1-x)

Rmin=2.8;
Rmax=4;
steps=201;
dR=((Rmax-Rmin)/(steps-1));
R[i_]:=Rmin+(i-1)dR
R=R[i];

x[j_]:=Nest[f,Range[0,1,0.002],j]

points=DeleteCases[Flatten[Table[Thread[{R,x[2000]}],{i,1,steps}],1],{_,0.0}];
ListPlot[points,AxesLabel->{"R","x"},AxesStyle->Thick,TicksStyle->Directive[Plain,10],LabelStyle->Directive[Italic,14],PlotStyle->PointSize[0.004]]

5o Σχημα

ClearAll["Global`*"]

f[x_]:=R x(1-x)
R=3.8282;
x[j_]:=Nest[f,0.2,j]
orbit=Table[{j,x[j]},{j,1,200}];
graph=ListLinePlot[orbit,AxesLabel->{"n","(Subscript[x, n])"},TicksStyle->Directive[Plain,10],LabelStyle->Directive[Italic,12],PlotMarkers->{"+"}, PlotRange->{0,1}, AspectRatio->0.3]

Export["c:\\aa\\map1D_logistraj.eps",graph]

6o Σχημα

ClearAll["Global`*"]

f[x_]:=R x(1-x)

Rmin=2.8;
Rmax=4;
steps=201;
dR=((Rmax-Rmin)/(steps-1));
R[i_]:=Rmin+(i-1)dR
R=R[i];

x[j_]:=Nest[f,0.2,j]
λ[n_]:=(1/n)Sum[Log[Abs[f'[x[j]]]],{j,0,n-1}]

points=Table[Thread[{R,λ[200]}],{i,1,steps}];
ListLinePlot[points,AxesLabel->{"R","λ"},PlotRange->{-2.3,0.7},AxesStyle->Thick,TicksStyle->Directive[Plain,10],LabelStyle->Directive[Italic,14],PlotStyle->Directive[Red,Thickness[0.005]]]

7o Σχημα

ClearAll["Global`*"]

cantorRule=Line[{{a_,n_},{b_,n_}}]:>{Line[{{a,n-0.1},{a+(b-a)/3,n-0.1}}],Line[{{b-(b-a)/3,n-0.1},{b,n-0.1}}]};
graph=Graphics[{CapForm["Butt"],Thickness[.01],NestList[#/.cantorRule&,Line[{{0,0},{1,0}}],5]}]

Export["c:\\aa\\map1D_cantor.eps",graph]

8o Σχημα

ClearAll["Global`*"]

f[x_]:=R x(1-x)

R=4.5;
s1=Plot[f[x],{x,0,1},PlotStyle->Thick];
s2=Plot[1,{x,0,1},PlotStyle->Directive[Black,Thick]];
s3=Graphics[{Thick,Line[{{1,0},{1,1}}]}];
s9=Graphics[{Green,Thickness[0.008],Line[{{0,0},{0,1}}]}];

sol=Solve[f[x]==1,x];
mdt1=Min[x/.sol[[1]],x/.sol[[2]]];
mdt2=Max[x/.sol[[1]],x/.sol[[2]]];

s4=Graphics[{Dashed,Line[{{mdt1,0},{mdt1,1}}]}];
s5=Graphics[{Dashed,Line[{{mdt2,0},{mdt2,1}}]}];
s6=Plot[0,{x,mdt1,mdt2},PlotStyle->Directive[Black,Thickness[0.01]]];
s7=Plot[0,{x,0,mdt1},PlotStyle->Directive[Red,Thickness[0.01]]];
s8=Plot[0,{x,mdt2,1},PlotStyle->Directive[Red,Thickness[0.01]]];

graph=Show[{s1,s2,s3,s4,s5,s6,s7,s8,s9},PlotRange->{{-0.1,1.03},{-0.06,R/4}},AspectRatio->1,Axes->{False,False},PlotRangeClipping->False]

Export["c:\\aa\\map1D_R4.eps",graph]