1
$\begingroup$

With reference to "Non-linear Physics with Mathematica for Scientist and Engineers", I extrapolate the codes for a visualisation of an iterative cubic map but ran into problems.

f[x_] := (a - 1) x + a x^3;

a = 3.3; b = 0.2; total = 60;

g = Nest[f, x, 2];

pts = Flatten[NestList[f, {b, b, b, b}, total]];

pts2 = Partition[Drop[pts, 3], 2];

Block[{$DisplayFunction = Identity},
 gr[0] = ListPlot[{{b, 0}, {b, f[b]}}, Joined -> True, 
   PlotStyle -> {Hue[0.6]}];
 gr[1] = ListPlot[pts2, Joined -> True, PlotStyle -> {Hue[0.6]}];
 gr[2] = Plot[x, {x, 0, 1}, PlotStyle -> {Hue[1]}];
 gr[3] = Plot[f[x], {x, 0, 1}, PlotStyle -> {Hue[0.3]}];
 gr[4] = Plot[g, {x, 0, 1}, PlotStyle -> {Dashing[{0.2}]}]]


Show[Table[gr[i], {i, 0, 4}], AxesLabel -> {"X", " "}, 
 PlotRange -> {{0, 1}, {0, 1}}, 
 AspectRatio -> 1,
  Epilog -> {Text["g", {0.2, 0.85}, {0, -1}], 
    Text["f", {0.4, 0.8}, {0, -1}], Text["y=x", {0.86, 0.9}, {0, -1}],
     Text["\!\(\*SubscriptBox[\(X\), \(0\)]\)", {b + .3, 
      0.1}, {0, -1}], 
    TextStyle -> {FontFamily -> "Times", FontSize -> 16}, 
    ImageSize -> {500, 500}}]

The visual iteration is not performing as intended. I would like a forward iteration given any parameter a and initial point x0 such that the convergence (or divergence of fixed point) can be observed. The current visual iteration produces a 'broken' snap shot of all trajectories.

Any help is appreciated. Thanks in advance.

$\endgroup$
2
$\begingroup$

Your parameters result in overflow, so you need to fix it, but otherwise you can do something like that:

fp[x_, a_] := Nest[(a - 1) # + a #^3 &, x, 1]
gp[x_, a_] := Nest[fp[#, a] &, x, 2]

iterate[x0_, a_, n_] := Module[{trace},
  trace = Sequence @@ {##, {#[[2]], #[[2]]}} & /@ 
            NestList[{#[[2]], fp[#[[2]], a]} &, {x0, fp[x0, a]}, n - 1]; 
  Prepend[#, {x0, 0}] &@trace 
  ]

Manipulate[
 Show[
  Plot[{x, fp[x, a], gp[x, a]}, {x, 0, 1}, 
   AspectRatio -> 1, 
   PlotRange -> {{0, 1}, {0, 1}}, 
   PlotStyle -> {Hue[1], Hue[0.3], Dashing[{0.2}]}
   ],
  ListLinePlot[iterate[b, a, total], PlotRange -> {{0, 1}, {0, 1}}],
  Epilog -> {
    Text["y=x", {0.86, 0.9}, {0, -1}], 
    TextStyle -> {FontFamily -> "Times", FontSize -> 16}, 
    },
  ImageSize -> {500, 500}
  ],
  {{a, 1.5}, 1, 2, 0.01}, {{total, 10}, 1, 20, 1}, {{b, 0.2}, 0, 1}
 ]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.