39348
|
1 |
(* ========================================================================= *)
|
|
2 |
(* ML UTILITY FUNCTIONS *)
|
39349
|
3 |
(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License *)
|
39348
|
4 |
(* ========================================================================= *)
|
|
5 |
|
|
6 |
structure Useful :> Useful =
|
|
7 |
struct
|
|
8 |
|
|
9 |
(* ------------------------------------------------------------------------- *)
|
|
10 |
(* Exceptions. *)
|
|
11 |
(* ------------------------------------------------------------------------- *)
|
|
12 |
|
|
13 |
exception Error of string;
|
|
14 |
|
|
15 |
exception Bug of string;
|
|
16 |
|
|
17 |
fun errorToStringOption err =
|
|
18 |
case err of
|
|
19 |
Error message => SOME ("Error: " ^ message)
|
|
20 |
| _ => NONE;
|
|
21 |
|
|
22 |
(*mlton
|
|
23 |
val () = MLton.Exn.addExnMessager errorToStringOption;
|
|
24 |
*)
|
|
25 |
|
|
26 |
fun errorToString err =
|
|
27 |
case errorToStringOption err of
|
|
28 |
SOME s => "\n" ^ s ^ "\n"
|
|
29 |
| NONE => raise Bug "errorToString: not an Error exception";
|
|
30 |
|
|
31 |
fun bugToStringOption err =
|
|
32 |
case err of
|
|
33 |
Bug message => SOME ("Bug: " ^ message)
|
|
34 |
| _ => NONE;
|
|
35 |
|
|
36 |
(*mlton
|
|
37 |
val () = MLton.Exn.addExnMessager bugToStringOption;
|
|
38 |
*)
|
|
39 |
|
|
40 |
fun bugToString err =
|
|
41 |
case bugToStringOption err of
|
|
42 |
SOME s => "\n" ^ s ^ "\n"
|
|
43 |
| NONE => raise Bug "bugToString: not a Bug exception";
|
|
44 |
|
|
45 |
fun total f x = SOME (f x) handle Error _ => NONE;
|
|
46 |
|
|
47 |
fun can f = Option.isSome o total f;
|
|
48 |
|
|
49 |
(* ------------------------------------------------------------------------- *)
|
|
50 |
(* Tracing. *)
|
|
51 |
(* ------------------------------------------------------------------------- *)
|
|
52 |
|
|
53 |
val tracePrint = ref print;
|
|
54 |
|
|
55 |
fun trace mesg = !tracePrint mesg;
|
|
56 |
|
|
57 |
(* ------------------------------------------------------------------------- *)
|
|
58 |
(* Combinators. *)
|
|
59 |
(* ------------------------------------------------------------------------- *)
|
|
60 |
|
|
61 |
fun C f x y = f y x;
|
|
62 |
|
|
63 |
fun I x = x;
|
|
64 |
|
|
65 |
fun K x y = x;
|
|
66 |
|
|
67 |
fun S f g x = f x (g x);
|
|
68 |
|
|
69 |
fun W f x = f x x;
|
|
70 |
|
|
71 |
fun funpow 0 _ x = x
|
|
72 |
| funpow n f x = funpow (n - 1) f (f x);
|
|
73 |
|
|
74 |
fun exp m =
|
|
75 |
let
|
|
76 |
fun f _ 0 z = z
|
|
77 |
| f x y z = f (m (x,x)) (y div 2) (if y mod 2 = 0 then z else m (z,x))
|
|
78 |
in
|
|
79 |
f
|
|
80 |
end;
|
|
81 |
|
|
82 |
(* ------------------------------------------------------------------------- *)
|
|
83 |
(* Pairs. *)
|
|
84 |
(* ------------------------------------------------------------------------- *)
|
|
85 |
|
|
86 |
fun fst (x,_) = x;
|
|
87 |
|
|
88 |
fun snd (_,y) = y;
|
|
89 |
|
|
90 |
fun pair x y = (x,y);
|
|
91 |
|
|
92 |
fun swap (x,y) = (y,x);
|
|
93 |
|
|
94 |
fun curry f x y = f (x,y);
|
|
95 |
|
|
96 |
fun uncurry f (x,y) = f x y;
|
|
97 |
|
|
98 |
val op## = fn (f,g) => fn (x,y) => (f x, g y);
|
|
99 |
|
|
100 |
(* ------------------------------------------------------------------------- *)
|
|
101 |
(* State transformers. *)
|
|
102 |
(* ------------------------------------------------------------------------- *)
|
|
103 |
|
|
104 |
val unit : 'a -> 's -> 'a * 's = pair;
|
|
105 |
|
|
106 |
fun bind f (g : 'a -> 's -> 'b * 's) = uncurry g o f;
|
|
107 |
|
|
108 |
fun mmap f (m : 's -> 'a * 's) = bind m (unit o f);
|
|
109 |
|
|
110 |
fun mjoin (f : 's -> ('s -> 'a * 's) * 's) = bind f I;
|
|
111 |
|
|
112 |
fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end;
|
|
113 |
|
|
114 |
(* ------------------------------------------------------------------------- *)
|
|
115 |
(* Equality. *)
|
|
116 |
(* ------------------------------------------------------------------------- *)
|
|
117 |
|
|
118 |
val equal = fn x => fn y => x = y;
|
|
119 |
|
|
120 |
val notEqual = fn x => fn y => x <> y;
|
|
121 |
|
|
122 |
fun listEqual xEq =
|
|
123 |
let
|
|
124 |
fun xsEq [] [] = true
|
|
125 |
| xsEq (x1 :: xs1) (x2 :: xs2) = xEq x1 x2 andalso xsEq xs1 xs2
|
|
126 |
| xsEq _ _ = false
|
|
127 |
in
|
|
128 |
xsEq
|
|
129 |
end;
|
|
130 |
|
|
131 |
(* ------------------------------------------------------------------------- *)
|
|
132 |
(* Comparisons. *)
|
|
133 |
(* ------------------------------------------------------------------------- *)
|
|
134 |
|
|
135 |
fun mapCompare f cmp (a,b) = cmp (f a, f b);
|
|
136 |
|
|
137 |
fun revCompare cmp x_y =
|
|
138 |
case cmp x_y of LESS => GREATER | EQUAL => EQUAL | GREATER => LESS;
|
|
139 |
|
|
140 |
fun prodCompare xCmp yCmp ((x1,y1),(x2,y2)) =
|
|
141 |
case xCmp (x1,x2) of
|
|
142 |
LESS => LESS
|
|
143 |
| EQUAL => yCmp (y1,y2)
|
|
144 |
| GREATER => GREATER;
|
|
145 |
|
|
146 |
fun lexCompare cmp =
|
|
147 |
let
|
|
148 |
fun lex ([],[]) = EQUAL
|
|
149 |
| lex ([], _ :: _) = LESS
|
|
150 |
| lex (_ :: _, []) = GREATER
|
|
151 |
| lex (x :: xs, y :: ys) =
|
|
152 |
case cmp (x,y) of
|
|
153 |
LESS => LESS
|
|
154 |
| EQUAL => lex (xs,ys)
|
|
155 |
| GREATER => GREATER
|
|
156 |
in
|
|
157 |
lex
|
|
158 |
end;
|
|
159 |
|
|
160 |
fun optionCompare _ (NONE,NONE) = EQUAL
|
|
161 |
| optionCompare _ (NONE,_) = LESS
|
|
162 |
| optionCompare _ (_,NONE) = GREATER
|
|
163 |
| optionCompare cmp (SOME x, SOME y) = cmp (x,y);
|
|
164 |
|
|
165 |
fun boolCompare (false,true) = LESS
|
|
166 |
| boolCompare (true,false) = GREATER
|
|
167 |
| boolCompare _ = EQUAL;
|
|
168 |
|
|
169 |
(* ------------------------------------------------------------------------- *)
|
|
170 |
(* Lists. *)
|
|
171 |
(* ------------------------------------------------------------------------- *)
|
|
172 |
|
|
173 |
fun cons x y = x :: y;
|
|
174 |
|
|
175 |
fun hdTl l = (hd l, tl l);
|
|
176 |
|
|
177 |
fun append xs ys = xs @ ys;
|
|
178 |
|
|
179 |
fun singleton a = [a];
|
|
180 |
|
|
181 |
fun first f [] = NONE
|
|
182 |
| first f (x :: xs) = (case f x of NONE => first f xs | s => s);
|
|
183 |
|
|
184 |
fun maps (_ : 'a -> 's -> 'b * 's) [] = unit []
|
|
185 |
| maps f (x :: xs) =
|
|
186 |
bind (f x) (fn y => bind (maps f xs) (fn ys => unit (y :: ys)));
|
|
187 |
|
|
188 |
fun mapsPartial (_ : 'a -> 's -> 'b option * 's) [] = unit []
|
|
189 |
| mapsPartial f (x :: xs) =
|
|
190 |
bind
|
|
191 |
(f x)
|
|
192 |
(fn yo =>
|
|
193 |
bind
|
|
194 |
(mapsPartial f xs)
|
|
195 |
(fn ys => unit (case yo of NONE => ys | SOME y => y :: ys)));
|
|
196 |
|
|
197 |
fun zipWith f =
|
|
198 |
let
|
|
199 |
fun z l [] [] = l
|
|
200 |
| z l (x :: xs) (y :: ys) = z (f x y :: l) xs ys
|
|
201 |
| z _ _ _ = raise Error "zipWith: lists different lengths";
|
|
202 |
in
|
|
203 |
fn xs => fn ys => rev (z [] xs ys)
|
|
204 |
end;
|
|
205 |
|
|
206 |
fun zip xs ys = zipWith pair xs ys;
|
|
207 |
|
|
208 |
fun unzip ab =
|
|
209 |
foldl (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) (rev ab);
|
|
210 |
|
|
211 |
fun cartwith f =
|
|
212 |
let
|
|
213 |
fun aux _ res _ [] = res
|
|
214 |
| aux xsCopy res [] (y :: yt) = aux xsCopy res xsCopy yt
|
|
215 |
| aux xsCopy res (x :: xt) (ys as y :: _) =
|
|
216 |
aux xsCopy (f x y :: res) xt ys
|
|
217 |
in
|
|
218 |
fn xs => fn ys =>
|
|
219 |
let val xs' = rev xs in aux xs' [] xs' (rev ys) end
|
|
220 |
end;
|
|
221 |
|
|
222 |
fun cart xs ys = cartwith pair xs ys;
|
|
223 |
|
|
224 |
fun takeWhile p =
|
|
225 |
let
|
|
226 |
fun f acc [] = rev acc
|
|
227 |
| f acc (x :: xs) = if p x then f (x :: acc) xs else rev acc
|
|
228 |
in
|
|
229 |
f []
|
|
230 |
end;
|
|
231 |
|
|
232 |
fun dropWhile p =
|
|
233 |
let
|
|
234 |
fun f [] = []
|
|
235 |
| f (l as x :: xs) = if p x then f xs else l
|
|
236 |
in
|
|
237 |
f
|
|
238 |
end;
|
|
239 |
|
|
240 |
fun divideWhile p =
|
|
241 |
let
|
|
242 |
fun f acc [] = (rev acc, [])
|
|
243 |
| f acc (l as x :: xs) = if p x then f (x :: acc) xs else (rev acc, l)
|
|
244 |
in
|
|
245 |
f []
|
|
246 |
end;
|
|
247 |
|
|
248 |
fun groups f =
|
|
249 |
let
|
|
250 |
fun group acc row x l =
|
|
251 |
case l of
|
|
252 |
[] =>
|
|
253 |
let
|
|
254 |
val acc = if null row then acc else rev row :: acc
|
|
255 |
in
|
|
256 |
rev acc
|
|
257 |
end
|
|
258 |
| h :: t =>
|
|
259 |
let
|
|
260 |
val (eor,x) = f (h,x)
|
|
261 |
in
|
|
262 |
if eor then group (rev row :: acc) [h] x t
|
|
263 |
else group acc (h :: row) x t
|
|
264 |
end
|
|
265 |
in
|
|
266 |
group [] []
|
|
267 |
end;
|
|
268 |
|
|
269 |
fun groupsBy eq =
|
|
270 |
let
|
|
271 |
fun f (x_y as (x,_)) = (not (eq x_y), x)
|
|
272 |
in
|
|
273 |
fn [] => []
|
|
274 |
| h :: t =>
|
|
275 |
case groups f h t of
|
|
276 |
[] => [[h]]
|
|
277 |
| hs :: ts => (h :: hs) :: ts
|
|
278 |
end;
|
|
279 |
|
|
280 |
local
|
|
281 |
fun fstEq ((x,_),(y,_)) = x = y;
|
|
282 |
|
|
283 |
fun collapse l = (fst (hd l), map snd l);
|
|
284 |
in
|
|
285 |
fun groupsByFst l = map collapse (groupsBy fstEq l);
|
|
286 |
end;
|
|
287 |
|
|
288 |
fun groupsOf n =
|
|
289 |
let
|
|
290 |
fun f (_,i) = if i = 1 then (true,n) else (false, i - 1)
|
|
291 |
in
|
|
292 |
groups f (n + 1)
|
|
293 |
end;
|
|
294 |
|
|
295 |
fun index p =
|
|
296 |
let
|
|
297 |
fun idx _ [] = NONE
|
|
298 |
| idx n (x :: xs) = if p x then SOME n else idx (n + 1) xs
|
|
299 |
in
|
|
300 |
idx 0
|
|
301 |
end;
|
|
302 |
|
|
303 |
fun enumerate l = fst (maps (fn x => fn m => ((m, x), m + 1)) l 0);
|
|
304 |
|
|
305 |
local
|
|
306 |
fun revDiv acc l 0 = (acc,l)
|
|
307 |
| revDiv _ [] _ = raise Subscript
|
|
308 |
| revDiv acc (h :: t) n = revDiv (h :: acc) t (n - 1);
|
|
309 |
in
|
|
310 |
fun revDivide l = revDiv [] l;
|
|
311 |
end;
|
|
312 |
|
|
313 |
fun divide l n = let val (a,b) = revDivide l n in (rev a, b) end;
|
|
314 |
|
|
315 |
fun updateNth (n,x) l =
|
|
316 |
let
|
|
317 |
val (a,b) = revDivide l n
|
|
318 |
in
|
|
319 |
case b of [] => raise Subscript | _ :: t => List.revAppend (a, x :: t)
|
|
320 |
end;
|
|
321 |
|
|
322 |
fun deleteNth n l =
|
|
323 |
let
|
|
324 |
val (a,b) = revDivide l n
|
|
325 |
in
|
|
326 |
case b of [] => raise Subscript | _ :: t => List.revAppend (a,t)
|
|
327 |
end;
|
|
328 |
|
|
329 |
(* ------------------------------------------------------------------------- *)
|
|
330 |
(* Sets implemented with lists. *)
|
|
331 |
(* ------------------------------------------------------------------------- *)
|
|
332 |
|
|
333 |
fun mem x = List.exists (equal x);
|
|
334 |
|
|
335 |
fun insert x s = if mem x s then s else x :: s;
|
|
336 |
|
|
337 |
fun delete x s = List.filter (not o equal x) s;
|
|
338 |
|
|
339 |
fun setify s = rev (foldl (fn (v,x) => if mem v x then x else v :: x) [] s);
|
|
340 |
|
|
341 |
fun union s t = foldl (fn (v,x) => if mem v t then x else v :: x) t (rev s);
|
|
342 |
|
|
343 |
fun intersect s t =
|
|
344 |
foldl (fn (v,x) => if mem v t then v :: x else x) [] (rev s);
|
|
345 |
|
|
346 |
fun difference s t =
|
|
347 |
foldl (fn (v,x) => if mem v t then x else v :: x) [] (rev s);
|
|
348 |
|
|
349 |
fun subset s t = List.all (fn x => mem x t) s;
|
|
350 |
|
|
351 |
fun distinct [] = true
|
|
352 |
| distinct (x :: rest) = not (mem x rest) andalso distinct rest;
|
|
353 |
|
|
354 |
(* ------------------------------------------------------------------------- *)
|
|
355 |
(* Sorting and searching. *)
|
|
356 |
(* ------------------------------------------------------------------------- *)
|
|
357 |
|
|
358 |
(* Finding the minimum and maximum element of a list, wrt some order. *)
|
|
359 |
|
|
360 |
fun minimum cmp =
|
|
361 |
let
|
|
362 |
fun min (l,m,r) _ [] = (m, List.revAppend (l,r))
|
|
363 |
| min (best as (_,m,_)) l (x :: r) =
|
|
364 |
min (case cmp (x,m) of LESS => (l,x,r) | _ => best) (x :: l) r
|
|
365 |
in
|
|
366 |
fn [] => raise Empty
|
|
367 |
| h :: t => min ([],h,t) [h] t
|
|
368 |
end;
|
|
369 |
|
|
370 |
fun maximum cmp = minimum (revCompare cmp);
|
|
371 |
|
|
372 |
(* Merge (for the following merge-sort, but generally useful too). *)
|
|
373 |
|
|
374 |
fun merge cmp =
|
|
375 |
let
|
|
376 |
fun mrg acc [] ys = List.revAppend (acc,ys)
|
|
377 |
| mrg acc xs [] = List.revAppend (acc,xs)
|
|
378 |
| mrg acc (xs as x :: xt) (ys as y :: yt) =
|
|
379 |
(case cmp (x,y) of
|
|
380 |
GREATER => mrg (y :: acc) xs yt
|
|
381 |
| _ => mrg (x :: acc) xt ys)
|
|
382 |
in
|
|
383 |
mrg []
|
|
384 |
end;
|
|
385 |
|
|
386 |
(* Merge sort (stable). *)
|
|
387 |
|
|
388 |
fun sort cmp =
|
|
389 |
let
|
|
390 |
fun findRuns acc r rs [] = rev (rev (r :: rs) :: acc)
|
|
391 |
| findRuns acc r rs (x :: xs) =
|
|
392 |
case cmp (r,x) of
|
|
393 |
GREATER => findRuns (rev (r :: rs) :: acc) x [] xs
|
|
394 |
| _ => findRuns acc x (r :: rs) xs
|
|
395 |
|
|
396 |
fun mergeAdj acc [] = rev acc
|
|
397 |
| mergeAdj acc (xs as [_]) = List.revAppend (acc,xs)
|
|
398 |
| mergeAdj acc (x :: y :: xs) = mergeAdj (merge cmp x y :: acc) xs
|
|
399 |
|
|
400 |
fun mergePairs [xs] = xs
|
|
401 |
| mergePairs l = mergePairs (mergeAdj [] l)
|
|
402 |
in
|
|
403 |
fn [] => []
|
|
404 |
| l as [_] => l
|
|
405 |
| h :: t => mergePairs (findRuns [] h [] t)
|
|
406 |
end;
|
|
407 |
|
|
408 |
fun sortMap _ _ [] = []
|
|
409 |
| sortMap _ _ (l as [_]) = l
|
|
410 |
| sortMap f cmp xs =
|
|
411 |
let
|
|
412 |
fun ncmp ((m,_),(n,_)) = cmp (m,n)
|
|
413 |
val nxs = map (fn x => (f x, x)) xs
|
|
414 |
val nys = sort ncmp nxs
|
|
415 |
in
|
|
416 |
map snd nys
|
|
417 |
end;
|
|
418 |
|
|
419 |
(* ------------------------------------------------------------------------- *)
|
|
420 |
(* Integers. *)
|
|
421 |
(* ------------------------------------------------------------------------- *)
|
|
422 |
|
|
423 |
fun interval m 0 = []
|
|
424 |
| interval m len = m :: interval (m + 1) (len - 1);
|
|
425 |
|
|
426 |
fun divides _ 0 = true
|
|
427 |
| divides 0 _ = false
|
|
428 |
| divides a b = b mod (Int.abs a) = 0;
|
|
429 |
|
|
430 |
local
|
|
431 |
fun hcf 0 n = n
|
|
432 |
| hcf 1 _ = 1
|
|
433 |
| hcf m n = hcf (n mod m) m;
|
|
434 |
in
|
|
435 |
fun gcd m n =
|
|
436 |
let
|
|
437 |
val m = Int.abs m
|
|
438 |
and n = Int.abs n
|
|
439 |
in
|
|
440 |
if m < n then hcf m n else hcf n m
|
|
441 |
end;
|
|
442 |
end;
|
|
443 |
|
|
444 |
local
|
|
445 |
fun calcPrimes ps n i =
|
|
446 |
if List.exists (fn p => divides p i) ps then calcPrimes ps n (i + 1)
|
|
447 |
else
|
|
448 |
let
|
|
449 |
val ps = ps @ [i]
|
|
450 |
and n = n - 1
|
|
451 |
in
|
|
452 |
if n = 0 then ps else calcPrimes ps n (i + 1)
|
|
453 |
end;
|
|
454 |
|
|
455 |
val primesList = ref [2];
|
|
456 |
in
|
|
457 |
fun primes n =
|
|
458 |
let
|
|
459 |
val ref ps = primesList
|
|
460 |
|
|
461 |
val k = n - length ps
|
|
462 |
in
|
|
463 |
if k <= 0 then List.take (ps,n)
|
|
464 |
else
|
|
465 |
let
|
|
466 |
val ps = calcPrimes ps k (List.last ps + 1)
|
|
467 |
|
|
468 |
val () = primesList := ps
|
|
469 |
in
|
|
470 |
ps
|
|
471 |
end
|
|
472 |
end;
|
|
473 |
end;
|
|
474 |
|
|
475 |
fun primesUpTo n =
|
|
476 |
let
|
|
477 |
fun f k =
|
|
478 |
let
|
|
479 |
val l = primes k
|
|
480 |
|
|
481 |
val p = List.last l
|
|
482 |
in
|
|
483 |
if p < n then f (2 * k) else takeWhile (fn j => j <= n) l
|
|
484 |
end
|
|
485 |
in
|
|
486 |
f 8
|
|
487 |
end;
|
|
488 |
|
|
489 |
(* ------------------------------------------------------------------------- *)
|
|
490 |
(* Strings. *)
|
|
491 |
(* ------------------------------------------------------------------------- *)
|
|
492 |
|
|
493 |
local
|
|
494 |
fun len l = (length l, l)
|
|
495 |
|
|
496 |
val upper = len (explode "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
|
|
497 |
|
|
498 |
val lower = len (explode "abcdefghijklmnopqrstuvwxyz");
|
|
499 |
|
|
500 |
fun rotate (n,l) c k =
|
|
501 |
List.nth (l, (k + Option.valOf (index (equal c) l)) mod n);
|
|
502 |
in
|
|
503 |
fun rot k c =
|
|
504 |
if Char.isLower c then rotate lower c k
|
|
505 |
else if Char.isUpper c then rotate upper c k
|
|
506 |
else c;
|
|
507 |
end;
|
|
508 |
|
|
509 |
fun charToInt #"0" = SOME 0
|
|
510 |
| charToInt #"1" = SOME 1
|
|
511 |
| charToInt #"2" = SOME 2
|
|
512 |
| charToInt #"3" = SOME 3
|
|
513 |
| charToInt #"4" = SOME 4
|
|
514 |
| charToInt #"5" = SOME 5
|
|
515 |
| charToInt #"6" = SOME 6
|
|
516 |
| charToInt #"7" = SOME 7
|
|
517 |
| charToInt #"8" = SOME 8
|
|
518 |
| charToInt #"9" = SOME 9
|
|
519 |
| charToInt _ = NONE;
|
|
520 |
|
|
521 |
fun charFromInt 0 = SOME #"0"
|
|
522 |
| charFromInt 1 = SOME #"1"
|
|
523 |
| charFromInt 2 = SOME #"2"
|
|
524 |
| charFromInt 3 = SOME #"3"
|
|
525 |
| charFromInt 4 = SOME #"4"
|
|
526 |
| charFromInt 5 = SOME #"5"
|
|
527 |
| charFromInt 6 = SOME #"6"
|
|
528 |
| charFromInt 7 = SOME #"7"
|
|
529 |
| charFromInt 8 = SOME #"8"
|
|
530 |
| charFromInt 9 = SOME #"9"
|
|
531 |
| charFromInt _ = NONE;
|
|
532 |
|
|
533 |
fun nChars x =
|
|
534 |
let
|
|
535 |
fun dup 0 l = l | dup n l = dup (n - 1) (x :: l)
|
|
536 |
in
|
|
537 |
fn n => implode (dup n [])
|
|
538 |
end;
|
|
539 |
|
|
540 |
fun chomp s =
|
|
541 |
let
|
|
542 |
val n = size s
|
|
543 |
in
|
|
544 |
if n = 0 orelse String.sub (s, n - 1) <> #"\n" then s
|
|
545 |
else String.substring (s, 0, n - 1)
|
|
546 |
end;
|
|
547 |
|
|
548 |
local
|
|
549 |
fun chop [] = []
|
|
550 |
| chop (l as (h :: t)) = if Char.isSpace h then chop t else l;
|
|
551 |
in
|
|
552 |
val trim = implode o chop o rev o chop o rev o explode;
|
|
553 |
end;
|
|
554 |
|
|
555 |
fun join _ [] = ""
|
|
556 |
| join s (h :: t) = foldl (fn (x,y) => y ^ s ^ x) h t;
|
|
557 |
|
|
558 |
local
|
|
559 |
fun match [] l = SOME l
|
|
560 |
| match _ [] = NONE
|
|
561 |
| match (x :: xs) (y :: ys) = if x = y then match xs ys else NONE;
|
|
562 |
|
|
563 |
fun stringify acc [] = acc
|
|
564 |
| stringify acc (h :: t) = stringify (implode h :: acc) t;
|
|
565 |
in
|
|
566 |
fun split sep =
|
|
567 |
let
|
|
568 |
val pat = String.explode sep
|
|
569 |
fun div1 prev recent [] = stringify [] (rev recent :: prev)
|
|
570 |
| div1 prev recent (l as h :: t) =
|
|
571 |
case match pat l of
|
|
572 |
NONE => div1 prev (h :: recent) t
|
|
573 |
| SOME rest => div1 (rev recent :: prev) [] rest
|
|
574 |
in
|
|
575 |
fn s => div1 [] [] (explode s)
|
|
576 |
end;
|
|
577 |
end;
|
|
578 |
|
|
579 |
fun capitalize s =
|
|
580 |
if s = "" then s
|
|
581 |
else str (Char.toUpper (String.sub (s,0))) ^ String.extract (s,1,NONE);
|
|
582 |
|
|
583 |
fun mkPrefix p s = p ^ s;
|
|
584 |
|
|
585 |
fun destPrefix p =
|
|
586 |
let
|
|
587 |
fun check s =
|
|
588 |
if String.isPrefix p s then ()
|
|
589 |
else raise Error "destPrefix"
|
|
590 |
|
|
591 |
val sizeP = size p
|
|
592 |
in
|
|
593 |
fn s =>
|
|
594 |
let
|
|
595 |
val () = check s
|
|
596 |
in
|
|
597 |
String.extract (s,sizeP,NONE)
|
|
598 |
end
|
|
599 |
end;
|
|
600 |
|
|
601 |
fun isPrefix p = can (destPrefix p);
|
|
602 |
|
|
603 |
fun stripPrefix pred s =
|
|
604 |
Substring.string (Substring.dropl pred (Substring.full s));
|
|
605 |
|
|
606 |
fun mkSuffix p s = s ^ p;
|
|
607 |
|
|
608 |
fun destSuffix p =
|
|
609 |
let
|
|
610 |
fun check s =
|
|
611 |
if String.isSuffix p s then ()
|
|
612 |
else raise Error "destSuffix"
|
|
613 |
|
|
614 |
val sizeP = size p
|
|
615 |
in
|
|
616 |
fn s =>
|
|
617 |
let
|
|
618 |
val () = check s
|
|
619 |
|
|
620 |
val sizeS = size s
|
|
621 |
in
|
|
622 |
String.substring (s, 0, sizeS - sizeP)
|
|
623 |
end
|
|
624 |
end;
|
|
625 |
|
|
626 |
fun isSuffix p = can (destSuffix p);
|
|
627 |
|
|
628 |
fun stripSuffix pred s =
|
|
629 |
Substring.string (Substring.dropr pred (Substring.full s));
|
|
630 |
|
|
631 |
(* ------------------------------------------------------------------------- *)
|
|
632 |
(* Tables. *)
|
|
633 |
(* ------------------------------------------------------------------------- *)
|
|
634 |
|
|
635 |
type columnAlignment = {leftAlign : bool, padChar : char}
|
|
636 |
|
|
637 |
fun alignColumn {leftAlign,padChar} column =
|
|
638 |
let
|
|
639 |
val (n,_) = maximum Int.compare (map size column)
|
|
640 |
|
|
641 |
fun pad entry row =
|
|
642 |
let
|
|
643 |
val padding = nChars padChar (n - size entry)
|
|
644 |
in
|
|
645 |
if leftAlign then entry ^ padding ^ row
|
|
646 |
else padding ^ entry ^ row
|
|
647 |
end
|
|
648 |
in
|
|
649 |
zipWith pad column
|
|
650 |
end;
|
|
651 |
|
|
652 |
local
|
|
653 |
fun alignTab aligns rows =
|
|
654 |
case aligns of
|
|
655 |
[] => map (K "") rows
|
|
656 |
| [{leftAlign = true, padChar = #" "}] => map hd rows
|
|
657 |
| align :: aligns =>
|
|
658 |
alignColumn align (map hd rows) (alignTab aligns (map tl rows));
|
|
659 |
in
|
|
660 |
fun alignTable aligns rows =
|
|
661 |
if null rows then [] else alignTab aligns rows;
|
|
662 |
end;
|
|
663 |
|
|
664 |
(* ------------------------------------------------------------------------- *)
|
|
665 |
(* Reals. *)
|
|
666 |
(* ------------------------------------------------------------------------- *)
|
|
667 |
|
|
668 |
val realToString = Real.toString;
|
|
669 |
|
|
670 |
fun percentToString x = Int.toString (Real.round (100.0 * x)) ^ "%";
|
|
671 |
|
|
672 |
fun pos r = Real.max (r,0.0);
|
|
673 |
|
|
674 |
local
|
|
675 |
val invLn2 = 1.0 / Math.ln 2.0;
|
|
676 |
in
|
|
677 |
fun log2 x = invLn2 * Math.ln x;
|
|
678 |
end;
|
|
679 |
|
|
680 |
(* ------------------------------------------------------------------------- *)
|
|
681 |
(* Sums. *)
|
|
682 |
(* ------------------------------------------------------------------------- *)
|
|
683 |
|
|
684 |
datatype ('a,'b) sum = Left of 'a | Right of 'b
|
|
685 |
|
|
686 |
fun destLeft (Left l) = l
|
|
687 |
| destLeft _ = raise Error "destLeft";
|
|
688 |
|
|
689 |
fun isLeft (Left _) = true
|
|
690 |
| isLeft (Right _) = false;
|
|
691 |
|
|
692 |
fun destRight (Right r) = r
|
|
693 |
| destRight _ = raise Error "destRight";
|
|
694 |
|
|
695 |
fun isRight (Left _) = false
|
|
696 |
| isRight (Right _) = true;
|
|
697 |
|
|
698 |
(* ------------------------------------------------------------------------- *)
|
|
699 |
(* Useful impure features. *)
|
|
700 |
(* ------------------------------------------------------------------------- *)
|
|
701 |
|
|
702 |
local
|
|
703 |
val generator = ref 0
|
|
704 |
in
|
|
705 |
fun newInt () =
|
|
706 |
let
|
|
707 |
val n = !generator
|
|
708 |
val () = generator := n + 1
|
|
709 |
in
|
|
710 |
n
|
|
711 |
end;
|
|
712 |
|
|
713 |
fun newInts 0 = []
|
|
714 |
| newInts k =
|
|
715 |
let
|
|
716 |
val n = !generator
|
|
717 |
val () = generator := n + k
|
|
718 |
in
|
|
719 |
interval n k
|
|
720 |
end;
|
|
721 |
end;
|
|
722 |
|
|
723 |
fun withRef (r,new) f x =
|
|
724 |
let
|
|
725 |
val old = !r
|
|
726 |
val () = r := new
|
|
727 |
val y = f x handle e => (r := old; raise e)
|
|
728 |
val () = r := old
|
|
729 |
in
|
|
730 |
y
|
|
731 |
end;
|
|
732 |
|
|
733 |
fun cloneArray a =
|
|
734 |
let
|
|
735 |
fun index i = Array.sub (a,i)
|
|
736 |
in
|
|
737 |
Array.tabulate (Array.length a, index)
|
|
738 |
end;
|
|
739 |
|
|
740 |
(* ------------------------------------------------------------------------- *)
|
|
741 |
(* Environment. *)
|
|
742 |
(* ------------------------------------------------------------------------- *)
|
|
743 |
|
|
744 |
fun host () = Option.getOpt (OS.Process.getEnv "HOSTNAME", "unknown");
|
|
745 |
|
|
746 |
fun time () = Date.fmt "%H:%M:%S" (Date.fromTimeLocal (Time.now ()));
|
|
747 |
|
|
748 |
fun date () = Date.fmt "%d/%m/%Y" (Date.fromTimeLocal (Time.now ()));
|
|
749 |
|
|
750 |
fun readDirectory {directory = dir} =
|
|
751 |
let
|
|
752 |
val dirStrm = OS.FileSys.openDir dir
|
|
753 |
|
|
754 |
fun readAll acc =
|
|
755 |
case OS.FileSys.readDir dirStrm of
|
|
756 |
NONE => acc
|
|
757 |
| SOME file =>
|
|
758 |
let
|
|
759 |
val filename = OS.Path.joinDirFile {dir = dir, file = file}
|
|
760 |
|
|
761 |
val acc = {filename = filename} :: acc
|
|
762 |
in
|
|
763 |
readAll acc
|
|
764 |
end
|
|
765 |
|
|
766 |
val filenames = readAll []
|
|
767 |
|
|
768 |
val () = OS.FileSys.closeDir dirStrm
|
|
769 |
in
|
|
770 |
rev filenames
|
|
771 |
end;
|
|
772 |
|
|
773 |
fun readTextFile {filename} =
|
|
774 |
let
|
|
775 |
open TextIO
|
|
776 |
|
|
777 |
val h = openIn filename
|
|
778 |
|
|
779 |
val contents = inputAll h
|
|
780 |
|
|
781 |
val () = closeIn h
|
|
782 |
in
|
|
783 |
contents
|
|
784 |
end;
|
|
785 |
|
|
786 |
fun writeTextFile {contents,filename} =
|
|
787 |
let
|
|
788 |
open TextIO
|
|
789 |
val h = openOut filename
|
|
790 |
val () = output (h,contents)
|
|
791 |
val () = closeOut h
|
|
792 |
in
|
|
793 |
()
|
|
794 |
end;
|
|
795 |
|
|
796 |
(* ------------------------------------------------------------------------- *)
|
|
797 |
(* Profiling and error reporting. *)
|
|
798 |
(* ------------------------------------------------------------------------- *)
|
|
799 |
|
|
800 |
fun chat s = TextIO.output (TextIO.stdErr, s ^ "\n");
|
|
801 |
|
|
802 |
local
|
|
803 |
fun err x s = chat (x ^ ": " ^ s);
|
|
804 |
in
|
|
805 |
fun try f x = f x
|
|
806 |
handle e as Error _ => (err "try" (errorToString e); raise e)
|
|
807 |
| e as Bug _ => (err "try" (bugToString e); raise e)
|
|
808 |
| e => (err "try" "strange exception raised"; raise e);
|
|
809 |
|
|
810 |
val warn = err "WARNING";
|
|
811 |
|
|
812 |
fun die s = (err "\nFATAL ERROR" s; OS.Process.exit OS.Process.failure);
|
|
813 |
end;
|
|
814 |
|
|
815 |
fun timed f a =
|
|
816 |
let
|
|
817 |
val tmr = Timer.startCPUTimer ()
|
|
818 |
val res = f a
|
|
819 |
val {usr,sys,...} = Timer.checkCPUTimer tmr
|
|
820 |
in
|
|
821 |
(Time.toReal usr + Time.toReal sys, res)
|
|
822 |
end;
|
|
823 |
|
|
824 |
local
|
|
825 |
val MIN = 1.0;
|
|
826 |
|
|
827 |
fun several n t f a =
|
|
828 |
let
|
|
829 |
val (t',res) = timed f a
|
|
830 |
val t = t + t'
|
|
831 |
val n = n + 1
|
|
832 |
in
|
|
833 |
if t > MIN then (t / Real.fromInt n, res) else several n t f a
|
|
834 |
end;
|
|
835 |
in
|
|
836 |
fun timedMany f a = several 0 0.0 f a
|
|
837 |
end;
|
|
838 |
|
|
839 |
val executionTime =
|
|
840 |
let
|
|
841 |
val startTime = Time.toReal (Time.now ())
|
|
842 |
in
|
|
843 |
fn () => Time.toReal (Time.now ()) - startTime
|
|
844 |
end;
|
|
845 |
|
|
846 |
end
|