1module Data.List.HT.Private where 2 3import Data.List as List (find, transpose, unfoldr, isPrefixOf, 4 findIndices, foldl', mapAccumL, ) 5import Data.Maybe as Maybe (fromMaybe, catMaybes, isJust, mapMaybe, ) 6import Data.Maybe.HT (toMaybe, ) 7import Control.Monad.HT ((<=<), ) 8import Control.Monad (guard, msum, mplus, ) 9import Control.Applicative ((<$>), (<*>), ) 10import Data.Tuple.HT (mapPair, mapFst, mapSnd, forcePair, swap, ) 11 12import qualified Control.Functor.HT as Func 13 14import qualified Data.List.Key.Private as Key 15import qualified Data.List.Match.Private as Match 16import qualified Data.List.Reverse.StrictElement as Rev 17 18import Prelude hiding (unzip, break, span, ) 19 20 21-- $setup 22-- >>> import qualified Test.QuickCheck as QC 23-- >>> import Test.Utility (forAllPredicates) 24-- >>> import Test.QuickCheck (NonNegative(NonNegative), Positive(Positive), NonEmptyList(NonEmpty)) 25-- >>> import qualified Data.List as List 26-- >>> import Data.List (transpose) 27-- >>> import Data.Maybe.HT (toMaybe) 28-- >>> import Data.Maybe (mapMaybe, isNothing) 29-- >>> import Data.Char (isLetter, toUpper) 30-- >>> import Data.Eq.HT (equating) 31-- >>> import Control.Monad (liftM2) 32-- >>> 33-- >>> divMaybe :: Int -> Int -> Maybe Int 34-- >>> divMaybe m n = case divMod n m of (q,0) -> Just q; _ -> Nothing 35-- >>> 36-- >>> forAllMaybeFn :: (QC.Testable test) => ((Int -> Maybe Int) -> test) -> QC.Property 37-- >>> forAllMaybeFn prop = QC.forAll (QC.choose (1,4)) $ prop . divMaybe 38 39 40-- * Improved standard functions 41 42{- | 43This function is lazier than the one suggested in the Haskell 98 report. 44It is @inits undefined = [] : undefined@, 45in contrast to @Data.List.inits undefined = undefined@. 46-} 47{- 48suggested in 49<http://www.haskell.org/pipermail/libraries/2014-July/023291.html> 50-} 51inits :: [a] -> [[a]] 52inits = map reverse . scanl (flip (:)) [] 53 54{- | 55As lazy as 'inits' but less efficient because of repeated 'map'. 56-} 57initsLazy :: [a] -> [[a]] 58initsLazy xt = 59 [] : 60 case xt of 61 [] -> [] 62 x:xs -> map (x:) (initsLazy xs) 63 64{- | 65Suggested implementation in the Haskell 98 report. 66It is not as lazy as possible. 67-} 68inits98 :: [a] -> [[a]] 69inits98 [] = [[]] 70inits98 (x:xs) = [[]] ++ map (x:) (inits98 xs) 71 72inits98' :: [a] -> [[a]] 73inits98' = 74 foldr (\x prefixes -> [] : map (x:) prefixes) [[]] 75 76 77{- | 78This function is lazier than the one suggested in the Haskell 98 report. 79It is @tails undefined = ([] : undefined) : undefined@, 80in contrast to @Data.List.tails undefined = undefined@. 81-} 82tails :: [a] -> [[a]] 83tails xt = 84 uncurry (:) $ 85 case xt of 86 [] -> ([],[]) 87 _:xs -> (xt, tails xs) 88 89tails' :: [a] -> [[a]] 90tails' = fst . breakAfter null . iterate tail 91 92tails98 :: [a] -> [[a]] 93tails98 [] = [[]] 94tails98 xxs@(_:xs) = xxs : tails98 xs 95 96{- | 97This function compares adjacent elements of a list. 98If two adjacent elements satisfy a relation then they are put into the same sublist. 99Example: 100 101>>> groupBy (<) "abcdebcdef" 102["abcde","bcdef"] 103 104In contrast to that 'Data.List.groupBy' compares 105the head of each sublist with each candidate for this sublist. 106This yields 107 108>>> List.groupBy (<) "abcdebcdef" 109["abcdebcdef"] 110 111The second @'b'@ is compared with the leading @'a'@. 112Thus it is put into the same sublist as @'a'@. 113 114The sublists are never empty. 115Thus the more precise result type would be @[(a,[a])]@. 116-} 117groupBy :: (a -> a -> Bool) -> [a] -> [[a]] 118groupBy = Key.groupBy 119 120group :: (Eq a) => [a] -> [[a]] 121group = groupBy (==) 122 123 124{- | 125Like standard 'unzip' but more lazy. 126It is @Data.List.unzip undefined == undefined@, 127but @unzip undefined == (undefined, undefined)@. 128-} 129unzip :: [(a,b)] -> ([a],[b]) 130unzip = 131 forcePair . 132 foldr (\ (x,y) ~(xs,ys) -> (x:xs,y:ys)) ([],[]) 133 134 135{- | 136'Data.List.partition' of GHC 6.2.1 fails on infinite lists. 137But this one does not. 138-} 139{- 140The lazy pattern match @(y,z)@ is necessary 141since otherwise it fails on infinite lists. 142-} 143partition :: (a -> Bool) -> [a] -> ([a], [a]) 144partition p = 145 forcePair . 146 foldr 147 (\x ~(y,z) -> 148 if p x 149 then (x : y, z) 150 else (y, x : z)) 151 ([],[]) 152 153{- | 154It is @Data.List.span f undefined = undefined@, 155whereas @span f undefined = (undefined, undefined)@. 156-} 157span, break :: (a -> Bool) -> [a] -> ([a],[a]) 158span p = 159 let recourse xt = 160 forcePair $ 161 fromMaybe ([],xt) $ 162 do (x,xs) <- viewL xt 163 guard $ p x 164 return $ mapFst (x:) $ recourse xs 165 in recourse 166 167break p = span (not . p) 168 169 170 171-- * Split 172 173{- | 174Split the list at the occurrences of a separator into sub-lists. 175Remove the separators. 176This is somehow a generalization of 'lines' and 'words'. 177But note the differences: 178 179>>> words "a a" 180["a","a"] 181>>> chop (' '==) "a a" 182["a","","a"] 183 184>>> lines "a\n\na" 185["a","","a"] 186>>> chop ('\n'==) "a\n\na" 187["a","","a"] 188 189>>> lines "a\n" 190["a"] 191>>> chop ('\n'==) "a\n" 192["a",""] 193-} 194chop :: (a -> Bool) -> [a] -> [[a]] 195chop p = 196 uncurry (:) . 197 foldr (\ x ~(y,ys) -> if p x then ([],y:ys) else ((x:y),ys) ) ([],[]) 198 199chop' :: (a -> Bool) -> [a] -> [[a]] 200chop' p = 201 let recourse = 202 uncurry (:) . 203 mapSnd (switchL [] (const recourse)) . 204 break p 205 in recourse 206 207 208chopAtRun :: (a -> Bool) -> [a] -> [[a]] 209chopAtRun p = 210 let recourse [] = [[]] 211 recourse y = 212 let (z,zs) = break p (dropWhile p y) 213 in z : recourse zs 214 in recourse 215 216 217{- | 218Like 'break', but splits after the matching element. 219 220prop> forAllPredicates $ \p xs -> uncurry (++) (breakAfter p xs) == xs 221-} 222breakAfter :: (a -> Bool) -> [a] -> ([a], [a]) 223breakAfter = breakAfterRec 224 225breakAfterRec :: (a -> Bool) -> [a] -> ([a], [a]) 226breakAfterRec p = 227 let recourse [] = ([],[]) 228 recourse (x:xs) = 229 mapFst (x:) $ 230 if p x 231 then ([],xs) 232 else recourse xs 233 in forcePair . recourse 234 235{- 236The use of 'foldr' might allow for fusion, 237but unfortunately this simple implementation would copy the tail of the list. 238-} 239-- | prop> forAllPredicates $ \p xs -> breakAfterRec p xs == breakAfterFoldr p xs 240breakAfterFoldr :: (a -> Bool) -> [a] -> ([a], [a]) 241breakAfterFoldr p = 242 forcePair . 243 foldr 244 (\x yzs -> mapFst (x:) $ if p x then ([], uncurry (++) yzs) else yzs) 245 ([],[]) 246 247-- | prop> forAllPredicates $ \p xs -> breakAfterRec p xs == breakAfterBreak p xs 248breakAfterBreak :: (a -> Bool) -> [a] -> ([a], [a]) 249breakAfterBreak p xs = 250 case break p xs of 251 (ys, []) -> (ys, []) 252 (ys, z:zs) -> (ys++[z], zs) 253 254-- | prop> forAllPredicates $ \p xs -> breakAfterRec p xs == breakAfterTakeUntil p xs 255breakAfterTakeUntil :: (a -> Bool) -> [a] -> ([a], [a]) 256breakAfterTakeUntil p xs = 257 forcePair $ 258 (\ys -> (map fst ys, maybe [] (snd . snd) $ viewR ys)) $ 259 takeUntil (p . fst) $ zip xs $ tail $ tails xs 260 261{- | 262Take all elements until one matches. 263The matching element is returned, too. 264This is the key difference to @takeWhile (not . p)@. 265It holds: 266 267prop> forAllPredicates $ \p xs -> takeUntil p xs == fst (breakAfter p xs) 268-} 269takeUntil :: (a -> Bool) -> [a] -> [a] 270takeUntil p = foldr (\x ys -> x : if p x then [] else ys) [] 271 272 273{- | 274Split the list after each occurence of a terminator. 275Keep the terminator. 276There is always a list for the part after the last terminator. 277It may be empty. 278See package @non-empty@ for more precise result type. 279 280prop> forAllPredicates $ \p xs -> concat (segmentAfter p xs) == xs 281prop> forAllPredicates $ \p xs -> length (filter p xs) == length (tail (segmentAfter p xs)) 282prop> forAllPredicates $ \p -> all (p . last) . init . segmentAfter p 283prop> forAllPredicates $ \p -> all (all (not . p) . init) . init . segmentAfter p 284 285This test captures both infinitely many groups and infinitely big groups: 286 287prop> forAllPredicates $ \p x -> flip seq True . (!!100) . concat . segmentAfter p . cycle . (x:) 288-} 289segmentAfter :: (a -> Bool) -> [a] -> [[a]] 290segmentAfter p = 291 uncurry (:) . 292 foldr 293 (\x ~(y,ys) -> 294 mapFst (x:) $ 295 if p x then ([],y:ys) else (y,ys)) 296 ([],[]) 297 298segmentAfter' :: (a -> Bool) -> [a] -> [[a]] 299segmentAfter' p = 300 foldr (\ x ~yt@(y:ys) -> if p x then [x]:yt else (x:y):ys) [[]] 301 302{- | 303Split the list before each occurence of a leading character. 304Keep these characters. 305There is always a list for the part before the first leading character. 306It may be empty. 307See package @non-empty@ for more precise result type. 308 309prop> forAllPredicates $ \p xs -> concat (segmentBefore p xs) == xs 310prop> forAllPredicates $ \p xs -> length (filter p xs) == length (tail (segmentBefore p xs)) 311prop> forAllPredicates $ \p -> all (p . head) . tail . segmentBefore p 312prop> forAllPredicates $ \p -> all (all (not . p) . tail) . tail . segmentBefore p 313prop> forAllPredicates $ \p x -> flip seq True . (!!100) . concat . segmentBefore p . cycle . (x:) 314-} 315segmentBefore :: (a -> Bool) -> [a] -> [[a]] 316segmentBefore p = 317-- foldr (\ x ~(y:ys) -> (if p x then ([]:) else id) ((x:y):ys)) [[]] 318 uncurry (:) . 319 foldr 320 (\ x ~(y,ys) -> 321 let xs = x:y 322 in if p x then ([],xs:ys) else (xs,ys)) 323 ([],[]) 324 325-- | prop> forAllPredicates $ \p xs -> segmentBefore p xs == segmentBefore' p xs 326segmentBefore' :: (a -> Bool) -> [a] -> [[a]] 327segmentBefore' p = 328 uncurry (:) . 329 (\xst -> 330 fromMaybe ([],xst) $ do 331 ((x:xs):xss) <- Just xst 332 guard $ not $ p x 333 return (x:xs, xss)) . 334 groupBy (\_ x -> not $ p x) 335 336-- | prop> forAllPredicates $ \p xs -> segmentBefore p xs == segmentBefore'' p xs 337segmentBefore'' :: (a -> Bool) -> [a] -> [[a]] 338segmentBefore'' p = 339 (\xst -> 340 case xst of 341 ~(xs:xss) -> 342 tail xs : xss) . 343 groupBy (\_ x -> not $ p x) . 344 (error "segmentBefore: dummy element" :) 345 346 347{- | 348>>> segmentBeforeJust (\c -> toMaybe (isLetter c) (toUpper c)) "123a5345b---" 349("123",[('A',"5345"),('B',"---")]) 350-} 351segmentBeforeJust :: 352 (a -> Maybe b) -> 353 [a] -> ([a], [(b, [a])]) 354segmentBeforeJust f = 355 forcePair . 356 foldr 357 (\ x ~(y,ys) -> 358 case f x of 359 Just b -> ([],(b,y):ys) 360 Nothing -> (x:y,ys)) 361 ([],[]) 362 363{- | 364>>> segmentAfterJust (\c -> toMaybe (isLetter c) (toUpper c)) "123a5345b---" 365([("123",'A'),("5345",'B')],"---") 366-} 367segmentAfterJust :: 368 (a -> Maybe b) -> 369 [a] -> ([([a], b)], [a]) 370segmentAfterJust f = 371 swap . 372 uncurry (mapAccumL (\as0 (b,as1) -> (as1, (as0,b)))) . 373 segmentBeforeJust f 374 375 376{- | 377>>> segmentBeforeRight [Left 'a', Right LT, Right GT, Left 'b'] 378("a",[(LT,""),(GT,"b")]) 379 380prop> forAllMaybeFn $ \f xs -> segmentBeforeJust f xs == segmentBeforeRight (map (\x -> maybe (Left x) Right (f x)) xs) 381-} 382segmentBeforeRight :: 383 [Either a b] -> ([a], [(b, [a])]) 384segmentBeforeRight = 385 forcePair . 386 foldr 387 (\ x ~(y,ys) -> 388 case x of 389 Right b -> ([],(b,y):ys) 390 Left a -> (a:y,ys)) 391 ([],[]) 392 393{- | 394>>> segmentAfterRight [Left 'a', Right LT, Right GT, Left 'b'] 395([("a",LT),("",GT)],"b") 396 397prop> forAllMaybeFn $ \f xs -> segmentAfterJust f xs == segmentAfterRight (map (\x -> maybe (Left x) Right (f x)) xs) 398-} 399segmentAfterRight :: 400 [Either a b] -> ([([a], b)], [a]) 401segmentAfterRight = 402 swap . 403 uncurry (mapAccumL (\as0 (b,as1) -> (as1, (as0,b)))) . 404 segmentBeforeRight 405 406 407-- cf. Matroid.hs 408{- | 409@removeEach xs@ represents a list of sublists of @xs@, 410where each element of @xs@ is removed and 411the removed element is separated. 412It seems to be much simpler to achieve with 413@zip xs (map (flip List.delete xs) xs)@, 414but the implementation of 'removeEach' does not need the 'Eq' instance 415and thus can also be used for lists of functions. 416 417See also the proposal 418 <http://www.haskell.org/pipermail/libraries/2008-February/009270.html> 419 420>>> removeEach "abc" 421[('a',"bc"),('b',"ac"),('c',"ab")] 422>>> removeEach "a" 423[('a',"")] 424>>> removeEach "" 425[] 426-} 427removeEach :: [a] -> [(a, [a])] 428removeEach = 429 map (\(ys, pivot, zs) -> (pivot,ys++zs)) . splitEverywhere 430 431{- | 432>>> splitEverywhere "abc" 433[("",'a',"bc"),("a",'b',"c"),("ab",'c',"")] 434>>> splitEverywhere "a" 435[("",'a',"")] 436>>> splitEverywhere "" 437[] 438-} 439splitEverywhere :: [a] -> [([a], a, [a])] 440splitEverywhere xs = 441 map 442 (\(y, zs0) -> 443 case zs0 of 444 z:zs -> (y,z,zs) 445 [] -> error "splitEverywhere: empty list") 446 (init (zip (inits xs) (tails xs))) 447 448 449 450-- * inspect ends of a list 451 452{-# DEPRECATED splitLast "use viewR instead" #-} 453{- | 454It holds @splitLast xs == (init xs, last xs)@, 455but 'splitLast' is more efficient 456if the last element is accessed after the initial ones, 457because it avoids memoizing list. 458 459prop> \(NonEmpty xs) -> splitLast (xs::String) == (init xs, last xs) 460-} 461splitLast :: [a] -> ([a], a) 462splitLast [] = error "splitLast: empty list" 463splitLast [x] = ([], x) 464splitLast (x:xs) = 465 let (xs', lastx) = splitLast xs in (x:xs', lastx) 466 467 468{- | 469Should be prefered to 'head' and 'tail'. 470-} 471{-# INLINE viewL #-} 472viewL :: [a] -> Maybe (a, [a]) 473viewL (x:xs) = Just (x,xs) 474viewL [] = Nothing 475 476{- | 477Should be prefered to 'init' and 'last'. 478 479prop> \xs -> maybe True ((init xs, last xs) == ) (viewR (xs::String)) 480-} 481viewR :: [a] -> Maybe ([a], a) 482viewR = 483 foldr (\x -> Just . forcePair . maybe ([],x) (mapFst (x:))) Nothing 484 485{- | 486Should be prefered to 'head' and 'tail'. 487-} 488{-# INLINE switchL #-} 489switchL :: b -> (a -> [a] -> b) -> [a] -> b 490switchL n _ [] = n 491switchL _ j (x:xs) = j x xs 492 493switchL' :: b -> (a -> [a] -> b) -> [a] -> b 494switchL' n j = 495 maybe n (uncurry j) . viewL 496 497{- | 498Should be prefered to 'init' and 'last'. 499 500prop> \xs -> switchR True (\ixs lxs -> ixs == init xs && lxs == last xs) (xs::String) 501-} 502{-# INLINE switchR #-} 503switchR :: b -> ([a] -> a -> b) -> [a] -> b 504switchR n j = 505 maybe n (uncurry j) . viewR 506 507 508-- * List processing starting at the end 509 510{- | 511@takeRev n@ is like @reverse . take n . reverse@ 512but it is lazy enough to work for infinite lists, too. 513 514prop> \n xs -> takeRev n (xs::String) == reverse (take n (reverse xs)) 515-} 516takeRev :: Int -> [a] -> [a] 517takeRev n xs = Match.drop (drop n xs) xs 518 519{- | 520@dropRev n@ is like @reverse . drop n . reverse@ 521but it is lazy enough to work for infinite lists, too. 522 523prop> \n xs -> dropRev n (xs::String) == reverse (drop n (reverse xs)) 524-} 525dropRev :: Int -> [a] -> [a] 526dropRev n xs = Match.take (drop n xs) xs 527 528{- | 529@splitAtRev n xs == (dropRev n xs, takeRev n xs)@. 530 531prop> \n xs -> splitAtRev n (xs::String) == (dropRev n xs, takeRev n xs) 532prop> \n xs -> (xs::String) == uncurry (++) (splitAtRev n xs) 533-} 534splitAtRev :: Int -> [a] -> ([a], [a]) 535splitAtRev n xs = Match.splitAt (drop n xs) xs 536 537 538-- * List processing with Maybe and Either 539 540{- | 541@maybePrefixOf xs ys@ is @Just zs@ if @xs@ is a prefix of @ys@, 542where @zs@ is @ys@ without the prefix @xs@. 543Otherwise it is @Nothing@. 544It is the same as 'Data.List.stripPrefix'. 545 546>>> maybePrefixOf "abc" "abcdef" 547Just "def" 548>>> maybePrefixOf "def" "abcdef" 549Nothing 550-} 551maybePrefixOf :: Eq a => [a] -> [a] -> Maybe [a] 552maybePrefixOf (x:xs) (y:ys) = guard (x==y) >> maybePrefixOf xs ys 553maybePrefixOf [] ys = Just ys 554maybePrefixOf _ [] = Nothing 555 556{- | 557>>> maybeSuffixOf "abc" "abcdef" 558Nothing 559>>> maybeSuffixOf "def" "abcdef" 560Just "abc" 561-} 562maybeSuffixOf :: Eq a => [a] -> [a] -> Maybe [a] 563maybeSuffixOf xs ys = 564 fmap reverse $ maybePrefixOf (reverse xs) (reverse ys) 565 566 567{- | 568Partition a list into elements which evaluate to @Just@ or @Nothing@ by @f@. 569 570prop> forAllMaybeFn $ \f xs -> partitionMaybe f xs == (mapMaybe f xs, filter (isNothing . f) xs) 571prop> forAllPredicates $ \p xs -> partition p xs == partitionMaybe (\x -> toMaybe (p x) x) xs 572-} 573partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) 574partitionMaybe f = 575 forcePair . 576 foldr 577 (\x -> maybe (mapSnd (x:)) (\y -> mapFst (y:)) (f x)) 578 ([],[]) 579 580{- | 581This is the cousin of 'takeWhile' 582analogously to 'catMaybes' being the cousin of 'filter'. 583 584>>> takeWhileJust [Just 'a', Just 'b', Nothing, Just 'c'] 585"ab" 586 587Example: Keep the heads of sublists until an empty list occurs. 588 589>>> takeWhileJust $ map (fmap fst . viewL) ["abc","def","","xyz"] 590"ad" 591 592For consistency with 'takeWhile', 593'partitionMaybe' and 'dropWhileNothing' it should have been: 594 595> takeWhileJust_ :: (a -> Maybe b) -> a -> [b] 596 597However, both variants are interchangeable: 598 599> takeWhileJust_ f == takeWhileJust . map f 600> takeWhileJust == takeWhileJust_ id 601-} 602takeWhileJust :: [Maybe a] -> [a] 603takeWhileJust = 604 foldr (\x acc -> maybe [] (:acc) x) [] 605 606dropWhileNothing :: (a -> Maybe b) -> [a] -> Maybe (b, [a]) 607dropWhileNothing f = 608 msum . map (Func.mapFst f <=< viewL) . tails 609 610-- | prop> forAllMaybeFn $ \f xs -> dropWhileNothing f xs == dropWhileNothingRec f xs 611dropWhileNothingRec :: (a -> Maybe b) -> [a] -> Maybe (b, [a]) 612dropWhileNothingRec f = 613 let go [] = Nothing 614 go (a:xs) = (flip (,) xs <$> f a) `mplus` go xs 615 in go 616 617-- | prop> forAllMaybeFn $ \f xs -> snd (breakJust f xs) == dropWhileNothing f xs 618breakJust :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) 619breakJust f = 620 let go [] = ([], Nothing) 621 go (a:xs) = 622 case f a of 623 Nothing -> mapFst (a:) $ go xs 624 Just b -> ([], Just (b, xs)) 625 in go 626 627-- memory leak, because xs is hold all the time 628-- | prop> forAllMaybeFn $ \f xs -> breakJust f xs == breakJustRemoveEach f xs 629breakJustRemoveEach :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) 630breakJustRemoveEach f xs = 631 switchL (xs, Nothing) const $ 632 mapMaybe (\(ys,a,zs) -> (\b -> (ys, Just (b,zs))) <$> f a) $ 633 splitEverywhere xs 634 635-- needs to apply 'f' twice at the end and uses partial functions 636-- | prop> forAllMaybeFn $ \f xs -> breakJust f xs == breakJustPartial f xs 637breakJustPartial :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) 638breakJustPartial f xs = 639 let (ys,zs) = break (isJust . f) xs 640 in (ys, 641 mapFst (maybe (error "breakJust: unexpected Nothing") id . f) <$> 642 viewL zs) 643 644spanJust :: (a -> Maybe b) -> [a] -> ([b], [a]) 645spanJust f = 646 let go [] = ([], []) 647 go xt@(a:xs) = 648 case f a of 649 Just b -> mapFst (b:) $ go xs 650 Nothing -> ([], xt) 651 in go 652 653 654unzipEithers :: [Either a b] -> ([a], [b]) 655unzipEithers = 656 forcePair . 657 foldr (either (\x -> mapFst (x:)) (\y -> mapSnd (y:))) ([],[]) 658 659 660-- * Sieve and slice 661 662{- | keep every k-th value from the list 663 664>>> sieve 6 ['a'..'z'] 665"agmsy" 666-} 667sieve, sieve', sieve'', sieve''' :: Int -> [a] -> [a] 668sieve k = 669 unfoldr (\xs -> toMaybe (not (null xs)) (head xs, drop k xs)) 670 671-- | prop> \(Positive n) xs -> sieve n xs == sieve' n (xs::String) 672sieve' k = map head . sliceVertical k 673 674-- | prop> \(Positive n) xs -> sieve n xs == sieve'' n (xs::String) 675sieve'' k x = map (x!!) [0,k..(length x-1)] 676 677-- | prop> \(Positive n) xs -> sieve n xs == sieve''' n (xs::String) 678sieve''' k = map head . takeWhile (not . null) . iterate (drop k) 679 680 681{- 682sliceHorizontal is faster than sliceHorizontal' but consumes slightly more memory 683(although it needs no swapping) 684-} 685{- | 686>>> sliceHorizontal 6 ['a'..'z'] 687["agmsy","bhntz","ciou","djpv","ekqw","flrx"] 688 689prop> \(NonEmpty xs) -> QC.forAll (QC.choose (1, length xs)) $ \n -> sliceHorizontal n xs == transpose (sliceVertical n (xs::String)) 690prop> \(NonEmpty xs) -> QC.forAll (QC.choose (1, length xs)) $ \n -> sliceVertical n xs == transpose (sliceHorizontal n (xs::String)) 691 692The properties do not hold for empty lists because of: 693 694>>> sliceHorizontal 4 ([]::[Int]) 695[[],[],[],[]] 696-} 697sliceHorizontal, sliceHorizontal', sliceHorizontal'', sliceHorizontal''' :: 698 Int -> [a] -> [[a]] 699sliceHorizontal n = 700 map (sieve n) . take n . iterate (drop 1) 701 702-- | prop> \(NonNegative n) xs -> sliceHorizontal n xs == sliceHorizontal' n (xs::String) 703sliceHorizontal' n = 704 foldr (\x ys -> let y = last ys in Match.take ys ((x:y):ys)) (replicate n []) 705 706-- | prop> \(Positive n) xs -> sliceHorizontal n xs == sliceHorizontal'' n (xs::String) 707sliceHorizontal'' n = 708 reverse . foldr (\x ~(y:ys) -> ys ++ [x:y]) (replicate n []) 709 710sliceHorizontal''' n = 711 take n . transpose . takeWhile (not . null) . iterate (drop n) 712 713 714{- | 715>>> sliceVertical 6 ['a'..'z'] 716["abcdef","ghijkl","mnopqr","stuvwx","yz"] 717-} 718sliceVertical, sliceVertical' :: Int -> [a] -> [[a]] 719sliceVertical n = 720 map (take n) . takeWhile (not . null) . iterate (drop n) 721 {- takeWhile must be performed before (map take) 722 in order to handle (n==0) correctly -} 723 724-- | prop> \(NonNegative n) xs -> equating (take 100000) (sliceVertical n xs) (sliceVertical' n (xs::String)) 725sliceVertical' n = 726 unfoldr (\x -> toMaybe (not (null x)) (splitAt n x)) 727 728 729 730 731-- * Search&replace 732 733search :: (Eq a) => [a] -> [a] -> [Int] 734search sub str = findIndices (isPrefixOf sub) (tails str) 735 736{- | 737prop> \(NonEmpty xs) ys -> replace xs xs ys == (ys::String) 738prop> \(NonEmpty xs) (NonEmpty ys) -> equating (take 1000) (replace xs ys (cycle xs)) (cycle (ys::String)) 739-} 740replace :: Eq a => [a] -> [a] -> [a] -> [a] 741replace src dst = 742 let recourse [] = [] 743 recourse str@(s:ss) = 744 fromMaybe 745 (s : recourse ss) 746 (fmap ((dst++) . recourse) $ 747 maybePrefixOf src str) 748 in recourse 749 750markSublists :: (Eq a) => [a] -> [a] -> [Maybe [a]] 751markSublists sub ys = 752 let ~(hd', rest') = 753 foldr (\c ~(hd, rest) -> 754 let xs = c:hd 755 in case maybePrefixOf sub xs of 756 Just suffix -> ([], Nothing : Just suffix : rest) 757 Nothing -> (xs, rest)) ([],[]) ys 758 in Just hd' : rest' 759 760replace' :: (Eq a) => [a] -> [a] -> [a] -> [a] 761replace' src dst xs = 762 concatMap (fromMaybe dst) (markSublists src xs) 763 764{- | This is slightly wrong, because it re-replaces things. 765 That's also the reason for inefficiency: 766 The replacing can go on only when subsequent replacements are finished. 767 Thus this functiob fails on infinite lists. -} 768replace'' :: (Eq a) => [a] -> [a] -> [a] -> [a] 769replace'' src dst = 770 foldr (\x xs -> let y=x:xs 771 in if isPrefixOf src y 772 then dst ++ drop (length src) y 773 else y) [] 774 775{- | 776prop \src dst xs -> replace src dst xs == multiReplace [(src,dst)] (xs::String) 777-} 778multiReplace :: Eq a => [([a], [a])] -> [a] -> [a] 779multiReplace dict = 780 let recourse [] = [] 781 recourse str@(s:ss) = 782 fromMaybe 783 (s : recourse ss) 784 (msum $ 785 map (\(src,dst) -> 786 fmap ((dst++) . recourse) $ 787 maybePrefixOf src str) dict) 788 in recourse 789 790multiReplace' :: Eq a => [([a], [a])] -> [a] -> [a] 791multiReplace' dict = 792 let recourse [] = [] 793 recourse str@(s:ss) = 794 maybe 795 (s : recourse ss) 796 (\(src, dst) -> dst ++ recourse (Match.drop src str)) 797 (find (flip isPrefixOf str . fst) dict) 798 in recourse 799 800 801-- * Lists of lists 802 803{- | 804Transform 805 806> [[00,01,02,...], [[00], 807> [10,11,12,...], --> [10,01], 808> [20,21,22,...], [20,11,02], 809> ...] ...] 810 811With @concat . shear@ you can perform a Cantor diagonalization, 812that is an enumeration of all elements of the sub-lists 813where each element is reachable within a finite number of steps. 814It is also useful for polynomial multiplication (convolution). 815-} 816shear :: [[a]] -> [[a]] 817shear = 818 map catMaybes . 819 shearTranspose . 820 transposeFill 821 822transposeFill :: [[a]] -> [[Maybe a]] 823transposeFill = 824 unfoldr (\xs -> 825 toMaybe (not (null xs)) 826 (mapSnd (Rev.dropWhile null) $ unzipCons xs)) 827 828unzipCons :: [[a]] -> ([Maybe a], [[a]]) 829unzipCons = 830 unzip . 831 map ((\my -> (fmap fst my, maybe [] snd my)) . viewL) 832 833{- | 834It's somehow inverse to zipCons, 835but the difficult part is, 836that a trailing empty list on the right side is suppressed. 837-} 838unzipConsSkew :: [[a]] -> ([Maybe a], [[a]]) 839unzipConsSkew = 840 let aux [] [] = ([],[]) -- one empty list at the end will be removed 841 aux xs ys = mapSnd (xs:) $ prep ys 842 prep = 843 forcePair . 844 switchL ([],[]) 845 (\y ys -> 846 let my = viewL y 847 in mapFst (fmap fst my :) $ 848 aux (maybe [] snd my) ys) 849 in prep 850 851 852 853shear' :: [[a]] -> [[a]] 854shear' xs@(_:_) = 855 let (y:ys,zs) = unzip (map (splitAt 1) xs) 856 zipConc (a:as) (b:bs) = (a++b) : zipConc as bs 857 zipConc [] bs = bs 858 zipConc as [] = as 859 in y : zipConc ys (shear' (Rev.dropWhile null zs)) 860 {- Dropping trailing empty lists is necessary, 861 otherwise finite lists are filled with empty lists. -} 862shear' [] = [] 863 864{- | 865Transform 866 867> [[00,01,02,...], [[00], 868> [10,11,12,...], --> [01,10], 869> [20,21,22,...], [02,11,20], 870> ...] ...] 871 872It's like 'shear' but the order of elements in the sub list is reversed. 873Its implementation seems to be more efficient than that of 'shear'. 874If the order does not matter, better choose 'shearTranspose'. 875 876prop> \xs -> shearTranspose xs == map reverse (shear (xs::[String])) 877-} 878shearTranspose :: [[a]] -> [[a]] 879shearTranspose = 880 foldr zipConsSkew [] 881 882zipConsSkew :: [a] -> [[a]] -> [[a]] 883zipConsSkew xt yss = 884 uncurry (:) $ 885 case xt of 886 x:xs -> ([x], zipCons xs yss) 887 [] -> ([], yss) 888 889{- | 890zipCons is like @zipWith (:)@ but it keeps lists which are too long 891This version works also for @zipCons something undefined@. 892-} 893zipCons :: [a] -> [[a]] -> [[a]] 894zipCons (x:xs) yt = 895 let (y,ys) = switchL ([],[]) (,) yt 896 in (x:y) : zipCons xs ys 897zipCons [] ys = ys 898 899-- | zipCons' is like @zipWith (:)@ but it keeps lists which are too long 900zipCons' :: [a] -> [[a]] -> [[a]] 901zipCons' (x:xs) (y:ys) = (x:y) : zipCons' xs ys 902zipCons' [] ys = ys 903zipCons' xs [] = map (:[]) xs 904 905 906{- | 907Operate on each combination of elements of the first and the second list. 908In contrast to the list instance of 'Monad.liftM2' 909it holds the results in a list of lists. 910 911prop> \xs ys -> let f x y = (x::Char,y::Int) in concat (outerProduct f xs ys) == liftM2 f xs ys 912-} 913outerProduct :: (a -> b -> c) -> [a] -> [b] -> [[c]] 914outerProduct f xs ys = map (flip map ys . f) xs 915 916 917 918-- * Miscellaneous 919 920{- | 921Take while first predicate holds, 922then continue taking while second predicate holds, 923and so on. 924-} 925takeWhileMulti :: [a -> Bool] -> [a] -> [a] 926takeWhileMulti [] _ = [] 927takeWhileMulti _ [] = [] 928takeWhileMulti aps@(p:ps) axs@(x:xs) = 929 if p x 930 then x : takeWhileMulti aps xs 931 else takeWhileMulti ps axs 932 933{- | 934prop> \ys xs -> let ps = map (<=) ys in takeWhileMulti ps xs == takeWhileMulti' ps (xs::String) 935-} 936takeWhileMulti' :: [a -> Bool] -> [a] -> [a] 937takeWhileMulti' ps xs = 938 concatMap fst (tail 939 (scanl (flip span . snd) (undefined,xs) ps)) 940 941{- 942Debug.QuickCheck.quickCheck (propTakeWhileMulti [(<0), (>0), odd, even, ((0::Int)==)]) 943-} 944 945{- | 946This is a combination of 'foldl'' and 'foldr' 947in the sense of 'propFoldl'r'. 948It is however more efficient 949because it avoids storing the whole input list as a result of sharing. 950-} 951foldl'r, foldl'rStrict, foldl'rNaive :: 952 (b -> a -> b) -> b -> (c -> d -> d) -> d -> [(a,c)] -> (b,d) 953foldl'r f b0 g d0 = 954-- (\(k,d1) -> (k b0, d1)) . 955 mapFst ($b0) . 956 foldr (\(a,c) ~(k,d) -> (\b -> k $! f b a, g c d)) (id,d0) 957 958foldl'rStrict f b0 g d0 = 959 mapFst ($b0) . 960 foldr (\(a,c) ~(k,d) -> ((,) $! (\b -> k $! f b a)) $! g c d) (id,d0) 961 962foldl'rNaive f b g d xs = 963 mapPair (foldl' f b, foldr g d) $ unzip xs 964 965propFoldl'r :: (Eq b, Eq d) => 966 (b -> a -> b) -> b -> (c -> d -> d) -> d -> [(a,c)] -> Bool 967propFoldl'r f b g d xs = 968 foldl'r f b g d xs == foldl'rNaive f b g d xs 969 970{- 971The results in GHCi surprise: 972 973*List.HT> mapSnd last $ foldl'rNaive (+) (0::Integer) (:) "" $ replicate 1000000 (1,'a') 974(1000000,'a') 975(0.44 secs, 141032856 bytes) 976 977*List.HT> mapSnd last $ foldl'r (+) (0::Integer) (:) "" $ replicate 1000000 (1,'a') 978(1000000,'a') 979(2.64 secs, 237424948 bytes) 980-} 981 982{- 983Debug.QuickCheck.quickCheck (\b d -> propFoldl'r (+) (b::Int) (++) (d::[Int])) 984-} 985 986 987{- | 988>>> lengthAtLeast 0 "" 989True 990>>> lengthAtLeast 3 "ab" 991False 992>>> lengthAtLeast 3 "abc" 993True 994>>> lengthAtLeast 3 $ repeat 'a' 995True 996>>> lengthAtLeast 3 $ "abc" ++ undefined 997True 998 999prop> \n xs -> lengthAtLeast n (xs::String) == (length xs >= n) 1000-} 1001lengthAtLeast :: Int -> [a] -> Bool 1002lengthAtLeast n = 1003 if n<=0 1004 then const True 1005 else not . null . drop (n-1) 1006 1007{- | 1008>>> lengthAtMost 0 "" 1009True 1010>>> lengthAtMost 3 "ab" 1011True 1012>>> lengthAtMost 3 "abc" 1013True 1014>>> lengthAtMost 3 "abcd" 1015False 1016>>> lengthAtMost 3 $ repeat 'a' 1017False 1018>>> lengthAtMost 3 $ "abcd" ++ undefined 1019False 1020 1021prop> \n xs -> lengthAtMost n (xs::String) == (length xs <= n) 1022-} 1023lengthAtMost :: Int -> [a] -> Bool 1024lengthAtMost n = 1025 if n<0 1026 then const False 1027 else null . drop n 1028 1029{- | 1030prop> \n xs -> lengthAtMost0 n (xs::String) == (length xs <= n) 1031-} 1032lengthAtMost0 :: Int -> [a] -> Bool 1033lengthAtMost0 n = (n>=) . length . take (n+1) 1034 1035{- 1036Iterate until elements start to cycle. 1037This implementation is inspired by Elements of Programming 1038but I am still not satisfied 1039where the iteration actually stops. 1040-} 1041iterateUntilCycle :: (Eq a) => (a -> a) -> a -> [a] 1042iterateUntilCycle f a = 1043 let as = iterate f a 1044 in (a:) $ map fst $ 1045 takeWhile (uncurry (/=)) $ 1046 zip (tail as) (concatMap (\ai->[ai,ai]) as) 1047 1048{- 1049iterateUntilCycleQ :: (Eq a) => (a -> a) -> a -> [a] 1050iterateUntilCycleQ f a = 1051 let as = tail $ iterate f a 1052 in (a:) $ map fst $ 1053 takeWhile (uncurry (/=)) $ 1054 zip as (downsample2 (tail as)) 1055-} 1056 1057iterateUntilCycleP :: (Eq a) => (a -> a) -> a -> [a] 1058iterateUntilCycleP f a = 1059 let as = iterate f a 1060 in map fst $ 1061 takeWhile (\(a1,(a20,a21)) -> a1/=a20 && a1/=a21) $ 1062 zip as (pairs (tail as)) 1063 1064pairs :: [t] -> [(t, t)] 1065pairs [] = [] 1066pairs (_:[]) = error "pairs: odd number of elements" 1067pairs (x0:x1:xs) = (x0,x1) : pairs xs 1068 1069 1070{- | rotate left -} 1071rotate, rotate', rotate'' :: Int -> [a] -> [a] 1072rotate n x = 1073 Match.take x (drop (mod n (length x)) (cycle x)) 1074 1075{- | more efficient implementation of rotate' 1076 1077prop> \(NonNegative n) (NonEmpty xs) -> rotate n xs == rotate' n (xs::String) 1078-} 1079rotate' n x = 1080 uncurry (flip (++)) 1081 (splitAt (mod n (length x)) x) 1082 1083{- | 1084prop> \(NonNegative n) xs -> rotate n xs == rotate'' n (xs::String) 1085-} 1086rotate'' n x = 1087 Match.take x (drop n (cycle x)) 1088 1089{- | 1090Given two lists that are ordered 1091(i.e. @p x y@ holds for subsequent @x@ and @y@) 1092'mergeBy' them into a list that is ordered, again. 1093 1094>>> mergeBy (<=) "agh" "begz" 1095"abegghz" 1096-} 1097mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] 1098mergeBy = Key.mergeBy 1099 1100 1101{- | 1102>>> allEqual "aab" 1103False 1104>>> allEqual "aaa" 1105True 1106>>> allEqual "aa" 1107True 1108>>> allEqual "a" 1109True 1110>>> allEqual "" 1111True 1112-} 1113allEqual :: Eq a => [a] -> Bool 1114allEqual = and . mapAdjacent (==) 1115 1116{- | 1117>>> isAscending "abc" 1118True 1119>>> isAscending "abb" 1120True 1121>>> isAscending "aba" 1122False 1123>>> isAscending "cba" 1124False 1125>>> isAscending "a" 1126True 1127>>> isAscending "" 1128True 1129-} 1130isAscending :: (Ord a) => [a] -> Bool 1131isAscending = and . isAscendingLazy 1132 1133isAscendingLazy :: (Ord a) => [a] -> [Bool] 1134isAscendingLazy = mapAdjacent (<=) 1135 1136{- | 1137This function combines every pair of neighbour elements 1138in a list with a certain function. 1139 1140>>> mapAdjacent (<=) "" 1141[] 1142>>> mapAdjacent (<=) "a" 1143[] 1144>>> mapAdjacent (<=) "aba" 1145[True,False] 1146>>> mapAdjacent (,) "abc" 1147[('a','b'),('b','c')] 1148 1149prop> \x xs -> mapAdjacent subtract (scanl (+) x xs) == (xs::[Integer]) 1150-} 1151mapAdjacent :: (a -> a -> b) -> [a] -> [b] 1152mapAdjacent f xs = zipWith f xs (tail xs) 1153 1154{- | 1155<http://mail.haskell.org/libraries/2016-April/026912.html> 1156 1157prop> \xs -> mapAdjacent (,) xs == mapAdjacentPointfree (,) (xs::String) 1158-} 1159mapAdjacentPointfree :: (a -> a -> b) -> [a] -> [b] 1160mapAdjacentPointfree f = zipWith f <*> tail 1161 1162 1163{- | 1164>>> let f x y z = [x,y]++show(z::Int) in mapAdjacent1 f 'a' [('b',1), ('c',2), ('d',3)] 1165["ab1","bc2","cd3"] 1166-} 1167mapAdjacent1 :: (a -> a -> b -> c) -> a -> [(a,b)] -> [c] 1168mapAdjacent1 f a xs = 1169 zipWith (\a0 (a1,b) -> f a0 a1 b) (a : map fst xs) xs 1170 1171 1172{- | 1173Enumerate without Enum context. 1174For Enum equivalent to enumFrom. 1175 1176>>> range 0 :: [Integer] 1177[] 1178>>> range 1 :: [Integer] 1179[0] 1180>>> range 8 :: [Integer] 1181[0,1,2,3,4,5,6,7] 1182 1183prop> \(NonNegative n) -> length (range n :: [Integer]) == n 1184-} 1185range :: Num a => Int -> [a] 1186range n = take n (iterate (+1) 0) 1187 1188 1189{-# INLINE padLeft #-} 1190padLeft :: a -> Int -> [a] -> [a] 1191padLeft c n xs = replicate (n - length xs) c ++ xs 1192 1193 1194{-# INLINE padRight #-} 1195padRight, padRight1 :: a -> Int -> [a] -> [a] 1196padRight c n xs = take n $ xs ++ repeat c 1197padRight1 c n xs = xs ++ replicate (n - length xs) c 1198 1199{- | 1200For an associative operation @op@ this computes 1201 @iterateAssociative op a = iterate (op a) a@ 1202but it is even faster than @map (powerAssociative op a a) [0..]@ 1203since it shares temporary results. 1204 1205The idea is: 1206From the list @map (powerAssociative op a a) [0,(2*n)..]@ 1207we compute the list @map (powerAssociative op a a) [0,n..]@, 1208and iterate that until @n==1@. 1209 1210prop> \x -> equating (take 1000) (List.iterate (x+) x) (iterateAssociative (+) (x::Integer)) 1211-} 1212iterateAssociative :: (a -> a -> a) -> a -> [a] 1213iterateAssociative op a = 1214 foldr (\pow xs -> pow : concatMap (\x -> [x, op x pow]) xs) 1215 undefined (iterate (\x -> op x x) a) 1216 1217{- | 1218This is equal to 'iterateAssociative'. 1219The idea is the following: 1220The list we search is the fixpoint of the function: 1221"Square all elements of the list, 1222then spread it and fill the holes with successive numbers 1223of their left neighbour." 1224This also preserves log n applications per value. 1225However it has a space leak, 1226because for the value with index @n@ 1227all elements starting at @div n 2@ must be kept. 1228 1229prop> \x -> equating (take 1000) (List.iterate (x+) x) (iterateLeaky (+) (x::Integer)) 1230-} 1231iterateLeaky :: (a -> a -> a) -> a -> [a] 1232iterateLeaky op x = 1233 let merge (a:as) b = a : merge b as 1234 merge _ _ = error "iterateLeaky: an empty list cannot occur" 1235 sqrs = map (\y -> op y y) z 1236 z = x : merge sqrs (map (op x) sqrs) 1237 in z 1238