The Hénon Map, orbit diagram

Orbit diagrams

x as a function of a (rewritten as 1-D map)

Clear[x,y,n,a,a1,a2,da,b,iter]
b=0.3;(*keeping it constant*)
iter=1000;

a1=0.2;a2=1.6;da=0.002; (*varying a 0.5 -- 1.5*)
x1=-1.4;x2=1.45;dx=0.004;(*trapping region*)
Gen2[x0_,a_,b_,iter_]:= RecurrenceTable[{
x[n+1]==1-a x[n]^2+b x[n-1],(*rewriten as 1D map*)
x[0]==x0,
x[1]==x0},
x,{n,1,iter}][[-1]]
plot1=Rasterize[ListPlot[
ParallelTable[
Thread[{a,Quiet[Gen2[Range[x1,x2,dx],a,b,iter]]}],
{a,a1,a2,da}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,PlotLabel->Style["x(a), rewritten as 1-D map",20],FrameLabel->{"a","x"},PlotRange->{{a1,a2},{x1,x2}},AspectRatio->0.7,ImageSize->400,LabelStyle->20]];

x as a function of a

Clear[x,y,n,a,a1,a2,da,b,iter]
b=0.3;(*keeping it constant*)
iter=600;

a1=0.3;a2=1.5;da=0.002; (*varying a*)
x1=-1.4;x2=1.45;dx=0.002;(*trapping region*)
GenX[x0_,a_,b_,iter_]:= RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==x0,
y[0]==0.27 x0},(*remains in trapping region. Needs varying, don't leave constant*)
{x,y},{n,0,iter}][[-1,1]]
ODxa=Rasterize[ListPlot[
ParallelTable[
Thread[{a,Quiet[GenX[Range[x1,x2,dx],a,b,iter]]}],
{a,a1,a2,da}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{"a","x"},PlotRange->{{a1,a2},{x1,x2}},AspectRatio->0.7,ImageSize->400,LabelStyle->20]];

x as a function of b

Clear[x,y,n,a,b1,b2,db,b,iter]
a=1.4;(*keeping it constant*)
iter=600;

b1=0.001;b2=0.32;db=0.0005; (*varying a*)
x1=-1.4;x2=1.45;dx=0.005;(*trapping region*)
GenX[x0_,a_,b_,iter_]:= RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==x0,
y[0]==0.27 x0},(*remains in trapping region. Needs varying, don't leave constant*)
{x,y},{n,0,iter}][[-1,1]]
ODxb=Rasterize[ListPlot[
ParallelTable[
Thread[{b,Quiet[GenX[Range[x1,x2,dx],a,b,iter]]}],
{b,b1,b2,db}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{"b","x"},PlotRange->{{b1,b2},{x1,x2}},AspectRatio->0.7,ImageSize->400,LabelStyle->20]];

y as a function of a

Clear[x,y,n,a,a1,a2,da,b,iter]
b=0.3;(*keeping it constant*)
iter=600;

a1=0.3;a2=1.5;da=0.002; (*varying a*)
y1=-0.4;y2=0.45;dy=0.002;(*trapping region*)
GenY[y0_,a_,b_,iter_]:= RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==3.5 y0,(*remains in trapping region. Needs varying, don't leave constant*)
y[0]==y0},
{x,y},{n,0,iter}][[-1,2]]
ODya=Rasterize[ListPlot[
ParallelTable[
Thread[{a,Quiet[GenY[Range[y1,y2,dy],a,b,iter]]}],
{a,a1,a2,da}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{"a","y"},PlotRange->{{a1,a2},{y1,y2}},AspectRatio->0.7,ImageSize->400,LabelStyle->20]];

y as a function of b

Clear[x,y,n,a,b1,b2,db,b,iter]
a=1.4;(*keeping it constant*)
iter=600;

b1=0.001;b2=0.35;db=0.0005; (*varying a*)
y1=-0.4;y2=0.4;dy=0.001;(*trapping region*)
GenY[y0_,a_,b_,iter_]:= RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==3.5 y0,(*remains in trapping region. Needs varying, don't leave constant*)
y[0]==y0},
{x,y},{n,0,iter}][[-1,2]]
ODyb=Rasterize[ListPlot[
ParallelTable[
Thread[{b,Quiet[GenY[Range[y1,y2,dy],a,b,iter]]}],
{b,b1,b2,db}],
PlotStyle->{{Black,Opacity[0.08],AbsolutePointSize[0.001]},{Black,Opacity[0.08],AbsolutePointSize[0.001]}},
Frame->True,FrameLabel->{"b","y"},PlotRange->{{b1,b2},{y1,y2}},AspectRatio->0.7,ImageSize->400,LabelStyle->20]];

Grid[{{plot1},{ODxa,ODxb},{ODya,ODyb}},Frame->All]

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