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, 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)
371 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
372 -- NB: it's *very* important that if we have the input list [a,b,c],
373 -- where a,b,c all have the same unique, then we get back the list
377 -- Hence the use of foldr, plus the reversed-args tack_on below
378 equivClassesByUniq get_uniq xs
379 = eltsUFM (foldr add emptyUFM xs)
381 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
382 tack_on old new = new++old
385 %************************************************************************
387 \subsection[Utils-sorting]{Sorting}
389 %************************************************************************
391 %************************************************************************
393 \subsubsection[Utils-quicksorting]{Quicksorts}
395 %************************************************************************
400 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
401 quicksort :: (a -> a -> Bool) -- Less-than predicate
403 -> [a] -- Result list in increasing order
406 quicksort lt [x] = [x]
407 quicksort lt (x:xs) = split x [] [] xs
409 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
410 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
411 | True = split x lo (y:hi) ys
415 Quicksort variant from Lennart's Haskell-library contribution. This
416 is a {\em stable} sort.
419 stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
421 sortLt :: (a -> a -> Bool) -- Less-than predicate
423 -> [a] -- Result list
425 sortLt lt l = qsort lt l []
427 -- qsort is stable and does not concatenate.
428 qsort :: (a -> a -> Bool) -- Less-than predicate
429 -> [a] -- xs, Input list
430 -> [a] -- r, Concatenate this list to the sorted input list
431 -> [a] -- Result = sort xs ++ r
435 qsort lt (x:xs) r = qpart lt x xs [] [] r
437 -- qpart partitions and sorts the sublists
438 -- rlt contains things less than x,
439 -- rge contains the ones greater than or equal to x.
440 -- Both have equal elements reversed with respect to the original list.
442 qpart lt x [] rlt rge r =
443 -- rlt and rge are in reverse order and must be sorted with an
444 -- anti-stable sorting
445 rqsort lt rlt (x : rqsort lt rge r)
447 qpart lt x (y:ys) rlt rge r =
450 qpart lt x ys (y:rlt) rge r
453 qpart lt x ys rlt (y:rge) r
455 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
457 rqsort lt [x] r = x:r
458 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
460 rqpart lt x [] rle rgt r =
461 qsort lt rle (x : qsort lt rgt r)
463 rqpart lt x (y:ys) rle rgt r =
466 rqpart lt x ys rle (y:rgt) r
469 rqpart lt x ys (y:rle) rgt r
472 %************************************************************************
474 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
476 %************************************************************************
480 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
482 mergesort cmp xs = merge_lists (split_into_runs [] xs)
484 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
485 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
487 split_into_runs [] [] = []
488 split_into_runs run [] = [run]
489 split_into_runs [] (x:xs) = split_into_runs [x] xs
490 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
491 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
492 | True = rl : (split_into_runs [x] xs)
495 merge_lists (x:xs) = merge x (merge_lists xs)
499 merge xl@(x:xs) yl@(y:ys)
501 EQ -> x : y : (merge xs ys)
502 LT -> x : (merge xs yl)
503 GT -> y : (merge xl ys)
507 %************************************************************************
509 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
511 %************************************************************************
514 Date: Mon, 3 May 93 20:45:23 +0200
515 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
516 To: partain@dcs.gla.ac.uk
517 Subject: natural merge sort beats quick sort [ and it is prettier ]
519 Here is a piece of Haskell code that I'm rather fond of. See it as an
520 attempt to get rid of the ridiculous quick-sort routine. group is
521 quite useful by itself I think it was John's idea originally though I
522 believe the lazy version is due to me [surprisingly complicated].
523 gamma [used to be called] is called gamma because I got inspired by
524 the Gamma calculus. It is not very close to the calculus but does
525 behave less sequentially than both foldr and foldl. One could imagine
526 a version of gamma that took a unit element as well thereby avoiding
527 the problem with empty lists.
529 I've tried this code against
531 1) insertion sort - as provided by haskell
532 2) the normal implementation of quick sort
533 3) a deforested version of quick sort due to Jan Sparud
534 4) a super-optimized-quick-sort of Lennart's
536 If the list is partially sorted both merge sort and in particular
537 natural merge sort wins. If the list is random [ average length of
538 rising subsequences = approx 2 ] mergesort still wins and natural
539 merge sort is marginally beaten by Lennart's soqs. The space
540 consumption of merge sort is a bit worse than Lennart's quick sort
541 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
542 fpca article ] isn't used because of group.
549 group :: (a -> a -> Bool) -> [a] -> [[a]]
552 Date: Mon, 12 Feb 1996 15:09:41 +0000
553 From: Andy Gill <andy@dcs.gla.ac.uk>
555 Here is a `better' definition of group.
558 group p (x:xs) = group' xs x x (x :)
560 group' [] _ _ s = [s []]
561 group' (x:xs) x_min x_max s
562 | not (x `p` x_max) = group' xs x_min x (s . (x :))
563 | x `p` x_min = group' xs x x_max ((x :) . s)
564 | otherwise = s [] : group' xs x x (x :)
566 -- This one works forwards *and* backwards, as well as also being
567 -- faster that the one in Util.lhs.
572 let ((h1:t1):tt1) = group p xs
573 (t,tt) = if null xs then ([],[]) else
574 if x `p` h1 then (h1:t1,tt1) else
579 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
580 generalMerge p xs [] = xs
581 generalMerge p [] ys = ys
582 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
583 | otherwise = y : generalMerge p (x:xs) ys
585 -- gamma is now called balancedFold
587 balancedFold :: (a -> a -> a) -> [a] -> a
588 balancedFold f [] = error "can't reduce an empty list using balancedFold"
589 balancedFold f [x] = x
590 balancedFold f l = balancedFold f (balancedFold' f l)
592 balancedFold' :: (a -> a -> a) -> [a] -> [a]
593 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
594 balancedFold' f xs = xs
596 generalMergeSort p [] = []
597 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
599 generalNaturalMergeSort p [] = []
600 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
602 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
604 mergeSort = generalMergeSort (<=)
605 naturalMergeSort = generalNaturalMergeSort (<=)
607 mergeSortLe le = generalMergeSort le
608 naturalMergeSortLe le = generalNaturalMergeSort le
611 %************************************************************************
613 \subsection[Utils-transitive-closure]{Transitive closure}
615 %************************************************************************
617 This algorithm for transitive closure is straightforward, albeit quadratic.
620 transitiveClosure :: (a -> [a]) -- Successor function
621 -> (a -> a -> Bool) -- Equality predicate
623 -> [a] -- The transitive closure
625 transitiveClosure succ eq xs
629 go done (x:xs) | x `is_in` done = go done xs
630 | otherwise = go (x:done) (succ x ++ xs)
633 x `is_in` (y:ys) | eq x y = True
634 | otherwise = x `is_in` ys
637 %************************************************************************
639 \subsection[Utils-accum]{Accumulating}
641 %************************************************************************
643 @mapAccumL@ behaves like a combination
644 of @map@ and @foldl@;
645 it applies a function to each element of a list, passing an accumulating
646 parameter from left to right, and returning a final value of this
647 accumulator together with the new list.
650 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
651 -- and accumulator, returning new
652 -- accumulator and elt of result list
653 -> acc -- Initial accumulator
655 -> (acc, [y]) -- Final accumulator and result list
657 mapAccumL f b [] = (b, [])
658 mapAccumL f b (x:xs) = (b'', x':xs') where
660 (b'', xs') = mapAccumL f b' xs
663 @mapAccumR@ does the same, but working from right to left instead. Its type is
664 the same as @mapAccumL@, though.
667 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
668 -- and accumulator, returning new
669 -- accumulator and elt of result list
670 -> acc -- Initial accumulator
672 -> (acc, [y]) -- Final accumulator and result list
674 mapAccumR f b [] = (b, [])
675 mapAccumR f b (x:xs) = (b'', x':xs') where
677 (b', xs') = mapAccumR f b xs
680 Here is the bi-directional version, that works from both left and right.
683 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
684 -- Function of elt of input list
685 -- and accumulator, returning new
686 -- accumulator and elt of result list
687 -> accl -- Initial accumulator from left
688 -> accr -- Initial accumulator from right
690 -> (accl, accr, [y]) -- Final accumulators and result list
692 mapAccumB f a b [] = (a,b,[])
693 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
695 (a',b'',y) = f a b' x
696 (a'',b',ys) = mapAccumB f a' b xs
699 A combination of foldl with zip. It works with equal length lists.
702 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
704 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
707 Count the number of times a predicate is true
710 count :: (a -> Bool) -> [a] -> Int
712 count p (x:xs) | p x = 1 + count p xs
713 | otherwise = count p xs
717 %************************************************************************
719 \subsection[Utils-comparison]{Comparisons}
721 %************************************************************************
724 thenCmp :: Ordering -> Ordering -> Ordering
725 {-# INLINE thenCmp #-}
727 thenCmp other any = other
729 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
730 -- `cmpList' uses a user-specified comparer
732 cmpList cmp [] [] = EQ
733 cmpList cmp [] _ = LT
734 cmpList cmp _ [] = GT
735 cmpList cmp (a:as) (b:bs)
736 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
740 cmpString :: String -> String -> Ordering
743 cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
744 else if x < y then LT
751 %************************************************************************
753 \subsection[Utils-pairs]{Pairs}
755 %************************************************************************
757 The following are curried versions of @fst@ and @snd@.
760 cfst :: a -> b -> a -- stranal-sem only (Note)
764 The following provide us higher order functions that, when applied
765 to a function, operate on pairs.
768 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
769 applyToPair (f,g) (x,y) = (f x, g y)
771 applyToFst :: (a -> c) -> (a,b)-> (c,b)
772 applyToFst f (x,y) = (f x,y)
774 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
775 applyToSnd f (x,y) = (x,f y)
777 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
778 foldPair fg ab [] = ab
779 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
780 where (u,v) = foldPair fg ab abs
784 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
785 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
790 seqList :: [a] -> b -> b
792 seqList :: (Eval a) => [a] -> b -> b
795 seqList (x:xs) b = x `seq` seqList xs b
797 #if __HASKELL1__ <= 4
798 ($!) :: (Eval a) => (a -> b) -> a -> b
804 #if __GLASGOW_HASKELL__ < 402
805 bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
806 bracket before after thing = do
808 r <- (thing a) `catch` (\err -> after a >> fail err)