(*^ ::[ Information = "This is a Mathematica Notebook file. It contains ASCII text, and can be transferred by email, ftp, or other text-file transfer utility. It should be read or edited using a copy of Mathematica or MathReader. If you received this as email, use your mail application or copy/paste to save everything from the line containing (*^ down to the line containing ^*) into a plain text file. On some systems you may have to give the file a name ending with ".ma" to allow Mathematica to recognize it as a Notebook. The line below identifies what version of Mathematica created this file, but it can be opened using any other version as well."; FrontEndVersion = "NeXT Mathematica Notebook Front End Version 2.2"; NeXTStandardFontEncoding; fontset = title, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L3, e8, 24, "Times"; ; fontset = subtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e6, 18, "Times"; ; fontset = subsubtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e6, 14, "Times"; ; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, a20, 14, "Times"; ; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, a15, 12, "Times"; ; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, a12, 10, "Times"; ; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 14, "Times"; ; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; ; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, 12, "Courier"; ; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, 12, "Courier"; ; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, R65535, 12, "Courier"; ; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, 12, "Courier"; ; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, 12, "Courier"; ; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, 10, "Courier"; ; fontset = name, inactive, noPageBreakInGroup, nowordwrap, nohscroll, preserveAspect, M7, italic, B65535, 10, "Times"; ; fontset = header, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; ; fontset = leftheader, 12; fontset = footer, inactive, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, 12; fontset = leftfooter, 12; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; ; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12; fontset = completions, inactive, nowordwrap, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12; fontset = special1, inactive, nowordwrap, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12; fontset = special2, inactive, nowordwrap, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, 12; fontset = special3, inactive, nowordwrap, nohscroll, noKeepOnOnePage, preserveAspect, right, M7, 12; fontset = special4, inactive, nowordwrap, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12; fontset = special5, inactive, nowordwrap, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12; paletteColors = 128; currentKernel; ] :[font = title; inactive; preserveAspect] Chapter Five: Iterative Complex Graphics :[font = section; inactive; Cclosed; preserveAspect; startGroup] 5.1 Complex Cantor Sets :[font = input; preserveAspect] ComplexBase1[b_, m_] := Block[{i = 1}, Show[Graphics[ Map[Point[{Re[#], Im[#]}] &, Nest[Join[#, # + b^i++] &, {0}, m]]], PlotRange -> All, Axes -> Automatic, AspectRatio -> 1]] :[font = input; preserveAspect] ComplexBase1[.5 + .5I, 11]//Timing :[font = input; preserveAspect] ComplexBase[b_, m_] := Block[{i = 1, powers = Map[{Re[#], Im[#]} &, b ^ Range[m + 1]]}, Show[Graphics[Map[Point, Nest[ Join[#, # /. {x_Real, y_Real} -> {x, y} + powers[[i++]]] &, {powers[[1]]}, m]]], PlotRange -> All, Axes -> Automatic, AspectRatio -> 1]] :[font = input; preserveAspect] ComplexBase[.5 + .5I, 11]//Timing :[font = input; Cclosed; preserveAspect; startGroup] m = 3 Flatten[Outer @@ Prepend[Table[{0, 1}, {m}], List], m - 1] //MatrixForm :[font = output; output; inactive; preserveAspect; endGroup] MatrixForm[{{0, 0, 0}, {0, 0, 1}, {0, 1, 0}, {0, 1, 1}, {1, 0, 0}, {1, 0, 1}, {1, 1, 0}, {1, 1, 1}}] ;[o] 0 0 0 0 0 1 0 1 0 0 1 1 1 0 0 1 0 1 1 1 0 1 1 1 :[font = input; Cclosed; preserveAspect; startGroup] Map[{Re[#], Im[#]} &, b^Range[m]] //MatrixForm :[font = output; output; inactive; preserveAspect; endGroup] MatrixForm[{{Re[b], Im[b]}, {Re[b^2], Im[b^2]}, {Re[b^3], Im[b^3]}}] ;[o] Re[b] Im[b] 2 2 Re[b ] Im[b ] 3 3 Re[b ] Im[b ] :[font = input; preserveAspect] FastComplexBase[b_, m_] := Show[Graphics[Point /@ (Flatten[Outer @@ Prepend[Table[{0., 1.}, {m}], List], m - 1]. Map[{Re[#], Im[#]} &, b^Range[m]])], PlotRange -> All, Axes -> Automatic, AspectRatio -> 1] :[font = input; preserveAspect] FastComplexBase[.5+.5I, 11]//Timing :[font = input; preserveAspect] FastComplexBase[z_, m_] := Show[Graphics[Point /@ ((temp = -MemoryInUse[]; Flatten[Outer @@ Prepend[Table[{0., 1.}, {m}], List], m - 1]). Map[{Re[#], Im[#]} &, z ^ Range[m]])], PlotRange -> (Print[temp + MemoryInUse[]]; All), Axes -> Automatic, AspectRatio -> 1] :[font = input; preserveAspect; endGroup] $Display = OpenWrite["psfile"] ComplexBase[.8 + .2 I, 15, {{1, 2}, None}, {{-.7, 2.5}, {-.2, 2.8}}]; Close["psfile"] $Display = "stdout"; :[font = section; inactive; Cclosed; preserveAspect; startGroup] 5.2 Iterated Function Systems :[font = input; preserveAspect] top = {.5, Sqrt[3.]/2} f1[x_] := .5 x; f2[x_] := .5(x + {1,0}); f3[x_] := .5(x + top) f[x_] := {f1,f2,f3}[[Random[Integer, {1,3}]]][x] ChaosGame[start_, n_] := Show[Graphics[Map[Point, NestList[f, start, n]]], PlotRange->{{0, 1}, {0, .87}}, Axes->Automatic, AspectRatio->.87, Ticks->{{.25, .5, .75, 1}, {.25, .5, .75}}] :[font = input; preserveAspect] ChaosGame[{.1, .8}, 3^8] :[font = input; preserveAspect] ChaosGame[{.4, .3}, 3^8] :[font = input; Cclosed; preserveAspect; startGroup] Clear[f] f[A_] := 0.5 Union[A, Map[# + {1,0} &, A], Map[# + {.5,Sqrt[3.]/2} &, A]] ChaosGameDeterministic[start_, n_] := Show[Graphics[Map[Point, Nest[f, {start}, n]]], PlotRange->{{0,1}, {0,.87}}, Axes->Automatic, AspectRatio->.87, Ticks->{{.25,.5,.75,1}, {.25,.5,.75,1}}] Do[ChaosGameDeterministic[{.1, .8}, i], {i, 0, 8}] :[font = input; preserveAspect; endGroup] distinctsubstrings[n_] := Length[Union[Partition[ Table[Random[Integer, {1, 3}], {n}], 10, 1]]] :[font = input; Cclosed; preserveAspect; startGroup] distinctsubstrings[100] :[font = output; output; inactive; preserveAspect; endGroup; endGroup] 91 ;[o] 91 :[font = section; inactive; Cclosed; preserveAspect; startGroup] 5.3 Biasing the Chaos Game: BarnsleyÕs Fern :[font = input; preserveAspect] Clear[f] top = {.5, Sqrt[3.]/2} f1[x_] := .5 x f2[x_] := .5(x + {1,0}) f3[x_] := .5(x + top) f[x_] := Which[(r = Random[Integer,{1,4}]) <= 2, f3[x], r == 3, f1[x], r == 4, f2[x]] BiasedChaosGame[start_, n_] := Show[Graphics[Map[Point, NestList[f, start, n]], PlotRange->{{0, 1}, {0, .87}}, AspectRatio->.87]] :[font = input; preserveAspect] BiasedChaosGame[{0,0},100] :[font = input; preserveAspect] MatrixNorm[A_] := Max[Sqrt[Eigenvalues[Transpose[A].A]]] :[font = input; Cclosed; preserveAspect; startGroup] {A1, A2, A3, A4} = { {{.85, .04}, {-.04, .85}}, {{-.15, .28}, { .26, .24}}, {{0.2, -.26}, { .23, .22}}, {{0, 0 }, { 0, .16}} }; Map[MatrixNorm, {A1, A2, A3, A4}] :[font = output; output; inactive; preserveAspect; endGroup] {0.8509406559801923109, 0.3791517719540821999, 0.3407118123825710023, 0.16} ;[o] {0.850941, 0.379152, 0.340712, 0.16} :[font = input; Cclosed; preserveAspect; startGroup] {fixed1, fixed2, fixed3, fixed4} = { Inverse[A1 - IdentityMatrix[2]] . {0, -1.6 }, Inverse[A2 - IdentityMatrix[2]] . {0, -.44}, Inverse[A3 - IdentityMatrix[2]] . {0, -1.6 }, Inverse[A4 - IdentityMatrix[2]] . {0, 0 } } :[font = output; output; inactive; preserveAspect; endGroup] {{2.655601659751037345, 9.958506224066390043}, {0.1537693459810284573, 0.6315526709935097352}, {-0.6083650190114068442, 1.871892366188944136}, {0, 0}} ;[o] {{2.6556, 9.95851}, {0.153769, 0.631553}, {-0.608365, 1.87189}, {0, 0}} :[font = input; preserveAspect] BarnsleyFern[n_] := Show[Graphics[Map[Point, NestList[ Which[ (r = Random[Integer, {1,100}]) <= 85, A1.# + {0, 1.6}, r <= 92, A2.# + {0, .44}, r <= 99, A3.# + {0, 1.6}, r == 100, A4.# ] &, {0,0}, n]], PlotRange->All]] :[font = text; inactive; preserveAspect] following two cells take a lot of time :[font = input; preserveAspect] BarnsleyFern[28000] :[font = input; preserveAspect] BarnsleyFern[10000] :[font = input; Cclosed; preserveAspect; startGroup] Clear[f1, f2, f3, f4] f1[{x_, y_}] := A1.{x,y} + {0, 1.6} /; Length[x] != 2 f1[set:{_List..}] := Map[f1, set] f2[{x_,y_}] := A2.{x,y} + {0, .44} /; Length[x] != 2 f2[set:{_List..}] := Map[f2, set] f3[{x_,y_}] := A3.{x,y} + {0, 1.6}/; Length[x] != 2 f3[set:{_List..}] := Map[f3, set] f4[{x_,y_}] := A4.{x,y}/; Length[x] != 2 f4[set:{_List..}] := Map[f4, set] :[font = input; preserveAspect] region = {fixed1, f2[fixed1], {0,0}, f3[fixed1], fixed1} Show[Graphics[Map[Line, NestList[f1, region, 10]]], AspectRatio->1, Axes->Automatic]; :[font = input; preserveAspect; endGroup; endGroup] region1 = {fixed1, f2[fixed1], f4[fixed1], f3[fixed1], fixed1} spine = NestList[f1, {0,0}, 35] Show[Graphics[{ Thickness[.001], Map[Line, NestList[f2, region1, 2]], Dashing[{.01}], Map[Line, NestList[f2, spine,2]]}], AspectRatio->1, Axes->Automatic]; :[font = section; inactive; Cclosed; preserveAspect; startGroup] 5.4 Julia Sets :[font = input; preserveAspect] ComplexTrajectory[z_, c_, init_:0, n_] := Show[Graphics[{PointSize[.025], Point[{Re[z],Im[z]}], Thickness[.0001], Line[Map[{Re[#],Im[#]} &, NestList[#^2 + c &, Nest[#^2+c &, If[Precision[z] < Infinity, z, N[z]], init], n]]]}], PlotRange->All, Axes->Automatic] :[font = input; preserveAspect] ComplexTrajectory[ -0.32 + 0.5I,-0.12256117 + 0.74486177I, 40]; :[font = input; preserveAspect] JuliaIIM[c_, n_] := Show[Graphics[ Map[{Point[{Re[#], Im[#]}], Point[-{Re[#], Im[#]}]} &, Drop[NestList[If[Random[Integer] == 1, 1, -1] Sqrt[# - c] &, 0.2, n + 50], 50]]]] :[font = input; preserveAspect] JuliaIIM[0.390541 - 0.586788I, 1400]; :[font = input; Cclosed; preserveAspect; startGroup] chop[z_] := (Round[600 Re[z]] + I Round[600 Im[z]]) / 600. Attributes[chop] = Listable :[font = input; preserveAspect] chop[.75024652465 + .15146426I] :[font = output; output; inactive; preserveAspect; endGroup] 0.75 + 0.1516666666666666667*I ;[o] 0.75 + 0.151667 I :[font = input; preserveAspect] JuliaIIMHistogram[c_, n_] := Show[Graphics3D[Map[ Line[{{Re[#], Im[#], 1}, {Re[#], Im[#], Count[temp, #]}}] &, Union[temp = chop@Drop[NestList[ If[Random[Integer] == 1, 1, -1] Sqrt[# - c] &, .2, n+40], 40]]]], Boxed->False, BoxRatios->{1,1,1/3}, PlotRange->All] :[font = input; preserveAspect] JuliaIIMHistogram[-0.1 + 0.8 I, 1000]; (* 10000 in book *) :[font = input; preserveAspect] JuliaIIMf[r_, n_] := Show[Graphics[ Map[{Point[{Re[#], Im[#]}], Point[{Re[#], -Im[#]}], Point[{1-Re[#], Im[#]}], Point[{1-Re[#], -Im[#]}]} &, Drop[NestList[.5 + If[Random[Integer]==1, 1, -1] * Sqrt[.25 - #/r] &, 0.2, n + 50], 50]]], Axes->Automatic, Ticks->{{0,1}, Automatic}] :[font = input; preserveAspect] JuliaIIMf[3, 500]; (* 5000 in book *) :[font = input; preserveAspect] orbitcheck[z_, c_, iters_] := (s = z; i = 0; While[++i <= iters && Abs[s = s^2 + c] < 2]; If[i == iters+1, {Re[z], Im[z]}*#& /@ {1,-1}, {}]) (* One of x0, y0 should be 0 *) FilledJuliaSet[c_, meshx_Integer, meshy_Integer, x0_, x1_, y0_, y1_, iters_:20] := Show[Graphics[{PointSize[.002], Point /@ Flatten[ Outer[orbitcheck[#1 + I #2, N[c], iters]&, Range[x0, x1, (x1-x0)/meshx], Range[y0, y1, (y1-y0)/meshy]], 2]}], AspectRatio->(ymax=Max[Abs[{y0,y1}]])/(xmax=Max[Abs[{x0,x1}]]), PlotRange->{{-xmax,xmax}, {-ymax,ymax}}] :[font = text; inactive; preserveAspect] following cells take a very long time and use lots of memory!!!!!!! :[font = input; preserveAspect] c = -.12256117 + .74486177 I (* rabbit *) FilledJuliaSet[c, 230, 195, -1.31, .52, 0, 1.11, 30] :[font = input; preserveAspect] c =.32 + .043 I (* 11-cycle dragon *) FilledJuliaSet[c, 160, 210, -.85, .80, 0, 1.12, 80] :[font = input; preserveAspect] c = -0.390541 - 0.586788*I (* Siegel disk *) FilledJuliaSet[c, 230, 165, -.77, 1.42, 0, 1.03, 30] :[font = text; inactive; preserveAspect] following cell uses program from the Appendix :[font = input; preserveAspect; endGroup] FilledJuliaSetReal[3, 140, 84, .5, .3, 60]; ^*)