2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[Util]{Highly random utility functions}
7 -- IF_NOT_GHC is meant to make this module useful outside the context of GHC
12 Eager, thenEager, returnEager, mapEager, appEager, runEager,
14 -- general list processing
15 IF_NOT_GHC(forall COMMA exists COMMA)
16 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
17 zipLazy, stretchZipEqual,
18 mapAndUnzip, mapAndUnzip3,
19 nOfThem, lengthExceeds, isSingleton,
24 assoc, assocUsing, assocDefault, assocDefaultUsing,
27 hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
30 IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
32 IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
33 IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
35 -- transitive closures
39 mapAccumL, mapAccumR, mapAccumB,
45 IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
46 IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
50 #include "HsVersions.h"
52 import List ( zipWith4 )
53 import Panic ( panic )
54 import Unique ( Unique )
55 import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
60 %************************************************************************
62 \subsection{The Eager monad}
64 %************************************************************************
66 The @Eager@ monad is just an encoding of continuation-passing style,
67 used to allow you to express "do this and then that", mainly to avoid
68 space leaks. It's done with a type synonym to save bureaucracy.
71 type Eager ans a = (a -> ans) -> ans
73 runEager :: Eager a a -> a
74 runEager m = m (\x -> x)
76 appEager :: Eager ans a -> (a -> ans) -> ans
77 appEager m cont = m cont
79 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
80 thenEager m k cont = m (\r -> k r cont)
82 returnEager :: a -> Eager ans a
83 returnEager v cont = cont v
85 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
86 mapEager f [] = returnEager []
87 mapEager f (x:xs) = f x `thenEager` \ y ->
88 mapEager f xs `thenEager` \ ys ->
92 %************************************************************************
94 \subsection[Utils-lists]{General list processing}
96 %************************************************************************
98 Quantifiers are not standard in Haskell. The following fill in the gap.
101 forall :: (a -> Bool) -> [a] -> Bool
102 forall pred [] = True
103 forall pred (x:xs) = pred x && forall pred xs
105 exists :: (a -> Bool) -> [a] -> Bool
106 exists pred [] = False
107 exists pred (x:xs) = pred x || exists pred xs
110 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
111 are of equal length. Alastair Reid thinks this should only happen if
112 DEBUGging on; hey, why not?
115 zipEqual :: String -> [a] -> [b] -> [(a,b)]
116 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
117 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
118 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
122 zipWithEqual _ = zipWith
123 zipWith3Equal _ = zipWith3
124 zipWith4Equal _ = zipWith4
126 zipEqual msg [] [] = []
127 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
128 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
130 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
131 zipWithEqual msg _ [] [] = []
132 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
134 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
135 = z a b c : zipWith3Equal msg z as bs cs
136 zipWith3Equal msg _ [] [] [] = []
137 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
139 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
140 = z a b c d : zipWith4Equal msg z as bs cs ds
141 zipWith4Equal msg _ [] [] [] [] = []
142 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
147 -- zipLazy is lazy in the second list (observe the ~)
149 zipLazy :: [a] -> [b] -> [(a,b)]
151 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
156 stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
157 -- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
159 stretchZipEqual f [] [] = []
160 stretchZipEqual f (x:xs) (y:ys) = case f x y of
161 Just x' -> x' : stretchZipEqual f xs ys
162 Nothing -> x : stretchZipEqual f xs (y:ys)
167 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
169 mapAndUnzip f [] = ([],[])
173 (rs1, rs2) = mapAndUnzip f xs
177 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
179 mapAndUnzip3 f [] = ([],[],[])
180 mapAndUnzip3 f (x:xs)
183 (rs1, rs2, rs3) = mapAndUnzip3 f xs
185 (r1:rs1, r2:rs2, r3:rs3)
189 nOfThem :: Int -> a -> [a]
190 nOfThem n thing = take n (repeat thing)
192 lengthExceeds :: [a] -> Int -> Bool
194 [] `lengthExceeds` n = 0 > n
195 (x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
197 isSingleton :: [a] -> Bool
199 isSingleton [x] = True
200 isSingleton _ = False
204 snocView :: [a] -> ([a], a) -- Split off the last element
205 snocView xs = go xs []
207 go [x] acc = (reverse acc, x)
208 go (x:xs) acc = go xs (x:acc)
211 Debugging/specialising versions of \tr{elem} and \tr{notElem}
214 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
217 isIn msg x ys = elem__ x ys
218 isn'tIn msg x ys = notElem__ x ys
220 --these are here to be SPECIALIZEd (automagically)
222 elem__ x (y:ys) = x==y || elem__ x ys
224 notElem__ x [] = True
225 notElem__ x (y:ys) = x /= y && notElem__ x ys
233 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
234 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
237 = notElem ILIT(0) x ys
239 notElem i x [] = True
241 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
242 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
248 %************************************************************************
250 \subsection[Utils-assoc]{Association lists}
252 %************************************************************************
254 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
257 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
258 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
259 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
260 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
262 assocDefaultUsing eq deflt ((k,v) : rest) key
264 | otherwise = assocDefaultUsing eq deflt rest key
266 assocDefaultUsing eq deflt [] key = deflt
268 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
269 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
270 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
273 %************************************************************************
275 \subsection[Utils-dups]{Duplicate-handling}
277 %************************************************************************
280 hasNoDups :: (Eq a) => [a] -> Bool
282 hasNoDups xs = f [] xs
284 f seen_so_far [] = True
285 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
290 is_elem = isIn "hasNoDups"
294 equivClasses :: (a -> a -> Ordering) -- Comparison
298 equivClasses cmp stuff@[] = []
299 equivClasses cmp stuff@[item] = [stuff]
300 equivClasses cmp items
301 = runs eq (sortLt lt items)
303 eq a b = case cmp a b of { EQ -> True; _ -> False }
304 lt a b = case cmp a b of { LT -> True; _ -> False }
307 The first cases in @equivClasses@ above are just to cut to the point
310 @runs@ groups a list into a list of lists, each sublist being a run of
311 identical elements of the input list. It is passed a predicate @p@ which
312 tells when two elements are equal.
315 runs :: (a -> a -> Bool) -- Equality
320 runs p (x:xs) = case (span (p x) xs) of
321 (first, rest) -> (x:first) : (runs p rest)
325 removeDups :: (a -> a -> Ordering) -- Comparison function
327 -> ([a], -- List with no duplicates
328 [[a]]) -- List of duplicate groups. One representative from
329 -- each group appears in the first result
331 removeDups cmp [] = ([], [])
332 removeDups cmp [x] = ([x],[])
334 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
337 collect_dups dups_so_far [x] = (dups_so_far, x)
338 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
343 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
344 -- NB: it's *very* important that if we have the input list [a,b,c],
345 -- where a,b,c all have the same unique, then we get back the list
349 -- Hence the use of foldr, plus the reversed-args tack_on below
350 equivClassesByUniq get_uniq xs
351 = eltsUFM (foldr add emptyUFM xs)
353 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
354 tack_on old new = new++old
357 %************************************************************************
359 \subsection[Utils-sorting]{Sorting}
361 %************************************************************************
363 %************************************************************************
365 \subsubsection[Utils-quicksorting]{Quicksorts}
367 %************************************************************************
370 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
371 quicksort :: (a -> a -> Bool) -- Less-than predicate
373 -> [a] -- Result list in increasing order
376 quicksort lt [x] = [x]
377 quicksort lt (x:xs) = split x [] [] xs
379 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
380 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
381 | True = split x lo (y:hi) ys
384 Quicksort variant from Lennart's Haskell-library contribution. This
385 is a {\em stable} sort.
388 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
390 sortLt :: (a -> a -> Bool) -- Less-than predicate
392 -> [a] -- Result list
394 sortLt lt l = qsort lt l []
396 -- qsort is stable and does not concatenate.
397 qsort :: (a -> a -> Bool) -- Less-than predicate
398 -> [a] -- xs, Input list
399 -> [a] -- r, Concatenate this list to the sorted input list
400 -> [a] -- Result = sort xs ++ r
404 qsort lt (x:xs) r = qpart lt x xs [] [] r
406 -- qpart partitions and sorts the sublists
407 -- rlt contains things less than x,
408 -- rge contains the ones greater than or equal to x.
409 -- Both have equal elements reversed with respect to the original list.
411 qpart lt x [] rlt rge r =
412 -- rlt and rge are in reverse order and must be sorted with an
413 -- anti-stable sorting
414 rqsort lt rlt (x : rqsort lt rge r)
416 qpart lt x (y:ys) rlt rge r =
419 qpart lt x ys (y:rlt) rge r
422 qpart lt x ys rlt (y:rge) r
424 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
426 rqsort lt [x] r = x:r
427 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
429 rqpart lt x [] rle rgt r =
430 qsort lt rle (x : qsort lt rgt r)
432 rqpart lt x (y:ys) rle rgt r =
435 rqpart lt x ys rle (y:rgt) r
438 rqpart lt x ys (y:rle) rgt r
441 %************************************************************************
443 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
445 %************************************************************************
448 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
450 mergesort cmp xs = merge_lists (split_into_runs [] xs)
452 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
453 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
455 split_into_runs [] [] = []
456 split_into_runs run [] = [run]
457 split_into_runs [] (x:xs) = split_into_runs [x] xs
458 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
459 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
460 | True = rl : (split_into_runs [x] xs)
463 merge_lists (x:xs) = merge x (merge_lists xs)
467 merge xl@(x:xs) yl@(y:ys)
469 EQ -> x : y : (merge xs ys)
470 LT -> x : (merge xs yl)
471 GT -> y : (merge xl ys)
474 %************************************************************************
476 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
478 %************************************************************************
481 Date: Mon, 3 May 93 20:45:23 +0200
482 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
483 To: partain@dcs.gla.ac.uk
484 Subject: natural merge sort beats quick sort [ and it is prettier ]
486 Here is a piece of Haskell code that I'm rather fond of. See it as an
487 attempt to get rid of the ridiculous quick-sort routine. group is
488 quite useful by itself I think it was John's idea originally though I
489 believe the lazy version is due to me [surprisingly complicated].
490 gamma [used to be called] is called gamma because I got inspired by
491 the Gamma calculus. It is not very close to the calculus but does
492 behave less sequentially than both foldr and foldl. One could imagine
493 a version of gamma that took a unit element as well thereby avoiding
494 the problem with empty lists.
496 I've tried this code against
498 1) insertion sort - as provided by haskell
499 2) the normal implementation of quick sort
500 3) a deforested version of quick sort due to Jan Sparud
501 4) a super-optimized-quick-sort of Lennart's
503 If the list is partially sorted both merge sort and in particular
504 natural merge sort wins. If the list is random [ average length of
505 rising subsequences = approx 2 ] mergesort still wins and natural
506 merge sort is marginally beaten by Lennart's soqs. The space
507 consumption of merge sort is a bit worse than Lennart's quick sort
508 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
509 fpca article ] isn't used because of group.
516 group :: (a -> a -> Bool) -> [a] -> [[a]]
519 Date: Mon, 12 Feb 1996 15:09:41 +0000
520 From: Andy Gill <andy@dcs.gla.ac.uk>
522 Here is a `better' definition of group.
525 group p (x:xs) = group' xs x x (x :)
527 group' [] _ _ s = [s []]
528 group' (x:xs) x_min x_max s
529 | not (x `p` x_max) = group' xs x_min x (s . (x :))
530 | x `p` x_min = group' xs x x_max ((x :) . s)
531 | otherwise = s [] : group' xs x x (x :)
533 -- This one works forwards *and* backwards, as well as also being
534 -- faster that the one in Util.lhs.
539 let ((h1:t1):tt1) = group p xs
540 (t,tt) = if null xs then ([],[]) else
541 if x `p` h1 then (h1:t1,tt1) else
546 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
547 generalMerge p xs [] = xs
548 generalMerge p [] ys = ys
549 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
550 | otherwise = y : generalMerge p (x:xs) ys
552 -- gamma is now called balancedFold
554 balancedFold :: (a -> a -> a) -> [a] -> a
555 balancedFold f [] = error "can't reduce an empty list using balancedFold"
556 balancedFold f [x] = x
557 balancedFold f l = balancedFold f (balancedFold' f l)
559 balancedFold' :: (a -> a -> a) -> [a] -> [a]
560 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
561 balancedFold' f xs = xs
563 generalMergeSort p [] = []
564 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
566 generalNaturalMergeSort p [] = []
567 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
569 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
571 mergeSort = generalMergeSort (<=)
572 naturalMergeSort = generalNaturalMergeSort (<=)
574 mergeSortLe le = generalMergeSort le
575 naturalMergeSortLe le = generalNaturalMergeSort le
578 %************************************************************************
580 \subsection[Utils-transitive-closure]{Transitive closure}
582 %************************************************************************
584 This algorithm for transitive closure is straightforward, albeit quadratic.
587 transitiveClosure :: (a -> [a]) -- Successor function
588 -> (a -> a -> Bool) -- Equality predicate
590 -> [a] -- The transitive closure
592 transitiveClosure succ eq xs
596 go done (x:xs) | x `is_in` done = go done xs
597 | otherwise = go (x:done) (succ x ++ xs)
600 x `is_in` (y:ys) | eq x y = True
601 | otherwise = x `is_in` ys
604 %************************************************************************
606 \subsection[Utils-accum]{Accumulating}
608 %************************************************************************
610 @mapAccumL@ behaves like a combination
611 of @map@ and @foldl@;
612 it applies a function to each element of a list, passing an accumulating
613 parameter from left to right, and returning a final value of this
614 accumulator together with the new list.
617 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
618 -- and accumulator, returning new
619 -- accumulator and elt of result list
620 -> acc -- Initial accumulator
622 -> (acc, [y]) -- Final accumulator and result list
624 mapAccumL f b [] = (b, [])
625 mapAccumL f b (x:xs) = (b'', x':xs') where
627 (b'', xs') = mapAccumL f b' xs
630 @mapAccumR@ does the same, but working from right to left instead. Its type is
631 the same as @mapAccumL@, though.
634 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
635 -- and accumulator, returning new
636 -- accumulator and elt of result list
637 -> acc -- Initial accumulator
639 -> (acc, [y]) -- Final accumulator and result list
641 mapAccumR f b [] = (b, [])
642 mapAccumR f b (x:xs) = (b'', x':xs') where
644 (b', xs') = mapAccumR f b xs
647 Here is the bi-directional version, that works from both left and right.
650 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
651 -- Function of elt of input list
652 -- and accumulator, returning new
653 -- accumulator and elt of result list
654 -> accl -- Initial accumulator from left
655 -> accr -- Initial accumulator from right
657 -> (accl, accr, [y]) -- Final accumulators and result list
659 mapAccumB f a b [] = (a,b,[])
660 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
662 (a',b'',y) = f a b' x
663 (a'',b',ys) = mapAccumB f a' b xs
666 %************************************************************************
668 \subsection[Utils-comparison]{Comparisons}
670 %************************************************************************
673 thenCmp :: Ordering -> Ordering -> Ordering
674 {-# INLINE thenCmp #-}
676 thenCmp other any = other
678 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
679 -- `cmpList' uses a user-specified comparer
681 cmpList cmp [] [] = EQ
682 cmpList cmp [] _ = LT
683 cmpList cmp _ [] = GT
684 cmpList cmp (a:as) (b:bs)
685 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
689 cmpString :: String -> String -> Ordering
692 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
693 else if x < y then LT
701 %************************************************************************
703 \subsection[Utils-pairs]{Pairs}
705 %************************************************************************
707 The following are curried versions of @fst@ and @snd@.
710 cfst :: a -> b -> a -- stranal-sem only (Note)
714 The following provide us higher order functions that, when applied
715 to a function, operate on pairs.
718 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
719 applyToPair (f,g) (x,y) = (f x, g y)
721 applyToFst :: (a -> c) -> (a,b)-> (c,b)
722 applyToFst f (x,y) = (f x,y)
724 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
725 applyToSnd f (x,y) = (x,f y)
727 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
728 foldPair fg ab [] = ab
729 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
730 where (u,v) = foldPair fg ab abs
734 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
735 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs