# How do I create cobweb iterations or stair steps **WITH ARROWS** to show attractive and repulsive fixed points for a graph? [closed]

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?

I want it to look like this

• 1. Please don't post screenshot of code, post the code text. 2. Have you read the posts linked under your previous question?: mathematica.stackexchange.com/q/277863/1871 Dec 29, 2022 at 6:08

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},
Darker[Green, .5],
Arrow /@ Partition[strand1, 2, 1],
Red,
Arrow /@ Partition[strand2, 2, 1]}]]]


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]

• Thank you so much. That's a great help!
– boii
Dec 31, 2022 at 6:29
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],
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]
`

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