1(**** ML Programs from Chapter 5 of 2 3 ML for the Working Programmer, 2nd edition 4 by Lawrence C. Paulson, Computer Laboratory, University of Cambridge. 5 (Cambridge University Press, 1996) 6 7Copyright (C) 1996 by Cambridge University Press. 8Permission to copy without fee is granted provided that this copyright 9notice and the DISCLAIMER OF WARRANTY are included in any copy. 10 11DISCLAIMER OF WARRANTY. These programs are provided `as is' without 12warranty of any kind. We make no warranties, express or implied, that the 13programs are free of error, or are consistent with any particular standard 14of merchantability, or that they will meet your requirements for any 15particular application. They should not be relied upon for solving a 16problem whose incorrect solution could result in injury to a person or loss 17of property. If you do use the programs or functions in such a manner, it 18is at your own risk. The author and publisher disclaim all liability for 19direct, incidental or consequential damages resulting from your use of 20these programs or functions. 21****) 22 23 24(*** Functions as values ***) 25 26fun insort lessequal = 27 let fun ins (x, []) = [x] 28 | ins (x, y::ys) = 29 if lessequal(x,y) then x::y::ys 30 else y :: ins (x,ys) 31 fun sort [] = [] 32 | sort (x::xs) = ins (x, sort xs) 33 in sort end; 34 35(*Sections*) 36fun secl x f y = f(x,y); 37fun secr f y x = f(x,y); 38 39fun summation f m = 40 let fun sum (i,z) : real = 41 if i=m then z else sum (i+1, z + (f i)) 42 in sum(0, 0.0) end; 43 44fun takewhile pred [] = [] 45 | takewhile pred (x::xs) = 46 if pred x then x :: takewhile pred xs 47 else []; 48 49fun dropwhile pred [] = [] 50 | dropwhile pred (x::xs) = 51 if pred x then dropwhile pred xs 52 else x::xs; 53 54infix mem; 55fun x mem xs = List.exists (secr op= x) xs; 56 57fun pair x y = (x,y); 58fun cartprod (xs, ys) = 59 foldr (fn (x, pairs) => 60 foldr (fn (y,l) => (x,y)::l) pairs ys) 61 [] xs; 62 63fun repeat f n x = 64 if n>0 then repeat f (n-1) (f x) 65 else x; 66 67 68(**** Sequences, or Infinite Lists ***) 69 70datatype 'a seq = Nil 71 | Cons of 'a * (unit -> 'a seq); 72 73(*Type seq is free in this signature!*) 74signature SEQUENCE = 75 sig 76 exception Empty 77 val cons : 'a * 'a seq -> 'a seq 78 val null : 'a seq -> bool 79 val hd : 'a seq -> 'a 80 val tl : 'a seq -> 'a seq 81 val fromList : 'a list -> 'a seq 82 val toList : 'a seq -> 'a list 83 val take : 'a seq * int -> 'a list 84 val drop : 'a seq * int -> 'a seq 85 val @ : 'a seq * 'a seq -> 'a seq 86 val interleave : 'a seq * 'a seq -> 'a seq 87 val map : ('a -> 'b) -> 'a seq -> 'b seq 88 val filter : ('a -> bool) -> 'a seq -> 'a seq 89 val iterates : ('a -> 'a) -> 'a -> 'a seq 90 val from : int -> int seq 91 end; 92 93 94structure Seq : SEQUENCE = 95 struct 96 exception Empty; 97 98 fun hd (Cons(x,xf)) = x 99 | hd Nil = raise Empty; 100 101 fun tl (Cons(x,xf)) = xf() 102 | tl Nil = raise Empty; 103 104 fun cons(x,xq) = Cons(x, fn()=>xq); 105 106 fun null (Cons _) = false 107 | null Nil = true; 108 109 fun fromList l = foldr cons Nil l; 110 111 fun toList Nil = [] 112 | toList (Cons(x,xf)) = x :: toList (xf()); 113 114 fun take (xq, 0) = [] 115 | take (Nil, n) = raise Subscript 116 | take (Cons(x,xf), n) = x :: take (xf(), n-1); 117 118 fun drop (xq, 0) = xq 119 | drop (Nil, n) = raise Subscript 120 | drop (Cons(x,xf), n) = drop (xf(), n-1); 121 122 fun Nil @ yq = yq 123 | (Cons(x,xf)) @ yq = Cons(x, fn()=> (xf()) @ yq); 124 125 fun interleave (Nil, yq) = yq 126 | interleave (Cons(x,xf), yq) = 127 Cons(x, fn()=> interleave(yq, xf())); 128 129 (** functionals for sequences **) 130 fun map f Nil = Nil 131 | map f (Cons(x,xf)) = Cons(f x, fn()=> map f (xf())); 132 133 fun filter pred Nil = Nil 134 | filter pred (Cons(x,xf)) = 135 if pred x then Cons(x, fn()=> filter pred (xf())) 136 else filter pred (xf()); 137 138 fun iterates f x = Cons(x, fn()=> iterates f (f x)); 139 140 fun from k = Cons(k, fn()=> from(k+1)); 141 142 end; 143 144 145 146(*** Simple applications ***) 147 148(*Return ALL ways of making change (not just the first way) *) 149fun seqChange (coins, coinvals, 0, coinsf) = Cons(coins,coinsf) 150 | seqChange (coins, [], amount, coinsf) = coinsf() 151 | seqChange (coins, c::coinvals, amount, coinsf) = 152 if amount<0 then coinsf() 153 else seqChange(c::coins, c::coinvals, amount-c, 154 fn() => seqChange(coins, coinvals, amount, coinsf)); 155 156 157(*Sequence of random numbers*) 158local val a = 16807.0 and m = 2147483647.0 159 fun nextRand seed = 160 let val t = a*seed 161 in t - m * real (Real.floor(t/m)) end 162in 163 fun randseq s = Seq.map (secr op/ m) 164 (Seq.iterates nextRand (real s)) 165end; 166 167 168(** prime numbers **) 169 170fun sift p = Seq.filter (fn n => n mod p <> 0); 171 172fun sieve (Cons(p,nf)) = Cons(p, fn()=> sieve (sift p (nf()))); 173 174val primes = sieve (Seq.from 2); 175 176 177(** Numerical methods: square roots **) 178 179fun nextApprox a x = (a/x + x) / 2.0; 180 181fun within (eps:real) (Cons(x,xf)) = 182 let val Cons(y,yf) = xf() 183 in if Real.abs(x-y) < eps then y 184 else within eps (Cons(y,yf)) 185 end; 186 187fun qroot a = within 1E~12 (Seq.iterates (nextApprox a) 1.0); 188 189 190(** Interleaving and sequences of sequences **) 191 192fun makeqq (xq,yq) = Seq.map (fn x=> Seq.map (pair x) yq) xq; 193 194fun takeqq (xqq, (m,n)) = List.map (secr Seq.take n) (Seq.take (xqq,m)); 195 196fun enumerate Nil = Nil 197 | enumerate (Cons(Nil, xqf)) = enumerate (xqf()) 198 | enumerate (Cons(Cons(x,xf), xqf)) = 199 Cons(x, fn()=> Seq.interleave(enumerate (xqf()), xf())); 200 201val double = fn n => n*2; 202fun powof2 n = repeat double n 1; 203fun pack_(i,j) = powof2(i-1) * (2*j - 1); 204 205val pairqq = makeqq (Seq.from 1, Seq.from 1); 206val nqq = Seq.map (Seq.map pack_) pairqq; 207 208 209(*** Searching ***) 210 211fun depthFirst next x = 212 let fun dfs [] = Nil 213 | dfs(y::ys) = Cons(y, fn()=> dfs(next y @ ys)) 214 in dfs [x] end; 215 216fun breadthFirst next x = 217 let fun bfs [] = Nil 218 | bfs(y::ys) = Cons(y, fn()=> bfs(ys @ next y)) 219 in bfs [x] end; 220 221 222(** Generating palindromes **) 223 224fun nextChar l = [#"A"::l, #"B"::l, #"C"::l]; 225fun isPalin l = (l = rev l); 226 227fun show n csq = map implode (Seq.take(csq,n)); 228 229show 8 (Seq.filter isPalin (breadthFirst nextChar [])); 230 231 232(** 8 Queens Problem **) 233 234fun safeQueen oldqs newq = 235 let fun nodiag (i, []) = true 236 | nodiag (i, q::qs) = 237 Int.abs(newq-q)<>i andalso nodiag(i+1,qs) 238 in not (newq mem oldqs) andalso nodiag (1,oldqs) end; 239 240fun upto (m,n) = 241 if m>n then [] else m :: upto(m+1,n); 242 243fun nextQueen n qs = 244 map (secr op:: qs) (List.filter (safeQueen qs) (upto(1,n))); 245 246fun isFull n qs = (length qs=n); 247 248fun depthQueen n = Seq.filter (isFull n) (depthFirst (nextQueen n) []); 249 250 251(** Depth-first iterative deepening **) 252 253fun depthIter next x = 254 let fun dfs k (y, sf) = 255 if k=0 then fn()=> Cons(y,sf) 256 else foldr (dfs (k-1)) sf (next y) 257 fun deepen k = dfs k (x, fn()=> deepen (k+1)) () 258 in deepen 0 end; 259 260