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, stretchZipEqual,
19 mapAndUnzip, mapAndUnzip3,
20 nOfThem, lengthExceeds, isSingleton, only,
25 assoc, assocUsing, assocDefault, assocDefaultUsing,
28 hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
31 IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
33 IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
34 IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
36 -- transitive closures
40 mapAccumL, mapAccumR, mapAccumB, foldl2, count,
49 IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
50 IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
54 #if __GLASGOW_HASKELL__ < 402
60 #include "HsVersions.h"
62 import List ( zipWith4 )
63 import Panic ( panic )
64 import Unique ( Unique )
65 import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
70 %************************************************************************
72 \subsection{The Eager monad}
74 %************************************************************************
76 The @Eager@ monad is just an encoding of continuation-passing style,
77 used to allow you to express "do this and then that", mainly to avoid
78 space leaks. It's done with a type synonym to save bureaucracy.
83 type Eager ans a = (a -> ans) -> ans
85 runEager :: Eager a a -> a
86 runEager m = m (\x -> x)
88 appEager :: Eager ans a -> (a -> ans) -> ans
89 appEager m cont = m cont
91 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
92 thenEager m k cont = m (\r -> k r cont)
94 returnEager :: a -> Eager ans a
95 returnEager v cont = cont v
97 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
98 mapEager f [] = returnEager []
99 mapEager f (x:xs) = f x `thenEager` \ y ->
100 mapEager f xs `thenEager` \ ys ->
105 %************************************************************************
107 \subsection[Utils-lists]{General list processing}
109 %************************************************************************
111 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
112 are of equal length. Alastair Reid thinks this should only happen if
113 DEBUGging on; hey, why not?
116 zipEqual :: String -> [a] -> [b] -> [(a,b)]
117 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
118 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
119 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
123 zipWithEqual _ = zipWith
124 zipWith3Equal _ = zipWith3
125 zipWith4Equal _ = zipWith4
127 zipEqual msg [] [] = []
128 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
129 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
131 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
132 zipWithEqual msg _ [] [] = []
133 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
135 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
136 = z a b c : zipWith3Equal msg z as bs cs
137 zipWith3Equal msg _ [] [] [] = []
138 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
140 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
141 = z a b c d : zipWith4Equal msg z as bs cs ds
142 zipWith4Equal msg _ [] [] [] [] = []
143 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
148 -- zipLazy is lazy in the second list (observe the ~)
150 zipLazy :: [a] -> [b] -> [(a,b)]
152 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
157 stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
158 -- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
160 stretchZipEqual f [] [] = []
161 stretchZipEqual f (x:xs) (y:ys) = case f x y of
162 Just x' -> x' : stretchZipEqual f xs ys
163 Nothing -> x : stretchZipEqual f xs (y:ys)
168 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
170 mapAndUnzip f [] = ([],[])
174 (rs1, rs2) = mapAndUnzip f xs
178 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
180 mapAndUnzip3 f [] = ([],[],[])
181 mapAndUnzip3 f (x:xs)
184 (rs1, rs2, rs3) = mapAndUnzip3 f xs
186 (r1:rs1, r2:rs2, r3:rs3)
190 nOfThem :: Int -> a -> [a]
191 nOfThem n thing = replicate n thing
193 lengthExceeds :: [a] -> Int -> Bool
194 -- (lengthExceeds xs n) is True if length xs > n
195 (x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
196 [] `lengthExceeds` n = n < 0
198 isSingleton :: [a] -> Bool
199 isSingleton [x] = True
200 isSingleton _ = False
211 snocView :: [a] -> ([a], a) -- Split off the last element
212 snocView xs = go xs []
214 go [x] acc = (reverse acc, x)
215 go (x:xs) acc = go xs (x:acc)
218 Debugging/specialising versions of \tr{elem} and \tr{notElem}
221 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
224 isIn msg x ys = elem__ x ys
225 isn'tIn msg x ys = notElem__ x ys
227 --these are here to be SPECIALIZEd (automagically)
229 elem__ x (y:ys) = x==y || elem__ x ys
231 notElem__ x [] = True
232 notElem__ x (y:ys) = x /= y && notElem__ x ys
240 | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
241 | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
244 = notElem ILIT(0) x ys
246 notElem i x [] = True
248 | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
249 | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
255 %************************************************************************
257 \subsection[Utils-assoc]{Association lists}
259 %************************************************************************
261 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
264 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
265 assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
266 assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
267 assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
269 assocDefaultUsing eq deflt ((k,v) : rest) key
271 | otherwise = assocDefaultUsing eq deflt rest key
273 assocDefaultUsing eq deflt [] key = deflt
275 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
276 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
277 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
280 %************************************************************************
282 \subsection[Utils-dups]{Duplicate-handling}
284 %************************************************************************
287 hasNoDups :: (Eq a) => [a] -> Bool
289 hasNoDups xs = f [] xs
291 f seen_so_far [] = True
292 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
297 is_elem = isIn "hasNoDups"
301 equivClasses :: (a -> a -> Ordering) -- Comparison
305 equivClasses cmp stuff@[] = []
306 equivClasses cmp stuff@[item] = [stuff]
307 equivClasses cmp items
308 = runs eq (sortLt lt items)
310 eq a b = case cmp a b of { EQ -> True; _ -> False }
311 lt a b = case cmp a b of { LT -> True; _ -> False }
314 The first cases in @equivClasses@ above are just to cut to the point
317 @runs@ groups a list into a list of lists, each sublist being a run of
318 identical elements of the input list. It is passed a predicate @p@ which
319 tells when two elements are equal.
322 runs :: (a -> a -> Bool) -- Equality
327 runs p (x:xs) = case (span (p x) xs) of
328 (first, rest) -> (x:first) : (runs p rest)
332 removeDups :: (a -> a -> Ordering) -- Comparison function
334 -> ([a], -- List with no duplicates
335 [[a]]) -- List of duplicate groups. One representative from
336 -- each group appears in the first result
338 removeDups cmp [] = ([], [])
339 removeDups cmp [x] = ([x],[])
341 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
344 collect_dups dups_so_far [x] = (dups_so_far, x)
345 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
350 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
351 -- NB: it's *very* important that if we have the input list [a,b,c],
352 -- where a,b,c all have the same unique, then we get back the list
356 -- Hence the use of foldr, plus the reversed-args tack_on below
357 equivClassesByUniq get_uniq xs
358 = eltsUFM (foldr add emptyUFM xs)
360 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
361 tack_on old new = new++old
364 %************************************************************************
366 \subsection[Utils-sorting]{Sorting}
368 %************************************************************************
370 %************************************************************************
372 \subsubsection[Utils-quicksorting]{Quicksorts}
374 %************************************************************************
379 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
380 quicksort :: (a -> a -> Bool) -- Less-than predicate
382 -> [a] -- Result list in increasing order
385 quicksort lt [x] = [x]
386 quicksort lt (x:xs) = split x [] [] xs
388 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
389 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
390 | True = split x lo (y:hi) ys
394 Quicksort variant from Lennart's Haskell-library contribution. This
395 is a {\em stable} sort.
398 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
400 sortLt :: (a -> a -> Bool) -- Less-than predicate
402 -> [a] -- Result list
404 sortLt lt l = qsort lt l []
406 -- qsort is stable and does not concatenate.
407 qsort :: (a -> a -> Bool) -- Less-than predicate
408 -> [a] -- xs, Input list
409 -> [a] -- r, Concatenate this list to the sorted input list
410 -> [a] -- Result = sort xs ++ r
414 qsort lt (x:xs) r = qpart lt x xs [] [] r
416 -- qpart partitions and sorts the sublists
417 -- rlt contains things less than x,
418 -- rge contains the ones greater than or equal to x.
419 -- Both have equal elements reversed with respect to the original list.
421 qpart lt x [] rlt rge r =
422 -- rlt and rge are in reverse order and must be sorted with an
423 -- anti-stable sorting
424 rqsort lt rlt (x : rqsort lt rge r)
426 qpart lt x (y:ys) rlt rge r =
429 qpart lt x ys (y:rlt) rge r
432 qpart lt x ys rlt (y:rge) r
434 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
436 rqsort lt [x] r = x:r
437 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
439 rqpart lt x [] rle rgt r =
440 qsort lt rle (x : qsort lt rgt r)
442 rqpart lt x (y:ys) rle rgt r =
445 rqpart lt x ys rle (y:rgt) r
448 rqpart lt x ys (y:rle) rgt r
451 %************************************************************************
453 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
455 %************************************************************************
459 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
461 mergesort cmp xs = merge_lists (split_into_runs [] xs)
463 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
464 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
466 split_into_runs [] [] = []
467 split_into_runs run [] = [run]
468 split_into_runs [] (x:xs) = split_into_runs [x] xs
469 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
470 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
471 | True = rl : (split_into_runs [x] xs)
474 merge_lists (x:xs) = merge x (merge_lists xs)
478 merge xl@(x:xs) yl@(y:ys)
480 EQ -> x : y : (merge xs ys)
481 LT -> x : (merge xs yl)
482 GT -> y : (merge xl ys)
486 %************************************************************************
488 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
490 %************************************************************************
493 Date: Mon, 3 May 93 20:45:23 +0200
494 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
495 To: partain@dcs.gla.ac.uk
496 Subject: natural merge sort beats quick sort [ and it is prettier ]
498 Here is a piece of Haskell code that I'm rather fond of. See it as an
499 attempt to get rid of the ridiculous quick-sort routine. group is
500 quite useful by itself I think it was John's idea originally though I
501 believe the lazy version is due to me [surprisingly complicated].
502 gamma [used to be called] is called gamma because I got inspired by
503 the Gamma calculus. It is not very close to the calculus but does
504 behave less sequentially than both foldr and foldl. One could imagine
505 a version of gamma that took a unit element as well thereby avoiding
506 the problem with empty lists.
508 I've tried this code against
510 1) insertion sort - as provided by haskell
511 2) the normal implementation of quick sort
512 3) a deforested version of quick sort due to Jan Sparud
513 4) a super-optimized-quick-sort of Lennart's
515 If the list is partially sorted both merge sort and in particular
516 natural merge sort wins. If the list is random [ average length of
517 rising subsequences = approx 2 ] mergesort still wins and natural
518 merge sort is marginally beaten by Lennart's soqs. The space
519 consumption of merge sort is a bit worse than Lennart's quick sort
520 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
521 fpca article ] isn't used because of group.
528 group :: (a -> a -> Bool) -> [a] -> [[a]]
531 Date: Mon, 12 Feb 1996 15:09:41 +0000
532 From: Andy Gill <andy@dcs.gla.ac.uk>
534 Here is a `better' definition of group.
537 group p (x:xs) = group' xs x x (x :)
539 group' [] _ _ s = [s []]
540 group' (x:xs) x_min x_max s
541 | not (x `p` x_max) = group' xs x_min x (s . (x :))
542 | x `p` x_min = group' xs x x_max ((x :) . s)
543 | otherwise = s [] : group' xs x x (x :)
545 -- This one works forwards *and* backwards, as well as also being
546 -- faster that the one in Util.lhs.
551 let ((h1:t1):tt1) = group p xs
552 (t,tt) = if null xs then ([],[]) else
553 if x `p` h1 then (h1:t1,tt1) else
558 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
559 generalMerge p xs [] = xs
560 generalMerge p [] ys = ys
561 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
562 | otherwise = y : generalMerge p (x:xs) ys
564 -- gamma is now called balancedFold
566 balancedFold :: (a -> a -> a) -> [a] -> a
567 balancedFold f [] = error "can't reduce an empty list using balancedFold"
568 balancedFold f [x] = x
569 balancedFold f l = balancedFold f (balancedFold' f l)
571 balancedFold' :: (a -> a -> a) -> [a] -> [a]
572 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
573 balancedFold' f xs = xs
575 generalMergeSort p [] = []
576 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
578 generalNaturalMergeSort p [] = []
579 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
581 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
583 mergeSort = generalMergeSort (<=)
584 naturalMergeSort = generalNaturalMergeSort (<=)
586 mergeSortLe le = generalMergeSort le
587 naturalMergeSortLe le = generalNaturalMergeSort le
590 %************************************************************************
592 \subsection[Utils-transitive-closure]{Transitive closure}
594 %************************************************************************
596 This algorithm for transitive closure is straightforward, albeit quadratic.
599 transitiveClosure :: (a -> [a]) -- Successor function
600 -> (a -> a -> Bool) -- Equality predicate
602 -> [a] -- The transitive closure
604 transitiveClosure succ eq xs
608 go done (x:xs) | x `is_in` done = go done xs
609 | otherwise = go (x:done) (succ x ++ xs)
612 x `is_in` (y:ys) | eq x y = True
613 | otherwise = x `is_in` ys
616 %************************************************************************
618 \subsection[Utils-accum]{Accumulating}
620 %************************************************************************
622 @mapAccumL@ behaves like a combination
623 of @map@ and @foldl@;
624 it applies a function to each element of a list, passing an accumulating
625 parameter from left to right, and returning a final value of this
626 accumulator together with the new list.
629 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
630 -- and accumulator, returning new
631 -- accumulator and elt of result list
632 -> acc -- Initial accumulator
634 -> (acc, [y]) -- Final accumulator and result list
636 mapAccumL f b [] = (b, [])
637 mapAccumL f b (x:xs) = (b'', x':xs') where
639 (b'', xs') = mapAccumL f b' xs
642 @mapAccumR@ does the same, but working from right to left instead. Its type is
643 the same as @mapAccumL@, though.
646 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
647 -- and accumulator, returning new
648 -- accumulator and elt of result list
649 -> acc -- Initial accumulator
651 -> (acc, [y]) -- Final accumulator and result list
653 mapAccumR f b [] = (b, [])
654 mapAccumR f b (x:xs) = (b'', x':xs') where
656 (b', xs') = mapAccumR f b xs
659 Here is the bi-directional version, that works from both left and right.
662 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
663 -- Function of elt of input list
664 -- and accumulator, returning new
665 -- accumulator and elt of result list
666 -> accl -- Initial accumulator from left
667 -> accr -- Initial accumulator from right
669 -> (accl, accr, [y]) -- Final accumulators and result list
671 mapAccumB f a b [] = (a,b,[])
672 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
674 (a',b'',y) = f a b' x
675 (a'',b',ys) = mapAccumB f a' b xs
678 A combination of foldl with zip. It works with equal length lists.
681 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
683 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
686 Count the number of times a predicate is true
689 count :: (a -> Bool) -> [a] -> Int
691 count p (x:xs) | p x = 1 + count p xs
692 | otherwise = count p xs
696 %************************************************************************
698 \subsection[Utils-comparison]{Comparisons}
700 %************************************************************************
703 thenCmp :: Ordering -> Ordering -> Ordering
704 {-# INLINE thenCmp #-}
706 thenCmp other any = other
708 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
709 -- `cmpList' uses a user-specified comparer
711 cmpList cmp [] [] = EQ
712 cmpList cmp [] _ = LT
713 cmpList cmp _ [] = GT
714 cmpList cmp (a:as) (b:bs)
715 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
719 cmpString :: String -> String -> Ordering
722 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
723 else if x < y then LT
730 %************************************************************************
732 \subsection[Utils-pairs]{Pairs}
734 %************************************************************************
736 The following are curried versions of @fst@ and @snd@.
739 cfst :: a -> b -> a -- stranal-sem only (Note)
743 The following provide us higher order functions that, when applied
744 to a function, operate on pairs.
747 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
748 applyToPair (f,g) (x,y) = (f x, g y)
750 applyToFst :: (a -> c) -> (a,b)-> (c,b)
751 applyToFst f (x,y) = (f x,y)
753 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
754 applyToSnd f (x,y) = (x,f y)
756 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
757 foldPair fg ab [] = ab
758 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
759 where (u,v) = foldPair fg ab abs
763 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
764 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
769 seqList :: [a] -> b -> b
771 seqList :: (Eval a) => [a] -> b -> b
774 seqList (x:xs) b = x `seq` seqList xs b
776 #if __HASKELL1__ <= 4
777 ($!) :: (Eval a) => (a -> b) -> a -> b
783 #if __GLASGOW_HASKELL__ < 402
784 bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
785 bracket before after thing = do
787 r <- (thing a) `catch` (\err -> after a >> fail err)