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