morphisms.hs

import Data.List
import Test.QuickCheck
import Test.QuickCheck.Checkers

-- catamorphisms
cata :: b -> (a -> b -> b) -> [a] -> b
cata b f []     = b
cata b f (a:as) = f a (cata b f as)

cataLength :: [a] -> Int
cataLength = cata 0 (<+>)
  where a <+> n = 1 + n

cataFilter p = cata [] (<+>)
  where a <+> as
          | p a       = a:as
          | otherwise = as

-- anamorphisms
ana :: (b -> (a, b)) -> (b -> Bool) -> b -> [a]
ana g p b
  | p b       = []
  | otherwise = a:ana g p b'
  where (a, b') = g b

anaZip :: [a] -> [b] -> [(a, b)]
anaZip = curry (ana g p)
  where p ([], _) = True
        p (_, []) = True
        p _       = False
        g ((a:as), (b:bs)) = ((a, b), (as, bs))

anaIterate :: (a -> a) -> a -> [a]
anaIterate f = ana g (const False)
  where g a = (a, f a)

map' :: (a -> b) -> [a] -> [b]
map' f []     = []
map' f (a:as) = f a:map' f as

cataMap :: (a -> b) -> [a] -> [b]
cataMap f = cata [] (<+>)
  where a <+> bs = (f a):bs

anaMap :: (a -> b) -> [a] -> [b]
anaMap f = ana g p
  where p []     = True
        p _      = False
        g (a:as) = (f a, as)

-- Hylomorphisms
hylo c f g p a
  | p a       = c
  | otherwise = f b (hylo c f g p a')
  where (b, a') = g a

fac :: Int -> Int
fac 0       = 1
fac (n + 1) = (n + 1) * fac n
                  
hyloFac :: Int -> Int
hyloFac = hylo 1 (*) g p
  where p n       = n == 0
        g (n + 1) = (1 + n, n)

-- Paramorphisms
numPara b f 0       = b
numPara b f (n + 1) = f n (numPara b f n)

listPara b f []     = b
listPara b f (a:as) = f a (as, listPara b f as)

paraFac :: Int -> Int
paraFac = numPara 1 f
  where f n m = (1 + n) * m

paraTails :: [a] -> [[a]]
paraTails = listPara ([]:[]) f
  where f a (as, tls) = (a:as):tls

-- Tests
prop_cataLength :: [Int] -> Bool
prop_cataLength xs = length xs == cataLength xs

prop_cataFilter :: Int -> [Int] -> Bool
prop_cataFilter x xs = filter p xs == cataFilter p xs
  where p = (== x)

prop_anaZip :: [Int] -> [Int] -> Bool
prop_anaZip xs ys = zip xs ys == anaZip xs ys

prop_anaIterate :: Int -> Int -> Bool
prop_anaIterate x y = and $ take 100 $ zipWith (==) (iterate (+x) y) (anaIterate (+x) y)

prop_map' :: [Int] -> Int -> Bool
prop_map' xs y = and $ take 100 $ zipWith (==) (map (+y) xs) (map' (+y) xs)

prop_cataMap :: [Int] -> Int -> Bool
prop_cataMap xs y = and $ take 100 $ zipWith (==) (map (+y) xs) (cataMap (+y) xs)

prop_anaMap :: [Int] -> Int -> Bool
prop_anaMap xs y = and $ take 100 $ zipWith (==) (map (+y) xs)  (anaMap (+y) xs)

prop_hyloFac :: NonNegative Int -> Bool
prop_hyloFac x = fac x' == hyloFac x'
  where NonNegative x' = x

prop_paraFac :: NonNegative Int -> Bool
prop_paraFac x = fac x' == paraFac x'
  where NonNegative x' = x

prop_paraTails :: [Int] -> Bool
prop_paraTails xs = tails xs == paraTails xs

batch :: TestBatch
batch = ( "morphism tests"
        , [ ("catamorphism - length",  property $ prop_cataLength)
          , ("catamorphism - filter",  property $ prop_cataFilter)
          , ("anamorphism  - zip",     property $ prop_anaZip)
          , ("anamorphism  - iterate", property $ prop_anaIterate)
          , ("recursion    - map",     property $ prop_map')
          , ("catamorphism - map",     property $ prop_cataMap)
          , ("anamorphism  - map",     property $ prop_anaMap)
       -- , ("hylomorphism - fac",     property $ prop_hyloFac)
       -- , ("paramorphism - fac",     property $ prop_paraFac)
          , ("paramorphism - tails",   property $ prop_paraTails)
          ]
        )

main = quickBatch batch