Henon Map

Mapping Function

Clear[T, α, x, y]
\(T[x_, 
        y_, α_] := {x\ Cos[α]\  - \ \((y - 
                x^2)\)\ Sin[α], 
			\ \ \ \ x\ Sin[α]\  + \ \((y\  - \ x^2)\)\ Cos[α]}\)

Henon Mapping Properties

Test Area Preserving

Clear[jacMat]
jacMat[x_, y_, α_] := 
      Transpose[{D[T[x, y, α], x],  
          D[T[x, y, α], y]}]

jacMat[x, y, α] // MatrixForm

Det[jacMat[x, y, α]]

Find Fixed Points  x*=Tx*

Clear[fixedP]
fixedP  = 
      Simplify[Solve[
          T[x, y, α]  ==  {x, y}, {x, y}]]

Plot[{2 Tan[(α/2)], 2 Tan[(α/2)]^2}, {α, 0, 
        2  Pi}]

Find First Order Behavior Around the Fixed Points

Clear[pointCond]
pointCond [x_, y_, α_, n_] := 
      jacMat[x, y, α] /. fixedP[[n]]

pointCond[x, y, α, 1] // MatrixForm

Simplify[ComplexExpand[pointCond[x, y, α, 2]]] // 
      MatrixForm

Eigenvalues[pointCond[x, y, α, 1]]

Eigenvectors[pointCond[x, y, α, 1]]

Simplify[Eigenvalues[pointCond[x, y, α, 2]]]

Simplify[Eigenvectors[pointCond[x, y, α, 2]]]

Second Order Mapping Function

Clear[T2, α, x, y]

T2[x_, y_, α_] := 
      T[T[x, y, α][[1]], T[x, 
            y, α][[2]], α]

T2[x, y, α]

Henon Mapping Properties

Test Area Preserving

Clear[jacMat]
jacMat[x_, y_, α_] := 
      Transpose[{D[T2[x, y, α], x],  
          D[T[x, y, α], y]}]

Det[jacMat[x, y, α]]

Find Fixed Points

Clear[fixedP2, α]
fixedP2[α_] := 
      Simplify[Solve[
          T2[x, y, α]  ==  {x, y}, {x, y}]]

2 More fixed points !

fixedP2[α]

Domain

Clear[td, ic, α, x, y]
td[x_, 
        y_, α_] := T[x, y, α] /; -1 < x < 
            1  /; -1 < y < 1

Test

td[1, 1, α]

td[ .5,  .5, α]

DeleteCases[{td[ .5,  .5, α], td[ .7,  .7, α], 
        td[1, 1, α]}, td[_, _, _]]

Domain Picture

Clear[g]
g = 
      Graphics[{RGBColor[ .5,  .5,  .5], 
          Line[{{-1, -1}, {1, -1}, {1, 1}, {-1, 
                1}, {-1, -1}}],  RGBColor[0, 0, 0], 
          Text["{-1,-1}", {-1, -1}, {-1, -1}], 
          Text["{-1,1}", {-1, 1}, {-1, 1}], 
          Text["{1,1}", {1, 1}, {1, 1}], 
          Text["{1,-1}", {1, -1}, {1, -1}]}, 
        AspectRatio -> 1]

Show[g];

Initial Conditions

Line

Clear[linef]
linef[x_] := x* .8
linef2[x_] := -x* .7  +  .3

Line Picture

line  = 
        Plot[linef[x], {x, -1, 1},  AspectRatio -> 1, 
          AxesLabel -> {x, y}, 
          PlotRange -> {{-1, 1}, {-1, 1}}, 
          Axes -> False];

lineic  = Show[line, g]

Circle

Clear[circletopf, circlebotf]
circletopf[x_]  :=  Sqrt[ .7^2  -  x^2]
circlebotf[x_]  := -Sqrt[ .7^2  -  x^2]

Circle Picture

circle  =  
      Plot[{circletopf[x], circlebotf[x]}, {x, -1, 1}, 
        AxesLabel -> {x, y}, AspectRatio -> 1, 
        PlotRange -> {{-1, 1}, {-1, 1}}, 
        Axes -> False]

circleic  = Show[circle, g]

Sin

sinf[x_] := Sin[x*Pi]
sin2f[x_] := Sin[x*Pi/3 +  .3]
cosf[x_] := Cos[x*Pi]

Sin Picture

sin  =  
        Plot[sinf[x], {x, -1, 1}, AxesLabel -> {x, y}, 
          AspectRatio -> 1, 
          PlotRange -> {{-1, 1}, {-1, 1}}, 
          Axes -> False];

sinic  = Show[sin, g]

Discretize The Initial Conditions

Clear[a, b, c, d, e, f, nextStep, ns, ic, graphPoints,  icLine, icSin, 
      icCircle, step]

nextStep[x_, y_, α_] := 
      Thread[Sequence[
          DeleteCases[Thread[td[x, y, α]], 
            td[_, _, _]]]]
ns[ic_, α_]  := 
      nextStep[ic[[1]], 
        ic[[2]], α]

ic[f_, step_] := {Range[-1, 1, step], 
        Table[f[i], {i, -1, 1, step}]}

Initial Conditions

Clear[icLine, icLine2, icSin, icCircle]
icLine[step_]  :=  {Range[-1, 1, step], 
        Table[linef[i], {i, -1, 1, 
            step}]}

icLine2[step_]  :=  {Range[-1, 1, step], 
        Table[linef2[i], {i, -1, 1, 
            step}]}

icSin[step_]  :=  {Range[-1, 1, step], 
        Table[sinf[i], {i, -1, 1, 
            step}]}

icCircle[
        step_]  :=  {Flatten[{Range[- .7,  .7, step], 
            Range[- .7,  .7, step]}], 
        Flatten[{Table[circletopf[i], {i, - .7,  .7, step}], 
            Table[circlebotf[i], {i, - .7,  .7, step}]}]}

Test Iterations

Graphs of Initial Conditions and First Iteration

graphPoints[ic_, α_] := 
      Show[ListPlot[Thread[ic], PlotRange -> {{-1, 1}, {-1, 1}}, 
          AspectRatio -> 1], Graphics[RGBColor[0, 0, 1]], 
        ListPlot[Thread[ns[ic, α]], 
          PlotRange -> {{-1, 1}, {-1, 1}}, 
          AspectRatio -> 1]]

Line

graphPoints[icLine[ .001],  .5]

Circle

ListPlot[DeleteCases[Thread[icCircle[ .001]], {_, _Complex}], 
      PlotRange -> {{-1, 1}, {-1, 1}}, 
      AspectRatio -> 1]

Sin

graphPoints[icSin[ .001], 0.5]

Vary Alpha

alpha1  =  ArcCos[- .05];
alpha2  =  ArcCos[ .4];
alpha3  =  ArcCos[ .24];

Iterate to Find Solution

\(iterateHenon[ic_, nmax_, α_] := 
	
      Module[
	{n = 0, 
          g = ListPlot[DeleteCases[Thread[ic], {_, _Complex}], 
              AspectRatio -> 1, 
              PlotRange -> {{\(-1\), 1}, {\(-1\), 1}}], 
          nextS = ic}, 
	{While[
            n < nmax, 
	{nextS\  = \ 
                ns[nextS, α], 
	
              g\  = \ Flatten[{g, Graphics[Hue[n/nmax]], 
                    ListPlot[DeleteCases[Thread[nextS], {_, _Complex}], 
                      AspectRatio -> 1, Axes -> True, 
                      PlotRange -> {{\(-1\), 1}, {\(-1\), 1}}, 
                      DefaultColor -> 
                        Hue[n/nmax]]}], 
	
              n = n + 1}], 
Show[
            Flatten[{Graphics[PointSize[0.001]], g}], AspectRatio -> 1, 
            Axes -> True, 
            PlotRange -> {{\(-1\), 1}, {\(-1\), 1}}]}]\)

Clear[plotIcColor]
plotIcColor[ic_] := 
      Module[{initial  = DeleteCases[Thread[ic], {_, _Complex}] }, 
        Thread[{Map[Hue, Range[0, 1, 1/(Length[initial] - 1)]], 
            Map[Point, initial]}]]

Show[Map[Graphics, plotIcColor[icLine[ .01]]]]

\(iterateHenon2[ic_, nmax_, α_] := 
	
      Module[
	{n = 0, g = plotIcColor[ic], 
          nextS = ic}, 
	{While[
            n < nmax, 
	{nextS\  = \ 
                ns[nextS, α], 
	
              g\  = Flatten[{g, plotIcColor[nextS]}], 
	
              n = n + 1}], 
Show[
            Map[Graphics, Flatten[{PointSize[ .005], g}]], 
            AspectRatio -> 1, 
            PlotRange -> {{\(-1\), 1}, {\(-1\), 1}}]}]\)

Output

iterateHenon2[icLine[ .01], 100, ArcCos[- .05]]

iterateHenon2[icSin[ .001], 100, ArcCos[- .05]]

iterateHenon2[icLine[ .01], 100, alpha2]

iterateHenon2[icLine[ .01], 100, alpha3]

iterateHenon2[icLine2[ .01], 100, alpha3]

iterateHenon2[icCircle[ .01], 100, alpha2]

iterateHenon2[icCircle[ .01], 100, alpha3]

iterateHenon2[icSin[ .01], 100, alpha3]

iterateHenon2[ic[sin2f,  .01], 100, alpha3]

iterateHenon2[ic[cosf,  .01], 100, alpha3]