Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /archive/0.93/doc/examples/textbooks/working/Functions.ML
ViewVC logotype

Annotation of /archive/0.93/doc/examples/textbooks/working/Functions.ML

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4958 - (view) (download)

1 : dbm 4958 (**** ML Programs from the book
2 :    
3 :     ML for the Working Programmer
4 :     by Lawrence C. Paulson, Computer Laboratory, University of Cambridge.
5 :     (Cambridge University Press, 1991)
6 :    
7 :     Copyright (C) 1991 by Cambridge University Press.
8 :     Permission to copy without fee is granted provided that this copyright
9 :     notice and the DISCLAIMER OF WARRANTY are included in any copy.
10 :    
11 :     DISCLAIMER OF WARRANTY. These programs are provided `as is' without
12 :     warranty of any kind. We make no warranties, express or implied, that the
13 :     programs are free of error, or are consistent with any particular standard
14 :     of merchantability, or that they will meet your requirements for any
15 :     particular application. They should not be relied upon for solving a
16 :     problem whose incorrect solution could result in injury to a person or loss
17 :     of property. If you do use the programs or functions in such a manner, it
18 :     is at your own risk. The author and publisher disclaim all liability for
19 :     direct, incidental or consequential damages resulting from your use of
20 :     these programs or functions.
21 :     ****)
22 :    
23 :    
24 :     (**** Chapter 5. FUNCTIONS AND INFINITE DATA ****)
25 :    
26 :     (*Sections*)
27 :     fun secl x f y = f(x,y);
28 :     fun secr f y x = f(x,y);
29 :    
30 :     (*** List functionals ***)
31 :    
32 :     fun filter pred [] = []
33 :     | filter pred (x::xs) =
34 :     if pred(x) then x :: filter pred xs
35 :     else filter pred xs;
36 :    
37 :     fun takewhile pred [] = []
38 :     | takewhile pred (x::xs) =
39 :     if pred x then x :: takewhile pred xs
40 :     else [];
41 :    
42 :     fun dropwhile pred [] = []
43 :     | dropwhile pred (x::xs) =
44 :     if pred x then dropwhile pred xs
45 :     else x::xs;
46 :    
47 :     fun foldleft f (e, []) = e
48 :     | foldleft f (e, x::xs) = foldleft f (f(e,x), xs);
49 :    
50 :     fun foldright f ([], e) = e
51 :     | foldright f (x::xs, e) = f(x, foldright f (xs,e));
52 :    
53 :    
54 :     (**** SEQUENCES, OR LAZY LISTS ***)
55 :    
56 :     datatype 'a seq = Nil
57 :     | Cons of 'a * (unit -> 'a seq);
58 :    
59 :     fun head(Cons(x,_)) = x;
60 :     fun tail(Cons(_,xf)) = xf();
61 :    
62 :     (*eager -- evaluates xq -- only for "putting back" a sequence*)
63 :     fun consq(x,xq) = Cons(x, fn()=>xq);
64 :    
65 :     fun from k = Cons(k, fn()=> from(k+1));
66 :    
67 :     fun takeq (0, xq) = []
68 :     | takeq (n, Nil) = []
69 :     | takeq (n, Cons(x,xf)) = x :: takeq (n-1, xf());
70 :    
71 :     (** functionals for sequences **)
72 :     fun mapq f Nil = Nil
73 :     | mapq f (Cons(x,xf)) = Cons(f x, fn()=> mapq f (xf()));
74 :    
75 :     fun filterq pred Nil = Nil
76 :     | filterq pred (Cons(x,xf)) =
77 :     if pred x then Cons(x, fn()=> filterq pred (xf()))
78 :     else filterq pred (xf());
79 :    
80 :     fun iterates f x = Cons(x, fn()=> iterates f (f x));
81 :    
82 :     (*Random numbers: real version for systems with 46-bit mantissas
83 :     Generates sequence of random numbers between 0 and 1 from integer seed *)
84 :     local val a = 16807.0 and m = 2147483647.0 in
85 :     fun nextrandom seed =
86 :     let val t = a*seed
87 :     in t - m * real(floor(t/m)) end
88 :     fun randseq s = mapq (secr op/ m) (iterates nextrandom (real s))
89 :     end;
90 :    
91 :     (** prime numbers **)
92 :     fun sift p = filterq (fn n => n mod p <> 0);
93 :     fun sieve (Cons(p,nf)) = Cons(p, fn()=> sieve (sift p (nf())));
94 :     val primes = sieve (from 2);
95 :    
96 :     (** Square Roots **)
97 :    
98 :     fun nextapprox a x = (a/x + x) / 2.0;
99 :    
100 :     fun within (eps:real) (Cons(x,xf)) =
101 :     let val Cons(y,yf) = xf()
102 :     in if abs(x-y) <= eps then y
103 :     else within eps (Cons(y,yf))
104 :     end;
105 :    
106 :     fun qroot a = within 1E~6 (iterates (nextapprox a) 1.0);
107 :    
108 :    
109 :     (*** Interleaving and sequences of sequences ***)
110 :    
111 :     fun pair x y = (x,y);
112 :     fun makeqq (xq,yq) = mapq (fn x=> mapq (pair x) yq) xq;
113 :     fun takeqq ((m,n), xqq) = map (secl n takeq) (takeq (m,xqq));
114 :    
115 :     fun interleave (Nil, yq) = yq
116 :     | interleave (Cons(x,xf), yq) =
117 :     Cons(x, fn()=> interleave(yq, xf()));
118 :    
119 :     fun enumerate Nil = Nil
120 :     | enumerate (Cons(Nil, xqf)) = enumerate (xqf())
121 :     | enumerate (Cons(Cons(x,xf), xqf)) =
122 :     Cons(x, fn()=> interleave(enumerate (xqf()), xf()));
123 :    
124 :     val pairqq = makeqq (from 1, from 1);
125 :    
126 :     fun powof2 n = if n=0 then 1 else 2 * powof2(n-1);
127 :     fun pack(i,j) = powof2(i-1) * (2*j - 1);
128 :    
129 :     val nqq = mapq (mapq pack) pairqq;
130 :    
131 :    
132 :     (*** Searching ***)
133 :    
134 :     fun depthfirst (next,pred) x =
135 :     let fun dfs [] = Nil
136 :     | dfs(y::ys) =
137 :     if pred y then Cons(y, fn()=> dfs(next y @ ys))
138 :     else dfs(next y @ ys)
139 :     in dfs [x] end;
140 :    
141 :     fun breadthfirst (next,pred) x =
142 :     let fun bfs [] = Nil
143 :     | bfs(y::ys) =
144 :     if pred y then Cons(y, fn()=> bfs(ys @ next y))
145 :     else bfs(ys @ next y)
146 :     in bfs [x] end;
147 :    
148 :     (** 8 Queens Problem **)
149 :    
150 :     fun upto (m,n) =
151 :     if m>n then [] else m :: upto(m+1,n);
152 :    
153 :     infix mem;
154 :     fun x mem [] = false
155 :     | x mem (y::l) = (x=y) orelse (x mem l);
156 :    
157 :     local fun length1 (n, [ ]) = n
158 :     | length1 (n, x::l) = length1 (n+1, l)
159 :     in fun length l = length1 (0,l) end;
160 :    
161 :     fun safequeen oldqs newq =
162 :     let fun nodiag (i, []) = true
163 :     | nodiag (i, q::qs) =
164 :     abs(newq-q)<>i andalso nodiag(i+1,qs)
165 :     in not (newq mem oldqs) andalso nodiag (1,oldqs) end;
166 :    
167 :     fun nextqueen n qs =
168 :     map (secr op:: qs)
169 :     (filter (safequeen qs) (upto(1,n)));
170 :    
171 :     fun isfull n qs = (length qs=n);
172 :    
173 :     (** Depth-first iterative deepening **)
174 :    
175 :     fun depthiter (next,pred) x =
176 :     let fun dfs k (y, sf) =
177 :     if k=0 then
178 :     if pred y then fn()=> Cons(y,sf)
179 :     else sf
180 :     else foldright (dfs (k-1)) (next y, sf)
181 :     fun deepen k = dfs k (x, fn()=> deepen (k+1)) ()
182 :     in deepen 0 end;
183 :    
184 :    
185 :     (******** SHORT DEMONSTRATIONS ********)
186 :    
187 :     (*random numbers*)
188 :     takeq (15, mapq (floor o secl(10.0) op* ) (randseq 1));
189 :    
190 :     takeq(25,primes);
191 :    
192 :     qroot 9.0;
193 :    
194 :     (*sequences of sequences*)
195 :     takeqq ((4,6), nqq);
196 :     takeq(15, enumerate nqq);
197 :    
198 :     (*8 Queens Problem*)
199 :     takeq(100, depthfirst (nextqueen 8, isfull 8) []);
200 :     depthfirst (nextqueen 8, isfull 8) [];
201 :     depthiter (nextqueen 8, isfull 8) [];

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0