(*^

::[	frontEndVersion = "Macintosh Mathematica Notebook Front End Version 2.1";
	macintoshStandardFontEncoding; 
	paletteColors = 128; automaticGrouping; currentKernel; 
	fontset = title, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e8,  24, "Times"; ;
	fontset = subtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e6,  18, "Times"; ;
	fontset = subsubtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, e6,  14, "Times"; ;
	fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, a20,  18, "Times"; ;
	fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, a15,  14, "Times"; ;
	fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, a12,  12, "Times"; ;
	fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  10, "Times"; ;
	fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L-5,  12, "Courier"; ;
	fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5,  12, "Courier"; ;
	fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, R65535, L-5,  12, "Courier"; ;
	fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5,  12, "Courier"; ;
	fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, B65535, L-5,  12, "Courier"; ;
	fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287,  12, "Courier"; ;
	fontset = name, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic,  10, "Geneva"; ;
	fontset = header, inactive, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = leftheader, inactive, L2,  12, "Times"; ;
	fontset = footer, inactive, noKeepOnOnePage, preserveAspect, center, M7,  12, "Times"; ;
	fontset = leftfooter, inactive, L2,  12, "Times"; ;
	fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  10, "Times"; ;
	fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
	fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7,  12, "Times"; ;
]
:[font = special1; inactive; preserveAspect; ]
                   Sequences -- Classifying 2-Cycles -- Answer 3
                           
The cell below finds the equilibrium points and the 2-cycles for the model

                        R(p) = 0.5 + 0.0015 p - 0.000001166667 p (p - 500)
 
                        f(p) = R(p) p
                          
                        p(n + 1) := f(p(n))
                        
Evaluate it now.  Notice that the output is two lists -- EqPoints, a list of equilibrium points -- and AllPoints, a list of the points that are either in 2-cycles or equilibrium points.  The next cell picks one of the 2-cycle points that is not an equilibrium point.  Either one of these true 2-cycle points will do.  That cell was written after looking at the output from the cell immediately below this one.  Evaluate that cell after evaluating the cell immediately below this one and checking that a true 2-cycle point will be chosen.
;[s]
9:0,1;93,0;169,1;284,0;311,1;380,2;398,3;720,4;789,2;918,-1;
5:2,13,9,Times,0,12,0,0,0;3,13,9,Times,1,12,0,0,0;2,13,9,Times,1,12,65535,0,0;1,13,9,Times,1,12,0,0,65535;1,13,9,Times,1,12,65535,0,65535;
:[font = input; preserveAspect; ]
Clear[R, f, AllPoints, EqPoints]

R[p_] :=  0.5 + 0.0015 p - 0.000001166667 p (p - 500)

f[p_] := R[p] p

EqPoints = Table[p /.Solve[f[p] == p, p]];

AllPoints = Table[p /. Solve[f[f[p]] == p, p]];

EqPoints

AllPoints
;[s]
3:0,0;43,1;87,0;219,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,9,Times,1,12,0,0,0;
:[font = input; preserveAspect; ]
(* This cell picks one of the true 2-cycle points.   *)
(* You may have to change it.  It picks one of       *)
(* the solutions of f[f[p]] == p that is not an      *)
(* equilibrium point.                                *)
(*                                                   *)
(* The 6 chooses the sixth item in the list,         *)
(* AllPoints of solutions of f[f[p]] == p.           *)

Clear[Cycle]

Cycle = AllPoints[[6]] 
;[s]
6:0,1;287,2;288,1;393,0;426,2;427,0;431,-1;
3:2,12,10,Courier,1,12,0,0,0;2,12,10,Courier,1,12,65535,0,0;2,12,10,Courier,1,12,0,0,65535;
:[font = special1; inactive; preserveAspect; ]
The next cell calculates the derivative of the function  f[f[p]]  and then evaluates this derivative at the true 2-cycle point chosen above. Evaluate the next cell now.
;[s]
4:0,0;57,1;65,0;141,2;169,-1;
3:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0;1,13,9,Times,1,12,65535,0,0;
:[font = input; preserveAspect; ]
Clear[fp]

fp[p_] = D[f[f[p]], p];

fp[Cycle] 
:[font = special1; inactive; preserveAspect; ]
Notice that the derivative is less than one in absolute value, so this 2-cycle is attracting.

The next cell gives an example with an initial condition so high that the population drops below the "threshold" and dies out.  Evaluate the next cell now.
;[s]
3:0,0;223,1;250,0;251,-1;
2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,65535,0,0;
:[font = input; preserveAspect; ]
Clear[pop]

pop[1] := 2000

pop[n_] := f[pop[n - 1]]

TableForm[Table[{i, pop[i]}, {i, 1, 20}]]

ListPlot[Table[{i, pop[i]}, {i, 1, 20}],
         PlotRange -> {0, 2000},
         PlotJoined -> True]
^*)