The Hénon Map and its dynamics

A blob of randomly placed initial conditions

Clear[map,a,b]
imsize=550;xlim=1.9;ylim=0.5;
frame=12;
points=700;(*points per frame*)
icoord=RandomReal[{-0.4,0.4},{points,2}];(*random blob of points, initial condition*)
a=1.4;b=0.3;

map[ic_,i_]:={1-a ic[[i,1]]^2+ic[[i,2]],b ic[[i,1]]}
sol=NestList[
Table[map[#,i],{i,1,points,1}]
&,icoord,frame];

fixedpoints=Quiet[Solve[{x==1-a x^2+y,y==b x},{x,y}]];
coordinates={x,y}/.fixedpoints;
fixedp=Graphics[{PointSize[0.02],Red,Point[coordinates]}];

ListAnimate[
Table[Show[{
ListPlot[sol[[i]],PlotRange->{{-xlim,xlim},{-ylim,ylim}},Frame-> True,PlotStyle->Black,PlotMarkers->{"•",6},FrameLabel->{x,y},AspectRatio->0.7,LabelStyle->20,ImageSize->imsize],fixedp}],
{i,1,frame}],
AnimationRunning->False,SaveDefinitions->True]
StringForm["Fixed points' coordinates: ``",coordinates]

Iterations of the map, CHAOTIC

Clear[x,y,n,a,b]
a=1.4;b=0.3;
iter=60;

sol=RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==0.1,
y[0]==0.1},
{x,y},{n,0,iter}];

ListLinePlot[{sol[[All,1]],sol[[All,2]]},PlotMarkers->{"•",12},AxesLabel->{n,"(Subscript[x, n]), (Subscript[y, n])"},PlotRange->{{0,iter},{-1.5,1.5}},PlotLegends->{"(Subscript[x, n])","(Subscript[y, n])"},LabelStyle->20,ImageSize->600]

Single iterate path

Clear[x,y,t,iter,n,a,b,x0,y0,point]
Manipulate[
sol=RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==point[[1]],y[0]==point[[2]]},{x,y},{n,0,iter}];
fixedpoints=Quiet[Solve[{x==1-a x^2+y,y==b x},{x,y}]];
coordinates={x,y}/.fixedpoints;
fixedp=Graphics[{PointSize[0.021],Red,Point[coordinates]}];
att2=ListPlot[sol,PlotMarkers->{"•",10},PlotStyle->Black,Frame-> True,PlotRange->{{-2,2},{-1,1}},Joined->True,FrameLabel->{x,y},LabelStyle->20,AspectRatio->1.0,ImageSize->420];
ip=ListLinePlot[{sol[[All,1]],sol[[All,2]]},Frame->True,PlotRange->{All,{-2,2}},AspectRatio->1.0,PlotMarkers->{"•",12},FrameLabel->{n,"(Subscript[x, n]), (Subscript[y, n])"},PlotRange->{{0,iter},All},PlotLegends->{"(Subscript[x, n])","(Subscript[y, n])"},LabelStyle->20,ImageSize->410];
xp=ListLinePlot[sol[[All,1]],Frame->True,PlotRange->{All,{-2,2}},AspectRatio->1.0,PlotMarkers->{"•",12},FrameLabel->{n,"(Subscript[x, n])"},PlotRange->{{0,iter},All},LabelStyle->20,ImageSize->410,PlotStyle->Black];
yp=ListLinePlot[sol[[All,2]],Frame->True,PlotRange->{All,{-1,1}},AspectRatio->1.0,PlotMarkers->{"•",12},FrameLabel->{n,"(Subscript[y, n])"},PlotRange->{{0,iter},All},LabelStyle->20,ImageSize->410,PlotStyle->Black];
Grid[{{Show[att2,fixedp],yp},{xp,ip}},Frame->All],
{{point,{0.5,0.5}},Locator},
{{a,1.4,"Parameter a"},0,4,Appearance->"Labeled"},
{{b,0.3,"Parameter b"},0,4,Appearance->"Labeled"},
{{iter,15,"Number of iterations n"},0,50,1,Appearance->"Labeled"},
SaveDefinitions->True,TrackedSymbols:>{point,a,b,iter}]

Iterations of the map, PERIODIC – period-2 cycle

Clear[x,y,n,a,b]
a=0.43;
b=0.4;
iter=70;

sol=RecurrenceTable[{
x[n+1]==1-a x[n]^2+y[n],
y[n+1]==b x[n],
x[0]==-0.7,
y[0]==-0.5},
{x,y},{n,0,iter}];

fixedpoints=Quiet[Solve[{x==1-a x^2+y,y==b x},{x,y}]];
coordinates={x,y}/.fixedpoints;
fixedp=Graphics[{PointSize[0.02],Red,Point[coordinates]}];

att2=ListPlot[sol,PlotMarkers->{"•",14},PlotStyle->Black,Frame-> True,FrameLabel->{x,y},LabelStyle->20];
Show[att2,fixedp,PlotRange->All]
StringForm["Fixed points' coordinates: ``",coordinates]

ListLinePlot[{sol[[All,1]],sol[[All,2]]},PlotMarkers->{"•",14},AxesLabel->{n,"(Subscript[x, n]), (Subscript[y, n])"},PlotRange->{{0,iter},{-0.5,1.7}},PlotLegends->{"(Subscript[x, n])","(Subscript[y, n])"},LabelStyle->20,ImageSize->500]

Orbit diagrams

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[{{ODxa,ODxb},{ODya,ODyb}},Frame->All]

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