(*^ ::[ 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; keywords = "carddeck, areEltsEven, maxima, removeRand, deal, pick, perfect2, perfectK, chooseWithoutReplacement, perfecto, survivor, pocketChange, frequencies, split1, split2, lotto1, lotto2, makeChange"; fontset = title, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e8, 24, "Times"; ; fontset = subtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, L1, e6, 18, "Times"; ; fontset = subsubtitle, inactive, noPageBreakBelow, noPageBreakInGroup, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, L1, e6, 14, "Times"; ; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, L1, a20, 18, "Times"; ; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, L1, a15, 14, "Times"; ; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, L1, a12, 12, "Times"; ; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 10, "Times"; ; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L1, 12, "Courier"; ; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; ; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L1, 12, "Courier"; ; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, L1, 12, "Courier"; ; fontset = name, inactive, noPageBreakInGroup, nohscroll, preserveAspect, M7, italic, B65535, L1, 10, "Times"; ; fontset = header, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, L1, 12, "Times"; ; fontset = leftheader, 12; fontset = footer, inactive, nohscroll, noKeepOnOnePage, preserveAspect, center, M7, italic, L1, 12, "Times"; ; fontset = leftfooter, 12; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12, "Courier"; ; fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, L1, 12; paletteColors = 128; automaticGrouping; currentKernel; ] :[font = title; inactive; preserveAspect; startGroup] Introduction to Programming with Mathematica ;[s] 2:0,0;35,1;47,-1; 2:1,21,16,Times,1,24,0,0,0;1,22,17,Times,3,24,0,0,0; :[font = subsubtitle; inactive; preserveAspect] By Richard J. Gaylord (gaylord@ux1.cso.uiuc.edu) Samuel N. Kamin (kamin@cs.uiuc.edu) Paul R. Wellin (wellin@sonoma.edu) :[font = subsubtitle; inactive; preserveAspect; plain; fontName = "Times"] Copyright ã 1993 by TELOS/Springer-Verlag ;[s] 3:0,0;10,1;11,2;41,-1; 3:1,13,10,Times,0,14,0,0,0;1,0,0,Symbol,0,14,0,0,0;1,13,10,Times,0,14,0,0,0; :[font = subtitle; inactive; preserveAspect; startGroup] Chapter 4 ± Functions :[font = subsubtitle; inactive; preserveAspect] (Mathematica code) :[font = section; inactive; Cclosed; preserveAspect; startGroup] Functions defined in this Notebook...(page no. in book) :[font = text; inactive; preserveAspect; endGroup] carddeck...78 areEltsEven...77,84 maxima...77, 85 removeRand...78, 85 deal...79,81,82,86 pick...79 perfect2...83 perfectK...83 chooseWithoutReplacement...79 perfecto...83 survivor...88 pocketChange...90 frequencies...91 split1...91 split2...91 lotto1...91 lotto2...92 makeChange...92 :[font = section; inactive; Cclosed; preserveAspect; startGroup] Initialization (evaluate to turn off spell messages) :[font = input; initialization; preserveAspect] *) Off[General::spell] (* :[font = input; initialization; preserveAspect; endGroup] *) Off[General::spell1] (* :[font = section; inactive; Cclosed; preserveAspect; startGroup; keywords = "carddeck"] Section 4.2 Programs as functions :[font = input; preserveAspect] Clear[c,d,h,s,J,Q,K,A] :[font = input; preserveAspect] Trace[Cos[Sin[Tan[4.0]]]] :[font = input; preserveAspect] Apply[And, Map[EvenQ, {2, 4, 6, 7, 8}] ] :[font = input; preserveAspect] Union[Rest[FoldList[Max, 0, {3, 1, 6, 5, 4, 8, 7}]]] :[font = input; preserveAspect] Trace[Union[Rest[FoldList[Max, 0, {3, 1, 6, 5, 4, 8, 7}]]]] :[font = input; preserveAspect] Flatten[Outer[List, {c, d, h, s}, Join[Range[2, 10], {J, Q, K, A}]], 1] :[font = input; preserveAspect] Join[Range[2, 10], {J, Q, K, A}] :[font = input; preserveAspect] Outer[List, {c, d, h, s}, Join[Range[2, 10], {J, Q, K, A}]] :[font = input; preserveAspect] Flatten[%, 1] :[font = input; preserveAspect; endGroup] carddeck = Flatten[Outer[List, {c, d, h, s}, Join[Range[2, 10], {J, Q, K, A}]], 1] :[font = section; inactive; Cclosed; preserveAspect; startGroup; keywords = "areEltsEven, maxima, carddeck, removeRand, deal, pick"] Section 4.3 User-defined functions :[font = input; preserveAspect] areEltsEven[lis_] := Apply[And, Map[EvenQ, lis] ] :[font = input; preserveAspect] areEltsEven[{2, 8, 14, 6, 16}] :[font = input; preserveAspect] maxima[x_] := Union[Rest[FoldList[Max, 0, x]]] :[font = input; preserveAspect] maxima[{4, 2, 7, 3, 4, 9, 14, 11, 17}] :[font = input; preserveAspect] Clear[c,d,h,s,J,Q,K,A] :[font = input; preserveAspect] carddeck = Flatten[Outer[List, {c, d, h, s}, Join[Range[2, 10], {J, Q, K, A}]], 1]; :[font = input; preserveAspect] removeRand[lis_] := Delete[lis, Random[Integer, {1, Length[lis]}]] :[font = input; preserveAspect] deal[n_] := Complement[carddeck, Nest[removeRand, carddeck, n]] :[font = input; preserveAspect] deal[5] :[font = input; preserveAspect] pick[n_] := Table[Random[Integer, {0, 9}], {n}] :[font = input; preserveAspect; endGroup] pick[4] :[font = section; inactive; Cclosed; preserveAspect; startGroup; keywords = "deal, perfect2, perfectK"] Section 4.4 Auxiliary functions :[font = input; preserveAspect] Clear[c,d,h,s,J,Q,K,A] :[font = input; preserveAspect] deal[n_] := (carddeck = Flatten[Outer[List, {c, d, h, s}, Join[Range[2, 10], {J, Q, K, A}]], 1]; removeRand[lis_] := Delete[lis, Random[Integer, {1, Length[lis]}] ]; Complement[carddeck, Nest[removeRand, carddeck, n]] ) :[font = input; preserveAspect] deal[5] :[font = input; preserveAspect] deal[n_] := Module[{removeRand, carddeck}, carddeck = Flatten[Outer[List, {c, d, h, s}, Join[Range[2, 10], {J,Q,K,A}]], 1]; removeRand[lis_] := Delete[lis, Random[Integer, {1, Length[lis]}]]; Complement[carddeck, Nest[removeRand, carddeck, n]] ] :[font = input; preserveAspect] deal[5] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] 4.4 Exercises :[font = input; preserveAspect] perfect2[{n_Integer,m_Integer}] := Position[Map[perfectQ, Range[n,m]], True] + (n-1) :[font = input; preserveAspect] (* Remove comments to evaluate *) (* perfect2[{8100,8200}] *) :[font = input; preserveAspect] perfectK[n_Integer, m_Integer, k_Integer] := (test[j_] := Apply[Plus, Divisors[j]] == k j; Position[Map[test, Range[n,m]], True] + (n - 1) ) :[font = input; preserveAspect] perfectK[n_Integer, m_Integer, k_Integer] := Module[{test,j}, test[j_] := Apply[Plus, Divisors[j]] == k j; Position[Map[test, Range[n,m]], True] + (n - 1) ] :[font = input; preserveAspect] (* Remove comments to evaluate: time consuming *) (* perfectK[1,9000,2] *) :[font = input; preserveAspect; endGroup; endGroup] (* Remove comments to evaluate: time consuming *) (* perfectK[1,1000,3] *) :[font = section; inactive; Cclosed; preserveAspect; startGroup; keywords = "areEltsEven, maxima, removeRand, deal, chooseWithoutReplacement, perfecto"] Section 4.5 Anonymous functions :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] areEltsEven :[font = input; preserveAspect] areEltsEven[lis_] := Apply[And, Map[EvenQ, lis] ] :[font = input; preserveAspect] (Apply[And, Map[EvenQ, #] ])& :[font = input; preserveAspect; endGroup] Function[x, Apply[And, Map[EvenQ, x] ] ] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] maxima :[font = input; preserveAspect] maxima[x_] := Union[Rest[FoldList[Max, 0, x]]] :[font = input; preserveAspect] (Union[Rest[FoldList[Max, 0, #]]])& :[font = input; preserveAspect; endGroup] Function[y, Union[Rest[FoldList[Max, 0, y]]]] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] removeRand :[font = input; preserveAspect] removeRand[lis_] := Delete[lis, Random[Integer, {1, Length[lis]}] ] :[font = input; preserveAspect] (Delete[#, Random[Integer, {1, Length[#]}] ])& :[font = input; preserveAspect; endGroup] Function[x, Delete[x, Random[Integer, {1, Length[x]}] ] ] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] Nested anonymous functions :[font = input; preserveAspect] (Map[(#^2)&, #])&[{3, 2, 7}] :[font = input; preserveAspect; endGroup] Function[y, Map[Function[x, x^2], y]][{3, 2, 7}] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] deal :[font = input; preserveAspect] Clear[c,d,h,s,J,Q,K,A] :[font = input; preserveAspect] deal[n_] := Module[{carddeck}, carddeck = Flatten[Outer[List, {c, d, h, s}, Join[Range[2, 10], {J,Q,K,A}]], 1]; Complement[carddeck, Nest[(Delete[#, Random[Integer, {1, Length[#]}] ])&, carddeck, n]] ] :[font = input; preserveAspect; endGroup] deal[5] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] chooseWithoutReplacement :[font = input; preserveAspect; endGroup] chooseWithoutReplacement[lis_, n_] := Complement[lis, Nest[(Delete[#, Random[Integer, {1, Length[#]}] ])&, lis, n]] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] perfecto :[font = text; inactive; preserveAspect] Here is a good exercise to convert the perfect[ ] function to a self-contained one by using anonymous functions: :[font = input; preserveAspect] perfecto[n_] := Select[Range[n], (Apply[Plus,Divisors[#]] == 2#)&] :[font = input; preserveAspect; endGroup; endGroup] perfecto[500] :[font = section; inactive; Cclosed; preserveAspect; startGroup; keywords = "survivor, pocketChange, frequencies, split1, split2, lotto1, lotto2, makeChange"] Section 4.6 One-liners :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] survivor :[font = input; preserveAspect] survivor[lis_] := Nest[(Rest[RotateLeft[#]])&, lis, Length[lis] - 1] :[font = input; preserveAspect; endGroup] survivor[Range[10]] :[font = subsection; inactive; Cclosed; preserveAspect; startGroup] pocket change :[font = input; preserveAspect] Clear[p,n,d,q] :[font = input; preserveAspect] coins = {p, p, q, n, d, d, p, q, q, p} :[font = input; preserveAspect] Map[(Count[coins, #])&, {p, n, d, q}] :[font = input; preserveAspect] pocketChange[x_] := Apply[Plus, Map[(Count[x, #])&, {p, n, d, q}] {1, 5, 10, 25}] :[font = input; preserveAspect; endGroup] pocketChange[coins] :[font = subsection; inactive; preserveAspect; startGroup] Exercises :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4.6.1 frequencies :[font = input; preserveAspect] frequencies[lis_] := Map[({#, Count[lis, #]})&, Union[lis]] :[font = input; preserveAspect] Clear[a,b,c] :[font = input; preserveAspect; endGroup] frequencies[{a, a, b, b, b, a, c, c}] :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4.6.2 split1 :[font = input; preserveAspect] split1[lis_, parts_] := Inner[Take[lis, {#1, #2}]&, Drop[#1, -1] + 1, Rest[#1], List]&[FoldList[Plus, 0, parts]] :[font = input; preserveAspect; endGroup] split1[Range[10], {2, 5, 0, 3}] :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4.6.3 split2 :[font = input; preserveAspect; endGroup] split2[lis_, parts_] := Map[(Take[lis, # + {1, 0}])&, Partition[FoldList[Plus, 0, parts], 2, 1]] :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4.6.4 lotto1 :[font = input; preserveAspect] lotto1[lis_, n_] := (Flatten[Rest[MapThread[Complement, {RotateRight[#], #}, 1]]])& [NestList[Delete[#, Random[Integer,{1, Length[#]}]]&, lis, n]] :[font = input; preserveAspect; endGroup] lotto1[Range[10], 5] :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4.6.5 lotto2 :[font = input; preserveAspect; endGroup] lotto2[lis_, n_] := Take[Transpose[Sort[ Transpose[{Table[Random[], {Length[lis]}], lis}]]][[2]], n] :[font = subsubsection; inactive; Cclosed; preserveAspect; startGroup] 4.6.7 makeChange :[font = input; preserveAspect] makeChange[x_] := Quotient[Drop[FoldList[Mod, x, {25, 10, 5, 1}], -1], {25, 10, 5, 1}] :[font = input; preserveAspect; endGroup; endGroup; endGroup; endGroup; endGroup] makeChange[119] ^*)