{- Exploring Languages with Interprters and Functional Programming
Chapter 17: Higher-Order Function Examples
Copyright (C) 2018, H. Conrad Cunningham
1234567890123456789012345678901234567890123456789012345678901234567890
2018-07-11: Revised for 2018 textbook Chapter 17
2018-10-23: Fixed bug in msort program (single element list)
-}
module HigherOrderExamples
where
-- List-breaking functions
takeWhile':: (a -> Bool) -> [a] -> [a] -- takeWhile in Prelude
takeWhile' p [] = []
takeWhile' p (x:xs)
| p x = x : takeWhile' p xs
| otherwise = []
dropWhile' :: (a -> Bool) -> [a] -> [a] -- dropWhile in Prelude
dropWhile' p [] = []
dropWhile' p xs@(x:xs')
| p x = dropWhile' p xs'
| otherwise = xs
span' :: (a -> Bool) -> [a] -> ([a],[a]) -- span in Prelude
span' _ xs@[] = (xs, xs)
span' p xs@(x:xs')
| p x = let (ys,zs) = span' p xs' in (x:ys,zs)
| otherwise = ([],xs)
break' :: (a -> Bool) -> [a] -> ([a],[a]) -- break in Prelude
break' p = span (not . p)
-- List-combining functions
zipWith' :: (a->b->c) -> [a]->[b]->[c] -- zipWith in Prelude
zipWith' z (x:xs) (y:ys) = z x y : zipWith' z xs ys
zipWith' _ _ _ = []
zip'' :: [a] -> [b] -> [(a,b)]
zip'' = zipWith' (\x y -> (x,y))
zip''' :: [a] -> [b] -> [(a,b)]
zip''' = zipWith' (,)
sp :: Num a => [a] -> [a] -> a
sp xs ys = sum (zipWith' (*) xs ys)
-- Merge sort
msort :: Ord a => (a -> a -> Bool) -> [a] -> [a]
msort _ [] = []
msort _ [x] = [x]
msort less xs = merge less (msort less ls) (msort less rs)
where n = (length xs) `div` 2
(ls,rs) = splitAt n xs
merge _ [] ys = ys
merge _ xs [] = xs
merge less ls@(x:xs) rs@(y:ys)
| less x y = x : (merge less xs rs)
| otherwise = y : (merge less ls ys)
descendSort :: Ord a => [a] -> [a]
descendSort = msort (\ x y -> x > y) -- or (>)
-- Playing around with a generalized merge
gmerge :: Ord d =>
(a -> d) -> -- keya
(b -> d) -> -- keyb
[c] -> -- e1
([b] -> [c]) -> -- e2
([a] -> [c]) -> -- e3
(a -> b -> [c]) -> -- f4
(a -> b -> [c]) -> -- f5
(a -> b -> [c]) -> -- f6
([a] -> [a]) -> -- g4
([a] -> [a]) -> -- g5
([a] -> [a]) -> -- g6
([b] -> [b]) -> -- h4
([b] -> [b]) -> -- h5
([b] -> [b]) -> -- h6
[a] -> [b] -> [c]
gmerge keya keyb e1 e2 e3 f4 f5 f6 g4 g5 g6 h4 h5 h6
= gmerge'
where
gmerge' [] [] = e1
gmerge' [] bs@(y:ys) = e2 bs
gmerge' as@(x:xs) [] = e3 as
gmerge' as@(x:xs) bs@(y:ys)
| keya x < keyb y = f4 x y ++ gmerge' (g4 as) (h4 bs)
| keya x == keyb y = f5 x y ++ gmerge' (g5 as) (h5 bs)
| keya x > keyb y = f6 x y ++ gmerge' (g6 as) (h6 bs)
merge1 :: Ord a => [a] -> [a] -> [a]
merge1 [] [] = []
merge1 [] bs@(y:ys) = bs
merge1 as@(x:xs) [] = as
merge1 as@(x:xs) bs@(y:ys)
| x < y = x : merge1 xs bs
| x == y = x : merge1 xs bs
| x > y = y : merge1 as ys
merge2 :: Ord a => [a] -> [a] -> [a]
merge2 [] bs = bs
merge2 as [] = as
merge2 as@(x:xs) bs@(y:ys)
| x <= y = x : merge2 xs bs
| x > y = y : merge2 as ys
intersect :: Ord a => [a] -> [a] -> [a]
intersect [] _ = [] -- discard any remaining
intersect _ [] = [] -- discard any remaining
intersect as@(x:xs) bs@(y:ys)
| x == y = x : intersect xs ys -- keep match
| x < y = intersect xs bs -- discard smaller
| x > y = intersect as ys -- discard smaller
merge1' :: Ord a => [a] -> [a] -> [a]
merge1' = gmerge id id -- keya, keyb
[] id id -- e1, e2, e3
(const . (:[])) -- f4
(const . (:[])) -- f5
(flip (const . (:[]))) -- f6
tail tail id -- g4, g5, g6
id id tail -- h4, h5, h6
intersect' :: Ord a => [a] -> [a] -> [a]
intersect' = gmerge id id -- keya, keyb
[] (const []) (const []) -- e1, e2, e3
(\ x y -> []) -- f4
(const . (:[])) -- f5
(\ x y -> []) -- f6
tail tail id -- g4, g5, g6
id tail tail -- h4, h5, h6