recursionSchemes.hs

{-# LANGUAGE 
    DeriveGeneric
  , DeriveDataTypeable
  , DeriveFunctor
  , ScopedTypeVariables
  , StandaloneDeriving 
  , UndecidableInstances #-}
module RecursionSchemes where

import Data.List
import Data.Data
import Data.Maybe (fromMaybe)
import GHC.Generics
import Test.QuickCheck


--------------------
-- List Morphisms --
--------------------

-- Catamorphism
-- Anamorphism
-- Hylomorphism
-- Paramorphism


-- Catamorphism:
cataL :: (a -> b -> b) -> b -> [a] -> b
cataL _ b [] = b
cataL f b (a:as) = a `f` cataL f b as

lengthL :: [a] -> Int
lengthL = cataL (\a b -> 1 + b) 0

filterL :: (a -> Bool) -> [a] -> [a]
filterL p = cataL (\a b -> if p a then a : b else b) []


-- Anamorphism:
anaL :: (b -> Bool) -> (b -> (a, b)) -> b -> [a]
anaL p g b =
    if p b then [] else a : anaL p g b'
    where (a, b') = g b

zipL :: (Eq a, Eq b) => ([a], [b]) -> [(a,b)]
zipL = anaL p g
    where p (as, bs) = (as == []) || (bs == [])
          g (x : xs, y : ys) = ((x,y), (xs, ys))

iterateL :: (a -> a) -> a -> [a]
iterateL f a = anaL p g a
    where p _ = False
          g a' = (a', f a')

mapL :: (a -> b) -> [a] -> [b]
mapL f as = anaL p g as
    where p xs = length xs == 0
          g (x:xs) = (f x, xs)


-- Hylomorphism
hyloL :: c -> (b -> c -> c) -> (a -> (b, a)) -> (a -> Bool) -> a -> c
hyloL c f g p a = 
    if p a then c else b `f` hyloL c f g p a'
    where (b, a') = g a

facL = hyloL 1 (*) g p
    where g n = (n, n-1)
          p n = n == 0


-- Paramorphism
data Nat' = Z | S Nat' deriving (Show, Eq)

addNat :: Nat' -> Nat' -> Nat'
addNat Z b = b
addNat (S a) b = S (addNat a b)

multNat :: Nat' -> Nat' -> Nat'
multNat a b = go a b
    where go (S Z) y = y
          go (S x) y = go x (addNat b y)
          go Z y = Z


paraL :: (Nat' -> b -> b) -> b -> Nat' -> b
paraL f b Z = b
paraL f b (S n) = n `f` paraL f b n

paraLFac :: Nat' -> Nat'
paraLFac = paraL f b
    where f n acc =  S n `multNat` acc
          b = S Z

------------------------------
---- Fixed Point Operator ----
------------------------------

-- In order to make recursion explicit, we use:
-- µ ∈ (A -> A) -> A 
-- µ f = x where x = f x
u :: (a -> a) -> a
u f = x where x = f x
u f = let x = f x in x

-- Least Fixed Point Recursion Example:
len xs = if null xs then 0 else 1 + len (tail xs)

len' :: Eq a => [a] -> Int
len' = u (\rec xs -> if null xs then 0 else 1 + rec (tail xs))


--------------------------------
---- Haskell Implementation ----
--------------------------------

newtype Fix f = Fix (f (Fix f)) deriving (Generic, Typeable)

deriving instance Show (f (Fix f)) => Show (Fix f)

fix :: f (Fix f) -> Fix f
fix = Fix

unfix :: Fix f -> f (Fix f)
unfix (Fix f) = f

genCata :: Functor f => (f a -> a) -> (Fix f -> a)
genCata alg = alg . fmap (genCata alg) . unfix

genAna :: Functor f => (a -> f a) -> a -> Fix f
genAna coAlg = fix . fmap (genAna coAlg) . coAlg

genHylo :: Functor f => (f b -> b) -> (a -> f a) -> a -> b
genHylo phi psi = genCata phi . genAna psi


----------------------
---- List Example ----
----------------------

--data List a = Nil | Cons a (List a)

type List a = Fix (ListF a)
data ListF a x = NilF | ConsF a x deriving (Functor, Show)

nil :: List a
nil = Fix NilF

cons :: a -> List a -> List a
cons x xs = Fix $ ConsF x xs

headF :: List a -> a
headF (Fix (ConsF x xs)) = x

tailF :: List a -> List a
tailF (Fix (ConsF x xs)) = xs

listLengthCata :: Num p => List a -> p
listLengthCata = genCata alg
    where alg :: Num p => ListF a p -> p
          alg NilF = 0
          alg (ConsF _ n) = n + 1

listSumCata :: Num a => List a -> a
listSumCata = genCata alg
    where alg :: Num a => ListF a a -> a
          alg NilF = 0
          alg (ConsF a r) = a + r

listFilterCata :: (a -> Bool) -> List a -> List a
listFilterCata p = genCata (alg p)
    where alg :: (a -> Bool) -> ListF a (List a) -> List a
          alg _ NilF =  nil
          alg p (ConsF a r) = if p a then cons a r else r

listFoldCata :: Monoid a => List a -> a
listFoldCata = genCata alg
    where alg :: Monoid a => ListF a a -> a
          alg NilF = mempty
          alg (ConsF a r) = a `mappend` r

listFoldrCata :: forall a b. (a -> b -> b) -> b -> List a -> b
listFoldrCata f b = genCata (alg f b)
    where alg :: (a -> b -> b) -> b -> ListF a b -> b
          alg _ b' NilF = b
          alg f' _ (ConsF a r) = f a r

listMapCata :: (a -> b) -> List a -> List b
listMapCata f = genCata (alg f)
    where alg :: (a -> b) -> ListF a (List b) -> List b
          alg _ NilF = nil
          alg f' (ConsF a r) = f' a `cons` r

replicateAna :: Int -> a -> List a
replicateAna n a = genAna coalg n
    where coalg 0 = NilF
          coalg n' = ConsF a (n' - 1)

concatCata :: forall a. List a -> List a -> List a
concatCata xs ys = genCata alg xs
    where alg :: ListF a (List a) -> List a
          alg NilF = ys
          alg (ConsF a r) = cons a ys

splitAtCata :: forall a. List a -> Nat -> (List a, List a)
splitAtCata xs = genCata alg
    where alg :: NatF (List a, List a) -> (List a, List a)
          alg ZF = (nil, xs)
          alg (SF (x, as)) = (concatCata x (cons (headF as) nil), tailF as) 

dropCata :: forall a. Nat -> List a -> List a
dropCata z xs = genCata alg z
    where alg :: NatF (List a) -> List a
          alg ZF = xs
          alg (SF ys) = tailF ys

-- TODO: Fix Dis!
takeCata :: forall a. Nat -> List a -> List a
takeCata z xs = genCata alg z
    where alg :: NatF (List a) -> List a
          alg ZF = nil
          alg (SF ys) = cons (headF ys) xs


fromL :: [a] -> Fix (ListF a)
fromL = foldr (\a b -> Fix (ConsF a b)) (Fix NilF)

toL :: List a -> [a]
toL = genCata alg
    where alg :: ListF a [a] -> [a]
          alg NilF = []
          alg (ConsF a as) = a : as
  

-----------------------
---- Peano Numbers ----
-----------------------

type Nat = Fix NatF 
data NatF x = ZF | SF x deriving (Functor, Show)

zero :: Nat
zero = Fix ZF

suc :: Nat -> Nat
suc n = Fix (SF n)

fromI :: Integer -> Nat
fromI 0 = zero
fromI n = suc (fromI (n-1))

toI :: Nat -> Integer
toI = genCata coalg
    where coalg ZF = 0
          coalg (SF i) = i+1


-----------------------------
---- Binary Tree Example ----
-----------------------------

--data BinTree' a = Leaf | Branch (BinTree' a) a (BinTree' a) deriving Show

type BinTree a = Fix (BinTreeF a)
data BinTreeF a x = LeafF | BranchF x a x deriving (Functor, Show)

leaf :: BinTree a
leaf = Fix LeafF

branch :: BinTree a -> a -> BinTree a -> BinTree a
branch l a r = Fix (BranchF l a r)

treeSumCata :: Num a => BinTree a -> a
treeSumCata = genCata alg
    where alg LeafF = 0
          alg (BranchF l a r) = l + a + r

-- TODO: Fix Dis!
--factorTreeCoAlg :: [Integer] -> Integer -> BinTreeF Integer Integer
--factorTreeCoAlg primes 0 = LeafF
--factorTreeCoAlg primes 1 = LeafF
--factorTreeCoAlg primes n 
--    | n `elem` primes = LeafF
--    | otherwise = BranchF left n right
--    where left = fromMaybe 1 (find (\a -> n `mod` a == 0 && n /= a) primes)
--          right = n `div` right
--
--factorTreeAna n = genAna (factorTreeCoAlg primes) n
--    where primes = takeWhileS (\x -> x <= (n `div` 2)) $ sieveAna [2..]

--fromT :: BinTree' a -> BinTree a
--fromT Leaf = Fix LeafF
--fromT (Branch l a r) = Fix (BranchF (fromT l) a (fromT r))

--toT :: BinTree a -> BinTree' a
--toT =
--    genCata (\case
--        LeafF -> Leaf
--        BranchF l a r -> Branch l a r)

------------------------------
---- General Tree Example ----
------------------------------

--data GenTree a = GenLeaf | GenBranch a [GenTree a] deriving Show

type GenTree a = Fix (GenTreeF a)
data GenTreeF a x = GenLeafF | GenBranchF a [x] deriving (Functor, Show)

genLeaf :: GenTree a
genLeaf = Fix GenLeafF

genBranch :: a -> [GenTree a] -> GenTree a
genBranch a ts = Fix (GenBranchF a ts)

genTreeSumCata :: Num a => GenTree a -> a
genTreeSumCata = genCata alg
    where alg GenLeafF = 0
          alg (GenBranchF x xs) = x + sum xs

--toGT :: Fix (GenTreeF a) -> GenTree a
--toGT = 
--    genCata (\case
--        GenLeafF -> GenLeaf
--        GenBranchF x xs -> GenBranch x xs)

--fromGT :: GenTree a -> Fix (GenTreeF a)
--fromGT GenLeaf = Fix GenLeafF
--fromGT (GenBranch x xs) = Fix (GenBranchF x (fmap fromGT xs))


------------------------
---- Stream Example ----
------------------------

--data Stream a = Stream a (Stream a) deriving Show

type Stream a = Fix (StreamF a)
data StreamF a x = StreamF a x deriving (Functor, Show)

stream :: a -> Stream a
stream a = fix (StreamF a (stream a))

-- TODO: Rewrite take and takeWhile using recursion schemes:
takeS :: Int -> Stream a -> [a]
takeS 0 s = []
takeS n s =
    let (StreamF a as) = unfix s
    in a : takeS (n - 1) as
--takeS n (Fix (StreamF a as)) = a : takeS (n-1) as

takeWhileS :: (a -> Bool) -> Stream a -> [a]
takeWhileS p s =
    let (StreamF a as) = unfix s
    in if p a then a : takeWhileS p as else []

countAna :: Integer -> Stream Integer
countAna = genAna coalg
    where coalg :: Integer -> StreamF Integer Integer
          coalg n = StreamF n (n + 1)

fibAna :: (Integer, Integer) -> Stream (Integer, Integer)
fibAna = genAna coalg
    where coalg :: (Integer, Integer) -> StreamF (Integer, Integer) (Integer, Integer)
          coalg (n, m) = StreamF (n, m) (m, m + n)

-- TODO: Test performance of sievaAna
sieveAna :: [Integer] -> Stream Integer
sieveAna = genAna coalg
    where coalg :: [Integer] -> StreamF Integer [Integer]
          coalg (p:ps) = StreamF p (filter (\x -> x `mod` p /= 0) ps)

--fromS :: Stream a -> Fix (StreamF a)
--fromS (Stream a as) = Fix (StreamF a (fromS as))

--toS :: Fix (StreamF a) -> Stream a
--toS = genCata (\(StreamF a x) -> Stream a x)