Data/List.hs

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  Data.List
   5 -- Copyright   :  (c) The University of Glasgow 2001
   6 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  provisional
  10 -- Portability :  portable
  11 --
  12 -- Operations on lists.
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module Data.List
  17    (
  18 #ifdef __NHC__
  19      [] (..)
  20    ,
  21 #endif
  22      elemIndex         -- :: (Eq a) => a -> [a] -> Maybe Int
  23    , elemIndices       -- :: (Eq a) => a -> [a] -> [Int]
  24
  25    , find              -- :: (a -> Bool) -> [a] -> Maybe a
  26    , findIndex         -- :: (a -> Bool) -> [a] -> Maybe Int
  27    , findIndices       -- :: (a -> Bool) -> [a] -> [Int]
  28
  29    , nub               -- :: (Eq a) => [a] -> [a]
  30    , nubBy             -- :: (a -> a -> Bool) -> [a] -> [a]
  31
  32    , delete            -- :: (Eq a) => a -> [a] -> [a]
  33    , deleteBy          -- :: (a -> a -> Bool) -> a -> [a] -> [a]
  34    , (\\)              -- :: (Eq a) => [a] -> [a] -> [a]
  35    , deleteFirstsBy    -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
  36
  37    , union             -- :: (Eq a) => [a] -> [a] -> [a]
  38    , unionBy           -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
  39
  40    , intersect         -- :: (Eq a) => [a] -> [a] -> [a]
  41    , intersectBy       -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
  42
  43    , intersperse       -- :: a -> [a] -> [a]
  44    , transpose         -- :: [[a]] -> [[a]]
  45    , partition         -- :: (a -> Bool) -> [a] -> ([a], [a])
  46
  47    , group             -- :: Eq a => [a] -> [[a]]
  48    , groupBy           -- :: (a -> a -> Bool) -> [a] -> [[a]]
  49
  50    , inits             -- :: [a] -> [[a]]
  51    , tails             -- :: [a] -> [[a]]
  52
  53    , isPrefixOf        -- :: (Eq a) => [a] -> [a] -> Bool
  54    , isSuffixOf        -- :: (Eq a) => [a] -> [a] -> Bool
  55
  56    , mapAccumL         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
  57    , mapAccumR         -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
  58
  59    , sort              -- :: (Ord a) => [a] -> [a]
  60    , sortBy            -- :: (a -> a -> Ordering) -> [a] -> [a]
  61
  62    , insert            -- :: (Ord a) => a -> [a] -> [a]
  63    , insertBy          -- :: (a -> a -> Ordering) -> a -> [a] -> [a]
  64
  65    , maximumBy         -- :: (a -> a -> Ordering) -> [a] -> a
  66    , minimumBy         -- :: (a -> a -> Ordering) -> [a] -> a
  67
  68    , genericLength     -- :: (Integral a) => [b] -> a
  69    , genericTake       -- :: (Integral a) => a -> [b] -> [b]
  70    , genericDrop       -- :: (Integral a) => a -> [b] -> [b]
  71    , genericSplitAt    -- :: (Integral a) => a -> [b] -> ([b], [b])
  72    , genericIndex      -- :: (Integral a) => [b] -> a -> b
  73    , genericReplicate  -- :: (Integral a) => a -> b -> [b]
  74
  75    , unfoldr            -- :: (b -> Maybe (a, b)) -> b -> [a]
  76
  77    , zip4, zip5, zip6, zip7
  78    , zipWith4, zipWith5, zipWith6, zipWith7
  79    , unzip4, unzip5, unzip6, unzip7
  80
  81    , map               -- :: ( a -> b ) -> [a] -> [b]
  82    , (++)              -- :: [a] -> [a] -> [a]
  83    , concat            -- :: [[a]] -> [a]
  84    , filter            -- :: (a -> Bool) -> [a] -> [a]
  85    , head              -- :: [a] -> a
  86    , last              -- :: [a] -> a
  87    , tail              -- :: [a] -> [a]
  88    , init              -- :: [a] -> [a]
  89    , null              -- :: [a] -> Bool
  90    , length            -- :: [a] -> Int
  91    , (!!)              -- :: [a] -> Int -> a
  92    , foldl             -- :: (a -> b -> a) -> a -> [b] -> a
  93    , foldl'            -- :: (a -> b -> a) -> a -> [b] -> a
  94    , foldl1            -- :: (a -> a -> a) -> [a] -> a
  95    , scanl             -- :: (a -> b -> a) -> a -> [b] -> [a]
  96    , scanl1            -- :: (a -> a -> a) -> [a] -> [a]
  97    , foldr             -- :: (a -> b -> b) -> b -> [a] -> b
  98    , foldr1            -- :: (a -> a -> a) -> [a] -> a
  99    , scanr             -- :: (a -> b -> b) -> b -> [a] -> [b]
 100    , scanr1            -- :: (a -> a -> a) -> [a] -> [a]
 101    , iterate           -- :: (a -> a) -> a -> [a]
 102    , repeat            -- :: a -> [a]
 103    , replicate         -- :: Int -> a -> [a]
 104    , cycle             -- :: [a] -> [a]
 105    , take              -- :: Int -> [a] -> [a]
 106    , drop              -- :: Int -> [a] -> [a]
 107    , splitAt           -- :: Int -> [a] -> ([a], [a])
 108    , takeWhile         -- :: (a -> Bool) -> [a] -> [a]
 109    , dropWhile         -- :: (a -> Bool) -> [a] -> [a]
 110    , span              -- :: (a -> Bool) -> [a] -> ([a], [a])
 111    , break             -- :: (a -> Bool) -> [a] -> ([a], [a])
 112
 113    , lines             -- :: String   -> [String]
 114    , words             -- :: String   -> [String]
 115    , unlines           -- :: [String] -> String
 116    , unwords           -- :: [String] -> String
 117    , reverse           -- :: [a] -> [a]
 118    , and               -- :: [Bool] -> Bool
 119    , or                -- :: [Bool] -> Bool
 120    , any               -- :: (a -> Bool) -> [a] -> Bool
 121    , all               -- :: (a -> Bool) -> [a] -> Bool
 122    , elem              -- :: a -> [a] -> Bool
 123    , notElem           -- :: a -> [a] -> Bool
 124    , lookup            -- :: (Eq a) => a -> [(a,b)] -> Maybe b
 125    , sum               -- :: (Num a) => [a] -> a
 126    , product           -- :: (Num a) => [a] -> a
 127    , maximum           -- :: (Ord a) => [a] -> a
 128    , minimum           -- :: (Ord a) => [a] -> a
 129    , concatMap         -- :: (a -> [b]) -> [a] -> [b]
 130    , zip               -- :: [a] -> [b] -> [(a,b)]
 131    , zip3
 132    , zipWith           -- :: (a -> b -> c) -> [a] -> [b] -> [c]
 133    , zipWith3
 134    , unzip             -- :: [(a,b)] -> ([a],[b])
 135    , unzip3
 136
 137    ) where
 138
 139 import Prelude hiding (Maybe(..))
 140 import Data.Maybe
 141
 142 #ifdef __GLASGOW_HASKELL__
 143 import GHC.Num
 144 import GHC.Real
 145 import GHC.List
 146 import GHC.Show ( lines, words, unlines, unwords )
 147 import GHC.Base
 148 #endif
 149
 150 infix 5 \\
 151
 152 -- -----------------------------------------------------------------------------
 153 -- List functions
 154
 155 elemIndex       :: Eq a => a -> [a] -> Maybe Int
 156 elemIndex x     = findIndex (x==)
 157
 158 elemIndices     :: Eq a => a -> [a] -> [Int]
 159 elemIndices x   = findIndices (x==)
 160
 161 find            :: (a -> Bool) -> [a] -> Maybe a
 162 find p          = listToMaybe . filter p
 163
 164 findIndex       :: (a -> Bool) -> [a] -> Maybe Int
 165 findIndex p     = listToMaybe . findIndices p
 166
 167 findIndices      :: (a -> Bool) -> [a] -> [Int]
 168
 169 #if defined(USE_REPORT_PRELUDE) || !defined(__GLASGOW_HASKELL__)
 170 findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
 171 #else
 172 -- Efficient definition
 173 findIndices p ls = loop 0# ls
 174                  where
 175                    loop _ [] = []
 176                    loop n (x:xs) | p x       = I# n : loop (n +# 1#) xs
 177                                  | otherwise = loop (n +# 1#) xs
 178 #endif  /* USE_REPORT_PRELUDE */
 179
 180 isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool
 181 isPrefixOf [] _         =  True
 182 isPrefixOf _  []        =  False
 183 isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys
 184
 185 isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool
 186 isSuffixOf x y          =  reverse x `isPrefixOf` reverse y
 187
 188 -- nub (meaning "essence") remove duplicate elements from its list argument.
 189 nub                     :: (Eq a) => [a] -> [a]
 190 #ifdef USE_REPORT_PRELUDE
 191 nub                     =  nubBy (==)
 192 #else
 193 -- stolen from HBC
 194 nub l                   = nub' l []             -- '
 195   where
 196     nub' [] _           = []                    -- '
 197     nub' (x:xs) ls                              -- '
 198         | x `elem` ls   = nub' xs ls            -- '
 199         | otherwise     = x : nub' xs (x:ls)    -- '
 200 #endif
 201
 202 nubBy                   :: (a -> a -> Bool) -> [a] -> [a]
 203 #ifdef USE_REPORT_PRELUDE
 204 nubBy eq []             =  []
 205 nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs)
 206 #else
 207 nubBy eq l              = nubBy' l []
 208   where
 209     nubBy' [] _         = []
 210     nubBy' (y:ys) xs
 211        | elem_by eq y xs = nubBy' ys xs
 212        | otherwise       = y : nubBy' ys (y:xs)
 213
 214 -- Not exported:
 215 -- Note that we keep the call to `eq` with arguments in the
 216 -- same order as in the reference implementation
 217 -- 'xs' is the list of things we've seen so far,
 218 -- 'y' is the potential new element
 219 elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool
 220 elem_by _  _ []         =  False
 221 elem_by eq y (x:xs)     =  x `eq` y || elem_by eq y xs
 222 #endif
 223
 224
 225 -- delete x removes the first occurrence of x from its list argument.
 226 delete                  :: (Eq a) => a -> [a] -> [a]
 227 delete                  =  deleteBy (==)
 228
 229 deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]
 230 deleteBy _  _ []        = []
 231 deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys
 232
 233 -- list difference (non-associative).  In the result of xs \\ ys,
 234 -- the first occurrence of each element of ys in turn (if any)
 235 -- has been removed from xs.  Thus, (xs ++ ys) \\ xs == ys.
 236 (\\)                    :: (Eq a) => [a] -> [a] -> [a]
 237 (\\)                    =  foldl (flip delete)
 238
 239 -- List union, remove the elements of first list from second.
 240 union                   :: (Eq a) => [a] -> [a] -> [a]
 241 union                   = unionBy (==)
 242
 243 unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 244 unionBy eq xs ys        =  xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
 245
 246 intersect               :: (Eq a) => [a] -> [a] -> [a]
 247 intersect               =  intersectBy (==)
 248
 249 intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 250 intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]
 251
 252 -- intersperse sep inserts sep between the elements of its list argument.
 253 -- e.g. intersperse ',' "abcde" == "a,b,c,d,e"
 254 intersperse             :: a -> [a] -> [a]
 255 intersperse _   []      = []
 256 intersperse _   [x]     = [x]
 257 intersperse sep (x:xs)  = x : sep : intersperse sep xs
 258
 259 transpose               :: [[a]] -> [[a]]
 260 transpose []             = []
 261 transpose ([]   : xss)   = transpose xss
 262 transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss])
 263
 264
 265 -- partition takes a predicate and a list and returns a pair of lists:
 266 -- those elements of the argument list that do and do not satisfy the
 267 -- predicate, respectively; i,e,,
 268 -- partition p xs == (filter p xs, filter (not . p) xs).
 269 partition               :: (a -> Bool) -> [a] -> ([a],[a])
 270 {-# INLINE partition #-}
 271 partition p xs = foldr (select p) ([],[]) xs
 272
 273 select p x (ts,fs) | p x       = (x:ts,fs)
 274                    | otherwise = (ts, x:fs)
 275
 276 -- @mapAccumL@ behaves like a combination
 277 -- of  @map@ and @foldl@;
 278 -- it applies a function to each element of a list, passing an accumulating
 279 -- parameter from left to right, and returning a final value of this
 280 -- accumulator together with the new list.
 281
 282 mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
 283                                     -- and accumulator, returning new
 284                                     -- accumulator and elt of result list
 285           -> acc            -- Initial accumulator
 286           -> [x]            -- Input list
 287           -> (acc, [y])     -- Final accumulator and result list
 288 mapAccumL _ s []        =  (s, [])
 289 mapAccumL f s (x:xs)    =  (s'',y:ys)
 290                            where (s', y ) = f s x
 291                                  (s'',ys) = mapAccumL f s' xs
 292
 293 -- @mapAccumR@ does the same, but working from right to left instead.
 294 -- Its type is the same as @mapAccumL@, though.
 295
 296 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 297                                         -- and accumulator, returning new
 298                                         -- accumulator and elt of result list
 299             -> acc              -- Initial accumulator
 300             -> [x]              -- Input list
 301             -> (acc, [y])               -- Final accumulator and result list
 302 mapAccumR _ s []        =  (s, [])
 303 mapAccumR f s (x:xs)    =  (s'', y:ys)
 304                            where (s'',y ) = f s' x
 305                                  (s', ys) = mapAccumR f s xs
 306
 307
 308 insert :: Ord a => a -> [a] -> [a]
 309 insert e ls = insertBy (compare) e ls
 310
 311 insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
 312 insertBy _   x [] = [x]
 313 insertBy cmp x ys@(y:ys')
 314  = case cmp x y of
 315      GT -> y : insertBy cmp x ys'
 316      _  -> x : ys
 317
 318 maximumBy               :: (a -> a -> Ordering) -> [a] -> a
 319 maximumBy _ []          =  error "List.maximumBy: empty list"
 320 maximumBy cmp xs        =  foldl1 max xs
 321                         where
 322                            max x y = case cmp x y of
 323                                         GT -> x
 324                                         _  -> y
 325
 326 minimumBy               :: (a -> a -> Ordering) -> [a] -> a
 327 minimumBy _ []          =  error "List.minimumBy: empty list"
 328 minimumBy cmp xs        =  foldl1 min xs
 329                         where
 330                            min x y = case cmp x y of
 331                                         GT -> y
 332                                         _  -> x
 333
 334 genericLength           :: (Num i) => [b] -> i
 335 genericLength []        =  0
 336 genericLength (_:l)     =  1 + genericLength l
 337
 338 genericTake             :: (Integral i) => i -> [a] -> [a]
 339 genericTake 0 _         =  []
 340 genericTake _ []        =  []
 341 genericTake n (x:xs) | n > 0  =  x : genericTake (n-1) xs
 342 genericTake _  _        =  error "List.genericTake: negative argument"
 343
 344 genericDrop             :: (Integral i) => i -> [a] -> [a]
 345 genericDrop 0 xs        =  xs
 346 genericDrop _ []        =  []
 347 genericDrop n (_:xs) | n > 0  =  genericDrop (n-1) xs
 348 genericDrop _ _         =  error "List.genericDrop: negative argument"
 349
 350 genericSplitAt          :: (Integral i) => i -> [b] -> ([b],[b])
 351 genericSplitAt 0 xs     =  ([],xs)
 352 genericSplitAt _ []     =  ([],[])
 353 genericSplitAt n (x:xs) | n > 0  =  (x:xs',xs'') where
 354                                (xs',xs'') = genericSplitAt (n-1) xs
 355 genericSplitAt _ _      =  error "List.genericSplitAt: negative argument"
 356
 357
 358 genericIndex :: (Integral a) => [b] -> a -> b
 359 genericIndex (x:_)  0 = x
 360 genericIndex (_:xs) n
 361  | n > 0     = genericIndex xs (n-1)
 362  | otherwise = error "List.genericIndex: negative argument."
 363 genericIndex _ _      = error "List.genericIndex: index too large."
 364
 365 genericReplicate        :: (Integral i) => i -> a -> [a]
 366 genericReplicate n x    =  genericTake n (repeat x)
 367
 368
 369 zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
 370 zip4                    =  zipWith4 (,,,)
 371
 372 zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
 373 zip5                    =  zipWith5 (,,,,)
 374
 375 zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
 376                               [(a,b,c,d,e,f)]
 377 zip6                    =  zipWith6 (,,,,,)
 378
 379 zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
 380                               [g] -> [(a,b,c,d,e,f,g)]
 381 zip7                    =  zipWith7 (,,,,,,)
 382
 383 zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 384 zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
 385                         =  z a b c d : zipWith4 z as bs cs ds
 386 zipWith4 _ _ _ _ _      =  []
 387
 388 zipWith5                :: (a->b->c->d->e->f) ->
 389                            [a]->[b]->[c]->[d]->[e]->[f]
 390 zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
 391                         =  z a b c d e : zipWith5 z as bs cs ds es
 392 zipWith5 _ _ _ _ _ _    = []
 393
 394 zipWith6                :: (a->b->c->d->e->f->g) ->
 395                            [a]->[b]->[c]->[d]->[e]->[f]->[g]
 396 zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
 397                         =  z a b c d e f : zipWith6 z as bs cs ds es fs
 398 zipWith6 _ _ _ _ _ _ _  = []
 399
 400 zipWith7                :: (a->b->c->d->e->f->g->h) ->
 401                            [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
 402 zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
 403                    =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
 404 zipWith7 _ _ _ _ _ _ _ _ = []
 405
 406 unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])
 407 unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
 408                                         (a:as,b:bs,c:cs,d:ds))
 409                                  ([],[],[],[])
 410
 411 unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
 412 unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
 413                                         (a:as,b:bs,c:cs,d:ds,e:es))
 414                                  ([],[],[],[],[])
 415
 416 unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
 417 unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
 418                                         (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
 419                                  ([],[],[],[],[],[])
 420
 421 unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
 422 unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
 423                                 (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
 424                          ([],[],[],[],[],[],[])
 425
 426
 427
 428 deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 429 deleteFirstsBy eq       =  foldl (flip (deleteBy eq))
 430
 431
 432 -- group splits its list argument into a list of lists of equal, adjacent
 433 -- elements.  e.g.,
 434 -- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
 435 group                   :: (Eq a) => [a] -> [[a]]
 436 group                   =  groupBy (==)
 437
 438 groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]
 439 groupBy _  []           =  []
 440 groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs
 441                            where (ys,zs) = span (eq x) xs
 442
 443 -- inits xs returns the list of initial segments of xs, shortest first.
 444 -- e.g., inits "abc" == ["","a","ab","abc"]
 445 inits                   :: [a] -> [[a]]
 446 inits []                =  [[]]
 447 inits (x:xs)            =  [[]] ++ map (x:) (inits xs)
 448
 449 -- tails xs returns the list of all final segments of xs, longest first.
 450 -- e.g., tails "abc" == ["abc", "bc", "c",""]
 451 tails                   :: [a] -> [[a]]
 452 tails []                =  [[]]
 453 tails xxs@(_:xs)        =  xxs : tails xs
 454
 455
 456 ------------------------------------------------------------------------------
 457 -- Quick Sort algorithm taken from HBC's QSort library.
 458
 459 sort :: (Ord a) => [a] -> [a]
 460 sortBy :: (a -> a -> Ordering) -> [a] -> [a]
 461
 462 #ifdef USE_REPORT_PRELUDE
 463 sort = sortBy compare
 464 sortBy cmp = foldr (insertBy cmp) []
 465 #else
 466
 467 sortBy cmp l = mergesort cmp l
 468 sort l = mergesort compare l
 469
 470 {-
 471 Quicksort replaced by mergesort, 14/5/2002.
 472
 473 From: Ian Lynagh <igloo@earth.li>
 474
 475 I am curious as to why the List.sort implementation in GHC is a
 476 quicksort algorithm rather than an algorithm that guarantees n log n
 477 time in the worst case? I have attached a mergesort implementation along
 478 with a few scripts to time it's performance, the results of which are
 479 shown below (* means it didn't finish successfully - in all cases this
 480 was due to a stack overflow).
 481
 482 If I heap profile the random_list case with only 10000 then I see
 483 random_list peaks at using about 2.5M of memory, whereas in the same
 484 program using List.sort it uses only 100k.
 485
 486 Input style     Input length     Sort data     Sort alg    User time
 487 stdin           10000            random_list   sort        2.82
 488 stdin           10000            random_list   mergesort   2.96
 489 stdin           10000            sorted        sort        31.37
 490 stdin           10000            sorted        mergesort   1.90
 491 stdin           10000            revsorted     sort        31.21
 492 stdin           10000            revsorted     mergesort   1.88
 493 stdin           100000           random_list   sort        *
 494 stdin           100000           random_list   mergesort   *
 495 stdin           100000           sorted        sort        *
 496 stdin           100000           sorted        mergesort   *
 497 stdin           100000           revsorted     sort        *
 498 stdin           100000           revsorted     mergesort   *
 499 func            10000            random_list   sort        0.31
 500 func            10000            random_list   mergesort   0.91
 501 func            10000            sorted        sort        19.09
 502 func            10000            sorted        mergesort   0.15
 503 func            10000            revsorted     sort        19.17
 504 func            10000            revsorted     mergesort   0.16
 505 func            100000           random_list   sort        3.85
 506 func            100000           random_list   mergesort   *
 507 func            100000           sorted        sort        5831.47
 508 func            100000           sorted        mergesort   2.23
 509 func            100000           revsorted     sort        5872.34
 510 func            100000           revsorted     mergesort   2.24
 511 -}
 512
 513 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
 514 mergesort cmp = mergesort' cmp . map wrap
 515
 516 mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a]
 517 mergesort' cmp [] = []
 518 mergesort' cmp [xs] = xs
 519 mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss)
 520
 521 merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]]
 522 merge_pairs cmp [] = []
 523 merge_pairs cmp [xs] = [xs]
 524 merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss
 525
 526 merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
 527 merge cmp xs [] = xs
 528 merge cmp [] ys = ys
 529 merge cmp (x:xs) (y:ys)
 530  = case x `cmp` y of
 531         GT -> y : merge cmp (x:xs)   ys
 532         _  -> x : merge cmp    xs (y:ys)
 533
 534 wrap :: a -> [a]
 535 wrap x = [x]
 536
 537 {-
 538 OLD: qsort version
 539
 540 -- qsort is stable and does not concatenate.
 541 qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
 542 qsort _   []     r = r
 543 qsort _   [x]    r = x:r
 544 qsort cmp (x:xs) r = qpart cmp x xs [] [] r
 545
 546 -- qpart partitions and sorts the sublists
 547 qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
 548 qpart cmp x [] rlt rge r =
 549     -- rlt and rge are in reverse order and must be sorted with an
 550     -- anti-stable sorting
 551     rqsort cmp rlt (x:rqsort cmp rge r)
 552 qpart cmp x (y:ys) rlt rge r =
 553     case cmp x y of
 554         GT -> qpart cmp x ys (y:rlt) rge r
 555         _  -> qpart cmp x ys rlt (y:rge) r
 556
 557 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
 558 rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
 559 rqsort _   []     r = r
 560 rqsort _   [x]    r = x:r
 561 rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r
 562
 563 rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
 564 rqpart cmp x [] rle rgt r =
 565     qsort cmp rle (x:qsort cmp rgt r)
 566 rqpart cmp x (y:ys) rle rgt r =
 567     case cmp y x of
 568         GT -> rqpart cmp x ys rle (y:rgt) r
 569         _  -> rqpart cmp x ys (y:rle) rgt r
 570 -}
 571
 572 #endif /* USE_REPORT_PRELUDE */
 573
 574 {-
 575 \begin{verbatim}
 576   unfoldr f' (foldr f z xs) == (z,xs)
 577
 578  if the following holds:
 579
 580    f' (f x y) = Just (x,y)
 581    f' z       = Nothing
 582 \end{verbatim}
 583 -}
 584
 585 unfoldr      :: (b -> Maybe (a, b)) -> b -> [a]
 586 unfoldr f b  =
 587   case f b of
 588    Just (a,new_b) -> a : unfoldr f new_b
 589    Nothing        -> []
 590
 591
 592 -- -----------------------------------------------------------------------------
 593 -- strict version of foldl
 594
 595 foldl'           :: (a -> b -> a) -> a -> [b] -> a
 596 foldl' f a []     = a
 597 foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs
 598
 599 #ifndef __HUGS__
 600 -- -----------------------------------------------------------------------------
 601 -- List sum and product
 602
 603 -- sum and product compute the sum or product of a finite list of numbers.
 604 {-# SPECIALISE sum     :: [Int] -> Int #-}
 605 {-# SPECIALISE sum     :: [Integer] -> Integer #-}
 606 {-# SPECIALISE product :: [Int] -> Int #-}
 607 {-# SPECIALISE product :: [Integer] -> Integer #-}
 608 sum, product            :: (Num a) => [a] -> a
 609 #ifdef USE_REPORT_PRELUDE
 610 sum                     =  foldl (+) 0
 611 product                 =  foldl (*) 1
 612 #else
 613 sum     l       = sum' l 0
 614   where
 615     sum' []     a = a
 616     sum' (x:xs) a = sum' xs (a+x)
 617 product l       = prod l 1
 618   where
 619     prod []     a = a
 620     prod (x:xs) a = prod xs (a*x)
 621 #endif
 622 #endif  /* __HUGS__ */