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 7 – Recursion

(Mathematica code)

Functions defined in this Notebook

F (Fibonacci function)...129-131
sumElts...132
addPairs...131
multPairwise...133
deal...133
carddeck...133
doubleUptoZero...135
runEncode...135-138
maxima...137,139
interleave2...137
ddx (symbolic derivatives)...141-144
solve...147
elimx1...147
subtractE1...147
encodeString...157,161
decode...158
printTree...152,154
printIndented...152
zip...154
extend...154
drawTree...
drawSepTree...251
placeTree...250
TR...250
TR1...250
width...250
drawTree1... 
drawTree2... 
drawSepTree2... 
settext... 
drawBox... 
revtree... 
transGraphic... 
enlargeDisk... 
fruitTree graphic... 
World tree graphic...154 
huffmanTree... 156
huffman2...157 
FF (Fibonacci function)...162
map...164,166
nest...165
repeat...165

Initialization (evaluate to turn off spell messages)

Off[General::spell]

Off[General::spell1]

Section 7.1  Fibonacci numbers

Clear[F,n]

F[0] := 0
F[1] := 1
F[n_] := F[n-2] + F[n-1] /; n > 1

Table[F[i], {i,0,10}]

Section 7.2  List Functions

sumElts (3 versions)

sumElts[lis_] := Apply[Plus, lis]

sumElts[lis_] := Fold[Plus, 0, lis]

sumElts[{}] := 0
sumElts[{x_, r___}] := x + sumElts[{r}]

addPairs

addPairs[{}, {}] := {}
addPairs[{x1_, r1___}, {x2_, r2___}] :=
              Join[{x1+x2}, addPairs[{r1}, {r2}]]

addPairs[{1, 2, 3}, {4, 5, 6}]

multPairwise

multPairwise[{}] := {}
multPairwise[{x_, y_, r___}] := 
		Join[{x y}, multPairwise[{r}]]

multPairwise[{3, 9, 17, 2, 6, 60}]

deal

Clear[c,d,h,s,J,Q,K,A]

carddeck = 
   Flatten[Outer[List, {c, d, h, s},
		Join[Range[2, 10], {J, Q, K, A}]], 1];

deal[0] := {}

deal[n_] := Module[{dealt = deal[n-1]},
Append[dealt, Complement[carddeck,dealt][[Random[Integer, {1, 53-n}]]]]]

deal[5]

Section 7.3  Thinking Recursively

doubleUptoZero

doubleUptoZero[{}] := {}
doubleUptoZero[{0, y___}] := {0, y}
doubleUptoZero[{x_, y___}] := 
		Join[{2x}, doubleUptoZero[{y}]]

doubleUptoZero[{2, 3, 0, 4, 5}]

doubleUptoZero[{2, 3, 4, 5}]

runEncode

Version 1

runEncode[{}] := {}
runEncode[{x_}] := {{x, 1}}
runEncode[{x_, r___}] :=
    Module[{R = runEncode[{r}]},                                   (* R = {{y, k},...} *)
          Module[{p = First[R], rst = Rest[R]},                (* p = {y, k} *)
             If[x == First[p],                                       (* First[p] = y *)
                Join[{{x, p[[2]]+1}}, rst],                   (* p[[2]] = k *)
                Join[{{x, 1}}, R]]]]

runEncode[{9, 9, 9, 9, 9, 4, 3, 3, 3, 3, 5, 5, 5, 5, 5, 5}]

Version 2

runEncode[{}] := {}
runEncode[{x_}] := {{x, 1}}
runEncode[{x_, r__}] :=
    runEncode[{r}] /. {{y_, k_}, s___} ->
               If[x==y, {{x, k+1}, s}, {{x, 1}, {y, k}, s}]

runEncode[{9, 9, 9, 9, 9, 4, 3, 3, 3, 3, 5, 5, 5, 5, 5, 5}]

Version 3 (Frank Zizza)

runEncode[L_] := 
	Map[({#, 1})&, L] //.
		{x___, {y_, i_}, {y_, j_}, z___} -> {x, {y, i+j}, z}

runEncode[{9, 9, 9, 9, 9, 4, 3, 3, 3, 3, 5, 5, 5, 5, 5, 5}]

maxima

maxima[{}] := {}
maxima[{x_, r___}] := 
	Join[{x}, Select[maxima[{r}], (#>x)&]]

maxima[{9, 2, 10, 3, 14, 9}]

interleave2

Clear[a,b,c,d,e,f]

interleave2[{}, M_] := M
interleave2[L_, {}] := L
interleave2[{x_, r___}, {y_, s___}] := 
	Join[{x, y}, interleave2[{r}, {s}]]

interleave2[{a, b, c}, {1, 2, 3, 4, 5}]

interleave2[{a, b, c, d, e, f}, {1, 2, 3}]

Section 7.4  Recursion and Symbolic Computations

Clear[x,ddx]

ddx[c_?NumberQ] := 0

ddx[x] := 1

ddx[u_ + v_] := ddx[u] + ddx[v]

ddx[u_ - v_] := ddx[u] - ddx[v]

ddx[u_ v_] := u ddx[v] + v ddx[u]

ddx[u_ / v_] := (v ddx[u] - u ddx[v]) / v^2

ddx[u_ ^ c_?NumberQ] := c u^(c-1) ddx[u]

ddx[5 x^3 - 2x^2 + 3/x]

ddx[x^3 (x^2+4)^2]

Section 7.5  Gaussian Elimination

m = N[Table[1/(i+j-1), {i, 15}, {j, 15}]];

b = Table[Random[], {15}];

xs = LinearSolve[m, b]

m.xs - b

solve[S_] :=
   Module[{E1 = First[S],
           x2toxn = solve[elimx1[S]]},
         Module[{b1 = Last[E1],
                 a11 = First[E1],
                 a12toa1n = Drop[Rest[E1], -1]},
            Join[{(b1 - a12toa1n . x2toxn) / a11}, x2toxn]]]

solve[{{a11_, b1_}}] := {b1/a11}

elimx1[S_] := Map[subtractE1[S[[1]], #]&, Rest[S]]

subtractE1[E1_, Ei_] := 
    Module[{z = Ei[[1]]/E1[[1]]},
                Module[{newE1 = z * Rest[E1]},
                                Rest[Ei] - newE1]]

solve[{{1, 2, 3}, {4, 5, 6}}]

Section 7.6  Binary Trees

encodeString

Htree = {" ABEHONST", {" AT", {" "}, {"AT", {"T"}, {"A"}}},
          {"BEHONS", {"EON", {"E"}, {"ON", {"O"}, {"N"}}},
               {"BHS", {"BH", {"H"}, {"B"}}, {"S"}}}};

stringMemberQ[str_, ch_] := StringPosition[str, ch] != {}

encodeChar[c_, {_, lc_, rc_}] :=
   If[stringMemberQ[First[lc], c],   (* if c in left subtree *)
      Join[{0}, encodeChar[c, lc]],  (* prepend 0 *)
      Join[{1}, encodeChar[c, rc]]]  (* otherwise prepend 1 *)

encodeChar[_, {_}] := {}

encodeChar[c_] := encodeChar[c, Htree]

encodeString[str_] :=
    Flatten[Map[encodeChar, Characters[str]]]

encodeString["HONEST ABE"]

decode

decode[code_, {ch_}] :=     (* leaf node - label is character *)
      StringJoin[ch, decode[code, Htree]]
decode[{0, r___}, {_, lc_, _}] := decode[{r}, lc]
decode[{1, r___}, {_, _, rc_}] := decode[{r}, rc]
decode[{}, _] := ""

decode[code_] := decode[code, Htree]

Code for trees

printTree[t_] := printTree[t, 0]

printTree[{lab_}, k_] := (printIndented[lab, 3k]; Null)
printTree[{lab_, lc_, rc_}, k_] :=
   (printIndented[lab, 3k]; Map[(printTree[#, k+1])&, {lc, rc}];)

printIndented[x_, spaces_] :=
   Print[Apply[StringJoin, Table[" ", {spaces}]], x]

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]

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

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

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

TR[{_}] := {{}, {}, {}}
TR[{_, lc_, rc_}] :=
   With[{left = TR[lc],
         right = TR[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}]]]

TR1[{x_}] := {{}, {width[x]/2}, {width[x]/2}}
TR1[{x_, lc_, rc_}] :=
   With[{left = TR1[lc],
         right = TR1[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_] := 0

drawTree1[t_] := drawSepTree1[t, TR1[t][[1]], 0, 0]
drawTree2[t_] := drawSepTree2[t, TR1[t][[1]], 0, 0]

drawSepTree1[{lab_}, {}, lev_, xaxis_] :=
           {Text[settext[lab], {xaxis, lev}]}
        (* should be: drawBox[width[lab], lev, xaxis] *)

drawSepTree1[{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}}]},
         drawSepTree1[lc, ls, lev-1, xaxis-sep],
         drawSepTree1[rc, rs, lev-1, xaxis+sep]]]

drawSepTree2[{lab_}, {}, lev_, xaxis_] :=
           {Text[settext[lab], {xaxis, lev}]}
drawSepTree2[{lab_, lc_, rc_}, {sep_, ls_, rs_}, lev_, xaxis_]  :=
   With[{h1 = If[lab == "", 0, .5],
         h2 = If[lc[[1]] == "", 0, .5],
         h3 = If[rc[[1]] == "", 0, .5]},
      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}}]},
         drawSepTree2[lc, ls, lev-1, xaxis-sep],
         drawSepTree2[rc, rs, lev-1, xaxis+sep]]]

         (* should be: drawBox[width[lab], lev, xaxis], *)
settext[lab_] := FontForm[lab, {"Times-Roman", 10}]
drawBox[w_, y_, x_] :=  (* open rectangle of height ?, width w, centered
                         at (x, y) *)
      With[{height = .3},
        {Line[{{x-w/2, y-height/2}, {x-w/2, y+height/2}}],
         Line[{{x-w/2, y+height/2}, {x+w/2, y+height/2}}],
         Line[{{x+w/2, y+height/2}, {x+w/2, y-height/2}}],
         Line[{{x+w/2, y-height/2}, {x-w/2, y-height/2}}]}]

revtree[{x_}] := {x}
revtree[{x_, t1_, t2_}] := {x, revtree[t2], revtree[t1]}

Clear[transGraphic]
transGraphic[Line[x_], o_] := Line[transGraphic[x, o]]
transGraphic[Disk[x_, w_], o_] := Disk[transGraphic[x, o], w]
transGraphic[Text[t_, x_], o_] := Text[t, transGraphic[x, o]]
transGraphic[{i_, j_}, o_] := {i+o, j}  /; NumberQ[i]
transGraphic[{p1__}, o_] := Map[transGraphic[#, o]&, {p1}]
transGraphic[{any_}, o_] := {transGraphic[any, o]}

enlargeDisk[Disk[x_, w_], f_] := Disk[x, w*f]
enlargeDisk[x_, f_] := x

f[x, y + 1] tree (p. 150)

t1 = {"f", {"x"}, {"+", {"y"}, {"1"}}};
figtree1 = drawTree1[t1];

Show[Graphics[figtree1, PlotRange->{-2.1, .1}]];

Fruit tree (p. 151)

t2 = {"fig", {"date", {"kumquat"}, {"papaya"}}, {"mango"}};
fruitTree = drawTree1[t2];
Show[Graphics[fruitTree, 
	PlotRange->{{-.6, .32},{-2.13, .14}}]];

World tree (p. 154)

worldTree =
    {Text["World", {1.5, 2}],
     Text["Asia", {0, 1}],
     Text["Europe", {1, 1}],
     Text["America", {2, 1}],
     Text["Africa", {3, 1}],
     Text["North", {1.5, 0}],
     Text["South", {2.5, 0}],
     Line[{{1.5, 1.8}, {0, 1.2}}],
     Line[{{1.5, 1.8}, {1, 1.2}}],
     Line[{{1.5, 1.8}, {2, 1.2}}],
     Line[{{1.5, 1.8}, {3, 1.2}}],
     Line[{{2, .8}, {1.5, .2}}],
     Line[{{2, .8}, {2.5, .2}}] };

Show[Graphics[worldTree, 
		PlotRange->{{-.12, 3.2},{-.07,2.1}}]];

Huffman encoding tree (p. 156)

t3 = {"", {"", {"b"}, {"", {"T"}, {"A"}}},
          {"", {"", {"E"}, {"", {"O"}, {"N"}}},
               {"", {"", {"H"}, {"B"}}, {"S"}}}};

huffmanTree = drawTree2[t3];
Show[Graphics[huffmanTree, PlotRange->{-4.2, .1}]];

Huffman tree with interior labels (p. 157)

t4 = {"bABEHONST", {"bAT", {"b"}, {"AT", {"T"}, {"A"}}},
          {"BEHONS", {"EON", {"E"}, {"ON", {"O"}, {"N"}}},
               {"BHS", {"BH", {"H"}, {"B"}}, {"S"}}}};
huffmanTree2 = drawTree2[t4];

Show[Graphics[huffmanTree2, PlotRange->{-4.2,.1}]];

Section 7.7  Dynamic Programming

Fibonacci numbers

FF[0] := 0
FF[1] := 1
FF[n_] := (FF[n] = FF[n-2] + FF[n-1])

Table[FF[j], {j, 1, 10}]

Section 7.8  Higher-Order Functions and Recursion

map

map[f_, {}] := {}
map[f_, {x_, y___}] := Join[{f[x]}, map[f, {y}]]

map[Cos, {1, 2, 3}]

nest

nest[f_, x_, 0] := x
nest[f_, x_, n_] := f[nest[f, x, n-1]]

nest[Cos, 1.0, 50]

repeat

repeat[f_, L_, pred_] := L /; pred[Drop[L, -1], Last[L]]
repeat[f_, L_, pred_] := repeat[f, Append[L, f[Last[L]]], pred]

repeatCount[f_, n_] := repeat[f, {n}, MemberQ]

plus4mod20[x_] := Mod[x+4, 20]

repeatCount[plus4mod20, 0]

Section 7.9  Debugging

F[0] := 0
F[1] := 1
F[n_] := F[n-2] + F[n-1] /; n > 1

?F

Trace[F[2]]

TracePrint[F[2]]

Trace[F[2], F]

TracePrint[F[2], F]

TracePrint[F[2], F[_]]

TracePrint[F[2], F[n_Integer] -> n]

F[n_] := (Print[n]; F[n-2] + F[n-1]) /; n > 1

F[4]