-2
$\begingroup$

I'm new to Mathematica, so I would appreciate any help. How do I create cobweb iterations or stair steps WITH ARROWS to show attractive and repulsive fixed points for this graph? enter image description here

I want it to look like this enter image description here

$\endgroup$
1

2 Answers 2

5
$\begingroup$

If we have two functions that we're "bouncing" between, then at each step we can solve for how to move horizontally or vertically from one function to the other. We need to know whether for any particular step we should move horizontally or vertically, and one way to do that would be to keep a counter. So, we might have a function like this:

NextPoint[fn1_, fn2_][{step_, coords : {x_, y_}}] :=
  Switch[
    Mod[step, 2],
    0, {1 + step, {x, fn1[x]}},
    _, {1 + step, {First@Nearest[SolveValues[fn2[\[FormalX]] == y, \[FormalX]], x], y}}]

With that we can Nest as many times as we want. Let's package this up into its own function:

WebStrand[fn1_, fn2_, xInit_, segmentCount_] :=
  NestList[NextPoint[fn1, fn2], {0, {xInit, 0}}, segmentCount][[All,2]]

Let's try it out:

WebStrand[Exp[.3 #] &, Identity, 5.5, 10]

{{5.5,0},{5.5,5.20698},{5.20698,5.20698},{5.20698,4.7688},{4.7688,4.7688},{4.7688,4.18137},{4.18137,4.18137},{4.18137,3.50577},{3.50577,3.50577},{3.50577,2.8626},{2.8626,2.8626}}

We can turn this into a Line directly, but we can also pretty easily make it a sequence of Arrows:

Graphics[Arrow /@ Partition[WebStrand[Exp[.3 #] &, Identity, 5.5, 10], 2, 1]]

But you want a plot. Well, we can use Epilog to add graphics elements to a Plot. I'll jump ahead a few steps:

With[
  {curveFn = Exp[.3 #] &,
   lineFn = Identity,
   strand1Start = 5.5,
   strand2Start = 6.3},
  With[
    {strand1 = WebStrand[curveFn, lineFn, strand1Start, 10],
     strand2 = WebStrand[curveFn, lineFn, strand2Start, 10]},
    Plot[
      {lineFn[x], curveFn[x]}, {x, 0, 8},
      AspectRatio -> Automatic,
      PlotRange -> {0, 10},
      Epilog -> {Arrowheads[.025], 
                 Darker[Green, .5], 
                 Arrow /@ Partition[strand1, 2, 1],
                 Red, 
                 Arrow /@ Partition[strand2, 2, 1]}]]]

enter image description here

At this point, you'll need to do the tedious work of adding your labels and exact styling.

UPDATE

The generalization to "bouncing" between any two functions was probably a step too far. You could use an alternate version of WebStrand:

WebStrand[fn_, xInit_, stepCount_] :=
  ReplacePart[
    Partition[
      Rest@FoldPairList[
             {#1, #2} &, 
             Null, 
             NestList[fn, xInit, stepCount],
             Splice], 
      2, 1], 
  {1, 2} -> 0]
$\endgroup$
1
  • $\begingroup$ Thank you so much. That's a great help! $\endgroup$
    – boii
    Dec 31, 2022 at 6:29
3
$\begingroup$
Clear["Global`*"]

Without the arrows just use ResourceFunction["CobwebPlot"]

f = Exp[0.23 #] &;
pt1 = {#, f@#} &;
pt2 = {#, #} &;

fixedPts = {x, x} /.
    Solve[{x == f[x], 0 < x < 15}, x] // Quiet;

start1 = 9;
start2 = 10.6;

iter1 = Most@Flatten[
    (Arrow /@ {{pt1@#[[1]], pt2@#[[2]]},
         {pt2@#[[2]], pt1@#[[2]]}}) & /@ 
     Partition[NestList[f, start1, 6], 2, 1], 1];

iter2 = Most@Flatten[
    (Arrow /@ {{pt1@#[[1]], pt2@#[[2]]},
         {pt2@#[[2]], pt1@#[[2]]}}) & /@ 
     Partition[NestList[f, start2, 3], 2, 1], 1];

Labeled[Plot[{x, f@x}, {x, -2, 15},
  PlotRange -> {-1, 25}, AxesOrigin -> {0, 0},
  PlotStyle -> {{Lighter[Gray, 0.5], Dashed}, Blue},
  AspectRatio -> 1, Ticks -> None,
  Epilog -> {AbsolutePointSize[4],
    Arrowheads[Small],
    Darker[Green], Point[{start1, 0}],
    Text[HoldForm[Subscript[y, n]],
     {start1, 0}, {-2, -1.5}],
    Arrow[{{start1, 0}, pt1@start1}],
    Point[fixedPts[[1]]],
    Text[HoldForm@Subscript[P, 1],
     fixedPts[[1]], {1, -1.5}], iter1,
    Text[HoldForm@Subscript[y, n + 1],
     {0, f@start1}, {1.5, 0}],
    {Opacity[0.5], Dotted,
     Line[{pt1@start1, {0, f@start1}}]},
    Orange, Point[{start2, 0}],
    Text[HoldForm@Subscript[OverTilde@y, n],
     {start2, 0}, {-2, -1.5}],
    Arrow[{{start2, 0}, pt1@start2}],
    Point[fixedPts[[2]]],
    Text[HoldForm@Subscript[P, 2],
     fixedPts[[2]], {1, -1.5}], iter2,
    Text[HoldForm@
      Subscript[OverTilde@y, n + 1],
     {0, f@start2}, {1.5, 0}],
    {Opacity[0.5], Dotted,
     Line[{pt1@start2, {0, f@start2}}]},
    Blue,
    Text[StringForm["`` \[LongEqual] ``",
      HoldForm@Subscript[y, n + 1],
      HoldForm@r@Subscript[y, n]], {4, 20}]}], 
 Style[StringForm[
   "Cobweb iteration of sequence with an attractive (``) and a repulsive (``) \
fixed points.",
   HoldForm[Subscript[P, 1]],
   HoldForm[Subscript[P, 2]]], 8], Bottom]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thank you so much, that's a great help. $\endgroup$
    – boii
    Dec 31, 2022 at 6:30

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