How to draw discrete dynamic systems in mathematica

Question

How to find invariant sets in nonlinear discrete dynamical systems. How to draw discrete dynamic systems in mathematica? $$x[n+1]=f(x[n],y[n]), y[n+1]=g(x[n],y[n])$$ example $$x[n+1]=0.9*y^2[n]/(y[n]+2)+x[n]*(1-0.8/(1+x[n]))$$ $$y[n+1]=0.8*x[n]/(1+x[n])+0.6*y[n]$$

Answer 1

Play with the following example:

$$ \begin{eqnarray} x(n+1)&=&rx(n)(1-y(n))\\ y(n)&=&x(n), \end{eqnarray} $$ with $r=\displaystyle\frac{2005}{1000}$ and three orbits.

The phase portrait of our discrete dynamical system:

With[{a = 2005/1000, icv = {{0.35, 0.5}, {0.36, 0.51}, {0.51, 0.51}}, 
niterates = {{n, 3000, 5000}, {n, 1, 480}, {n, 1, 1200}}, points = {300, 450, 200},
orbitstyle = {{Black, PointSize[0.0045]}, {Red, 
PointSize[0.0045]}, {Blue, PointSize[0.0045]}}},
fp = Part[{x, y} /. 
NSolve[{a x (1 - y) - x, x - y} == {0, 0} && x > 0 && y > 0, {x, y}], 1]; 
Show@Table[
ListPlot[
RecurrenceTable[{x[n + 1] == a x[n] (1 - y[n]), y[n + 1] == x[n], 
{x[0], y[0]} == {Part[icv[[i]], 1], Part[icv[[i]], 2]}}, {x, y}, niterates[[i]]], 
PlotRange -> All, MaxPlotPoints -> points[[i]], Axes -> False, 
PlotStyle -> orbitstyle[[i]], AspectRatio -> 1, Frame -> True, 
LabelStyle -> Directive[Black, Tiny], 
FrameStyle -> Directive[Black], 
Epilog -> {{PointSize[0.012], Black, 
Point[fp]}, {PointSize[0.006], White, Point[fp]}}, 
Background -> Lighter[Gray, 0.95], ImageSize -> Medium], {i, 1, Length[icv]}]]

Enjoy playing with this example!

Your discrete system with many initial conditions:

a = 1.15; b := 0.9;
ListPlot[Table[RecurrenceTable[{x[n + 1] == (a y[n])/(1 + x[n]^2), y[n + 1] == (b x[n])/(1 + y[n]^2), x[0] == m, y[0] == m}, {x, y}, {n, 1, 1000}], {m, -0.3, 0.3, 0.01}], PlotRange -> {{-0.55, 0.55}, {-0.55, 0.55}}, LabelStyle -> Directive[White, Tiny], Background -> GrayLevel[0.1]]

Answer 2

Simpler to ask: Find the subset of a bounded set in $\mathbb{R}^2$, such that the iterates:

$$f(x_{n+1},y_{x+1})=\{g(x_{n},y_n\},h(x_n,y_n)\}$$

remain in the set for some non-linear functions $g$ and $h$.

Take this example: Forward Invaraiant sets

with:

$$f(x,y)=\bigg\{\frac{y}{1+x^2},\frac{0.9 x}{1+y^2}\bigg\}$$

Ok, now just run it through the iterates in the circular region of the reference. Just start with a few points, or even one say $\{x_0,y_0\}=\{-0.5,-0.5\}$:

a = 1.0;
b = 0.9;
myf[{x_, y_}] = {(a y)/(1 + x^2), (b x)/(1 + y^2)}
myList = NestList[myf, {-0.5, -0.5}, 20]
{{-0.5,-0.5},{-0.4,-0.36},{-0.310345,-0.318697}, 

{-0.290699,-0.253557},{-0.2338,-0.245824}, {-0.233083,-0.198429},{-0.188204,-0.201828}, {-0.194924,-0.162754},{-0.156796,-0.170905}, {-0.166804,-0.137112},{-0.1334,-0.147353}, {-0.144777,-0.117509},{-0.115096,-0.128524}, {-0.126844,-0.101903},{-0.10029,-0.112986}, {-0.111861,-0.0891231},{-0.0880217,-0.0998817}, {-0.0991138,-0.078437},{-0.077674,-0.088657}, {-0.0881253,-0.0693614},{-0.0688269,-0.078933}}

Notice they're staying in the region. Try to iterate it to say 200 maybe, then create an array of points in the region to test. Now add a check using NestWhileList which would check if the next iterate stays in the region. Create an array of say 100000 points in the region {{-2,2},{-2,2}} and iterate. Some points will remain in the set some will escape. Flag the ones that stay in the region after 200 iterations. Now plot those points via say the ListPlot function. Keep studying it programatically this way.

It's a start.

Answer 3

Perhaps this can start you:

Your system:

f[a_, b_, n_] := 
 NestList[{0.9 #[[2]]^2/(#[[2]] + 2) + (1 - 0.8/(1 + #[[1]])) #[[1]],
    0.8 #[[1]]/(1 + #[[1]]) + 0.6 #[[2]]} &, {a, b}, n]

Fixed points:

pts = NSolveValues[f[s, t, 1][[2]] == {s, t}, {s, t}]

Visualizing behaviour in relation to fixed points:

res = Table[f[i, j, 20], {i, 0, 10, 1}, {j, 0, 10, 1}];
p1 = ListPlot[Join @@ res, Joined -> True, 
  Epilog -> {PointSize[0.02], Black, Point[pts]}];
p1 /. Line[q__] :> {Arrowheads[{0.02, 0.02, 0.02}], Arrow[q]}