2 % (c) The University of Glasgow 1992-2002
4 \section[Util]{Highly random utility functions}
9 -- general list processing
10 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
11 zipLazy, stretchZipWith,
12 mapAndUnzip, mapAndUnzip3,
14 lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
24 sortLt, naturalMergeSortLe,
26 -- transitive closures
30 mapAccumL, mapAccumR, mapAccumB,
33 takeList, dropList, splitAtList,
36 eqListBy, equalLength, compareLength,
37 thenCmp, cmpList, prefixMatch, suffixMatch,
51 #include "../includes/config.h"
52 #include "HsVersions.h"
54 import Panic ( panic, trace )
57 #if __GLASGOW_HASKELL__ <= 408
58 import EXCEPTION ( catchIO, justIoErrors, raiseInThread )
60 import DATA_IOREF ( IORef, newIORef )
61 import UNSAFE_IO ( unsafePerformIO )
63 import qualified List ( elem, notElem )
66 import List ( zipWith4 )
69 import Char ( isUpper, isAlphaNum )
74 %************************************************************************
76 \subsection{The Eager monad}
78 %************************************************************************
80 The @Eager@ monad is just an encoding of continuation-passing style,
81 used to allow you to express "do this and then that", mainly to avoid
82 space leaks. It's done with a type synonym to save bureaucracy.
87 type Eager ans a = (a -> ans) -> ans
89 runEager :: Eager a a -> a
90 runEager m = m (\x -> x)
92 appEager :: Eager ans a -> (a -> ans) -> ans
93 appEager m cont = m cont
95 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
96 thenEager m k cont = m (\r -> k r cont)
98 returnEager :: a -> Eager ans a
99 returnEager v cont = cont v
101 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
102 mapEager f [] = returnEager []
103 mapEager f (x:xs) = f x `thenEager` \ y ->
104 mapEager f xs `thenEager` \ ys ->
109 %************************************************************************
111 \subsection{A for loop}
113 %************************************************************************
116 -- Compose a function with itself n times. (nth rather than twice)
117 nTimes :: Int -> (a -> a) -> (a -> a)
120 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 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
217 -- atLength atLenPred atEndPred ls n
218 -- | n < 0 = atLenPred n
219 -- | length ls < n = atEndPred (n - length ls)
220 -- | otherwise = atLenPred (drop n ls)
222 atLength :: ([a] -> b)
227 atLength atLenPred atEndPred ls n
228 | n < 0 = atEndPred n
229 | otherwise = go n ls
231 go n [] = atEndPred n
232 go 0 ls = atLenPred ls
233 go n (_:xs) = go (n-1) xs
236 lengthExceeds :: [a] -> Int -> Bool
237 -- (lengthExceeds xs n) = (length xs > n)
238 lengthExceeds = atLength notNull (const False)
240 lengthAtLeast :: [a] -> Int -> Bool
241 lengthAtLeast = atLength notNull (== 0)
243 lengthIs :: [a] -> Int -> Bool
244 lengthIs = atLength null (==0)
246 listLengthCmp :: [a] -> Int -> Ordering
247 listLengthCmp = atLength atLen atEnd
251 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
257 isSingleton :: [a] -> Bool
258 isSingleton [x] = True
259 isSingleton _ = False
261 notNull :: [a] -> Bool
265 snocView :: [a] -> Maybe ([a],a)
266 -- Split off the last element
267 snocView [] = Nothing
268 snocView xs = go [] xs
270 -- Invariant: second arg is non-empty
271 go acc [x] = Just (reverse acc, x)
272 go acc (x:xs) = go (x:acc) xs
282 Debugging/specialising versions of \tr{elem} and \tr{notElem}
285 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
288 isIn msg x ys = elem__ x ys
289 isn'tIn msg x ys = notElem__ x ys
291 --these are here to be SPECIALIZEd (automagically)
293 elem__ x (y:ys) = x==y || elem__ x ys
295 notElem__ x [] = True
296 notElem__ x (y:ys) = x /= y && notElem__ x ys
300 = elem (_ILIT 0) x ys
304 | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
306 | otherwise = x == y || elem (i +# _ILIT(1)) x ys
309 = notElem (_ILIT 0) x ys
311 notElem i x [] = True
313 | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
314 x `List.notElem` (y:ys)
315 | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys
319 %************************************************************************
321 \subsection[Utils-sorting]{Sorting}
323 %************************************************************************
325 %************************************************************************
327 \subsubsection[Utils-quicksorting]{Quicksorts}
329 %************************************************************************
334 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
335 quicksort :: (a -> a -> Bool) -- Less-than predicate
337 -> [a] -- Result list in increasing order
340 quicksort lt [x] = [x]
341 quicksort lt (x:xs) = split x [] [] xs
343 split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
344 split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
345 | True = split x lo (y:hi) ys
349 Quicksort variant from Lennart's Haskell-library contribution. This
350 is a {\em stable} sort.
353 sortLt :: (a -> a -> Bool) -- Less-than predicate
355 -> [a] -- Result list
357 sortLt lt l = qsort lt l []
359 -- qsort is stable and does not concatenate.
360 qsort :: (a -> a -> Bool) -- Less-than predicate
361 -> [a] -- xs, Input list
362 -> [a] -- r, Concatenate this list to the sorted input list
363 -> [a] -- Result = sort xs ++ r
367 qsort lt (x:xs) r = qpart lt x xs [] [] r
369 -- qpart partitions and sorts the sublists
370 -- rlt contains things less than x,
371 -- rge contains the ones greater than or equal to x.
372 -- Both have equal elements reversed with respect to the original list.
374 qpart lt x [] rlt rge r =
375 -- rlt and rge are in reverse order and must be sorted with an
376 -- anti-stable sorting
377 rqsort lt rlt (x : rqsort lt rge r)
379 qpart lt x (y:ys) rlt rge r =
382 qpart lt x ys (y:rlt) rge r
385 qpart lt x ys rlt (y:rge) r
387 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
389 rqsort lt [x] r = x:r
390 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
392 rqpart lt x [] rle rgt r =
393 qsort lt rle (x : qsort lt rgt r)
395 rqpart lt x (y:ys) rle rgt r =
398 rqpart lt x ys rle (y:rgt) r
401 rqpart lt x ys (y:rle) rgt r
404 %************************************************************************
406 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
408 %************************************************************************
412 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
414 mergesort cmp xs = merge_lists (split_into_runs [] xs)
416 a `le` b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
417 a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True }
419 split_into_runs [] [] = []
420 split_into_runs run [] = [run]
421 split_into_runs [] (x:xs) = split_into_runs [x] xs
422 split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
423 split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
424 | True = rl : (split_into_runs [x] xs)
427 merge_lists (x:xs) = merge x (merge_lists xs)
431 merge xl@(x:xs) yl@(y:ys)
433 EQ -> x : y : (merge xs ys)
434 LT -> x : (merge xs yl)
435 GT -> y : (merge xl ys)
439 %************************************************************************
441 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
443 %************************************************************************
446 Date: Mon, 3 May 93 20:45:23 +0200
447 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
448 To: partain@dcs.gla.ac.uk
449 Subject: natural merge sort beats quick sort [ and it is prettier ]
451 Here is a piece of Haskell code that I'm rather fond of. See it as an
452 attempt to get rid of the ridiculous quick-sort routine. group is
453 quite useful by itself I think it was John's idea originally though I
454 believe the lazy version is due to me [surprisingly complicated].
455 gamma [used to be called] is called gamma because I got inspired by
456 the Gamma calculus. It is not very close to the calculus but does
457 behave less sequentially than both foldr and foldl. One could imagine
458 a version of gamma that took a unit element as well thereby avoiding
459 the problem with empty lists.
461 I've tried this code against
463 1) insertion sort - as provided by haskell
464 2) the normal implementation of quick sort
465 3) a deforested version of quick sort due to Jan Sparud
466 4) a super-optimized-quick-sort of Lennart's
468 If the list is partially sorted both merge sort and in particular
469 natural merge sort wins. If the list is random [ average length of
470 rising subsequences = approx 2 ] mergesort still wins and natural
471 merge sort is marginally beaten by Lennart's soqs. The space
472 consumption of merge sort is a bit worse than Lennart's quick sort
473 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
474 fpca article ] isn't used because of group.
481 group :: (a -> a -> Bool) -> [a] -> [[a]]
484 Date: Mon, 12 Feb 1996 15:09:41 +0000
485 From: Andy Gill <andy@dcs.gla.ac.uk>
487 Here is a `better' definition of group.
490 group p (x:xs) = group' xs x x (x :)
492 group' [] _ _ s = [s []]
493 group' (x:xs) x_min x_max s
494 | not (x `p` x_max) = group' xs x_min x (s . (x :))
495 | x `p` x_min = group' xs x x_max ((x :) . s)
496 | otherwise = s [] : group' xs x x (x :)
498 -- This one works forwards *and* backwards, as well as also being
499 -- faster that the one in Util.lhs.
504 let ((h1:t1):tt1) = group p xs
505 (t,tt) = if null xs then ([],[]) else
506 if x `p` h1 then (h1:t1,tt1) else
511 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
512 generalMerge p xs [] = xs
513 generalMerge p [] ys = ys
514 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
515 | otherwise = y : generalMerge p (x:xs) ys
517 -- gamma is now called balancedFold
519 balancedFold :: (a -> a -> a) -> [a] -> a
520 balancedFold f [] = error "can't reduce an empty list using balancedFold"
521 balancedFold f [x] = x
522 balancedFold f l = balancedFold f (balancedFold' f l)
524 balancedFold' :: (a -> a -> a) -> [a] -> [a]
525 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
526 balancedFold' f xs = xs
528 generalMergeSort p [] = []
529 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
531 generalNaturalMergeSort p [] = []
532 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
535 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
537 mergeSort = generalMergeSort (<=)
538 naturalMergeSort = generalNaturalMergeSort (<=)
540 mergeSortLe le = generalMergeSort le
543 naturalMergeSortLe le = generalNaturalMergeSort le
546 %************************************************************************
548 \subsection[Utils-transitive-closure]{Transitive closure}
550 %************************************************************************
552 This algorithm for transitive closure is straightforward, albeit quadratic.
555 transitiveClosure :: (a -> [a]) -- Successor function
556 -> (a -> a -> Bool) -- Equality predicate
558 -> [a] -- The transitive closure
560 transitiveClosure succ eq xs
564 go done (x:xs) | x `is_in` done = go done xs
565 | otherwise = go (x:done) (succ x ++ xs)
568 x `is_in` (y:ys) | eq x y = True
569 | otherwise = x `is_in` ys
572 %************************************************************************
574 \subsection[Utils-accum]{Accumulating}
576 %************************************************************************
578 @mapAccumL@ behaves like a combination
579 of @map@ and @foldl@;
580 it applies a function to each element of a list, passing an accumulating
581 parameter from left to right, and returning a final value of this
582 accumulator together with the new list.
585 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
586 -- and accumulator, returning new
587 -- accumulator and elt of result list
588 -> acc -- Initial accumulator
590 -> (acc, [y]) -- Final accumulator and result list
592 mapAccumL f b [] = (b, [])
593 mapAccumL f b (x:xs) = (b'', x':xs') where
595 (b'', xs') = mapAccumL f b' xs
598 @mapAccumR@ does the same, but working from right to left instead. Its type is
599 the same as @mapAccumL@, though.
602 mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
603 -- and accumulator, returning new
604 -- accumulator and elt of result list
605 -> acc -- Initial accumulator
607 -> (acc, [y]) -- Final accumulator and result list
609 mapAccumR f b [] = (b, [])
610 mapAccumR f b (x:xs) = (b'', x':xs') where
612 (b', xs') = mapAccumR f b xs
615 Here is the bi-directional version, that works from both left and right.
618 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
619 -- Function of elt of input list
620 -- and accumulator, returning new
621 -- accumulator and elt of result list
622 -> accl -- Initial accumulator from left
623 -> accr -- Initial accumulator from right
625 -> (accl, accr, [y]) -- Final accumulators and result list
627 mapAccumB f a b [] = (a,b,[])
628 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
630 (a',b'',y) = f a b' x
631 (a'',b',ys) = mapAccumB f a' b xs
634 A strict version of foldl.
637 foldl' :: (a -> b -> a) -> a -> [b] -> a
638 foldl' f z xs = lgo z xs
641 lgo z (x:xs) = (lgo $! (f z x)) xs
644 A combination of foldl with zip. It works with equal length lists.
647 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
649 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
652 Count the number of times a predicate is true
655 count :: (a -> Bool) -> [a] -> Int
657 count p (x:xs) | p x = 1 + count p xs
658 | otherwise = count p xs
661 @splitAt@, @take@, and @drop@ but with length of another
662 list giving the break-off point:
665 takeList :: [b] -> [a] -> [a]
670 (y:ys) -> y : takeList xs ys
672 dropList :: [b] -> [a] -> [a]
674 dropList _ xs@[] = xs
675 dropList (_:xs) (_:ys) = dropList xs ys
678 splitAtList :: [b] -> [a] -> ([a], [a])
679 splitAtList [] xs = ([], xs)
680 splitAtList _ xs@[] = (xs, xs)
681 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
683 (ys', ys'') = splitAtList xs ys
688 %************************************************************************
690 \subsection[Utils-comparison]{Comparisons}
692 %************************************************************************
695 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
696 eqListBy eq [] [] = True
697 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
698 eqListBy eq xs ys = False
700 equalLength :: [a] -> [b] -> Bool
701 equalLength [] [] = True
702 equalLength (_:xs) (_:ys) = equalLength xs ys
703 equalLength xs ys = False
705 compareLength :: [a] -> [b] -> Ordering
706 compareLength [] [] = EQ
707 compareLength (_:xs) (_:ys) = compareLength xs ys
708 compareLength [] _ys = LT
709 compareLength _xs [] = GT
711 thenCmp :: Ordering -> Ordering -> Ordering
712 {-# INLINE thenCmp #-}
714 thenCmp other any = other
716 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
717 -- `cmpList' uses a user-specified comparer
719 cmpList cmp [] [] = EQ
720 cmpList cmp [] _ = LT
721 cmpList cmp _ [] = GT
722 cmpList cmp (a:as) (b:bs)
723 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
727 prefixMatch :: Eq a => [a] -> [a] -> Bool
728 prefixMatch [] _str = True
729 prefixMatch _pat [] = False
730 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
733 suffixMatch :: Eq a => [a] -> [a] -> Bool
734 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
737 %************************************************************************
739 \subsection[Utils-pairs]{Pairs}
741 %************************************************************************
743 The following are curried versions of @fst@ and @snd@.
747 cfst :: a -> b -> a -- stranal-sem only (Note)
752 The following provide us higher order functions that, when applied
753 to a function, operate on pairs.
757 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
758 applyToPair (f,g) (x,y) = (f x, g y)
760 applyToFst :: (a -> c) -> (a,b)-> (c,b)
761 applyToFst f (x,y) = (f x,y)
763 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
764 applyToSnd f (x,y) = (x,f y)
767 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
768 foldPair fg ab [] = ab
769 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
770 where (u,v) = foldPair fg ab abs
774 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
775 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
779 seqList :: [a] -> b -> b
781 seqList (x:xs) b = x `seq` seqList xs b
787 global :: a -> IORef a
788 global a = unsafePerformIO (newIORef a)
794 looksLikeModuleName [] = False
795 looksLikeModuleName (c:cs) = isUpper c && go cs
797 go ('.':cs) = looksLikeModuleName cs
798 go (c:cs) = (isAlphaNum c || c == '_') && go cs