Project Help Notebook by Keith Stroyan

Help NoteBook Copyright 1998 by Academic Press, Inc. - All rights reserved.
Modify this Notebook to prepare your project report.

Project 18: Repeated Exponents

by A. Student and B. Pupil

with technical help from Da LabMonitor and Help Notebook

Use of  cobWeb[ f, initP, nrIter, pmax ] is described in a sample.

Needs["Graphics`Colors`"];

Off[General::spell1];
BeginPackage["Cobwebs`"];

cobWeb::usage = "cobWeb[f, p1, itnum, pmin,pmax, opns] calculates itnum
iterates of the discrete dynamical system p[i] = p[i-1] + f[ p[i-1] ]
beginning at p1 and draws a graph of the resulting 'cobweb'.  pmin, pmax
and opns are parameters that specify a range for the p-axis and
any options to use in drawing the plots.  cobWeb returns a list of
the iterates it calculates.";

Begin["`Private`"];

maxf[ g_,pmin_ , pmax_ ] :=
Module[ {prange, funcvalues},
		prange = Range[pmin, pmax, pmax/100] ;
		funcvalues = Map[ g[#]&, prange ] ;
		Max[ funcvalues, pmax ]
	]
minf[ g_, pmin_ , pmax_ ] :=
Module[ {prange, funcvalues},
		prange = Range[pmin, pmax, pmax/100] ;
		funcvalues = Map[ g[#]&, prange ] ;
		Min[ funcvalues, pmin ]
	]

makeWeb[ iterates_List, p1_ ] :=
Module[ {linepoints, funcpoints, pathpoints, depth},
		linepoints = Drop[ Transpose[ {iterates, iterates} ],
								1 ] ;
		funcpoints = Partition[ iterates, 2, 1 ] ;
		pathpoints = { } ;
		depth = Length[funcpoints] ;
		Do[
			AppendTo[ pathpoints,
				{funcpoints[[i]], linepoints[[i]]} ],
			{i, 1, depth}
		] ;
		pathpoints = Flatten[pathpoints, 1] ;
		pathpoints = PrependTo[pathpoints, {p1, 0} ] ;
		Line[Drop[pathpoints, -1]]
	]
	
cobWeb[ f_, p1_, itnum_, pmin_, pmax_,color___ ] :=
Module[ {iterates, path,ymin,ymax,gPlot},
	g[p_] := p + f[p] ;
	ymin = minf[ g, pmin,pmax ] ;
	ymax = maxf[ g, pmin,pmax ] ;
	gPlot=	Plot[ {p, g[p]}, {p, pmin, pmax}, 
			PlotRange -> {{pmin, pmax}, {ymin, ymax}},
			AxesOrigin -> {0, 0}, AspectRatio->Automatic,
			DisplayFunction->Identity ] ;
					
		iterates = NestList[ g, p1, itnum ] ;
		path = makeWeb[ iterates, p1 ] ;
Return[
{Show[gPlot,Graphics[{color,path}],DisplayFunction->$DisplayFunction],
		iterates}]
	]
	
End[ ];

EndPackage[ ] ;
On[General::spell1];

My Project Introduction

Write this last.  Begin with the basic question and state your main finding clearly, but with few technical details.  You might even modify the title of this section to make it more interesting.

Beginning Explorations

Hint 18.1

Read the project and solve the hint by hand.  Then try the following.

\(Clear[p, t, g, a0]; 
g[p_] := b\^p\)p[0] = a0p[t_] := g[p[t - 1]]p[1]p[2]p[3]p[10]

Mathematica is based on "re-writing rules," so if we simply tell Mathematica the rules (at  t  looking back at  t-1)  and ask for  p[3], it will look up p[3-1], if it knows it stop, otherwise, look up  p[2-1], etc. until it comes to  p[0] which it knows.

To learn about the recursive sequences

(Subscript[a, 0]),  (Subscript[a, 1]) = g[(Subscript[a, 0])],  
    (Subscript[a, 2]) =  g[(Subscript[a, 1])]  =  g[g[(Subscript[a, 0])]],   ...

see the main text CD Chapter 20.

Plots

Plot some special cases to try to get an idea of when this converges and when it diverges.

a0=1;
b=1.2;
first=ListPlot[ Table[p[t],{t,1,10}],PlotStyle->Red,Prolog->AbsolutePointSize[4]];

a0=1;
b=0.8;
second=ListPlot[ Table[p[t],{t,1,10}],PlotStyle->Blue,Prolog->AbsolutePointSize[4]];

Show[first, second];

Hint 18.2, 18.3

Read the project and solve the hint by hand.  Try the following.

Plot[{x, (3^x)}, {x, -1, 1}, PlotStyle -> {Red, Blue}, 
      AxesLabel -> {"x", "y"}, AspectRatio -> Automatic];

Plot[{x, (((1.1))^x)}, {x, -5, 5}, PlotStyle -> {Red, Blue}, 
      AxesLabel -> {"x", "y"}, AspectRatio -> Automatic];

Plot[{x, (((0.7))^x)}, {x, -5, 5}, PlotStyle -> {Red, Blue}, 
      AxesLabel -> {"x", "y"}, AspectRatio -> Automatic];

Why Solve  x = g[x]?

The main text CD Chapter 20 shows that if the sequence

(Subscript[a, 0]),  (Subscript[a, 1]) = g[(Subscript[a, 0])],  
    (Subscript[a, 2]) =  g[(Subscript[a, 1])]  =  g[g[(Subscript[a, 0])]], 
    (Subscript[a, 3]) =  g[(Subscript[a, 2])]  =  g[g[(Subscript[a, 1])]]  =  g[g[g[(Subscript[a, 0])]]],   ...

converges, (Subscript[a, n]) -> (Subscript[a, ∞])  as  n->∞, then  g[(Subscript[a, ∞])]= (Subscript[a, ∞]).  Solutions to  g[x] = x are thus potential limits for the sequence.  Explain this for your project.

The iteration approach to solving discrete dynamical systems can be viewed as a "cobweb" winding around the graph  q = g[p]  and  the graph  q = p.  This is explained in detail in Chapter 20.

Cobwebs

The cobweb program from Chapter 20 contains the following related information.

The change form of a dynamical system is:

p[0] = P0
	p[t+1] = p[t] + f[p[t]]

where the function  f[p]  is known.  From the value of p[0] and the change law, we compute

p[1] = p[0] + f[p[0]]
	p[2] = p[1] + f[p[1]]
	p[3] = p[2] + f[p[2]]
	p[4] = p[3] + f[p[3]], etc.

If we define the iteration function  g[p] = p + f[p], this can be written

p[1] = g[p[0]]
	p[2] = g[p[1]] = g[ g[p[0] ]
	p[3] = g[p[2]] = g[ g[ p[1]] ] = g[ g[ g[p[0] ] ] ]
	p[4] = g[ g[ g[ g[p[0] ] ] ] ], etc.,
	p[n] = g[g[ ...n-times ...p[0]...]]

The cobWeb[.] function requires you to define  f[p] = (b^p) - p .  The package itself defines the iteration function  g[p] = p + f[p] = (b^p).

The "Cob Web" process needs the initial value of  p, p[0] = P0 as a specific number.  This is the
second variable in the cobWeb[f,initP,.] function.  The third variable is the number of times you wish to iterate the process.  The fourth variable is the maximum value of  p  in your graph.  To solve  15  steps of the problem of repeated exponents we simply <Enter> the instructions in the next input cell (provided  cobWeb[·] was initialized above.):

\(Clear[f, p]; 
f[p_] := b\^p - p; 
b = 1.4; 
initP = 1; 

    nrIter = 15; 
\(pMin = 0; \)\)\(pMax = \ 3; 
soln = cobWeb[f, initP, nrIter, pMin, pMax]\)

Following is a plot of the sequence vs index from the cobweb solution.

ListPlot[soln[[2]], Prolog -> AbsolutePointSize[4], 
      PlotStyle -> Brick];

Hint 18.5 Solving  x = (b^x)

Read the printed project Hint 18.5.  Find the largest value of  b  so that  x = (b^x)  has a solution.  (Hint use calculus to "say" the curve "just touches.")

\(b = 1.1; 

    Plot[{Log[b], Log[x]\/x}, {x,  .1, 5}, PlotStyle -> {Red, Blue}, 
      AxesLabel -> {"x", "y"}, AspectRatio -> Automatic]; \)

Stability and the Lowest b

Read the main text CD Section 20.4 on the local stability theorem for discrete dynamical systems

(Subscript[a, 0]),  (Subscript[a, 1]) = g[(Subscript[a, 0])],  
    (Subscript[a, 2]) =  g[(Subscript[a, 1])]  =  g[g[(Subscript[a, 0])]], 
    (Subscript[a, 3]) =  g[(Subscript[a, 2])]  =  g[g[(Subscript[a, 1])]]  =  g[g[g[(Subscript[a, 0])]]],   ...

and apply the result to the case  g[x]  =  (b^x)

Hint 18.6

Solve this problem and write your answer.

Samples

\(Clear[f, p]; 
f[p_] := b\^p - p; 
b = 0.065988; 
initP = 1; 

    nrIter = 50; 
pMin = 0; 
\(pMax = \ 3; 

    soln = cobWeb[f, initP, nrIter, pMin, pMax]; 

    points = ListPlot[soln[\([2]\)], PlotStyle -> Brick, 
        DisplayFunction -> Identity]; 

    connexions = 
      ListPlot[soln[\([2]\)], PlotJoined -> True, PlotStyle -> SandyBrown, 
        DisplayFunction -> Identity]; 

    Show[points, connexions, Prolog -> AbsolutePointSize[4], 
      DisplayFunction -> $DisplayFunction]; \)\)