(*********************************************************************** Mathematica-Compatible Notebook This notebook can be used on any computer system with Mathematica 3.0, MathReader 3.0, or any compatible application. The data for the notebook starts with the line of stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. ***********************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 20559, 568]*) (*NotebookOutlinePosition[ 21613, 604]*) (* CellTagsIndexPosition[ 21569, 600]*) (*WindowFrame->Normal*) Notebook[{ Cell[TextData["\nChapter Four:\n\nIterative Graphics"], "Title", Evaluatable->False, AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["4.1 Roses"], "Section", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "rect[theta_, r_] := {r Cos[theta], r Sin[theta]} //N\n\ ParametricPlot[rect[theta, Sin[2 theta]], {theta, 0, 2 Pi},\n\t\t\t\ Ticks->None, AspectRatio->1]"], "Input", AspectRatioFixed->True], Cell[TextData[ "rose[i_] := rect[i Degree, Sin[n i Degree]]\n\tAttributes[rose] = \ {Listable}"], "Input", AspectRatioFixed->True], Cell[TextData[ "n = 2;\nd = 71;\nwalk = Line[rose[Range[0, 360 d, d]]];\n\ Show[Graphics[{Thickness[.0005], walk}], AspectRatio->1]"], "Input", AspectRatioFixed->True], Cell[TextData[ "n = 2; d = 30;\n\ncosets = Table[Line[rose[Range[m, m+LCM[d, 360], d]]],\n\t\ \t\t{m, 0, 0}];\n\nShow[Graphics[{Thickness[.0005], cosets}], \ AspectRatio->1]"], "Input", AspectRatioFixed->True], Cell[TextData[ "n = 2; d = 180;\n\ncosets = Table[Line[rose[Range[m, m + LCM[d, 360], d]]],\n\ \t\t{m, 0, GCD[d, 360] - 1}];\n\nShow[Graphics[{Thickness[.0005], cosets}], \ AspectRatio->1]"], "Input", AspectRatioFixed->True], Cell[TextData[ "MaurerRose::usage = \"MaurerRose[n, d, z:360] shows the\nwalk along an n- \ (or 2n-) leafed rose in steps of d degrees \n(including cosets). Varying z \ changes the size of a 'degree'.\";\n\nMaurerRose[n_Integer, d_Integer, \ z_Integer:360] :=\n Block[{zz = If[!EvenQ[n] && z == 360, 180, z], cosets},\ \n\n rect[theta_, r_] := {r Cos[theta], r Sin[theta]} //N;\n\n rose[i_] \ := rect[i 2 Pi / z, Sin[n i 2 Pi / z]];\n\t\tAttributes[rose] = {Listable};\n\ \n cosets = Table[Line[rose[Range[m, m + LCM[d, zz], d]]],\n\t\t\t\t\t\t\t\t\ {m, 0, GCD[d, zz] - 1}];\n\n Show[Graphics[{Thickness[.0005], cosets}], \ AspectRatio->1]]"], "Input", AspectRatioFixed->True], Cell[TextData["MaurerRose[4,120];"], "Input", AspectRatioFixed->True], Cell[TextData["MaurerRose[6,72];"], "Input", AspectRatioFixed->True], Cell[TextData["MaurerRose[2,150]"], "Input", AspectRatioFixed->True], Cell[TextData["MaurerRose[90, 90, 359]"], "Input", AspectRatioFixed->True], Cell[TextData["MaurerRose[181, 90, 359]"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["4.2 The Cantor Function"], "Section", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "spawn[{a_Rational, b_Rational}] :=\n\tBlock[{w = (b - a)/3}, {{a - 2w, a - \ w}, {b + w, b + 2w}}]"], "Input", AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["spawn[{1/3, 2/3}]\t"], "Input", AspectRatioFixed->True], Cell[OutputFormData["\<\ {{1/9, 2/9}, {7/9, 8/9}}\ \>", "\<\ 1 2 7 8 {{-, -}, {-, -}} 9 9 9 9\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["spawn[{1/9,2/9}]"], "Input", AspectRatioFixed->True], Cell[OutputFormData["\<\ {{1/27, 2/27}, {7/27, 8/27}}\ \>", "\<\ 1 2 7 8 {{--, --}, {--, --}} 27 27 27 27\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[TextData[ "spawn[intervals_List] := Flatten[Map[spawn, intervals], 1] /; \n\t\ Length[intervals[[1]]] > 1 "], "Input", AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["spawn[spawn[{1/3, 2/3}]]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {{1/27, 2/27}, {7/27, 8/27}, {19/27, 20/27}, {25/27, 26/27}}\ \>", "\<\ 1 2 7 8 19 20 25 26 {{--, --}, {--, --}, {--, --}, {--, --}} 27 27 27 27 27 27 27 27\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData[ "removedintervals[n_] := \n\tFlatten[NestList[spawn, {{1/3, 2/3}}, n - 1], 1]\ \nremovedintervals[4]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {{1/3, 2/3}, {1/9, 2/9}, {7/9, 8/9}, {1/27, 2/27}, {7/27, 8/27}, {19/27, 20/27}, {25/27, 26/27}, {1/81, 2/81}, {7/81, 8/81}, {19/81, 20/81}, {25/81, 26/81}, {55/81, 56/81}, {61/81, 62/81}, {73/81, 74/81}, {79/81, 80/81}}\ \>", "\<\ 1 2 1 2 7 8 1 2 7 8 19 20 25 26 {{-, -}, {-, -}, {-, -}, {--, --}, {--, --}, {--, --}, {--, --}, 3 3 9 9 9 9 27 27 27 27 27 27 27 27 1 2 7 8 19 20 25 26 55 56 61 62 73 74 {--, --}, {--, --}, {--, --}, {--, --}, {--, --}, {--, --}, {--, --}, 81 81 81 81 81 81 81 81 81 81 81 81 81 81 79 80 {--, --}} 81 81\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["BaseForm[removedintervals[3]//N, 3]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {{3^^0.1, 3^^0.2}, {3^^0.002222222222222222222222222222222222222222, 3^^0.02}, {3^^0.21, 3^^0.22}, {3^^0.0002222222222222222222222222222222222222222, 3^^0.002}, {3^^0.021, 3^^0.022}, {3^^0.2010000000000000000000000000000000000001, 3^^0.202}, {3^^0.221, 3^^0.2220000000000000000000000000000000000001}}\ \>", "\<\ {{0.1 , 0.2 }, {0.01 , 0.02 }, {0.21 , 0.22 }, {0.001 , 0.002 }, 3 3 3 3 3 3 3 3 {0.021 , 0.022 }, {0.201 , 0.202 }, {0.221 , 0.222 }} 3 3 3 3 3 3\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[TextData[ "spawn[{a_Rational, b_Rational}] :=\n\tBlock[{w = (b - a)/3}, {{a - 2w, a - \ w}, {b + w, b + 2w}}]\nspawn[intervals_List] := Flatten[Map[spawn, \ intervals], 1] /; \nLength[intervals[[1]]] > 1 \nremovedintervals[n_] := \n\t\ Flatten[NestList[spawn, {{1/3, 2/3}}, n - 1], 1]\n\nf[0] = 0;\nf[x_] := \ f[3x]/2 /; x <= 1/3;\nf[x_] := 1 - f[1 - x] /; 2/3 <= x;\n\n\ connect[{a_, b_}] := Block[{y = f[a]}, Line[{{a, y}, {b, y}}]]\n\n\ CantorFunction[levels_] := Show[Graphics[\n \t\t{Thickness[.001], \n \t\t \ Map[connect, removedintervals[levels]]}],\n\t\t Axes->{0, 0},\n\t\t \ Ticks->{N[Range[0., 1, 1/9], 3], Automatic}]"], "Input", AspectRatioFixed->True], Cell[TextData["CantorFunction[7]"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["4.4 Penrose Tiles"], "Section", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "phi = GoldenRatio //N;\ntoppoint = {1/2, Sin[72 Degree] phi} //N;\n\ starttriangle = {toppoint, {1, 0.}, {0., 0.}, 1};\n\ndissect[{p_, q_, r_, 1}] \ :=\n\t\t\t(newpoint = (phi q + p) * (2 - phi);\n\t\t\t{{r, newpoint, q, 1}, \ {r, newpoint, p, -1}})\n\ndissect[{p_, q_, r_, -1}] := (newpoint = (phi r + \ p)*(2 - phi);\n\t\t{{r, newpoint, q, -1}, {p, q, newpoint, 1}})\n\n\ dissect[list_] := (type *= -1;\n Select[list, Last[#] != type &] \n\t\t\t\ ~Join~\n Flatten[Map[dissect, Select[list, Last[#] == type &]],1] /; \n\t\t\ \t\t\t\t\t\t\tTensorRank[list] != 1)\n\nTriangleDissection[n_] := (type = 1;\n\ tiles = Nest[dissect, starttriangle, n] /.\n\t {p_, q_, r_, x_} -> \n\t\ \t {Line[{q, r, p}], Thickness[.015], Line[{p, q}]};\n \ Show[Graphics[{Thickness[.0005], tiles}],\n\t\tAspectRatio->toppoint[[2]],\n\t\ \tPlotRange->All])\n\nAttributes[TriangleDissection] = Listable;"], "Input", AspectRatioFixed->True], Cell[TextData["TriangleDissection[5]"], "Input", AspectRatioFixed->True], Cell[TextData[ "KitesAndDarts[n_] := (type = 1;\n\ttiles = Nest[dissect, starttriangle, 2 n] \ /.\n \t {{p_, q_, r_, -1} -> Line[{q, r, p}],\n\t {p_ ,q_, r_, 1} -> \ {GrayLevel[.5], Polygon[{q, r, p}], \n\t \t\t\t GrayLevel[0], \ Line[{q, r, p}]}};\nShow[Graphics[{Thickness[.0005], tiles}],\n\t\ AspectRatio->toppoint[[2]], PlotRange->All])"], "Input", AspectRatioFixed->True], Cell[TextData["KitesAndDarts[5]"], "Input", AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["First[x/.N[Solve[Tan[72 Degree] x == 1-2x, x]]]"], "Input", AspectRatioFixed->True], Cell[OutputFormData["\<\ 0.1969401977651222734\ \>", "\<\ 0.19694\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[TextData[ "Rhombs[n_] := (type = 1;\n\t\t\ttiles = Nest[dissect, starttriangle, 2 n + \ 1] /.\n { {p_, q_, r_, 1} -> Line[{r, p, q}],\n {p_, q_, r_, \ -1} ->\n\t\t {{GrayLevel[.5], Polygon[{p,q,r}]}, Line[{p,q,r}]}};\n\t\ Show[Graphics[{Thickness[.003], tiles}],\n\tAspectRatio->toppoint[[2]], \ PlotRange->All])"], "Input", AspectRatioFixed->True], Cell[TextData["Rhombs[5]"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["4.5 Dynamics of the Quadratic Map"], "Section", Evaluatable->False, AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["NestList[Cos, 1.5, 20]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {1.5, 0.07073720166770290991, 0.9974991672065860805, 0.5424049923392198306, 0.856469708947328079, 0.6551088017807835455, 0.7929816457973529434, 0.7017241682765734656, 0.7637303112908589108, 0.7222610821345201857, 0.7503128857099855267, 0.7314755580346738381, 0.7441895866305826303, 0.7356370983487154757, 0.7414033729092688743, 0.7375215544615987624, 0.740137474793432143, 0.7383758541602386692, 0.7395627261702680185, 0.73876333657695582, 0.7393018610305957089}\ \>", "\<\ {1.5, 0.0707372, 0.997499, 0.542405, 0.85647, 0.655109, 0.792982, 0.701724, 0.76373, 0.722261, 0.750313, 0.731476, 0.74419, 0.735637, 0.741403, 0.737522, 0.740137, 0.738376, 0.739563, 0.738763, 0.739302}\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["NestList[Cos, Nest[Cos, 1.5, 100], 10]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {0.7390851332151606475, 0.7390851332151606382, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428}\ \>", "\<\ {0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085}\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData[ "Table[Nest[Cos, Random[Real, {-100, 100}], 100], {20}]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {0.7390851332151606382, 0.7390851332151606382, 0.7390851332151606475, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606382, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606475, 0.7390851332151606428, 0.7390851332151606382, 0.7390851332151606428, 0.7390851332151606428, 0.7390851332151606475, 0.7390851332151606428, 0.7390851332151606428}\ \>", "\<\ {0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085, 0.739085}\ \>"], "Output",\ Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[TextData[ "Plot[Nest[Cos, x, 4], {x, 0, 2 Pi}, PlotRange->{-.5, 1}];"], "Input", AspectRatioFixed->True], Cell[TextData[ "Trajectory::usage = \"Trajectory[f, x0, initial, length, xmin:0,\n xmax:1] \ returns a graphical trace of the iterations of f. \n Starting value is x0; \ orbit consists of orbitlength many \n iterations starting from the \ initial'th; the graph is \n displayed between xmin and xmax.\";\n\n\ Trajectory[f_, x0_, initial_, orbitlength_, xmin_:0, xmax_:1] :=\n\t\ Block[{start, orbit, plot, lines},\n\t start = Nest[f, N[x0], initial];\n\t \ orbit = NestList[f, start, orbitlength];\n\t plot = Plot[f[x], {x, xmin, \ xmax}, \n\t\t\t\t\t\tDisplayFunction->Identity];\n\t lines = \ Line[Rest[Partition[\n\t\tFlatten[Transpose[{orbit, orbit}]], 2, 1]]];\n\n \ Show[plot,\n \tGraphics[{{Thickness[.0001], PointSize[.02],\n \t\ lines,\n\t\tPoint[{start, f[start]}],\n\t\tLine[{{xmin, xmin}, {xmax, \ xmax}}]}}],\n\t Axes->{xmin, xmin},\n\t \ DisplayFunction->$DisplayFunction,\n\t PlotRange->{{xmin, xmax}, {xmin, \ xmax}}]]\n\nAttributes[Trajectory] = Listable;"], "Input", AspectRatioFixed->True], Cell[TextData["Trajectory[Cos, 1.5, 0, 20, 0, 1.6]"], "Input", AspectRatioFixed->True], Cell[TextData[ "f[x_] := r x (1 - x)\nr = 2\nTrajectory[f, .1, 0, 10, 0, 1] "], "Input", AspectRatioFixed->True], Cell[TextData[ "r = 3.45\nTrajectory[f, .1, 0, 100, 0, .9]\nTrajectory[f, .1, 300, 50, .3, \ .9]\t"], "Input", AspectRatioFixed->True], Cell[TextData["r = 3.839\nTrajectory[f, .1, 150, 50, 0, 1]"], "Input", AspectRatioFixed->True], Cell[TextData[ "r = 4\nTrajectory[f, .1, 200, 75, 0, 1]\nTrajectory[f, .1, 1000, 50, 0, 1]"], "Input", AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData[ "r = 3.45\nTable[NestList[f, Nest[f, Random[Real, {0, 1}], 400], 3], {10}]"], "Input", AspectRatioFixed->True], Cell[OutputFormData[ "\<\ {{0.4474798467057452092, 0.8529836355679205229, 0.4326388079233244837, 0.8468455208169318355}, {0.4422835743032876664, 0.8510074090065458007, 0.4374386059376645714, 0.8489969483067712758}\\ , {0.4474540998998393092, 0.8529743029201905679, 0.4326615380991191419, 0.8468560838434414791}, {0.847114006491835584, 0.4468159394152914379, 0.8527415221640410696, 0.4332282939678138639}, {0.8529919414808110828, 0.4326185779111463721, 0.846836116652628932, 0.4474812432393677162}, {0.8528897442647803848, 0.4328674579549457534, 0.8469516152050631321, 0.4472047896377624282}, {0.8468265973301564133, 0.4475040242761301141, 0.8529923952381560795, 0.432617472718901448}, {0.8471983390260063855, 0.4466139311526590432, 0.8526672504029430514, 0.4334090462016361314}, {0.4329315893325364735, 0.846981307602364603, 0.4471337040022086647, 0.8528577838787849959}, {0.4475039846490396355, 0.8529923808843374815, 0.4326175076797435104, 0.8468356190640514845}}\ \>", "\<\ {{0.44748, 0.852984, 0.432639, 0.846846}, {0.442284, 0.851007, 0.437439, 0.848997}, {0.447454, 0.852974, 0.432662, 0.846856}, {0.847114, 0.446816, 0.852742, 0.433228}, {0.852992, 0.432619, 0.846836, 0.447481}, {0.85289, 0.432867, 0.846952, 0.447205}, {0.846827, 0.447504, 0.852992, 0.432617}, {0.847198, 0.446614, 0.852667, 0.433409}, {0.432932, 0.846981, 0.447134, 0.852858}, {0.447504, 0.852992, 0.432618, 0.846836}}\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["r = 345/100;\nf[49/69]"], "Input", AspectRatioFixed->True], Cell[OutputFormData["\<\ 49/69\ \>", "\<\ 49 -- 69\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[TextData[ "r = 4; n = 80;\ntraj = Transpose[{Range[0, n], NestList[f, 0.1, n]}];\n\ traj1 = Transpose[{Range[0, n], NestList[f, 0.1 + 10^-10, n]}];\n\t\n\ Show[ListPlot[traj, PlotJoined->True,\n\t\t\t\t\t\ PlotStyle->Thickness[.0005]],\n\tListPlot[traj1, PlotJoined->True,\n\t\t\t\t\t\ PlotStyle->Thickness[.003]]]"], "Input", AspectRatioFixed->True], Cell[TextData[ "OrbitDiagram::usage = \"OrbitDiagram[start, end, n, init, final]\n produces \ an orbit diagram of the quadratic map as r varies \n from start to end in n \ steps. The number of initial iterations\n is init; the number of displayed \ iterations is final.\";\n\nf = r # (1-#) &;\n\n(* following is the version \ with plotstart and plotend *)\n\nOrbitDiagram[\n\tstart_, end_, plotstart_, \ plotend_, n_, init_, final_] := \n\nShow[Graphics[{PointSize[.001], Table[\n \ Map[Point[{r, #}] &, NestList[f, Nest[f, .5, init], final]],\n\t \t\t\t\t\ \t{r, end, start, (start - end)/n}]}],\n\tPlotRange->{{plotstart,plotend},{0, \ 1}}, \n\tAxes->{plotstart, 0}]\n"], "Input", AspectRatioFixed->True], Cell["", "Input", AspectRatioFixed->True], Cell[TextData["Following two cells take a while"], "Text", Evaluatable->False, AspectRatioFixed->True], Cell[TextData["OrbitDiagram[2.9, 3.45, 2.9, 4, 300, 120, 4];"], "Input", AspectRatioFixed->True], Cell[TextData["OrbitDiagram[3.45, 4, 2.9, 4, 300, 120, 150];"], "Input", AspectRatioFixed->True], Cell[TextData[ "Clear[r]\nDo[Trajectory[f, 0.5, 500, 5, 0, 1], {r, 2.9, 3.5, .025}]"], "Input", AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData["f[f[x]]"], "Input", AspectRatioFixed->True], Cell[OutputFormData["\<\ r^2*(1 - x)*x*(1 - r*(1 - x)*x)\ \>", "\<\ 2 r (1 - x) x (1 - r (1 - x) x)\ \>"], "Output", Evaluatable->False, AspectRatioFixed->True]}, Open]], Cell[TextData[ "g[x_] := r^2*(1 - x)*x*(1 - r*(1 - x)*x)\nr = 3.2;\nDo[Trajectory[g, x0, 0, \ 10], {x0, .1, .9, .15}] "], "Input", AspectRatioFixed->True], Cell[CellGroupData[{Cell[TextData[ "r = .; Do[Trajectory[g, .1, 0, 10], {r, 2.9, 3.2, .05}]"], "Input", AspectRatioFixed->True], Cell[TextData[ "g[r_, x_] := r^2*(1 - x)*x*(1 - r*(1 - x)*x)\n\n(* this plot takes a while \ *)\n\nPlot3D[{z = g[r,x], GrayLevel[If[Abs[z -x] <=.0028, 0, 1]]}, \n\t\t\t\t\ \t\t\t{r, 2.8, 3.2}, {x, 0, 1},\nPlotRange->{0,.9}, Shading->False, \ Lighting-> False,\nAxesLabel->{\"r\", \"x\", None},\nClipFill->None, Boxed-> \ False, PlotPoints->{30,90},\nViewPoint-> {2, .8, 1.5}];\n\n"], "Input", AspectRatioFixed->True]}, Open]], Cell[TextData[ "f = r # (1-#) &; limitr = 3.569945557391440;\n\ Show[Graphics[{PointSize[.001],\n\tTable[(r = limitr - 10 ^ logr;\n \ Map[Point[{-logr, #}] &,\n NestList[f, Nest[f, .5, 150], 32]]),\n \ {logr, start = Log[10, limitr-2.5], -3, (-3-start)/200}]}], \n \ PlotRange->{0.3, .9}, Axes->{0, 0.3}];"], "Input", AspectRatioFixed->True]}, Open]], Cell[CellGroupData[{Cell[TextData["4.6 Variations on Circular Motion"], "Section", Evaluatable->False, AspectRatioFixed->True], Cell[TextData[ "ParametricPlot[\n\t(2 + Sin[8 t]/2) {Cos[tt = (t + Sin[16 t]/4)], Sin[tt]},\n\ \t\t{t, 0, 2 Pi},\n\tMaxBend->5, PlotPoints->50, PlotDivision->30,\n\t\ AspectRatio->1]"], "Input", AspectRatioFixed->True], Cell[TextData[ "f[t_, a_, b_, c_] :=\n (2 + Sin[a t]/2) * {Cos[tt = (t + Sin[b t]/c)], \ Sin[tt]};\n\nAttributes[f] = Listable;\n\nStarr[a_, b_, c_, n_] := Block[{r}, \ \n\t values = f[Range[0., 2 Pi, 2 Pi/n //N], a, b, c];\n\t \ Show[Graphics[{Thickness[.0005],\n\t Map[Line[{{0, 0}, #}] &, values],\n\ \t Table[Line[values r ^ 0.2 ], {r, 0., 1, .05}]}],\n \ PlotRange->{{-2.5, 2.5}, {-2.5, 2.5}},\n AspectRatio->1]]"], "Input", AspectRatioFixed->True], Cell[TextData["Starr[8, 16, 4, 720]"], "Input", AspectRatioFixed->True], Cell[TextData["Starr[9, 6, 6, 720]"], "Input", AspectRatioFixed->True], Cell[TextData["Starr[8, 16, 16, 720]"], "Input", AspectRatioFixed->True], Cell[TextData["Starr[6, 18, 18, 720]"], "Input", AspectRatioFixed->True]}, Open]] }, FrontEndVersion->"Macintosh 3.0", ScreenRectangle->{{0, 640}, {0, 460}}, WindowToolbars->{}, CellGrouping->Manual, WindowSize->{520, 365}, WindowMargins->{{52, Automatic}, {Automatic, 1}}, PrivateNotebookOptions->{"ColorPalette"->{RGBColor, -1}}, ShowCellLabel->True, ShowCellTags->False, RenderingOptions->{"ObjectDithering"->True, "RasterDithering"->False}, MacintoshSystemPageSetup->"\<\ AVU/IFiQKFD000000V1e009POM0000000ORWP095TlP0AP1Y06`0I@1^0642H7D0 0V1ml0000001n:MP0TFCb000000000000000009PM@0000000000000000000000 00000000000000000000000000000000\>" ] (*********************************************************************** Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. ***********************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[1711, 51, 112, 2, 70, "Title", Evaluatable->False], Cell[CellGroupData[{ Cell[1846, 55, 86, 2, 70, "Section", Evaluatable->False], Cell[1935, 59, 207, 4, 70, "Input"], Cell[2145, 65, 132, 3, 70, "Input"], Cell[2280, 70, 169, 3, 70, "Input"], Cell[2452, 75, 211, 4, 70, "Input"], Cell[2666, 81, 226, 4, 70, "Input"], Cell[2895, 87, 688, 10, 70, "Input"], Cell[3586, 99, 71, 1, 70, "Input"], Cell[3660, 102, 70, 1, 70, "Input"], Cell[3733, 105, 70, 1, 70, "Input"], Cell[3806, 108, 76, 1, 70, "Input"], Cell[3885, 111, 77, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[3994, 114, 100, 2, 70, "Section", Evaluatable->False], Cell[4097, 118, 152, 3, 70, "Input"], Cell[CellGroupData[{ Cell[4272, 123, 72, 1, 70, "Input"], Cell[4347, 126, 172, 8, 70, "Output", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[4551, 136, 69, 1, 70, "Input"], Cell[4623, 139, 188, 9, 70, "Output", Evaluatable->False] }, Closed]], Cell[4823, 150, 149, 3, 70, "Input"], Cell[CellGroupData[{ Cell[4995, 155, 77, 1, 70, "Input"], Cell[5075, 158, 282, 10, 70, "Output", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[5389, 170, 153, 3, 70, "Input"], Cell[5545, 175, 773, 21, 70, "Output", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[6350, 198, 88, 1, 70, "Input"], Cell[6441, 201, 658, 16, 70, "Output", Evaluatable->False] }, Closed]], Cell[7111, 219, 686, 10, 70, "Input"], Cell[7800, 231, 70, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[7902, 234, 94, 2, 70, "Section", Evaluatable->False], Cell[7999, 238, 950, 13, 70, "Input"], Cell[8952, 253, 74, 1, 70, "Input"], Cell[9029, 256, 394, 6, 70, "Input"], Cell[9426, 264, 69, 1, 70, "Input"], Cell[CellGroupData[{ Cell[9518, 267, 100, 1, 70, "Input"], Cell[9621, 270, 131, 7, 70, "Output", Evaluatable->False] }, Closed]], Cell[9764, 279, 370, 6, 70, "Input"], Cell[10137, 287, 62, 1, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[10231, 290, 110, 2, 70, "Section", Evaluatable->False], Cell[CellGroupData[{ Cell[10364, 294, 75, 1, 70, "Input"], Cell[10442, 297, 800, 19, 70, "Output", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[11274, 318, 91, 1, 70, "Input"], Cell[11368, 321, 481, 13, 70, "Output", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[11881, 336, 108, 2, 70, "Input"], Cell[11992, 340, 794, 19, 70, "Output", Evaluatable->False] }, Closed]], Cell[12798, 361, 111, 2, 70, "Input"], Cell[12912, 365, 1034, 15, 70, "Input"], Cell[13949, 382, 88, 1, 70, "Input"], Cell[14040, 385, 114, 2, 70, "Input"], Cell[14157, 389, 136, 3, 70, "Input"], Cell[14296, 394, 96, 1, 70, "Input"], Cell[14395, 397, 131, 3, 70, "Input"], Cell[CellGroupData[{ Cell[14549, 402, 130, 3, 70, "Input"], Cell[14682, 407, 1561, 41, 70, "Output", Evaluatable->False] }, Closed]], Cell[CellGroupData[{ Cell[16275, 450, 75, 1, 70, "Input"], Cell[16353, 453, 115, 8, 70, "Output", Evaluatable->False] }, Closed]], Cell[16480, 463, 358, 6, 70, "Input"], Cell[16841, 471, 713, 10, 70, "Input"], Cell[17557, 483, 43, 1, 70, "Input"], Cell[17603, 486, 106, 2, 70, "Text", Evaluatable->False], Cell[17712, 490, 99, 1, 70, "Input"], Cell[17814, 493, 101, 1, 70, "Input"], Cell[17918, 496, 124, 3, 70, "Input"], Cell[CellGroupData[{ Cell[18065, 501, 60, 1, 70, "Input"], Cell[18128, 504, 166, 7, 70, "Output", Evaluatable->False] }, Closed]], Cell[18306, 513, 156, 3, 70, "Input"], Cell[CellGroupData[{ Cell[18485, 518, 109, 2, 70, "Input"], Cell[18597, 522, 418, 6, 70, "Input"] }, Closed]], Cell[19027, 530, 363, 6, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[19422, 538, 110, 2, 70, "Section", Evaluatable->False], Cell[19535, 542, 220, 4, 70, "Input"], Cell[19758, 548, 481, 7, 70, "Input"], Cell[20242, 557, 74, 1, 70, "Input"], Cell[20319, 560, 74, 1, 70, "Input"], Cell[20396, 563, 74, 1, 70, "Input"], Cell[20473, 566, 74, 1, 70, "Input"] }, Closed]] } ] *) (*********************************************************************** End of Mathematica Notebook file. ***********************************************************************)