Util.lhs 22 KB
 partain committed Jan 08, 1996 1 %  simonmar committed Aug 29, 2002 2 % (c) The University of Glasgow 1992-2002  partain committed Jan 08, 1996 3 4 5 6 7 % \section[Util]{Highly random utility functions} \begin{code} module Util (  sof committed May 18, 1997 8   partain committed Jan 08, 1996 9  -- general list processing  partain committed Mar 19, 1996 10  zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,  simonpj committed Mar 23, 2000 11  zipLazy, stretchZipWith,  partain committed May 17, 1996 12  mapAndUnzip, mapAndUnzip3,  sof committed Oct 25, 2001 13 14 15  nOfThem, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, isSingleton, only,  simonpj committed Nov 11, 2002 16  notNull, snocView,  sof committed Apr 05, 2002 17   partain committed Jan 08, 1996 18 19  isIn, isn'tIn,  simonpj committed Mar 23, 2000 20 21 22  -- for-loop nTimes,  partain committed Jan 08, 1996 23  -- sorting  simonmar committed Aug 29, 2002 24  sortLt, naturalMergeSortLe,  partain committed Jan 08, 1996 25 26 27 28 29  -- transitive closures transitiveClosure, -- accumulating  simonmar committed Mar 01, 2001 30 31  mapAccumL, mapAccumR, mapAccumB, foldl2, count,  sof committed Oct 25, 2001 32 33  takeList, dropList, splitAtList,  partain committed Jan 08, 1996 34 35  -- comparisons  sof committed Oct 25, 2001 36 37  eqListBy, equalLength, compareLength, thenCmp, cmpList, prefixMatch, suffixMatch,  partain committed May 17, 1996 38   simonm committed Mar 04, 1999 39  -- strictness  simonmar committed Mar 01, 2001 40  foldl', seqList,  simonm committed Mar 04, 1999 41   partain committed Jan 08, 1996 42  -- pairs  simonmar committed Aug 29, 2002 43  unzipWith,  simonmar committed Jun 03, 1999 44   simonmar committed Aug 29, 2002 45  global,  simonmar committed Oct 15, 2002 46 47 48  -- module names looksLikeModuleName,  sof committed Feb 13, 2003 49 50  toArgs  partain committed Jan 08, 1996 51 52  ) where  rrt committed Dec 08, 2000 53 #include "../includes/config.h"  simonm committed Jan 08, 1998 54 55 #include "HsVersions.h"  simonpj committed Jan 04, 2002 56 import Panic ( panic, trace )  simonmar committed Oct 12, 2000 57 import FastTypes  simonmar committed Aug 29, 2002 58   simonmar committed Oct 27, 2000 59 #if __GLASGOW_HASKELL__ <= 408  simonmar committed Aug 29, 2002 60 61 62 63 64 65 66 67 68 import EXCEPTION ( catchIO, justIoErrors, raiseInThread ) #endif import DATA_IOREF ( IORef, newIORef ) import UNSAFE_IO ( unsafePerformIO ) import qualified List ( elem, notElem ) #ifndef DEBUG import List ( zipWith4 )  sewardj committed Oct 27, 2000 69 #endif  sof committed May 28, 2001 70   sof committed Feb 13, 2003 71 import Char ( isUpper, isAlphaNum, isSpace )  simonmar committed Oct 15, 2002 72   partain committed May 16, 1996 73 infixr 9 thenCmp  partain committed Jan 08, 1996 74 75 \end{code}  sof committed May 18, 1997 76 77 78 79 80 81 82 83 84 85 86 %************************************************************************ %* * \subsection{The Eager monad} %* * %************************************************************************ The @Eager@ monad is just an encoding of continuation-passing style, used to allow you to express "do this and then that", mainly to avoid space leaks. It's done with a type synonym to save bureaucracy. \begin{code}  simonmar committed Jun 03, 1999 87 88 #if NOT_USED  sof committed May 18, 1997 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 type Eager ans a = (a -> ans) -> ans runEager :: Eager a a -> a runEager m = m (\x -> x) appEager :: Eager ans a -> (a -> ans) -> ans appEager m cont = m cont thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b thenEager m k cont = m (\r -> k r cont) returnEager :: a -> Eager ans a returnEager v cont = cont v mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b] mapEager f [] = returnEager [] mapEager f (x:xs) = f x thenEager \ y -> mapEager f xs thenEager \ ys -> returnEager (y:ys)  simonmar committed Jun 03, 1999 108 #endif  sof committed May 18, 1997 109 110 \end{code}  simonpj committed Mar 23, 2000 111 112 113 114 115 116 117 118 119 120 121 122 123 124 %************************************************************************ %* * \subsection{A for loop} %* * %************************************************************************ \begin{code} -- Compose a function with itself n times. (nth rather than twice) nTimes :: Int -> (a -> a) -> (a -> a) nTimes 0 _ = id nTimes 1 f = f nTimes n f = f . nTimes (n-1) f \end{code}  partain committed Jan 08, 1996 125 126 127 128 129 130 %************************************************************************ %* * \subsection[Utils-lists]{General list processing} %* * %************************************************************************  partain committed Mar 19, 1996 131 132 133 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not?  partain committed Jan 08, 1996 134 135  \begin{code}  partain committed May 16, 1996 136 137 138 139 zipEqual :: String -> [a] -> [b] -> [(a,b)] zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]  partain committed Jan 08, 1996 140 141  #ifndef DEBUG  partain committed May 16, 1996 142 143 144 145 zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = zipWith4  partain committed Jan 08, 1996 146 #else  partain committed May 16, 1996 147 148 zipEqual msg [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs  simonpj committed May 18, 1999 149 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)  partain committed May 16, 1996 150 151 152  zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs zipWithEqual msg _ [] [] = []  simonpj committed May 18, 1999 153 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)  partain committed May 16, 1996 154 155 156 157  zipWith3Equal msg z (a:as) (b:bs) (c:cs) = z a b c : zipWith3Equal msg z as bs cs zipWith3Equal msg _ [] [] [] = []  simonpj committed May 18, 1999 158 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)  partain committed May 16, 1996 159 160 161 162  zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal msg _ [] [] [] [] = []  simonpj committed May 18, 1999 163 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)  partain committed Jan 08, 1996 164 165 166 #endif \end{code}  partain committed Mar 19, 1996 167 168 169 170 171 172 173 174 \begin{code} -- zipLazy is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] ys = [] zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys \end{code}  simonm committed Dec 02, 1998 175 176  \begin{code}  simonpj committed Mar 23, 2000 177 178 179 180 181 182 183 184 185 186 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- (stretchZipWith p z f xs ys) stretches ys by inserting z in -- the places where p returns *True* stretchZipWith p z f [] ys = [] stretchZipWith p z f (x:xs) ys | p x = f x z : stretchZipWith p z f xs ys | otherwise = case ys of [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys  simonm committed Dec 02, 1998 187 188 189 \end{code}  partain committed Apr 30, 1996 190 191 192 193 194 195 196 197 198 199 \begin{code} mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip f [] = ([],[]) mapAndUnzip f (x:xs) = let (r1, r2) = f x (rs1, rs2) = mapAndUnzip f xs in (r1:rs1, r2:rs2)  partain committed May 17, 1996 200 201 202 203 204 205 206 207 208 209  mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 f [] = ([],[],[]) mapAndUnzip3 f (x:xs) = let (r1, r2, r3) = f x (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3)  partain committed Apr 30, 1996 210 211 \end{code}  partain committed Jan 08, 1996 212 213 \begin{code} nOfThem :: Int -> a -> [a]  sof committed Mar 01, 1999 214 nOfThem n thing = replicate n thing  partain committed Jan 08, 1996 215   sof committed Oct 25, 2001 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n'; -- specification: -- -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred n -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) -- atLength :: ([a] -> b) -> (Int -> b) -> [a] -> Int -> b atLength atLenPred atEndPred ls n | n < 0 = atEndPred n | otherwise = go n ls where go n [] = atEndPred n go 0 ls = atLenPred ls go n (_:xs) = go (n-1) xs -- special cases.  partain committed Jan 08, 1996 238 lengthExceeds :: [a] -> Int -> Bool  simonpj committed Mar 25, 2002 239 -- (lengthExceeds xs n) = (length xs > n)  sof committed Apr 05, 2002 240 lengthExceeds = atLength notNull (const False)  sof committed Oct 25, 2001 241 242  lengthAtLeast :: [a] -> Int -> Bool  sof committed Apr 05, 2002 243 lengthAtLeast = atLength notNull (== 0)  sof committed Oct 25, 2001 244 245 246 247 248 249 250 251 252 253 254 255 256 257  lengthIs :: [a] -> Int -> Bool lengthIs = atLength null (==0) listLengthCmp :: [a] -> Int -> Ordering listLengthCmp = atLength atLen atEnd where atEnd 0 = EQ atEnd x | x > 0 = LT -- not yet seen 'n' elts, so list length is < n. | otherwise = GT atLen [] = EQ atLen _ = GT  partain committed Jan 08, 1996 258 259 260 261  isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False  simonm committed Apr 27, 1999 262   sof committed Apr 05, 2002 263 264 265 266 notNull :: [a] -> Bool notNull [] = False notNull _ = True  simonpj committed Nov 11, 2002 267 268 269 270 271 272 273 274 275 snocView :: [a] -> Maybe ([a],a) -- Split off the last element snocView [] = Nothing snocView xs = go [] xs where -- Invariant: second arg is non-empty go acc [x] = Just (reverse acc, x) go acc (x:xs) = go (x:acc) xs  simonm committed Apr 27, 1999 276 277 278 279 280 281 only :: [a] -> a #ifdef DEBUG only [a] = a #else only (a:_) = a #endif  partain committed Jan 08, 1996 282 283 284 \end{code} Debugging/specialising versions of \tr{elem} and \tr{notElem}  simonm committed Jan 08, 1998 285   partain committed Jan 08, 1996 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 \begin{code} isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool # ifndef DEBUG isIn msg x ys = elem__ x ys isn'tIn msg x ys = notElem__ x ys --these are here to be SPECIALIZEd (automagically) elem__ _ [] = False elem__ x (y:ys) = x==y || elem__ x ys notElem__ x [] = True notElem__ x (y:ys) = x /= y && notElem__ x ys # else {- DEBUG -} isIn msg x ys  simonmar committed Oct 12, 2000 302  = elem (_ILIT 0) x ys  partain committed Jan 08, 1996 303 304 305  where elem i _ [] = False elem i x (y:ys)  simonpj committed Jan 04, 2002 306 307 308  | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $x List.elem (y:ys) | otherwise = x == y || elem (i +# _ILIT(1)) x ys  partain committed Jan 08, 1996 309 310  isn'tIn msg x ys  simonmar committed Oct 12, 2000 311  = notElem (_ILIT 0) x ys  partain committed Jan 08, 1996 312 313 314  where notElem i x [] = True notElem i x (y:ys)  simonpj committed Jan 04, 2002 315 316 317  | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg)$ x List.notElem (y:ys) | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys  partain committed Jan 08, 1996 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 # endif {- DEBUG -} \end{code} %************************************************************************ %* * \subsection[Utils-sorting]{Sorting} %* * %************************************************************************ %************************************************************************ %* * \subsubsection[Utils-quicksorting]{Quicksorts} %* * %************************************************************************ \begin{code}  simonmar committed Jun 03, 1999 334 335 #if NOT_USED  partain committed Jan 08, 1996 336 337 338 339 340 341 342 343 344 345 346 347 -- tail-recursive, etc., "quicker sort" [as per Meira thesis] quicksort :: (a -> a -> Bool) -- Less-than predicate -> [a] -- Input list -> [a] -- Result list in increasing order quicksort lt [] = [] quicksort lt [x] = [x] quicksort lt (x:xs) = split x [] [] xs where split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi) split x lo hi (y:ys) | y lt x = split x (y:lo) hi ys | True = split x lo (y:hi) ys  simonmar committed Jun 03, 1999 348 #endif  partain committed Jan 08, 1996 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 \end{code} Quicksort variant from Lennart's Haskell-library contribution. This is a {\em stable} sort. \begin{code} sortLt :: (a -> a -> Bool) -- Less-than predicate -> [a] -- Input list -> [a] -- Result list sortLt lt l = qsort lt l [] -- qsort is stable and does not concatenate. qsort :: (a -> a -> Bool) -- Less-than predicate -> [a] -- xs, Input list -> [a] -- r, Concatenate this list to the sorted input list -> [a] -- Result = sort xs ++ r qsort lt [] r = r qsort lt [x] r = x:r qsort lt (x:xs) r = qpart lt x xs [] [] r -- qpart partitions and sorts the sublists  partain committed Mar 19, 1996 372 -- rlt contains things less than x,  partain committed Jan 08, 1996 373 374 375 376 377 378 379 380 381 382 383 384 -- rge contains the ones greater than or equal to x. -- Both have equal elements reversed with respect to the original list. qpart lt x [] rlt rge r = -- rlt and rge are in reverse order and must be sorted with an -- anti-stable sorting rqsort lt rlt (x : rqsort lt rge r) qpart lt x (y:ys) rlt rge r = if lt y x then -- y < x qpart lt x ys (y:rlt) rge r  partain committed Mar 19, 1996 385  else  partain committed Jan 08, 1996 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412  -- y >= x qpart lt x ys rlt (y:rge) r -- rqsort is as qsort but anti-stable, i.e. reverses equal elements rqsort lt [] r = r rqsort lt [x] r = x:r rqsort lt (x:xs) r = rqpart lt x xs [] [] r rqpart lt x [] rle rgt r = qsort lt rle (x : qsort lt rgt r) rqpart lt x (y:ys) rle rgt r = if lt x y then -- y > x rqpart lt x ys rle (y:rgt) r else -- y <= x rqpart lt x ys (y:rle) rgt r \end{code} %************************************************************************ %* * \subsubsection[Utils-dull-mergesort]{A rather dull mergesort} %* * %************************************************************************ \begin{code}  simonmar committed Jun 03, 1999 413 #if NOT_USED  simonm committed Jan 08, 1998 414 mergesort :: (a -> a -> Ordering) -> [a] -> [a]  partain committed Jan 08, 1996 415 416 417  mergesort cmp xs = merge_lists (split_into_runs [] xs) where  simonm committed Jan 08, 1998 418 419  a le b = case cmp a b of { LT -> True; EQ -> True; GT -> False } a ge b = case cmp a b of { LT -> False; EQ -> True; GT -> True }  partain committed Jan 08, 1996 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434  split_into_runs [] [] = [] split_into_runs run [] = [run] split_into_runs [] (x:xs) = split_into_runs [x] xs split_into_runs [r] (x:xs) | x ge r = split_into_runs [r,x] xs split_into_runs rl@(r:rs) (x:xs) | x le r = split_into_runs (x:rl) xs | True = rl : (split_into_runs [x] xs) merge_lists [] = [] merge_lists (x:xs) = merge x (merge_lists xs) merge [] ys = ys merge xs [] = xs merge xl@(x:xs) yl@(y:ys) = case cmp x y of  simonm committed Jan 08, 1998 435 436 437  EQ -> x : y : (merge xs ys) LT -> x : (merge xs yl) GT -> y : (merge xl ys)  simonmar committed Jun 03, 1999 438 #endif  partain committed Jan 08, 1996 439 440 441 442 443 444 445 446 447 448 449 450 451 452 \end{code} %************************************************************************ %* * \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} %* * %************************************************************************ \begin{display} Date: Mon, 3 May 93 20:45:23 +0200 From: Carsten Kehler Holst To: partain@dcs.gla.ac.uk Subject: natural merge sort beats quick sort [ and it is prettier ]  partain committed Mar 19, 1996 453 Here is a piece of Haskell code that I'm rather fond of. See it as an  partain committed Jan 11, 1996 454 455 attempt to get rid of the ridiculous quick-sort routine. group is quite useful by itself I think it was John's idea originally though I  partain committed Jan 08, 1996 456 believe the lazy version is due to me [surprisingly complicated].  partain committed Jan 11, 1996 457 458 gamma [used to be called] is called gamma because I got inspired by the Gamma calculus. It is not very close to the calculus but does  partain committed Mar 19, 1996 459 460 461 behave less sequentially than both foldr and foldl. One could imagine a version of gamma that took a unit element as well thereby avoiding the problem with empty lists.  partain committed Jan 08, 1996 462 463 464 465 466 467  I've tried this code against 1) insertion sort - as provided by haskell 2) the normal implementation of quick sort 3) a deforested version of quick sort due to Jan Sparud  partain committed Jan 22, 1996 468  4) a super-optimized-quick-sort of Lennart's  partain committed Jan 08, 1996 469 470 471 472  If the list is partially sorted both merge sort and in particular natural merge sort wins. If the list is random [ average length of rising subsequences = approx 2 ] mergesort still wins and natural  partain committed Jan 22, 1996 473 merge sort is marginally beaten by Lennart's soqs. The space  partain committed Jan 11, 1996 474 consumption of merge sort is a bit worse than Lennart's quick sort  partain committed Jan 08, 1996 475 476 477 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his fpca article ] isn't used because of group.  partain committed Mar 19, 1996 478 have fun  partain committed Jan 08, 1996 479 480 481 482 483 Carsten \end{display} \begin{code} group :: (a -> a -> Bool) -> [a] -> [[a]]  partain committed Jan 11, 1996 484   partain committed Mar 19, 1996 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 {- Date: Mon, 12 Feb 1996 15:09:41 +0000 From: Andy Gill Here is a better' definition of group. -} group p [] = [] group p (x:xs) = group' xs x x (x :) where group' [] _ _ s = [s []] group' (x:xs) x_min x_max s | not (x p x_max) = group' xs x_min x (s . (x :)) | x p x_min = group' xs x x_max ((x :) . s) | otherwise = s [] : group' xs x x (x :) -- This one works forwards *and* backwards, as well as also being -- faster that the one in Util.lhs. {- ORIG:  partain committed Jan 08, 1996 504 group p [] = [[]]  partain committed Mar 19, 1996 505 group p (x:xs) =  partain committed Jan 08, 1996 506 507  let ((h1:t1):tt1) = group p xs (t,tt) = if null xs then ([],[]) else  partain committed Mar 19, 1996 508 509  if x p h1 then (h1:t1,tt1) else ([], (h1:t1):tt1)  partain committed Jan 08, 1996 510  in ((x:t):tt)  partain committed Mar 19, 1996 511 -}  partain committed Jan 08, 1996 512 513 514 515  generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] generalMerge p xs [] = xs generalMerge p [] ys = ys  partain committed Jan 11, 1996 516 generalMerge p (x:xs) (y:ys) | x p y = x : generalMerge p xs (y:ys)  partain committed Mar 19, 1996 517  | otherwise = y : generalMerge p (x:xs) ys  partain committed Jan 08, 1996 518 519 520 521 522 523 524 525 526 527 528 529  -- gamma is now called balancedFold balancedFold :: (a -> a -> a) -> [a] -> a balancedFold f [] = error "can't reduce an empty list using balancedFold" balancedFold f [x] = x balancedFold f l = balancedFold f (balancedFold' f l) balancedFold' :: (a -> a -> a) -> [a] -> [a] balancedFold' f (x:y:xs) = f x y : balancedFold' f xs balancedFold' f xs = xs  partain committed Jan 11, 1996 530 531 532 533 534 generalMergeSort p [] = [] generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs generalNaturalMergeSort p [] = [] generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs  partain committed Jan 08, 1996 535   simonmar committed Aug 29, 2002 536 #if NOT_USED  partain committed Jan 08, 1996 537 538 539 540 541 542 mergeSort, naturalMergeSort :: Ord a => [a] -> [a] mergeSort = generalMergeSort (<=) naturalMergeSort = generalNaturalMergeSort (<=) mergeSortLe le = generalMergeSort le  simonmar committed Aug 29, 2002 543 544 #endif  partain committed Jan 08, 1996 545 546 547 548 549 550 551 552 553 554 555 556 557 558 naturalMergeSortLe le = generalNaturalMergeSort le \end{code} %************************************************************************ %* * \subsection[Utils-transitive-closure]{Transitive closure} %* * %************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. \begin{code} transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate  partain committed Mar 19, 1996 559  -> [a]  partain committed Jan 08, 1996 560 561 562  -> [a] -- The transitive closure transitiveClosure succ eq xs  partain committed Jun 05, 1996 563  = go [] xs  partain committed Jan 08, 1996 564  where  partain committed Jun 05, 1996 565 566 567  go done [] = done go done (x:xs) | x is_in done = go done xs | otherwise = go (x:done) (succ x ++ xs)  partain committed Jan 08, 1996 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623  x is_in [] = False x is_in (y:ys) | eq x y = True | otherwise = x is_in ys \end{code} %************************************************************************ %* * \subsection[Utils-accum]{Accumulating} %* * %************************************************************************ @mapAccumL@ behaves like a combination of @map@ and @foldl@; it applies a function to each element of a list, passing an accumulating parameter from left to right, and returning a final value of this accumulator together with the new list. \begin{code} mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list -- and accumulator, returning new -- accumulator and elt of result list -> acc -- Initial accumulator -> [x] -- Input list -> (acc, [y]) -- Final accumulator and result list mapAccumL f b [] = (b, []) mapAccumL f b (x:xs) = (b'', x':xs') where (b', x') = f b x (b'', xs') = mapAccumL f b' xs \end{code} @mapAccumR@ does the same, but working from right to left instead. Its type is the same as @mapAccumL@, though. \begin{code} mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list -- and accumulator, returning new -- accumulator and elt of result list -> acc -- Initial accumulator -> [x] -- Input list -> (acc, [y]) -- Final accumulator and result list mapAccumR f b [] = (b, []) mapAccumR f b (x:xs) = (b'', x':xs') where (b'', x') = f b' x (b', xs') = mapAccumR f b xs \end{code} Here is the bi-directional version, that works from both left and right. \begin{code} mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) -- Function of elt of input list -- and accumulator, returning new -- accumulator and elt of result list  partain committed Mar 19, 1996 624 625 626 627  -> accl -- Initial accumulator from left -> accr -- Initial accumulator from right -> [x] -- Input list -> (accl, accr, [y]) -- Final accumulators and result list  partain committed Jan 08, 1996 628 629 630 631 632 633 634 635  mapAccumB f a b [] = (a,b,[]) mapAccumB f a b (x:xs) = (a'',b'',y:ys) where (a',b'',y) = f a b' x (a'',b',ys) = mapAccumB f a' b xs \end{code}  simonmar committed Mar 01, 2001 636 637 638 639 640 641 642 643 644 645 A strict version of foldl. \begin{code} foldl' :: (a -> b -> a) -> a -> [b] -> a foldl' f z xs = lgo z xs where lgo z [] = z lgo z (x:xs) = (lgo $! (f z x)) xs \end{code}  simonpj committed May 18, 1999 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 A combination of foldl with zip. It works with equal length lists. \begin{code} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 k z [] [] = z foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs \end{code} Count the number of times a predicate is true \begin{code} count :: (a -> Bool) -> [a] -> Int count p [] = 0 count p (x:xs) | p x = 1 + count p xs | otherwise = count p xs \end{code}  sof committed Oct 25, 2001 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: \begin{code} takeList :: [b] -> [a] -> [a] takeList [] _ = [] takeList (_:xs) ls = case ls of [] -> [] (y:ys) -> y : takeList xs ys dropList :: [b] -> [a] -> [a] dropList [] xs = xs dropList _ xs@[] = xs dropList (_:xs) (_:ys) = dropList xs ys splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList [] xs = ([], xs) splitAtList _ xs@[] = (xs, xs) splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys \end{code}  simonpj committed May 18, 1999 689   partain committed Jan 08, 1996 690 691 692 693 694 695 %************************************************************************ %* * \subsection[Utils-comparison]{Comparisons} %* * %************************************************************************  partain committed Mar 19, 1996 696 \begin{code}  simonpj committed Jul 19, 2001 697 698 699 700 701 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool eqListBy eq [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys eqListBy eq xs ys = False  sof committed Oct 25, 2001 702 703 704 705 706 707 708 709 710 711 712 equalLength :: [a] -> [b] -> Bool equalLength [] [] = True equalLength (_:xs) (_:ys) = equalLength xs ys equalLength xs ys = False compareLength :: [a] -> [b] -> Ordering compareLength [] [] = EQ compareLength (_:xs) (_:ys) = compareLength xs ys compareLength [] _ys = LT compareLength _xs [] = GT  simonm committed Jan 08, 1998 713 thenCmp :: Ordering -> Ordering -> Ordering  partain committed Mar 19, 1996 714 {-# INLINE thenCmp #-}  simonm committed Jan 08, 1998 715 thenCmp EQ any = any  partain committed Mar 19, 1996 716 717 thenCmp other any = other  simonm committed Jan 08, 1998 718 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering  partain committed Mar 19, 1996 719 720  -- cmpList' uses a user-specified comparer  simonm committed Jan 08, 1998 721 722 723 cmpList cmp [] [] = EQ cmpList cmp [] _ = LT cmpList cmp _ [] = GT  partain committed Mar 19, 1996 724 cmpList cmp (a:as) (b:bs)  simonm committed Jan 08, 1998 725  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }  partain committed Mar 19, 1996 726 727 \end{code}  partain committed Jan 08, 1996 728 \begin{code}  simonmar committed Oct 11, 2000 729 730 731 732 733 734 prefixMatch :: Eq a => [a] -> [a] -> Bool prefixMatch [] _str = True prefixMatch _pat [] = False prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss | otherwise = False  sewardj committed Dec 05, 2000 735 736 suffixMatch :: Eq a => [a] -> [a] -> Bool suffixMatch pat str = prefixMatch (reverse pat) (reverse str)  partain committed Jan 08, 1996 737 738 739 740 741 742 743 744 745 746 747 \end{code} %************************************************************************ %* * \subsection[Utils-pairs]{Pairs} %* * %************************************************************************ The following are curried versions of @fst@ and @snd@. \begin{code}  simonmar committed Aug 29, 2002 748 #if NOT_USED  partain committed Jan 08, 1996 749 750 cfst :: a -> b -> a -- stranal-sem only (Note) cfst x y = x  simonmar committed Aug 29, 2002 751 #endif  partain committed Jan 08, 1996 752 753 754 755 756 757 \end{code} The following provide us higher order functions that, when applied to a function, operate on pairs. \begin{code}  simonmar committed Aug 29, 2002 758 #if NOT_USED  partain committed Jan 08, 1996 759 760 761 762 763 764 765 766 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d) applyToPair (f,g) (x,y) = (f x, g y) applyToFst :: (a -> c) -> (a,b)-> (c,b) applyToFst f (x,y) = (f x,y) applyToSnd :: (b -> d) -> (a,b) -> (a,d) applyToSnd f (x,y) = (x,f y)  simonmar committed Aug 29, 2002 767 #endif  partain committed Jan 08, 1996 768 769 770 771  foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) foldPair fg ab [] = ab foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)  partain committed Mar 19, 1996 772  where (u,v) = foldPair fg ab abs  partain committed Jan 08, 1996 773 774 775 776 777 778 779 \end{code} \begin{code} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs \end{code}  simonm committed Mar 04, 1999 780 781 782 783 \begin{code} seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x seq seqList xs b  simonmar committed Jun 01, 1999 784 \end{code}  simonmar committed Oct 11, 2000 785 786 787 788 789 790 791  Global variables: \begin{code} global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code}  simonmar committed Oct 15, 2002 792 793 794 795 796  Module names: \begin{code} looksLikeModuleName [] = False  simonmar committed Jan 09, 2003 797 798 799 800 looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True go ('.':cs) = looksLikeModuleName cs go (c:cs) = (isAlphaNum c || c == '_') && go cs  simonmar committed Oct 15, 2002 801 \end{code}  sof committed Feb 13, 2003 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826  Akin to @Prelude.words@, but sensitive to dquoted entities treating them as single words. \begin{code} toArgs :: String -> [String] toArgs "" = [] toArgs s = case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- " (w,aft) -> (\ ws -> if null w then ws else w : ws)$ case aft of [] -> [] (x:xs) | x /= '"' -> toArgs xs | otherwise -> case lex aft of ((str,rs):_) -> stripQuotes str : toArgs rs _ -> [aft] where -- strip away dquotes; assume first and last chars contain quotes. stripQuotes :: String -> String stripQuotes ('"':xs) = init xs stripQuotes xs = xs \end{code}