Chapter Five:

Iterative Complex Graphics

5.1 Complex Cantor Sets

ComplexBase1[b_, m_] := Block[{i = 1},
	Show[Graphics[
			Map[Point[{Re[#], Im[#]}] &, 
				Nest[Join[#, # + b^i++] &, {0}, m]]],
   PlotRange -> All, Axes -> Automatic, AspectRatio -> 1]]

ComplexBase1[.5 + .5I, 11]//Timing

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]]

ComplexBase[.5 + .5I, 11]//Timing

m = 3
Flatten[Outer @@ Prepend[Table[{0, 1}, {m}], List], 
		m - 1] //MatrixForm

Map[{Re[#], Im[#]} &, b^Range[m]] //MatrixForm

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]

FastComplexBase[.5+.5I, 11]//Timing

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]

$Display = OpenWrite["psfile"]
ComplexBase[.8 + .2 I, 15, {{1, 2}, None}, 
		{{-.7, 2.5}, {-.2, 2.8}}];
Close["psfile"]
$Display = "stdout";

5.2 Iterated Function Systems

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}}]

ChaosGame[{.1, .8}, 3^8]

ChaosGame[{.4, .3}, 3^8]

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}]

distinctsubstrings[n_] := Length[Union[Partition[
 Table[Random[Integer, {1, 3}], {n}], 10, 1]]]

distinctsubstrings[100]

5.3 Biasing the Chaos Game: Barnsley’s Fern

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]]

BiasedChaosGame[{0,0},100]

MatrixNorm[A_] := Max[Sqrt[Eigenvalues[Transpose[A].A]]]

{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}]

{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 }  }

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]]

following two cells take a lot of time

BarnsleyFern[28000]

BarnsleyFern[10000]

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]

region = {fixed1, f2[fixed1], {0,0}, f3[fixed1], fixed1}
Show[Graphics[Map[Line, NestList[f1, region, 10]]],
AspectRatio->1, Axes->Automatic];

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];

5.4 Julia Sets

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]

ComplexTrajectory[ -0.32 + 0.5I,-0.12256117 + 0.74486177I, 40];

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]]]]

JuliaIIM[0.390541 - 0.586788I, 1400];

chop[z_] := (Round[600 Re[z]] + I Round[600 Im[z]]) / 600.
Attributes[chop] = Listable

chop[.75024652465 + .15146426I]

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]

JuliaIIMHistogram[-0.1 + 0.8 I, 1000]; (* 10000 in book *)

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}]

JuliaIIMf[3, 500];	(* 5000 in book *)

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}}]

following cells take a very long time and use lots of memory!!!!!!!

c = -.12256117 + .74486177 I (* rabbit *)
FilledJuliaSet[c, 230, 195, -1.31, .52, 0, 1.11, 30]

c =.32 + .043 I (* 11-cycle dragon *) 
FilledJuliaSet[c, 160, 210, -.85, .80, 0, 1.12, 80]

c = -0.390541 - 0.586788*I  (* Siegel disk *)
FilledJuliaSet[c, 230, 165, -.77, 1.42, 0, 1.03, 30]

following cell uses program from the Appendix

FilledJuliaSetReal[3, 140, 84, .5, .3, 60];