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
13 Eager, thenEager, returnEager, mapEager, appEager, runEager,
16 -- general list processing
17 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
18 zipLazy, stretchZipWith,
19 mapAndUnzip, mapAndUnzip3,
20 nOfThem, lengthExceeds, isSingleton, only,
28 assoc, assocUsing, assocDefault, assocDefaultUsing,
31 hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq,
34 IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
36 IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
37 IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
39 -- transitive closures
43 mapAccumL, mapAccumR, mapAccumB, foldl2, count,
52 IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
53 IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
57 #if __GLASGOW_HASKELL__ < 402
63 #include "HsVersions.h"
65 import List ( zipWith4 )
66 import Panic ( panic )
67 import Unique ( Unique )
68 import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
73 %************************************************************************
75 \subsection{The Eager monad}
77 %************************************************************************
79 The @Eager@ monad is just an encoding of continuation-passing style,
80 used to allow you to express "do this and then that", mainly to avoid
81 space leaks. It's done with a type synonym to save bureaucracy.
86 type Eager ans a = (a -> ans) -> ans
88 runEager :: Eager a a -> a
89 runEager m = m (\x -> x)
91 appEager :: Eager ans a -> (a -> ans) -> ans
92 appEager m cont = m cont
94 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
95 thenEager m k cont = m (\r -> k r cont)
97 returnEager :: a -> Eager ans a
98 returnEager v cont = cont v
100 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
101 mapEager f [] = returnEager []
102 mapEager f (x:xs) = f x `thenEager` \ y ->
103 mapEager f xs `thenEager` \ ys ->
108 %************************************************************************
110 \subsection{A for loop}
112 %************************************************************************
115 -- Compose a function with itself n times. (nth rather than twice)
116 nTimes :: Int -> (a -> a) -> (a -> a)
119 nTimes n f = f . nTimes (n-1) f
123 %************************************************************************
125 \subsection[Utils-lists]{General list processing}
127 %************************************************************************
129 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
130 are of equal length. Alastair Reid thinks this should only happen if
131 DEBUGging on; hey, why not?
134 zipEqual :: String -> [a] -> [b] -> [(a,b)]
135 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
136 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
137 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
141 zipWithEqual _ = zipWith
142 zipWith3Equal _ = zipWith3
143 zipWith4Equal _ = zipWith4
145 zipEqual msg [] [] = []
146 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
147 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
149 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
150 zipWithEqual msg _ [] [] = []
151 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
153 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
154 = z a b c : zipWith3Equal msg z as bs cs
155 zipWith3Equal msg _ [] [] [] = []
156 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
158 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
159 = z a b c d : zipWith4Equal msg z as bs cs ds
160 zipWith4Equal msg _ [] [] [] [] = []
161 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
166 -- zipLazy is lazy in the second list (observe the ~)
168 zipLazy :: [a] -> [b] -> [(a,b)]
170 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
175 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
176 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
177 -- the places where p returns *True*
179 stretchZipWith p z f [] ys = []
180 stretchZipWith p z f (x:xs) ys
181 | p x = f x z : stretchZipWith p z f xs ys
182 | otherwise = case ys of
184 (y:ys) -> f x y : stretchZipWith p z f xs ys
189 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
191 mapAndUnzip f [] = ([],[])
195 (rs1, rs2) = mapAndUnzip f xs
199 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
201 mapAndUnzip3 f [] = ([],[],[])
202 mapAndUnzip3 f (x:xs)
205 (rs1, rs2, rs3) = mapAndUnzip3 f xs
207 (r1:rs1, r2:rs2, r3:rs3)
211 nOfThem :: Int -> a -> [a]
212 nOfThem n thing = replicate n thing
214 lengthExceeds :: [a] -> Int -> Bool
215 -- (lengthExceeds xs n) is True if length xs > n
216 (x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
217 [] `lengthExceeds` n = n < 0
219 isSingleton :: [a] -> Bool
220 isSingleton [x] = True
221 isSingleton _ = False
232 snocView :: [a] -> ([a], a) -- Split off the last element
233 snocView xs = go xs []
235 go [x] acc = (reverse acc, x)
236 go (x:xs) acc = go xs (x:acc)
239 Debugging/specialising versions of \tr{elem} and \tr{notElem}
242 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
245 isIn msg x ys = elem__ x ys
246 isn'tIn msg x ys = notElem__ x ys
248 --these are here to be SPECIALIZEd (automagically)
250 elem__ x (y:ys) = x==y || elem__ x ys
252 notElem__ x [] = True
253 notElem__ x (y:ys) = x /= y && notElem__ x ys
261 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
262 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
265 = notElem ILIT(0) x ys
267 notElem i x [] = True
269 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
270 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
276 %************************************************************************
278 \subsection[Utils-assoc]{Association lists}
280 %************************************************************************
282 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
285 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
286 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
287 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
288 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
290 assocDefaultUsing eq deflt ((k,v) : rest) key
292 | otherwise = assocDefaultUsing eq deflt rest key
294 assocDefaultUsing eq deflt [] key = deflt
296 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
297 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
298 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
301 %************************************************************************
303 \subsection[Utils-dups]{Duplicate-handling}
305 %************************************************************************
308 hasNoDups :: (Eq a) => [a] -> Bool
310 hasNoDups xs = f [] xs
312 f seen_so_far [] = True
313 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
318 is_elem = isIn "hasNoDups"
322 equivClasses :: (a -> a -> Ordering) -- Comparison
326 equivClasses cmp stuff@[] = []
327 equivClasses cmp stuff@[item] = [stuff]
328 equivClasses cmp items
329 = runs eq (sortLt lt items)
331 eq a b = case cmp a b of { EQ -> True; _ -> False }
332 lt a b = case cmp a b of { LT -> True; _ -> False }
335 The first cases in @equivClasses@ above are just to cut to the point
338 @runs@ groups a list into a list of lists, each sublist being a run of
339 identical elements of the input list. It is passed a predicate @p@ which
340 tells when two elements are equal.
343 runs :: (a -> a -> Bool) -- Equality
348 runs p (x:xs) = case (span (p x) xs) of
349 (first, rest) -> (x:first) : (runs p rest)
353 removeDups :: (a -> a -> Ordering) -- Comparison function
355 -> ([a], -- List with no duplicates
356 [[a]]) -- List of duplicate groups. One representative from
357 -- each group appears in the first result
359 removeDups cmp [] = ([], [])
360 removeDups cmp [x] = ([x],[])
362 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
365 collect_dups dups_so_far [x] = (dups_so_far, x)
366 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
368 removeDupsEq :: Eq a => [a] -> ([a], [[a]])
369 -- Same, but with only equality
370 -- It's worst case quadratic, but we only use it on short lists
371 removeDupsEq [] = ([], [])
372 removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
374 (ys,zs) = removeDupsEq (filter (/= x) xs)
375 removeDupsEq (x:xs) | otherwise = (x:ys, zs)
377 (ys,zs) = removeDupsEq xs
382 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
383 -- NB: it's *very* important that if we have the input list [a,b,c],
384 -- where a,b,c all have the same unique, then we get back the list
388 -- Hence the use of foldr, plus the reversed-args tack_on below
389 equivClassesByUniq get_uniq xs
390 = eltsUFM (foldr add emptyUFM xs)
392 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
393 tack_on old new = new++old
396 %************************************************************************
398 \subsection[Utils-sorting]{Sorting}
400 %************************************************************************
402 %************************************************************************
404 \subsubsection[Utils-quicksorting]{Quicksorts}
406 %************************************************************************
411 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
412 quicksort :: (a -> a -> Bool) -- Less-than predicate
414 -> [a] -- Result list in increasing order
417 quicksort lt [x] = [x]
418 quicksort lt (x:xs) = split x [] [] xs
420 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
421 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
422 | True = split x lo (y:hi) ys
426 Quicksort variant from Lennart's Haskell-library contribution. This
427 is a {\em stable} sort.
430 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
432 sortLt :: (a -> a -> Bool) -- Less-than predicate
434 -> [a] -- Result list
436 sortLt lt l = qsort lt l []
438 -- qsort is stable and does not concatenate.
439 qsort :: (a -> a -> Bool) -- Less-than predicate
440 -> [a] -- xs, Input list
441 -> [a] -- r, Concatenate this list to the sorted input list
442 -> [a] -- Result = sort xs ++ r
446 qsort lt (x:xs) r = qpart lt x xs [] [] r
448 -- qpart partitions and sorts the sublists
449 -- rlt contains things less than x,
450 -- rge contains the ones greater than or equal to x.
451 -- Both have equal elements reversed with respect to the original list.
453 qpart lt x [] rlt rge r =
454 -- rlt and rge are in reverse order and must be sorted with an
455 -- anti-stable sorting
456 rqsort lt rlt (x : rqsort lt rge r)
458 qpart lt x (y:ys) rlt rge r =
461 qpart lt x ys (y:rlt) rge r
464 qpart lt x ys rlt (y:rge) r
466 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
468 rqsort lt [x] r = x:r
469 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
471 rqpart lt x [] rle rgt r =
472 qsort lt rle (x : qsort lt rgt r)
474 rqpart lt x (y:ys) rle rgt r =
477 rqpart lt x ys rle (y:rgt) r
480 rqpart lt x ys (y:rle) rgt r
483 %************************************************************************
485 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
487 %************************************************************************
491 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
493 mergesort cmp xs = merge_lists (split_into_runs [] xs)
495 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
496 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
498 split_into_runs [] [] = []
499 split_into_runs run [] = [run]
500 split_into_runs [] (x:xs) = split_into_runs [x] xs
501 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
502 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
503 | True = rl : (split_into_runs [x] xs)
506 merge_lists (x:xs) = merge x (merge_lists xs)
510 merge xl@(x:xs) yl@(y:ys)
512 EQ -> x : y : (merge xs ys)
513 LT -> x : (merge xs yl)
514 GT -> y : (merge xl ys)
518 %************************************************************************
520 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
522 %************************************************************************
525 Date: Mon, 3 May 93 20:45:23 +0200
526 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
527 To: partain@dcs.gla.ac.uk
528 Subject: natural merge sort beats quick sort [ and it is prettier ]
530 Here is a piece of Haskell code that I'm rather fond of. See it as an
531 attempt to get rid of the ridiculous quick-sort routine. group is
532 quite useful by itself I think it was John's idea originally though I
533 believe the lazy version is due to me [surprisingly complicated].
534 gamma [used to be called] is called gamma because I got inspired by
535 the Gamma calculus. It is not very close to the calculus but does
536 behave less sequentially than both foldr and foldl. One could imagine
537 a version of gamma that took a unit element as well thereby avoiding
538 the problem with empty lists.
540 I've tried this code against
542 1) insertion sort - as provided by haskell
543 2) the normal implementation of quick sort
544 3) a deforested version of quick sort due to Jan Sparud
545 4) a super-optimized-quick-sort of Lennart's
547 If the list is partially sorted both merge sort and in particular
548 natural merge sort wins. If the list is random [ average length of
549 rising subsequences = approx 2 ] mergesort still wins and natural
550 merge sort is marginally beaten by Lennart's soqs. The space
551 consumption of merge sort is a bit worse than Lennart's quick sort
552 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
553 fpca article ] isn't used because of group.
560 group :: (a -> a -> Bool) -> [a] -> [[a]]
563 Date: Mon, 12 Feb 1996 15:09:41 +0000
564 From: Andy Gill <andy@dcs.gla.ac.uk>
566 Here is a `better' definition of group.
569 group p (x:xs) = group' xs x x (x :)
571 group' [] _ _ s = [s []]
572 group' (x:xs) x_min x_max s
573 | not (x `p` x_max) = group' xs x_min x (s . (x :))
574 | x `p` x_min = group' xs x x_max ((x :) . s)
575 | otherwise = s [] : group' xs x x (x :)
577 -- This one works forwards *and* backwards, as well as also being
578 -- faster that the one in Util.lhs.
583 let ((h1:t1):tt1) = group p xs
584 (t,tt) = if null xs then ([],[]) else
585 if x `p` h1 then (h1:t1,tt1) else
590 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
591 generalMerge p xs [] = xs
592 generalMerge p [] ys = ys
593 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
594 | otherwise = y : generalMerge p (x:xs) ys
596 -- gamma is now called balancedFold
598 balancedFold :: (a -> a -> a) -> [a] -> a
599 balancedFold f [] = error "can't reduce an empty list using balancedFold"
600 balancedFold f [x] = x
601 balancedFold f l = balancedFold f (balancedFold' f l)
603 balancedFold' :: (a -> a -> a) -> [a] -> [a]
604 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
605 balancedFold' f xs = xs
607 generalMergeSort p [] = []
608 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
610 generalNaturalMergeSort p [] = []
611 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
613 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
615 mergeSort = generalMergeSort (<=)
616 naturalMergeSort = generalNaturalMergeSort (<=)
618 mergeSortLe le = generalMergeSort le
619 naturalMergeSortLe le = generalNaturalMergeSort le
622 %************************************************************************
624 \subsection[Utils-transitive-closure]{Transitive closure}
626 %************************************************************************
628 This algorithm for transitive closure is straightforward, albeit quadratic.
631 transitiveClosure :: (a -> [a]) -- Successor function
632 -> (a -> a -> Bool) -- Equality predicate
634 -> [a] -- The transitive closure
636 transitiveClosure succ eq xs
640 go done (x:xs) | x `is_in` done = go done xs
641 | otherwise = go (x:done) (succ x ++ xs)
644 x `is_in` (y:ys) | eq x y = True
645 | otherwise = x `is_in` ys
648 %************************************************************************
650 \subsection[Utils-accum]{Accumulating}
652 %************************************************************************
654 @mapAccumL@ behaves like a combination
655 of @map@ and @foldl@;
656 it applies a function to each element of a list, passing an accumulating
657 parameter from left to right, and returning a final value of this
658 accumulator together with the new list.
661 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
662 -- and accumulator, returning new
663 -- accumulator and elt of result list
664 -> acc -- Initial accumulator
666 -> (acc, [y]) -- Final accumulator and result list
668 mapAccumL f b [] = (b, [])
669 mapAccumL f b (x:xs) = (b'', x':xs') where
671 (b'', xs') = mapAccumL f b' xs
674 @mapAccumR@ does the same, but working from right to left instead. Its type is
675 the same as @mapAccumL@, though.
678 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
679 -- and accumulator, returning new
680 -- accumulator and elt of result list
681 -> acc -- Initial accumulator
683 -> (acc, [y]) -- Final accumulator and result list
685 mapAccumR f b [] = (b, [])
686 mapAccumR f b (x:xs) = (b'', x':xs') where
688 (b', xs') = mapAccumR f b xs
691 Here is the bi-directional version, that works from both left and right.
694 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
695 -- Function of elt of input list
696 -- and accumulator, returning new
697 -- accumulator and elt of result list
698 -> accl -- Initial accumulator from left
699 -> accr -- Initial accumulator from right
701 -> (accl, accr, [y]) -- Final accumulators and result list
703 mapAccumB f a b [] = (a,b,[])
704 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
706 (a',b'',y) = f a b' x
707 (a'',b',ys) = mapAccumB f a' b xs
710 A combination of foldl with zip. It works with equal length lists.
713 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
715 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
718 Count the number of times a predicate is true
721 count :: (a -> Bool) -> [a] -> Int
723 count p (x:xs) | p x = 1 + count p xs
724 | otherwise = count p xs
728 %************************************************************************
730 \subsection[Utils-comparison]{Comparisons}
732 %************************************************************************
735 thenCmp :: Ordering -> Ordering -> Ordering
736 {-# INLINE thenCmp #-}
738 thenCmp other any = other
740 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
741 -- `cmpList' uses a user-specified comparer
743 cmpList cmp [] [] = EQ
744 cmpList cmp [] _ = LT
745 cmpList cmp _ [] = GT
746 cmpList cmp (a:as) (b:bs)
747 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
751 cmpString :: String -> String -> Ordering
754 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
755 else if x < y then LT
762 %************************************************************************
764 \subsection[Utils-pairs]{Pairs}
766 %************************************************************************
768 The following are curried versions of @fst@ and @snd@.
771 cfst :: a -> b -> a -- stranal-sem only (Note)
775 The following provide us higher order functions that, when applied
776 to a function, operate on pairs.
779 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
780 applyToPair (f,g) (x,y) = (f x, g y)
782 applyToFst :: (a -> c) -> (a,b)-> (c,b)
783 applyToFst f (x,y) = (f x,y)
785 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
786 applyToSnd f (x,y) = (x,f y)
788 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
789 foldPair fg ab [] = ab
790 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
791 where (u,v) = foldPair fg ab abs
795 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
796 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
801 seqList :: [a] -> b -> b
803 seqList :: (Eval a) => [a] -> b -> b
806 seqList (x:xs) b = x `seq` seqList xs b
808 #if __HASKELL1__ <= 4
809 ($!) :: (Eval a) => (a -> b) -> a -> b
815 #if __GLASGOW_HASKELL__ < 402
816 bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
817 bracket before after thing = do
819 r <- (thing a) `catch` (\err -> after a >> fail err)