(**** ML Programs from Chapter 5 of ML for the Working Programmer, 2nd edition by Lawrence C. Paulson, Computer Laboratory, University of Cambridge. (Cambridge University Press, 1996) Copyright (C) 1996 by Cambridge University Press. Permission to copy without fee is granted provided that this copyright notice and the DISCLAIMER OF WARRANTY are included in any copy. DISCLAIMER OF WARRANTY. These programs are provided `as is' without warranty of any kind. We make no warranties, express or implied, that the programs are free of error, or are consistent with any particular standard of merchantability, or that they will meet your requirements for any particular application. They should not be relied upon for solving a problem whose incorrect solution could result in injury to a person or loss of property. If you do use the programs or functions in such a manner, it is at your own risk. The author and publisher disclaim all liability for direct, incidental or consequential damages resulting from your use of these programs or functions. ****) (*** Functions as values ***) fun insort lessequal = let fun ins (x, []) = [x] | ins (x, y::ys) = if lessequal(x,y) then x::y::ys else y :: ins (x,ys) fun sort [] = [] | sort (x::xs) = ins (x, sort xs) in sort end; (*Sections*) fun secl x f y = f(x,y); fun secr f y x = f(x,y); fun summation f m = let fun sum (i,z) : real = if i=m then z else sum (i+1, z + (f i)) in sum(0, 0.0) end; fun takewhile pred [] = [] | takewhile pred (x::xs) = if pred x then x :: takewhile pred xs else []; fun dropwhile pred [] = [] | dropwhile pred (x::xs) = if pred x then dropwhile pred xs else x::xs; infix mem; fun x mem xs = List.exists (secr op= x) xs; fun pair x y = (x,y); fun cartprod (xs, ys) = foldr (fn (x, pairs) => foldr (fn (y,l) => (x,y)::l) pairs ys) [] xs; fun repeat f n x = if n>0 then repeat f (n-1) (f x) else x; (**** Sequences, or Infinite Lists ***) datatype 'a seq = Nil | Cons of 'a * (unit -> 'a seq); (*Type seq is free in this signature!*) signature SEQUENCE = sig exception Empty val cons : 'a * 'a seq -> 'a seq val null : 'a seq -> bool val hd : 'a seq -> 'a val tl : 'a seq -> 'a seq val fromList : 'a list -> 'a seq val toList : 'a seq -> 'a list val take : 'a seq * int -> 'a list val drop : 'a seq * int -> 'a seq val @ : 'a seq * 'a seq -> 'a seq val interleave : 'a seq * 'a seq -> 'a seq val map : ('a -> 'b) -> 'a seq -> 'b seq val filter : ('a -> bool) -> 'a seq -> 'a seq val iterates : ('a -> 'a) -> 'a -> 'a seq val from : int -> int seq end; structure Seq : SEQUENCE = struct exception Empty; fun hd (Cons(x,xf)) = x | hd Nil = raise Empty; fun tl (Cons(x,xf)) = xf() | tl Nil = raise Empty; fun cons(x,xq) = Cons(x, fn()=>xq); fun null (Cons _) = false | null Nil = true; fun fromList l = foldr cons Nil l; fun toList Nil = [] | toList (Cons(x,xf)) = x :: toList (xf()); fun take (xq, 0) = [] | take (Nil, n) = raise Subscript | take (Cons(x,xf), n) = x :: take (xf(), n-1); fun drop (xq, 0) = xq | drop (Nil, n) = raise Subscript | drop (Cons(x,xf), n) = drop (xf(), n-1); fun Nil @ yq = yq | (Cons(x,xf)) @ yq = Cons(x, fn()=> (xf()) @ yq); fun interleave (Nil, yq) = yq | interleave (Cons(x,xf), yq) = Cons(x, fn()=> interleave(yq, xf())); (** functionals for sequences **) fun map f Nil = Nil | map f (Cons(x,xf)) = Cons(f x, fn()=> map f (xf())); fun filter pred Nil = Nil | filter pred (Cons(x,xf)) = if pred x then Cons(x, fn()=> filter pred (xf())) else filter pred (xf()); fun iterates f x = Cons(x, fn()=> iterates f (f x)); fun from k = Cons(k, fn()=> from(k+1)); end; (*** Simple applications ***) (*Return ALL ways of making change (not just the first way) *) fun seqChange (coins, coinvals, 0, coinsf) = Cons(coins,coinsf) | seqChange (coins, [], amount, coinsf) = coinsf() | seqChange (coins, c::coinvals, amount, coinsf) = if amount<0 then coinsf() else seqChange(c::coins, c::coinvals, amount-c, fn() => seqChange(coins, coinvals, amount, coinsf)); (*Sequence of random numbers*) local val a = 16807.0 and m = 2147483647.0 fun nextRand seed = let val t = a*seed in t - m * real (Real.floor(t/m)) end in fun randseq s = Seq.map (secr op/ m) (Seq.iterates nextRand (real s)) end; (** prime numbers **) fun sift p = Seq.filter (fn n => n mod p <> 0); fun sieve (Cons(p,nf)) = Cons(p, fn()=> sieve (sift p (nf()))); val primes = sieve (Seq.from 2); (** Numerical methods: square roots **) fun nextApprox a x = (a/x + x) / 2.0; fun within (eps:real) (Cons(x,xf)) = let val Cons(y,yf) = xf() in if Real.abs(x-y) < eps then y else within eps (Cons(y,yf)) end; fun qroot a = within 1E~12 (Seq.iterates (nextApprox a) 1.0); (** Interleaving and sequences of sequences **) fun makeqq (xq,yq) = Seq.map (fn x=> Seq.map (pair x) yq) xq; fun takeqq (xqq, (m,n)) = List.map (secr Seq.take n) (Seq.take (xqq,m)); fun enumerate Nil = Nil | enumerate (Cons(Nil, xqf)) = enumerate (xqf()) | enumerate (Cons(Cons(x,xf), xqf)) = Cons(x, fn()=> Seq.interleave(enumerate (xqf()), xf())); val double = fn n => n*2; fun powof2 n = repeat double n 1; fun pack(i,j) = powof2(i-1) * (2*j - 1); val pairqq = makeqq (Seq.from 1, Seq.from 1); val nqq = Seq.map (Seq.map pack) pairqq; (*** Searching ***) fun depthFirst next x = let fun dfs [] = Nil | dfs(y::ys) = Cons(y, fn()=> dfs(next y @ ys)) in dfs [x] end; fun breadthFirst next x = let fun bfs [] = Nil | bfs(y::ys) = Cons(y, fn()=> bfs(ys @ next y)) in bfs [x] end; (** Generating palindromes **) fun nextChar l = [#"A"::l, #"B"::l, #"C"::l]; fun isPalin l = (l = rev l); fun show n csq = map implode (Seq.take(csq,n)); show 8 (Seq.filter isPalin (breadthFirst nextChar [])); (** 8 Queens Problem **) fun safeQueen oldqs newq = let fun nodiag (i, []) = true | nodiag (i, q::qs) = Int.abs(newq-q)<>i andalso nodiag(i+1,qs) in not (newq mem oldqs) andalso nodiag (1,oldqs) end; fun upto (m,n) = if m>n then [] else m :: upto(m+1,n); fun nextQueen n qs = map (secr op:: qs) (List.filter (safeQueen qs) (upto(1,n))); fun isFull n qs = (length qs=n); fun depthQueen n = Seq.filter (isFull n) (depthFirst (nextQueen n) []); (** Depth-first iterative deepening **) fun depthIter next x = let fun dfs k (y, sf) = if k=0 then fn()=> Cons(y,sf) else foldr (dfs (k-1)) sf (next y) fun deepen k = dfs k (x, fn()=> deepen (k+1)) () in deepen 0 end;