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 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
16 zipLazy, stretchZipEqual,
17 mapAndUnzip, mapAndUnzip3,
18 nOfThem, lengthExceeds, isSingleton, only,
23 assoc, assocUsing, assocDefault, assocDefaultUsing,
26 hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
29 IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
31 IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
32 IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
34 -- transitive closures
38 mapAccumL, mapAccumR, mapAccumB, foldl2, count,
47 IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
48 IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
52 #if __GLASGOW_HASKELL__ < 402
58 #include "HsVersions.h"
60 import List ( zipWith4 )
61 import Panic ( panic )
62 import Unique ( Unique )
63 import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
68 %************************************************************************
70 \subsection{The Eager monad}
72 %************************************************************************
74 The @Eager@ monad is just an encoding of continuation-passing style,
75 used to allow you to express "do this and then that", mainly to avoid
76 space leaks. It's done with a type synonym to save bureaucracy.
79 type Eager ans a = (a -> ans) -> ans
81 runEager :: Eager a a -> a
82 runEager m = m (\x -> x)
84 appEager :: Eager ans a -> (a -> ans) -> ans
85 appEager m cont = m cont
87 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
88 thenEager m k cont = m (\r -> k r cont)
90 returnEager :: a -> Eager ans a
91 returnEager v cont = cont v
93 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
94 mapEager f [] = returnEager []
95 mapEager f (x:xs) = f x `thenEager` \ y ->
96 mapEager f xs `thenEager` \ ys ->
100 %************************************************************************
102 \subsection[Utils-lists]{General list processing}
104 %************************************************************************
106 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
107 are of equal length. Alastair Reid thinks this should only happen if
108 DEBUGging on; hey, why not?
111 zipEqual :: String -> [a] -> [b] -> [(a,b)]
112 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
113 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
114 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
118 zipWithEqual _ = zipWith
119 zipWith3Equal _ = zipWith3
120 zipWith4Equal _ = zipWith4
122 zipEqual msg [] [] = []
123 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
124 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
126 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
127 zipWithEqual msg _ [] [] = []
128 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
130 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
131 = z a b c : zipWith3Equal msg z as bs cs
132 zipWith3Equal msg _ [] [] [] = []
133 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
135 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
136 = z a b c d : zipWith4Equal msg z as bs cs ds
137 zipWith4Equal msg _ [] [] [] [] = []
138 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
143 -- zipLazy is lazy in the second list (observe the ~)
145 zipLazy :: [a] -> [b] -> [(a,b)]
147 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
152 stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
153 -- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
155 stretchZipEqual f [] [] = []
156 stretchZipEqual f (x:xs) (y:ys) = case f x y of
157 Just x' -> x' : stretchZipEqual f xs ys
158 Nothing -> x : stretchZipEqual f xs (y:ys)
163 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
165 mapAndUnzip f [] = ([],[])
169 (rs1, rs2) = mapAndUnzip f xs
173 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
175 mapAndUnzip3 f [] = ([],[],[])
176 mapAndUnzip3 f (x:xs)
179 (rs1, rs2, rs3) = mapAndUnzip3 f xs
181 (r1:rs1, r2:rs2, r3:rs3)
185 nOfThem :: Int -> a -> [a]
186 nOfThem n thing = replicate n thing
188 lengthExceeds :: [a] -> Int -> Bool
189 -- (lengthExceeds xs n) is True if length xs > n
190 (x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
191 [] `lengthExceeds` n = n < 0
193 isSingleton :: [a] -> Bool
194 isSingleton [x] = True
195 isSingleton _ = False
206 snocView :: [a] -> ([a], a) -- Split off the last element
207 snocView xs = go xs []
209 go [x] acc = (reverse acc, x)
210 go (x:xs) acc = go xs (x:acc)
213 Debugging/specialising versions of \tr{elem} and \tr{notElem}
216 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
219 isIn msg x ys = elem__ x ys
220 isn'tIn msg x ys = notElem__ x ys
222 --these are here to be SPECIALIZEd (automagically)
224 elem__ x (y:ys) = x==y || elem__ x ys
226 notElem__ x [] = True
227 notElem__ x (y:ys) = x /= y && notElem__ x ys
235 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
236 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
239 = notElem ILIT(0) x ys
241 notElem i x [] = True
243 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
244 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
250 %************************************************************************
252 \subsection[Utils-assoc]{Association lists}
254 %************************************************************************
256 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
259 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
260 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
261 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
262 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
264 assocDefaultUsing eq deflt ((k,v) : rest) key
266 | otherwise = assocDefaultUsing eq deflt rest key
268 assocDefaultUsing eq deflt [] key = deflt
270 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
271 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
272 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
275 %************************************************************************
277 \subsection[Utils-dups]{Duplicate-handling}
279 %************************************************************************
282 hasNoDups :: (Eq a) => [a] -> Bool
284 hasNoDups xs = f [] xs
286 f seen_so_far [] = True
287 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
292 is_elem = isIn "hasNoDups"
296 equivClasses :: (a -> a -> Ordering) -- Comparison
300 equivClasses cmp stuff@[] = []
301 equivClasses cmp stuff@[item] = [stuff]
302 equivClasses cmp items
303 = runs eq (sortLt lt items)
305 eq a b = case cmp a b of { EQ -> True; _ -> False }
306 lt a b = case cmp a b of { LT -> True; _ -> False }
309 The first cases in @equivClasses@ above are just to cut to the point
312 @runs@ groups a list into a list of lists, each sublist being a run of
313 identical elements of the input list. It is passed a predicate @p@ which
314 tells when two elements are equal.
317 runs :: (a -> a -> Bool) -- Equality
322 runs p (x:xs) = case (span (p x) xs) of
323 (first, rest) -> (x:first) : (runs p rest)
327 removeDups :: (a -> a -> Ordering) -- Comparison function
329 -> ([a], -- List with no duplicates
330 [[a]]) -- List of duplicate groups. One representative from
331 -- each group appears in the first result
333 removeDups cmp [] = ([], [])
334 removeDups cmp [x] = ([x],[])
336 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
339 collect_dups dups_so_far [x] = (dups_so_far, x)
340 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
345 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
346 -- NB: it's *very* important that if we have the input list [a,b,c],
347 -- where a,b,c all have the same unique, then we get back the list
351 -- Hence the use of foldr, plus the reversed-args tack_on below
352 equivClassesByUniq get_uniq xs
353 = eltsUFM (foldr add emptyUFM xs)
355 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
356 tack_on old new = new++old
359 %************************************************************************
361 \subsection[Utils-sorting]{Sorting}
363 %************************************************************************
365 %************************************************************************
367 \subsubsection[Utils-quicksorting]{Quicksorts}
369 %************************************************************************
372 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
373 quicksort :: (a -> a -> Bool) -- Less-than predicate
375 -> [a] -- Result list in increasing order
378 quicksort lt [x] = [x]
379 quicksort lt (x:xs) = split x [] [] xs
381 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
382 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
383 | True = split x lo (y:hi) ys
386 Quicksort variant from Lennart's Haskell-library contribution. This
387 is a {\em stable} sort.
390 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
392 sortLt :: (a -> a -> Bool) -- Less-than predicate
394 -> [a] -- Result list
396 sortLt lt l = qsort lt l []
398 -- qsort is stable and does not concatenate.
399 qsort :: (a -> a -> Bool) -- Less-than predicate
400 -> [a] -- xs, Input list
401 -> [a] -- r, Concatenate this list to the sorted input list
402 -> [a] -- Result = sort xs ++ r
406 qsort lt (x:xs) r = qpart lt x xs [] [] r
408 -- qpart partitions and sorts the sublists
409 -- rlt contains things less than x,
410 -- rge contains the ones greater than or equal to x.
411 -- Both have equal elements reversed with respect to the original list.
413 qpart lt x [] rlt rge r =
414 -- rlt and rge are in reverse order and must be sorted with an
415 -- anti-stable sorting
416 rqsort lt rlt (x : rqsort lt rge r)
418 qpart lt x (y:ys) rlt rge r =
421 qpart lt x ys (y:rlt) rge r
424 qpart lt x ys rlt (y:rge) r
426 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
428 rqsort lt [x] r = x:r
429 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
431 rqpart lt x [] rle rgt r =
432 qsort lt rle (x : qsort lt rgt r)
434 rqpart lt x (y:ys) rle rgt r =
437 rqpart lt x ys rle (y:rgt) r
440 rqpart lt x ys (y:rle) rgt r
443 %************************************************************************
445 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
447 %************************************************************************
450 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
452 mergesort cmp xs = merge_lists (split_into_runs [] xs)
454 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
455 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
457 split_into_runs [] [] = []
458 split_into_runs run [] = [run]
459 split_into_runs [] (x:xs) = split_into_runs [x] xs
460 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
461 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
462 | True = rl : (split_into_runs [x] xs)
465 merge_lists (x:xs) = merge x (merge_lists xs)
469 merge xl@(x:xs) yl@(y:ys)
471 EQ -> x : y : (merge xs ys)
472 LT -> x : (merge xs yl)
473 GT -> y : (merge xl ys)
476 %************************************************************************
478 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
480 %************************************************************************
483 Date: Mon, 3 May 93 20:45:23 +0200
484 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
485 To: partain@dcs.gla.ac.uk
486 Subject: natural merge sort beats quick sort [ and it is prettier ]
488 Here is a piece of Haskell code that I'm rather fond of. See it as an
489 attempt to get rid of the ridiculous quick-sort routine. group is
490 quite useful by itself I think it was John's idea originally though I
491 believe the lazy version is due to me [surprisingly complicated].
492 gamma [used to be called] is called gamma because I got inspired by
493 the Gamma calculus. It is not very close to the calculus but does
494 behave less sequentially than both foldr and foldl. One could imagine
495 a version of gamma that took a unit element as well thereby avoiding
496 the problem with empty lists.
498 I've tried this code against
500 1) insertion sort - as provided by haskell
501 2) the normal implementation of quick sort
502 3) a deforested version of quick sort due to Jan Sparud
503 4) a super-optimized-quick-sort of Lennart's
505 If the list is partially sorted both merge sort and in particular
506 natural merge sort wins. If the list is random [ average length of
507 rising subsequences = approx 2 ] mergesort still wins and natural
508 merge sort is marginally beaten by Lennart's soqs. The space
509 consumption of merge sort is a bit worse than Lennart's quick sort
510 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
511 fpca article ] isn't used because of group.
518 group :: (a -> a -> Bool) -> [a] -> [[a]]
521 Date: Mon, 12 Feb 1996 15:09:41 +0000
522 From: Andy Gill <andy@dcs.gla.ac.uk>
524 Here is a `better' definition of group.
527 group p (x:xs) = group' xs x x (x :)
529 group' [] _ _ s = [s []]
530 group' (x:xs) x_min x_max s
531 | not (x `p` x_max) = group' xs x_min x (s . (x :))
532 | x `p` x_min = group' xs x x_max ((x :) . s)
533 | otherwise = s [] : group' xs x x (x :)
535 -- This one works forwards *and* backwards, as well as also being
536 -- faster that the one in Util.lhs.
541 let ((h1:t1):tt1) = group p xs
542 (t,tt) = if null xs then ([],[]) else
543 if x `p` h1 then (h1:t1,tt1) else
548 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
549 generalMerge p xs [] = xs
550 generalMerge p [] ys = ys
551 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
552 | otherwise = y : generalMerge p (x:xs) ys
554 -- gamma is now called balancedFold
556 balancedFold :: (a -> a -> a) -> [a] -> a
557 balancedFold f [] = error "can't reduce an empty list using balancedFold"
558 balancedFold f [x] = x
559 balancedFold f l = balancedFold f (balancedFold' f l)
561 balancedFold' :: (a -> a -> a) -> [a] -> [a]
562 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
563 balancedFold' f xs = xs
565 generalMergeSort p [] = []
566 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
568 generalNaturalMergeSort p [] = []
569 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
571 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
573 mergeSort = generalMergeSort (<=)
574 naturalMergeSort = generalNaturalMergeSort (<=)
576 mergeSortLe le = generalMergeSort le
577 naturalMergeSortLe le = generalNaturalMergeSort le
580 %************************************************************************
582 \subsection[Utils-transitive-closure]{Transitive closure}
584 %************************************************************************
586 This algorithm for transitive closure is straightforward, albeit quadratic.
589 transitiveClosure :: (a -> [a]) -- Successor function
590 -> (a -> a -> Bool) -- Equality predicate
592 -> [a] -- The transitive closure
594 transitiveClosure succ eq xs
598 go done (x:xs) | x `is_in` done = go done xs
599 | otherwise = go (x:done) (succ x ++ xs)
602 x `is_in` (y:ys) | eq x y = True
603 | otherwise = x `is_in` ys
606 %************************************************************************
608 \subsection[Utils-accum]{Accumulating}
610 %************************************************************************
612 @mapAccumL@ behaves like a combination
613 of @map@ and @foldl@;
614 it applies a function to each element of a list, passing an accumulating
615 parameter from left to right, and returning a final value of this
616 accumulator together with the new list.
619 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
620 -- and accumulator, returning new
621 -- accumulator and elt of result list
622 -> acc -- Initial accumulator
624 -> (acc, [y]) -- Final accumulator and result list
626 mapAccumL f b [] = (b, [])
627 mapAccumL f b (x:xs) = (b'', x':xs') where
629 (b'', xs') = mapAccumL f b' xs
632 @mapAccumR@ does the same, but working from right to left instead. Its type is
633 the same as @mapAccumL@, though.
636 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
637 -- and accumulator, returning new
638 -- accumulator and elt of result list
639 -> acc -- Initial accumulator
641 -> (acc, [y]) -- Final accumulator and result list
643 mapAccumR f b [] = (b, [])
644 mapAccumR f b (x:xs) = (b'', x':xs') where
646 (b', xs') = mapAccumR f b xs
649 Here is the bi-directional version, that works from both left and right.
652 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
653 -- Function of elt of input list
654 -- and accumulator, returning new
655 -- accumulator and elt of result list
656 -> accl -- Initial accumulator from left
657 -> accr -- Initial accumulator from right
659 -> (accl, accr, [y]) -- Final accumulators and result list
661 mapAccumB f a b [] = (a,b,[])
662 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
664 (a',b'',y) = f a b' x
665 (a'',b',ys) = mapAccumB f a' b xs
668 A combination of foldl with zip. It works with equal length lists.
671 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
673 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
676 Count the number of times a predicate is true
679 count :: (a -> Bool) -> [a] -> Int
681 count p (x:xs) | p x = 1 + count p xs
682 | otherwise = count p xs
686 %************************************************************************
688 \subsection[Utils-comparison]{Comparisons}
690 %************************************************************************
693 thenCmp :: Ordering -> Ordering -> Ordering
694 {-# INLINE thenCmp #-}
696 thenCmp other any = other
698 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
699 -- `cmpList' uses a user-specified comparer
701 cmpList cmp [] [] = EQ
702 cmpList cmp [] _ = LT
703 cmpList cmp _ [] = GT
704 cmpList cmp (a:as) (b:bs)
705 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
709 cmpString :: String -> String -> Ordering
712 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
713 else if x < y then LT
720 %************************************************************************
722 \subsection[Utils-pairs]{Pairs}
724 %************************************************************************
726 The following are curried versions of @fst@ and @snd@.
729 cfst :: a -> b -> a -- stranal-sem only (Note)
733 The following provide us higher order functions that, when applied
734 to a function, operate on pairs.
737 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
738 applyToPair (f,g) (x,y) = (f x, g y)
740 applyToFst :: (a -> c) -> (a,b)-> (c,b)
741 applyToFst f (x,y) = (f x,y)
743 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
744 applyToSnd f (x,y) = (x,f y)
746 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
747 foldPair fg ab [] = ab
748 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
749 where (u,v) = foldPair fg ab abs
753 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
754 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
759 seqList :: [a] -> b -> b
761 seqList :: (Eval a) => [a] -> b -> b
764 seqList (x:xs) b = x `seq` seqList xs b
766 #if __HASKELL1__ <= 4
767 ($!) :: (Eval a) => (a -> b) -> a -> b
773 #if __GLASGOW_HASKELL__ < 402
774 bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
775 bracket before after thing = do
777 r <- (thing a) `catch` (\err -> after a >> fail err)