Introduction to Programming 
with 
Mathematica

By
Richard J. Gaylord 
(gaylord@ux1.cso.uiuc.edu)

Samuel N. Kamin 
(kamin@cs.uiuc.edu)

Paul R. Wellin 
(wellin@sonoma.edu)

Copyright ã 1993 by TELOS/Springer-Verlag

Chapter 10 ± Graphics Programming

(Mathematica code)

Functions defined in this Notebook...(page no. in book)

line1...221
line2...222
point1...221
point2...222
hline...223
vline...223
text1...224
text2...224
text3...224
text4...226
arc...226
randomWalk3D...227
showRandomWalk3D...227,232
eqn1... 
eqn2... 
solns... 
rsolns... 
r1...230
r2...230
c...230
c1...230
c2...230
dashc1...231
dashc2...231
colorWheel...232
coords...243
points...243
lines...244
path...245
base...245
angle...245
remain...245
simpleClosePath...246
SimpleClosedPath... 
figtree5...250
figtree6...251
figtree7...253
figtree8...253
figtree9...253
digits...257
irratdigits...257
fmSynthesis...258
cmajor...259
notes4...260
tones...260
randomnotes...261
notes...261
somenotes...263
tonesAndTimes...263
step...263
s20...263
pos...263
brown...4
cmajor16...264
fractal...264

Initialization (evaluate to turn off spell messages)

Off[General::spell]

Off[General::spell1]

Section 10.1  Graphics Primitives

Graphical representation of complex numbers

z = 8 + 3I;

cz = Conjugate[z];

line1 = Line[{{0, 0}, {Re[z], Im[z]}}];

line2 = Line[{{0, 0}, {Re[cz], Im[cz]}}];

point1 = {PointSize[.02], Point[{Re[z], Im[z]}]};

point2 = {PointSize[.02], Point[{Re[cz], Im[cz]}]};

Show[Graphics[{line1, point1, line2, point2}, 
	Axes->True]];

hline = {Dashing[{0.04, 0.04}], 
   Line[{{0, Im[z]}, {Re[z], Im[z]}}]};

vline = {Dashing[{0.04, 0.04}],
   Line[{{Re[z], 0}, {Re[z], Im[z]}}]};

Show[Graphics[{line1, point1, line2, point2, hline, vline},
   Axes->True, Ticks->{{{Re[z], "a"}}, {{Im[z], "b"}}},
   AxesLabel->{Re, Im}, AspectRatio->Automatic]];

text1 = Text[FontForm["z = a + b i", {"Times-Italic", 9}],
          {Re[z] - .75, Im[z] + .35}];

text2 = Text[FontForm["Abs[z]", {"Times-Italic", 9}],
          {3.5, 2}];

text3 = Text[FontForm["Conjugate[z] = a - b i",
                      {"Times-Italic", 9}],
          {Re[cz] - 1.4, Im[cz] - .35}];

Show[Graphics[{line1, line2, point1, point2, hline, vline,
              text1, text2, text3},
   Axes->True, 
   Ticks->{{{Re[z], "a"}}, {{Im[z], "b"}}},
   AxesLabel->{Re, Im},
   AspectRatio->Automatic]];

arc = Circle[{0, 0}, Abs[z]/3, {0, Arg[z]}];

text4 = Text[FontForm["Arg[z]", {"Times", 9}],
          {3.5, .5}];

Show[Graphics[{line1, line2, point1, point2, hline, vline,
              text1, text2, text3, text4, arc},
   Axes->True,
   Ticks->{{{Re[z], "a"}}, {{Im[z], "b"}}},
   AxesLabel->{Re, Im},
   AspectRatio->Automatic]];

3-Dimensional random walk

randomWalk3D[n_Integer]:= 
   FoldList[Plus, {0, 0, 0},
      Map[{Cos[#], Sin[#], #/N[Pi] - 1}&,
          Table[Random[Real, {0, N[2Pi]}], {n}]]]

showRandomWalk3D[n_Integer]:= 
   Show[Graphics3D[Line[randomWalk3D[n]]]]

(* Example of 1000-step walk in space *)
showRandomWalk3D[1000];

Section 10.2  Graphics Directives and Options

Example of graphics directives

p1 = Point[{0, 0}];

p2 = Point[{1, 0}];

p3 = Point[{.5, .5}];

Show[Graphics[{{PointSize[.025], p1, p2}, p3}]];

Algebraic problem from Calculus&Mathematica

Clear[eqn1,eqn2,solns,rsolns,r1,r2,c,c1,c2,dashc1,dashc2]

eqn1 = (x-1)^2 + (y-1)^2 == 2;
eqn2 = (x+3)^2 + (y-4)^2 == r^2;

solns = Solve[{eqn1,eqn2},{x,y}]

solns[[1,1,2]]

rsolns = Solve[solns[[1,1,2]] == solns[[2,1,2]], r]

r1 = rsolns[[2,1,2]]

r2 = rsolns[[4,1,2]]

c = Circle[{1, 1}, Sqrt[2]]

c1 = Circle[{-3, 4}, r1];
c2 = Circle[{-3, 4}, r2];

Show[Graphics[{c, c1, c2},
   Axes->Automatic, AspectRatio->Automatic]];

dashc1 = {Dashing[{.025, .025}], Circle[{-3, 4}, r1]}
dashc2 = {Dashing[{.05, .05}], Circle[{-3, 4}, r2]}

Show[Graphics[{c, dashc1, dashc2}, 
   Axes->Automatic, AspectRatio->Automatic]]

Exercises  (color wheel)

Clear[c,theta]
colorWheel[theta_] :=
	Table[{Hue[j/N[2Pi]], Disk[{0, 0}, 1, {j, j+theta}]},
	{j, 0, 2Pi-theta, theta}]

Show[Graphics[colorWheel[Pi/48]],   (* Increase 48 for finer gradations *)
	AspectRatio->Automatic];

Section 10.3  Built-in Graphics Functions

sampledata = Table[Random[], {50}, {50}];

ListDensityPlot[sampledata]

Plot[Sin[x], {x, 0, 2Pi},
   PlotPoints->4, MaxBend->45, PlotDivision->1];

Plot[Cos[x], {x, 0, 2Pi (24)}];

Plot3D[Sin[x y], {x, 0, 3Pi/2}, {y, 0, 3Pi/2}];

Plot3D[Sin[x y], {x, 0, 2Pi}, {y, 0, 2Pi}];

(* Time and Memory Warning *)
Plot3D[Sin[x y], {x, 0, 2Pi}, {y, 0, 2Pi},
	PlotPoints->75];

Plot3D[1/(1 - ArcTan[x y]), {x, 0, 4}, {y, 0, 4}];

atanplot = 
	Plot3D[1/(1 - ArcTan[x y]), {x, 0, 4}, {y, 0, 4},
		PlotPoints->35];

Show[atanplot, ViewPoint->{2.8, 0, 2}];

Show[atanplot, Axes->False, Boxed->False];

Section 10.4  Graphics Programming

Simple closed paths

Clear[coords,points,lines,path,base,angle,remain,s,p]

coords = Table[{Random[], Random[]}, {10}]

points = Map[Point, coords]

Show[Graphics[{PointSize[.02], RGBColor[1,0,0], points}]];

lines = Line[coords]

Show[Graphics[{PointSize[.02], RGBColor[1,0,0],
	points, lines}]];

path = Line[AppendTo[coords, First[coords]]];
Show[Graphics[{{PointSize[.02], RGBColor[1,0,0],
	points}, path}]];

base = coords[[Random[Integer, {1, Length[coords]}]]]

angle[a_List, b_List] := Apply[ArcTan, (b - a)]

remain = DeleteCases[coords, base];

Map[angle[base, #]&, remain]

s = Sort[remain, (angle[base, #1] <= angle[base, #2])&]

p = Join[{base}, s, {base}]

path = Line[p];

Show[Graphics[{{PointSize[.02], RGBColor[1,0,0],
	points}, path}]];

simpleClosedPath

simpleClosedPath[l_] := 
   Module[{points, base, remain, angle, sorted, path},
      points =
         {PointSize[.02], RGBColor[1, 0, 0], Map[Point, l]};
      base = l[[ Random[Integer, {1, Length[l]}] ]];
      remain = DeleteCases[l, base];
      angle[a_, b_]:= Apply[ArcTan, (b - a)];
      sorted = Sort[remain,(angle[base, #1] <= angle[base, #2])&];
      path = Line[Join[{base}, sorted, {base}]];
      Show[Graphics[{points, path}]]
   ]

data = Table[{Random[], Random[]}, {25}];

simpleClosedPath[data];

data = Table[{Random[], Random[]}, {100}];

simpleClosedPath[data];

SimpleClosedPath (better version)

SimpleClosedPath[l_] := Module[{points, base, remain, angle, sorted, path},
	points = {PointSize[.02], RGBColor[1,0,0], Map[Point,l]};
	(* base = l[[ Random[Integer, {1, Length[l]}] ]]; *)
	base = Last[Sort[l,(#2[[2]] > #1[[2]])&]];
	remain = DeleteCases[l,base];
	angle[a_,b_]:= Apply[ArcTan, (b - a)];
	sorted = Sort[remain, (angle[base, #1] <= angle[base, #2])&];
	path = Line[Join[{base},sorted,{base}]];
	
	Show[Graphics[{points, path}]]
]

data = Table[{Random[],Random[]},{25}];
SimpleClosedPath[data];

Drawing Trees

(* The following must be evaluated to read in the definitions
   of the tree figures.  Place the file Trees.m where 
   Mathematica can find it.  If necessary, open Trees.m
   in Mathematica and evaluate the initialization cell(s).
*)

<< Trees`

$DefaultFont = {"Times-Roman", 10}

Figure 10.1  A tree with different separations

Show[Graphics[figtree5,
	AspectRatio->Automatic]];

Figure 10.2  Trees whose children have different separations

Clear[a,b]

a = Show[Graphics[t6a,
		PlotRange->{-5.3, 0.3},
		AspectRatio->Automatic]];

b = Show[Graphics[t6b,
		PlotRange->{-5.3, 0.3},
		AspectRatio->Automatic]];

Show[GraphicsArray[{a, b},
	GraphicsSpacing->0.25]];

Figure 10.3  Calculation of the separation between children

Show[Graphics[figtree9]];

Figure 10.4  Results from different tree-drawing algorithms

Clear[a7,b7]

a7 = Show[Graphics[figtree7a,
		AspectRatio->Automatic,
		PlotRange->{-5.3, .25}]];

b7 = Show[Graphics[figtree7b,
		AspectRatio->Automatic,
		PlotRange->{-5.3, .25}]];

Show[GraphicsArray[{a7, b7},
	GraphicsSpacing->0.1]];

Figure 10.5  A tricky tree to draw

Show[Graphics[figtree8,
	AspectRatio->Automatic]];

Section 10.5  Sound

Play[Sin[256 t (2Pi)], {t, 0, 2}]

Options[Play, SampleRate]

Play[Sin[8192 2Pi t], {t, 0, 3}];

digits = RealDigits[N[1/19, 1000]][[1]];

ListPlay[digits];

irratdigits = RealDigits[N[Pi, 1000]][[1]];
ListPlay[irratdigits];

Exercises  (FM synthesis)

fmSynthesis[a_, b_, c_, d_] :=
	Play[Sin[a t + b Sin[c t]], {t, 0, d}]

fmSynthesis[950, 30, 50, 2];    (* FM bird mating call *)

fmSynthesis[312, 30, 5, 5];     (* fly mating call *)

fmSynthesis[1850, 300, 15, 5];  (* let's dance *)

fmSynthesis[8192, 100, 5, 3];   (* cyber police siren *)

White noise, white music

Just scale - C major

c = 261.62558
d = 9/8 c
e = 5/4 c
f = 4/3 c
g = 3/2 c
a = 5/3 c
b = 15/8 c
c2 = 2 c

Pythagorean scale - C major

c = 261.62558
d = 9/8 c
e = 81/64 c
f = 4/3 c
g = 3/2 c
a = 27/16 c
b = 243/128 c
c2 = 2 c

Equal tempered scale - C major

c = 261.62558
d = N[2^(2/12) c]
e = N[2^(4/12) c]
f = N[2^(5/12) c]
g = N[2^(7/12) c]
a = N[2^(9/12) c]
b = N[2^(11/12) c]
c2 = N[2^(12/12) c]

Equal tempered scale - 12 tone, C major

cmajor = Table[N[261.62558 2^(j/12)], {j,0,12}]

Sound graphic (p. 262)

notes4 = Take[cmajor, 4]

x = Do[Play[Sin[notes4[[j]] 2Pi t], {t,0,1}],
 {j,1,4}] //Timing

Sound graphic (p. 263

tones[freq_] := Play[Sin[2 Pi t freq], {t,0,1}]
Map[tones,notes4]; //Timing

Random notes

randomnotes = Table[cmajor[[Random[Integer,{1,12}]]],{20}]

Map[tones,randomnotes];

Using a different distribution

The function "note" generates one of the 8 whole tones in the octave from middle C down to  C below middle C. The probabilities were chosen somewhat at random.

note := Which[(r = Random[]) < .05, cmajor[[1]],
	r < .1, cmajor[[2]],
	r < .2, cmajor[[3]],
	r < .3, cmajor[[4]],
	r < .4, cmajor[[5]],
	r < .5, cmajor[[6]],
	r < .7, cmajor[[7]],
	r < .8, cmajor[[8]],
	r < .85, cmajor[[9]],
	r < .9, cmajor[[10]],
	r < .95, cmajor[[11]],
	r <= 1.0, cmajor[[12]]
]

somenotes = Table[note,{4}]

Map[tones,somenotes];

Varying tones and durations

tonesAndTimes[freq_,time_]:=
	Play[Sin[2 Pi t freq], {t,0,time}]

MapThread[tonesAndTimes, {{189.0,220.0}, {0.5,.25}}];

Now to generate white noise, we generate 20 notes and 20 time durations:

n20 = Table[note,{20}];

t20 = Table[Random[Integer, {1,4}], {20}]/4 ;

This gives a list of fractions 1/4, 1/2, 3/4, 1 corresponding to quarter notes, half notes, etc.

MapThread[tonesAndTimes,{n20,t20}];

Brownian Noise

We want to do a random walk across our list of tones. We will allow steps of 0, 1, 2, -1, -2, steps.

step := Random[Integer, {-2,2}]

s20 = Table[step, {20}];

Need to add 1, so that we get no Part[expr, 0] which would return the Head, not a position.

FoldList[Plus, 6, s20]

pos = Mod[FoldList[Plus, 4, s20], 11] + 1

brown = cmajor[[pos]]

Brownian music

Map[tones, brown];

1/f Fractal Noise (raw code - needs improvement)

cmajor16 = Table[N[261.62558 2^(j/12)], {j, 0, 15}]

r := Random[Integer, {1,6}];
g := Random[Integer, {1,6}];
b := Random[Integer, {1,6}];

red = 0; green = 0; blue = 0;
l = {r + g + b};
n = {{0,0,0}, {0,0,1}, {0,1,0}, {0,1,1},
	 {1,0,0}, {1,0,1}, {1,1,0}, {1,1,1}};
Do[
	If[Mod[n[[j, 3]] + n[[j+1, 3]], 2] == 0, red, red=r];
	If[Mod[n[[j, 2]] + n[[j+1, 2]], 2] == 0, green, green=g];
	If[Mod[n[[j, 1]] + n[[j+1, 1]], 2] == 0, blue, blue=b];
	AppendTo[l, red + green + blue],
{j, 1, 7}]
l

fractal = Table[cmajor16[[ l[[j]] ]], {j, 1, Length[l]}]

tones[freq_] := Play[Sin[2 Pi t freq], {t, 0, 1}]

Map[tones, fractal]