Chapter 10
Graphics Programming

from
Introduction to Programming with Mathematica, 
(2nd Ed.)

Richard J Gaylord
Samuel N. Kamin
Paul R. Wellin

Copyright 1995 TELOS/Springer-Verlag

Initializations

$DefaultFont={"Helvetica",6};

Section 10.1  Graphics Primitives

Code from book

sinplot = Plot[Sin[x], {x,0,2Pi}]

z = 8 + 3I;

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

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

Show[Graphics[{line1, point1}]]

cz = Conjugate[z];
line2 = Line[{{0, 0}, {Re[cz], Im[cz]}}];
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, AxesLabel -> {Re, Im},
             Ticks -> {{{Re[z], "a"}}, {{Im[z], "b"}}},
             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.8, Im[cz] - .35}];

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

arc = Circle[{0, 0}, Abs[z]/3, {0, Arg[z]}];
text4 = Text[FontForm["Arg[z]", {"Times-Italic", 9}],
            {3.5, .5}];

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

Map[{Cos[#], Sin[#], #/N[Pi] - 1}&,
   {Random[Real, {0, N[2Pi]}]}]

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

showRandomWalk3D[1000]

Exercises

Ex.1

coords[n_] := Table[Random[], {n}, {2}]

Show[Graphics[Map[Point,coords[10]] ]]

Show[Graphics[
    {GrayLevel[0.5], PointSize[.03],
     Map[Point, coords[10]]}]]

Ex.2

c = Circle[{0,0}, 1];
ctext = Text[FontForm["Circle", {"Times-Italic",12}],
            {Cos[5Pi/4] + .25,Sin[5Pi/4]}];

t = Line[{{-1,0},{0,1},{1,0},{-1,0}}];
ttext = Text[FontForm["Triangle",{"Times-Italic",12}],
			{0,0+.05}];

r = Line[{{-1,-1},{-1,1},{2,1},{2,-1},{-1,-1}}];
rtext = Text[FontForm["Rectangle",{"Times-Italic",12}],
			{1.5,-1+.05}];

Show[Graphics[{c,t,r,ctext,ttext,rtext}],
    AspectRatio -> Automatic]

Ex.3

cubes = Map[Cuboid[#]&, Table[Random[],{6},{3}]]

Show[Graphics3D[cubes]]

Ex.5

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

r3 = randomWalk3D[2]

distance[{a_, b_}]:=
	Sqrt[Apply[Plus, (b-a)^2]]

distance[{r3[[2]], r3[[3]]}]

Ex.6

Needs["Graphics`Polyhedra`"]

solids =
Map[Graphics3D,{Cube[], Dodecahedron[], GreatDodecahedron[], 
 GreatIcosahedron[], GreatStellatedDodecahedron[], 
 Icosahedron[], Octahedron[],
 SmallStellatedDodecahedron[], Tetrahedron[]}];

gr = {Map[solids[[#]]&, Range[5]], 
 Map[solids[[#]]&,Range[6,9]]}

Show[GraphicsArray[ gr ]]

Section 10.2  Graphics Directives and Options

Code from book

p1 = Point[{0, 0}];
p2 = Point[{1, 0}];
p3 = Point[{.5, .5}];

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

c = Circle[{1, 1}, Sqrt[2]];
Show[Graphics[c, Axes -> Automatic,
                 AspectRatio -> Automatic]]

r1 = (10 + 2^(3/2))/2;
r2 = (10 - 2^(3/2))/2;
c1 = Circle[{-3, 4}, r1];
c2 = Circle[{-3, 4}, r2];

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

dashc1 = {Dashing[{.025, .025}], c1};
dashc2 = {Dashing[{.05, .05}], c2};
Show[Graphics[{c, dashc1, dashc2},
    Axes -> Automatic, AspectRatio -> Automatic]]

Exercises

Exercise 1.

colorWheel[n_]:= 
Show[Graphics[
   Map[{Hue[#/(2Pi-n)], Disk[{0,0}, 1, {#,#+n}]}&,
      Range[0, 2Pi-n, n]],
   AspectRatio -> Automatic]]

colorWheel[Pi/256]

Exercise 3.

randomcoords := Point[{Random[],Random[]}];

randomsize := PointSize[Random[Real,{.01,.1}]]

randomcolor := Hue[Random[]]

pts =
Table[{randomcolor,randomsize,randomcoords}, {500}];

Show[Graphics[pts, PlotRange -> All]]

Section 10.3  Built-in Graphics Functions

Code from book

sinplot = Plot[Sin[x], {x, 0, 2Pi}]

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

Plot3D[Sin[x y], {x,0,2Pi}, {y,0,2Pi},
      PlotPoints -> 80]

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]

Exercises

Ex.1

p1 = Plot[Cos[x] + Cos[3x], {x,-4Pi,4Pi}]

Show[p1, AspectRatio -> 2]

Show[p1,
    AxesLabel -> {FontForm["x",{"Times-Italic",14}],
                  FontForm["y",{"Times-Italic",14}]}]

Show[p1,
    Ticks -> {Range[-4Pi,4Pi,Pi], Automatic},
    DefaultFont -> {"Helvetica", 9}]

Show[p1, PlotLabel -> FontForm["A wiggly plot",
                              {"Times-Bold",20}]]

Ex.2

surf2 = Plot3D[Sin[x y], {x,0,3Pi/2},{y,0,3Pi/2},
			PlotPoints -> 25]

2.a

Show[surf2, ViewPoint->{0.000, 0.000, 3.384}]

2.b

Show[surf2, ColorFunction -> GrayLevel]

2.c

Show[ DensityGraphics[surf2], Mesh->False ]

DensityPlot[Sin[x y], {x,0,3Pi/2}, {y,0,3Pi/2},
	Mesh -> False, PlotPoints -> 100]

Ex.3

sinplot = Plot[Sin[x], {x,0,2Pi}]

Show[sinplot, 
   Graphics[
           {Thickness[.001],
	    Map[Line[{{#[[1]], 0}, #}]&,
	       Nest[First, sinplot, 4]]}]]

Ex.4

Clear[f,x]
f[x_] := x + Sin[x]

Normal[Series[f[x],{x,0,5}]]

Plot[%, {x,-5, 5}]

fplot = Plot[f[x],{x,-5,5},
			PlotStyle->Thickness[.01],
			DisplayFunction->Identity]

fseries = Table[Normal[Series[f[x],{x,0,n}]],{n,1,5,2}];

TableForm[fseries]

seriesplot = Plot[Evaluate[fseries],{x,-5,5},
				PlotStyle->{RGBColor[1,0,0],
				            RGBColor[0,1,0],
				            RGBColor[0,0,1]},
				DisplayFunction->Identity]

Show[fplot,seriesplot,
	DisplayFunction -> $DisplayFunction]

Ex.5

splot = Plot[Sin[x], {x,-2Pi,2Pi}];

Show[splot /. {x_?NumberQ, y_?NumberQ} -> {y,x}]

Ex.6

Plot the function Sin[x y] with x and y taking on values from 0 to 3Pi/2. Then use a transformation rule to perform a shear by stretching the graphic in the x-direction by a factor of 4.

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

Show[p /. {x_?NumberQ, y_?NumberQ, z_?NumberQ} ->
	{4x,y,z},AspectRatio->Automatic]

Ex.7

plot1 = Plot[Sin[x], {x,0,2Pi}]

RotatePlot[p_, theta_] := Show[p /. 
{x_?NumberQ,y_?NumberQ} ->
	{x,y}.{{Cos[theta],Sin[theta]},
	       {-Sin[theta],Cos[theta]}}]

RotatePlot[plot1, Pi]

Section 10.4  Graphics Programming

Simple Closed Paths

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

points = Map[Point, coords]

Show[Graphics[{PointSize[.02], points}]]

lines = Line[coords]

Show[Graphics[{PointSize[.02], points, lines}]]

path = Line[coords /. {a_,b__} -> {a,b,a}];
Show[Graphics[{PointSize[.02], points, path}]];

base = {0,0};
p1 = {5,2};
p2 = {3,4};
p3 = {-4,1.5};
font = {"Helvetica-Bold",10};
Show[Graphics[
	{Line[{base,p1}],Line[{base,p2}],Line[{base,p3}],
	 RGBColor[0,0,1],
	 Circle[base,3.5,{0,Arg[5+2I]}],
	 Circle[base,2.5,{0,Arg[3+4I]}],
	 Circle[base,1.5,{0,Arg[-4+1.5I]}],
	 GrayLevel[0],
	 Text[FontForm["Base",font],base-.2,{-1,1}],
	 Text[FontForm["p1",font],p1+.1,{-1,-1}],
	 Text[FontForm["p2",font],p2+.1,{-1,-1}],
	 Text[FontForm["p3",font],p3+.1,{-1,-1}],
	 Hue[0],PointSize[.02],Map[Point,{base,p1,p2,p3}],
	 GrayLevel[0],Dashing[{.05,.02}],Line[{{-5,0},{6,0}}]},
	 PlotRange->All,AspectRatio->Automatic]]

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

remain = Complement[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], points, path}]]

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

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

simpleClosedPath[data]

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

simpleClosedPath[data]

Trees

SetDirectory["/Zeppo/IPM2/DisketteFiles"];

<< Trees.m

Show[Graphics[figtree5,
	AspectRatio->Automatic,
	DefaultFont -> {"Helvetica",8}]];

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

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

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

Show[Graphics[figtree9,
	DefaultFont->{"Helvetica",10},
	PlotRange->All]];

placeTree[{_}] := {{ }, 0, 0}
placeTree[{_, lc_, rc_}] :=
   Module[{left = placeTree[lc], right = placeTree[rc],
           minsep = 1.0},
   Module[{sep = left[[3]] + right[[2]] + minsep},
         {{sep, left[[1]], right[[1]]},
          left[[2]] + sep/2, right[[3]] + sep/2}]]

drawSepTree[{}, lev_, xaxis_] := {Disk[{xaxis, lev}, 0.1]}
drawSepTree[{sep_, lc_, rc_}, lev_, xaxis_] :=
   Join[{Disk[{xaxis, lev}, 0.1],
         Line[{{xaxis, lev}, {xaxis-sep, lev-1}}],
         Line[{{xaxis, lev}, {xaxis+sep, lev-1}}]},
drawSepTree[lc, lev-1, xaxis-sep],
drawSepTree[rc, lev-1, xaxis+sep]]

Clear[a,b,c,d,e,f,g]
tree1 = {a, {b}, {a, {c, {e, {g}, {f}}, {d}}, {b}}}

showTree[tree_]:=
	Show[Graphics[drawSepTree[placeTree[tree][[1]],0,0]
	]]

showTree[tree1]

Exercises

Exercise 1.

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

pts = Table[Random[],{20},{2}];
SimpleClosedPath[pts]

Exercise 3.

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

SimpleClosedPath[ Table[Random[],{10},{2}] ]

Exercise 5.

a = {0,0};
b = {5,0};
c = {3,2};
alt = {3,0};
Show[Graphics[
	{GrayLevel[.75], Polygon[{a,b,c,a}],
	 RGBColor[1,0,0], Line[{a,b,c,a}],
	 GrayLevel[0], Dashing[{.04,.02}], Line[{c,alt}]},
	AspectRatio -> Automatic]]

Needs["Graphics`Arrow`"]

a = {0,0};
b = {5,0};
c = {3,2};
d = {-2,2};
Show[Graphics[{GrayLevel[.75],Polygon[{a,b,c,d}],
               Hue[0], Arrow[a,b], Arrow[a,c],
               GrayLevel[0],Line[{a,b,c,a}]}]]

Needs["Calculus`VectorAnalysis`"]

CrossProduct[{x2,y2}-{x1,y1}, {x3,y3}-{x1,y1}] /. 
	{x_,y_} -> {x,y,0}

a = {0,0};
b = {5,0};
c = {3,2};

CrossProduct[(b-a),(c-a)] /. {x_,y_} -> {x,y,0}

Apply[Plus,%]/2

triangleArea[v_List]:=
   1/2 Plus @@ (CrossProduct[v[[2]]-v[[1]],v[[3]]-v[[1]]] /. 
			{x_,y_} -> {x,y,0})

triangleArea[{v1_,v2_,v3_}]:=
   Det[{v1,v2,v3} /. {x_,y_} -> {x,y,1}]/2

triangleArea[{a,b,c}]

Exercise 7.

pointInPolygonQ[p_, poly_]:= Module[{leftofQ},
   leftofQ[{v1_,v2_,v3_}]:= 
      Det[{v1,v2,v3} /. {x_,y_} -> {x,y,1}]/2 >= 0;
   Apply[And, Map[leftofQ[Join[{p},#]]&,
                 Partition[poly/.{a_,b__}:>{a,b,a},2,1]]
   ]]

quad = {{1,0},{0,1},{-1,0},{0,-1}};

p1 = {0,0};

p2 = {1,1};

Show[Graphics[{Line[quad /. {a_,b__}:>{a,b,a}],
   PointSize[.025], Point[p1], Point[p2]},
   AspectRatio->Automatic]]

pointInPolygonQ[p1, quad]

pointInPolygonQ[p2, quad]

Exercise 8.

a7 = Show[Graphics[figtree7a,
	AspectRatio->Automatic,
	DefaultFont -> {"Helvetica",8},
	PlotRange->All]];

b7 = Show[Graphics[figtree7b,
	AspectRatio->Automatic,
	DefaultFont -> {"Helvetica",8},
	PlotRange->All]];

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

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

zip[{}, _] := {}
zip[_, {}] := {}
zip[{x1_, y1___}, {x2_, y2___}] := 
   Join[{{x1, x2}}, zip[{y1}, {y2}]]

extend[edges1_, edges2_, sep_] :=
   Join[edges1+sep,
        Take[edges2, 
        Min[0, Length[edges1]-Length[edges2]]] - sep]

RT[{_}] := {{}, {}, {}}
RT[{_, lc_, rc_}] :=
   With[{left = RT[lc],
         right = RT[rc],
         minsep = 2.0},
      With[{sep = (Max[0, Apply[Max, Map[Apply[Plus, #]&,
                         zip[left[[3]], right[[2]]]]]] + minsep) / 2},
         With[{newtree = {sep, left[[1]], right[[1]]},
               leftedge = Join[{sep}, extend[left[[2]], right[[2]], sep]],
               rightedge = Join[{sep}, extend[right[[3]], left[[3]], sep]]},
            {newtree, leftedge, rightedge}]]]

drawSepTree[{}, lev_, xaxis_] := {Disk[{xaxis, lev}, 0.2]}
drawSepTree[{sep_, lc_, rc_}, lev_, xaxis_]  :=
   Join[{Disk[{xaxis, lev}, 0.2],
         Line[{{xaxis,lev}, {xaxis-sep, lev-1}}],
         Line[{{xaxis,lev}, {xaxis+sep, lev-1}}]},
        drawSepTree[lc, lev-1, xaxis-sep],
        drawSepTree[rc, lev-1, xaxis+sep]]

drawTree[t_] := drawSepTree[RT[t][[1]], 0, 0]

Clear[a,b,c,d,e,f,g];
t1 = {a, {b}, {a, {c, {e, {g}, {f}}, {d}}, {b}}}

Show[Graphics[drawTree[t1]],
   PlotRange -> All,
   AspectRatio -> Automatic]

Exercise 9.

RT[{x_}] := {{}, {width[x]/2}, {width[x]/2}}
RT[{x_, lc_, rc_}] :=
   With[{left = RT[lc],
         right = RT[rc],
         minsep = 0.5},
      With[{sep = (Max[0, Apply[Max, Map[Apply[Plus, #]&,
                         zip[left[[3]], right[[2]]]]]] + minsep) / 2},
         With[{newtree = {sep, left[[1]], right[[1]]},
               leftedge = Join[{width[x]/2},
                               extend[left[[2]], right[[2]], sep]],
               rightedge = Join[{width[x]/2},
                                extend[right[[3]], left[[3]], sep]]},
            {newtree, leftedge, rightedge}]]]

width[t_] := StringLength[t]

t1 = {"a", {"abcdef"}, {"", {"abcdefghij"}, {"abc"}}}

settext[lab_] := FontForm[lab, {"Helvetica", 10}]

drawSepTree[{lab_}, {}, lev_, xaxis_] :=
           {Text[settext[lab], {xaxis, lev}]}

drawSepTree[{lab_, lc_, rc_}, {sep_, ls_, rs_}, lev_, xaxis_]  :=
   With[{h1 = If[lab == "", 0, .3],
         h2 = If[lc[[1]] == "", 0, .3],
         h3 = If[rc[[1]] == "", 0, .3]},
      Join[{Text[settext[lab], {xaxis, lev}],
            Line[{{xaxis-sep*(h1/2), lev-h1/2},
                  {xaxis-sep+sep*(h2/2), lev-1+h2/2}}],
            Line[{{xaxis+sep*(h1/2), lev-h1/2},
                  {xaxis+sep-sep*(h3/2), lev-1+h3/2}}]},
         drawSepTree[lc, ls, lev-1, xaxis-sep],
         drawSepTree[rc, rs, lev-1, xaxis+sep]]]

drawTree[t_] := drawSepTree[t, RT[t][[1]], 0, 0]

Show[Graphics[drawTree[t1]], 
   PlotRange -> All]

Section 10.5  Sound

Code from book

Plot[Sin[x], {x,0,2Pi}]

Plot[Sin[4x], {x,0,2Pi}];

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

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]

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

SetAttributes[playTones, Listable]

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

notes4 = Take[cmajor, 4];

playTones[notes4]

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

s20 = Table[step, {20}]

FoldList[Plus, 6, s20]

cmajor[[14]]

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

brown = cmajor[[pos]]

brownMusic[n_Integer, r_:2] := Module[{cmajor, s},
   cmajor = Table[N[261.62558 2^(j/12)], {j,0,11}];
   s = Table[Random[Integer,{-r,r}], {n}];
   cmajor[[ Mod[FoldList[Plus,4,s],11]+1 ]]
   ]

playTones[brownMusic[4] ]

Exercises

Ex.1

Play[Sin[1000/x],{x,-2,2}]

Ex.3

Play[Sin[2^t], {t,10,14}]

Ex.4

Here is a function for playing square waves. In this case, freq is the fundamental frequency, n is the order of the approximating function, and time gives the duration of the tone in seconds.

squarePlay[freq_, n_, time_] := 
Play[Sum[Sin[freq i 2Pi t], {i,1,n,2}], {t,0,time}]

This plays a tone with a fundamental frequency of 440Hz, using a fifth-order approximation, for 0.5 seconds.

squarePlay[440, 5, .5]

Here is a true square wave with a fundamental frequency of 440Hz.

Plot[(Sign[440t - Floor[440t] - 1/2] + 1)/2,
	{t,0,3/440}]

Play[(Sign[440t - Floor[440t] - 1/2] + 1)/2,
	{t,0,1}]

Ex.5

squarePlay[freq_, n_, time_] := 
   Play[Sum[Sin[freq i 2Pi t]/i, {i,1,n,2}],
       {t,0,time}]

squarePlay[440, 7, .5]

Plot[-440t-Floor[-440t], {t,0,3/440}]

Ex.7

sawPlay[freq_, n_, time_] := 
   Play[Sum[Sin[freq i 2Pi t]/i, {i,1,n}], {t,0,time}]

sawPlay[440, 6, 0.5]

Plot[-440t-Floor[-440t], {t,0,3/440}]

Play[-440t-Floor[-440t], {t,0,.5}]

Ex.8

Frequency modulation is given by the following formula.

a Sin[2Pi Fc t + mod Sin[2Pi Fm t]]

where a is the peak amplitude, Fc is the carrier frequency in Hz, mod the modulation index, and Fm is the modulating frequency in Hz.

FM[Amp_,Fc_,mod_,Fm_,time_]:=
	Play[Amp Sin[2Pi Fc t + mod Sin[2Pi Fm t]],
		{t,0,time}]

With a modulating frequency below 20Hz, vibrato is obtained.

FM[1, 440, 45, 4, 3]

Here is a more complicated modulation example.

FM[1, 440, 4400, 440, 2]

Ex.9

pentatonic[n_Integer, r_:2] := Module[{pscale, s},
	pscale = {277.183,311.13,369.99,415.30,466.16,554.37};
	s = Table[Random[Integer,{-r,r}], {n}];
	pscale[[ Mod[FoldList[Plus,3,s],4]+1 ]]
   ]

pentatonic[8]

playTones[ pentatonic[4] ]

Exe.10

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

pick := Which[(r=Random[Integer,{1,100}])<=5, cmajor[[1]],
			r<=10, cmajor[[2]],
			r<=15, cmajor[[3]],
			r<=25, cmajor[[4]],
			r<=35, cmajor[[5]],
			r<=45, cmajor[[6]],
			r<=55, cmajor[[7]],
			r<=65, cmajor[[8]],
			r<=75, cmajor[[9]],
			r<=85, cmajor[[10]],
			r<=90, cmajor[[11]],
			r<=95, cmajor[[12]],
			r<=100,cmajor[[13]]
			]

Table[pick,{5}]

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

Scan[playTone, Table[pick,{2}]]

Ex.11

tonesAndTimes[n_]:= Module[{cmajor, notes, durs},
	cmajor = Table[N[261.62558 2^(j/12)], {j,0,11}];
	notes := Table[cmajor[[Random[Integer,{1,12}]]],{n}];
	durs := Table[1/2^(Random[Integer,{0,3}]),{n}];
	MapThread[playTones,{notes, durs}]]

tonesAndTimes[3]

Ex.13

Following the implementation in the text, we first create 10 steps between -2 and 2. These steps will determine how to move up or down the list of tone durations (1/4,1/2,/3/4,1).

d10 = Table[Random[Integer,{-2,2}], {10}]

Mod[FoldList[Plus,0,d10], 4] + 1

durs = {1/8,1/4,1/2,1}[[%]]

Here are some 1/f^2 tones.

s10 = Table[Random[Integer,{-2,2}], {10}]

pos = Mod[FoldList[Plus,0,s10],13]+1

tones = cmajor[[pos]]

MapThread[playTones,{tones,durs}]

And finally, here is one function that puts this all together.

tonesAndTimes2[n_]:= Module[{cmajor, tones, durs,d,t},
	cmajor = Table[N[261.62558 2^(j/12)], {j,0,11}];
	d = Table[Random[Integer,{-2,2}], {n}];
	durs = {1/8,1/4,1/2,1}[[ Mod[FoldList[Plus,0,d], 4] + 1 ]];
	t = Table[Random[Integer,{-2,2}], {n}];
	tones = cmajor[[ Mod[FoldList[Plus,0,t],13]+1 ]];
	MapThread[playTones,{tones, durs}]]

tonesAndTimes2[3]

Ex.14

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

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}};
red=0; blue=0; green=0;
l = {red + green + blue};

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+=1

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

Scan[playTones, fractal]