{-  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