(**** 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 copyrightnotice and the DISCLAIMER OF WARRANTY are included in any copy. DISCLAIMER OF WARRANTY. These programs are provided `as is' withoutwarranty of any kind. We make no warranties, express or implied, that theprograms are free of error, or are consistent with any particular standardof merchantability, or that they will meet your requirements for anyparticular application. They should not be relied upon for solving aproblem whose incorrect solution could result in injury to a person or lossof property. If you do use the programs or functions in such a manner, itis at your own risk. The author and publisher disclaim all liability fordirect, incidental or consequential damages resulting from your use ofthese 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)) endin 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;
(**** 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;