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