{-# LANGUAGE Rank2Types , MultiParamTypeClasses , FunctionalDependencies , FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Recursion -- Copyright : 2004 Dave Menendez -- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental -- Portability : non-portable (rank-2 polymorphism, fundeps) -- -- Provides implementations of /catamorphisms/ ('fold'), -- /anamorphisms/ ('unfold'), and /hylomorphisms/ ('refold'), -- along with many generalizations implementing various -- forms of iteration and coiteration. -- -- Also provided is a type class for transforming a functor -- to its fixpoint type and back ('Fixpoint'), along with -- standard functors for natural numbers and lists ('ConsPair'), -- and a fixpoint type for arbitrary functors ('Fix'). -- -- Several combinators herein ((g_)futu, (g_)chrono, refoldWith, ...) -- are due to substantial help by Edward Kmett. -- ----------------------------------------------------------------------------- module Control.Recursion ( -- * Folding fold , para , zygo , histo , g_histo , foldWith -- * Unfolding , unfold , apo , g_apo , unfoldWith , futu , g_futu -- * Transforming , refold , refoldWith , chrono , g_chrono -- * Dynamic Programming , dyna , g_dyna , codyna , g_codyna -- * Functor fixpoints , Fixpoint(..) , Fix(..) , ConsPair(..) , cons ) where ---- import Control.Arrow import Control.Functor import Control.Monad.Identity import Control.Monad.Free import Control.Comonad import Control.Comonad.Cofree class Functor f => Fixpoint f t | t -> f where inF :: f t -> t -- ^ formally, @in[f]: f -> mu f@ outF :: t -> f t -- ^ formally, @in^-1[f]: mu f -> f@ -- | Creates a fixpoint for any functor. newtype Fix f = In (f (Fix f)) instance Functor f => Fixpoint f (Fix f) where inF = In outF (In f) = f instance Fixpoint Unit () where inF Unit = () outF () = Unit instance Fixpoint Maybe Int where inF Nothing = 0 inF (Just n) = n + 1 outF n | n > 0 = Just (n - 1) | otherwise = Nothing instance Fixpoint Maybe Integer where inF Nothing = 0 inF (Just n) = n + 1 outF n | n > 0 = Just (n - 1) | otherwise = Nothing -- | Fixpoint of lists data ConsPair a b = Nil | Pair a b deriving (Eq, Show) instance Functor (ConsPair a) where fmap _ Nil = Nil fmap f (Pair a b) = Pair a (f b) instance Fixpoint (ConsPair a) [a] where inF Nil = [] inF (Pair a b) = a : b outF [] = Nil outF (x:xs) = Pair x xs -- | Deconstructor for 'ConsPair' cons :: c -> (a -> b -> c) -> (ConsPair a b -> c) cons d _ Nil = d cons _ f (Pair a b) = f a b {-| A generalized @map@, known formally as a /hylomorphism/ and written [| f, g |]. @ refold f g == 'fold' f . 'unfold' g @ -} refold :: Functor f => (f b -> b) -> (a -> f a) -> a -> b refold f g = f . fmap (refold f g) . g {-| A generalized @foldr@, known formally as a /catmorphism/ and written (| f |). @ fold f == 'refold' f 'outF' fold f == 'foldWith' ('Identity' . fmap 'runIdentity') (f . fmap 'runIdentity') @ -} fold :: Fixpoint f t => (f a -> a) -> t -> a fold f = refold f outF {-| A generalized @unfoldr@, known formally as an /anamorphism/ and written [( f )]. @ unfold f == 'refold' 'inF' f unfold f == 'unfoldWith' (fmap 'Identity' . 'unIdentity') (fmap 'Identity' . f) @ -} unfold :: Fixpoint f t => (a -> f a) -> a -> t unfold f = refold inF f {-| A variant of 'fold' where the function /f/ also receives the result of the inner recursive calls. Formally known as a /paramorphism/ and written \<| f |\>. Dual to 'apo'. @ para == 'zygo' 'inF' para f == 'refold' f (fmap (id &&& id) . 'outF') para f == f . fmap (id &&& para f) . 'outF' @ Example: Computing the factorials. > fact :: Integer -> Integer > fact = para g > where > g Nothing = 1 > g (Just (n,f)) = f * (n + 1) * For the base case 0!, @g@ is passed @Nothing@. (Note that @'inF' Nothing == 0@.) * For subsequent cases (/n/+1)!, @g@ is passed /n/ and /n/!. (Note that @'inF' (Just n) == n + 1@.) Point-free version: @fact = para $ maybe 1 (uncurry (*) . first (+1))@. Example: @dropWhile@ > dropWhile :: (a -> Bool) -> [a] -> [a] > dropWhile p = para f > where > f Nil = [] > f (Pair x xs) = if p x then snd xs else x : fst xs Point-free version: > dropWhile p = para $ cons [] (\x xs -> if p x then snd xs else x : fst xs) -} para :: Fixpoint f t => (f (t,a) -> a) -> t -> a para = zygo inF {-| Implements course-of-value recursion. At each step, the function receives an F-branching stream ('Cofree') containing the previous values. Formally known as a /histomorphism/ and written {| f |}. @ histo == 'g_histo' id @ Example: Computing Fibonacci numbers. > fibo :: Integer -> Integer > fibo = histo next > where > next :: Maybe (Cofree Maybe Integer) -> Integer > next Nothing = 0 > next (Just (Consf _ Nothing)) = 1 > next (Just (Consf m (Just (Consf n _)))) = m + n * For the base case F(0), @next@ is passed @Nothing@ and returns 0. (Note that @'inF' Nothing == 0@) * For F(1), @next@ is passed a one-element stream, and returns 1. * For subsequent cases F(/n/), @next@ is passed a the stream [F(/n/-1), F(/n/-2), ..., F(0)] and returns F(/n/-1)+F(/n/-2). -} histo :: Fixpoint f t => (f (Cofree f a) -> a) -> t -> a histo = g_histo id ----- {-| A generalization of 'para' implementing \"semi-mutual\" recursion. Known formally as a /zygomorphism/ and written \<| f |\>^g, where /g/ is an auxiliary function. Dual to 'g_apo'. @ zygo g == 'foldWith' (g . fmap fst &&& fmap snd) @ -} zygo :: Fixpoint f t => (f b -> b) -> (f (b,a) -> a) -> t -> a zygo g f = snd . fold (g . fmap fst &&& f) {-| Generalizes 'histo' to cases where the recursion functor and the stream functor are distinct. Known as a /g-histomorphism/. @ g_histo g == 'foldWith' ('anaCofree' (fmap 'headCofree') (g . fmap 'tailCofree')) @ -} g_histo :: (Functor h, Fixpoint f t) => (forall b. f (h b) -> h (f b)) -- distributive law for /h/ and /f/ -> (f (Cofree h a) -> a) -> t -> a g_histo = foldWith . distribCofree {-| Generalizes 'fold', 'zygo', and 'g_histo'. Formally known as a /g-catamorphism/ and written (| f |)^(w,k), where /w/ is a 'Comonad' and /k/ is a distributive law between /n/ and the functor /f/. The behavior of @foldWith@ is determined by the comonad /w/. * 'Identity' recovers 'fold' * @((,) a)@ recovers 'zygo' (and 'para') * 'Cofree' recovers 'g_histo' (and 'histo') -} foldWith :: (Fixpoint f t, Comonad w) => (forall b. f (w b) -> w (f b)) -- distributive law for /f/ and /w/ -> (f (w a) -> a) -> t -> a foldWith k f = extract . fold (fmap f . k . fmap duplicate) ---- {-| /apomorphisms/, dual to 'para' @ apo == 'g_apo' 'outF' apo f == 'inF' . fmap (id ||| apo f) . f @ Example: Appending a list to another list > append :: [a] -> [a] -> [a] > append = curry (apo f) > where > f :: ([a],[a]) -> ConsPair a (Either [a] ([a],[a])) > f ([], []) = Nil > f ([], y:ys) = Pair y (Left ys) > f (x:xs, ys) = Pair x (Right (xs,ys)) -} apo :: Fixpoint f t => (a -> f (Either t a)) -> a -> t apo = g_apo outF {-| Generalized apomorphisms, dual to 'zygo' @ g_apo g == 'unfoldWith' (fmap Left . g ||| fmap Right) @ -} g_apo :: Fixpoint f t => (b -> f b) -> (a -> f (Either b a)) -> a -> t g_apo g f = unfold (fmap Left . g ||| f) . Right {-| Generalized anamorphisms parameterized by a monad, dual to 'foldWith' * @Identity@ recovers 'unfold' * @(Either a)@ recovers 'g_apo' (and 'apo') -} unfoldWith :: (Fixpoint f t, Monad m) => (forall b. m (f b) -> f (m b)) -> (a -> f (m a)) -> a -> t unfoldWith k f = unfold (fmap join . k . liftM f) . return {-| Generalized hylomorphisms parameterized by both a monad and a comonad. This one combinator subsumes most-if-not-all the other combinators in this library. * @w = Identity@ yields 'unfoldWith' * @m = Identity@ yields 'foldWith' * @Free m@ and @Cofree w@ yields 'g_chrono', and therefore 'g_histo' and 'g_futu' @e@ and @g@ are additional functors related to @f@ by natural transformations that have been fused into the distributive laws. -} refoldWith :: (Comonad w, Functor f, Monad m) => (forall c. f (w c) -> w (g c)) -> (forall c. m (e c) -> f (m c)) -> (g (w b) -> b) -> (a -> e (m a)) -> a -> b refoldWith w m f g = extract . refoldWith' w m f g . return -- | The kernel of the generalized hylomorphism. refoldWith' :: (Comonad w, Functor f, Monad m) => (forall c. f (w c) -> w (g c)) -> (forall c. m (e c) -> f (m c)) -> (g (w b) -> b) -> (a -> e (m a)) -> (m a -> w b) refoldWith' w m f g = liftW f . w . fmap (duplicate . refoldWith' w m f g . join) . m . liftM g {-| Futumorphism: course of argument coiteration @ futu == 'chrono' ('inF' . fmap 'headCofree') futu == 'g_futu' id @ Example, translated from /Primitive (Co)Recursion and Course-of-Value (Co)Iteration, Categorically/ (<http://citeseer.ist.psu.edu/uustalu99primitive.html>): > phi (x:y:zs) = Pair y . inFree . Pair x $ return zs > exch = futu phi > l = exch [1..] -- [2,1,4,3,6,5,8,7,10,9..] -} futu :: (Fixpoint f t) => (a -> f (Free f a)) -> a -> t futu = g_futu id {-| Generalized futumorphism @ g_futu m == 'g_chrono' (const 'Unit') m ('inF' . fmap 'headCofree') g_futu m == 'unfoldWith' ('distribFree' m) @ -} g_futu :: (Functor h, Fixpoint f t) => (forall b. h (f b) -> f (h b)) -> (a -> f (Free h a)) -> a -> t g_futu = unfoldWith . distribFree -- | a chronomorphism, coined by Edward Kmett, subsumes both histo -- and futumorphisms. chrono :: Functor f => (f (Cofree f b) -> b) -> (a -> f (Free f a)) -> a -> b chrono = g_chrono id id {-| Generalized chronomorphism. The recursion functor is separated from the Free and Cofree functors, and related by distributive laws. @ g_chrono w m == 'refoldWith' ('distribCofree' w) ('distribFree' m) @ -} g_chrono :: (Functor f, Functor m, Functor w) => (forall c. f (w c) -> w (f c)) -> (forall c. m (f c) -> f (m c)) -> (f (Cofree w b) -> b) -> (a -> f (Free m a)) -> a -> b g_chrono w m = refoldWith (distribCofree w) (distribFree m) {-| Dynamorphisms: a hylomorphism like combinator that captures dynamic programming. @ dyna f g == 'g_dyna' id (fmap Identity . runIdentity) f (fmap Identity . g) dyna f g == 'chrono' f (fmap return . g) @ Example, translated from /Recursion Schemes for Dynamic Programming/ (<http://citeseer.ist.psu.edu/748315.html>) section 4.2: > data Poly a = Term | Single a | Double a a > instance Functor Poly where > fmap _ Term = Term > fmap f (Single a) = Single (f a) > fmap f (Double a b) = Double (f a) (f b) > psi 0 = Term > psi n > | odd n = Single (n-1) > | even n = Double (n-1) (n `div` 2) > phi Term = 1 > phi (Single n) = n > phi (Double m n) = m + n > bp1 = refold phi psi -- hylo version; ineffcient > zeta 0 = Nil > zeta n = Pair n (n-1) > epsilon = headCofree > theta = tailCofree > pie x = let (Pair m y) = theta x in y > pieN 0 x = x > pieN n x = pieN (n-1) (pie x) > sigma Nil = Term > sigma (Pair n x) > | odd n = Single (epsilon x) > | even n = Double (epsilon x) (epsilon (pieN (n`div`2 - 1) x)) > bp2 = dyna (phi . sigma) zeta -- dynamically programmed -} dyna :: (Functor f) => (f (Cofree f b) -> b) -> (a -> f a) -> a -> b dyna f g = extract . dyna' f g -- | Kernel of the dynamorphism dyna' :: (Functor f) => (f (Cofree f b) -> b) -> (a -> f a) -> a -> Cofree f b dyna' f g = refold (f &&& id >>> Cofree) g {-| Generalized dynamorphism @ g_dyna w == 'refoldWith' ('distribCofree' w) @ -} g_dyna :: (Functor f, Functor h, Monad m) => (forall c. f (h c) -> h (f c)) -> (forall c. m (e c) -> f (m c)) -> (f (Cofree h b) -> b) -> (a -> e (m a)) -> a -> b g_dyna = refoldWith . distribCofree {- Generalized dynamorphism kernel g_dyna' :: (Functor f, Functor h, Monad m) => (forall c. f (h c) -> h (f c)) -> (forall c. m (e c) -> f (m c)) -> (f (Cofree h b) -> b) -> (a -> e (m a)) -> m a -> Cofree h b g_dyna' = refoldWith' . distribCofree -} {-| The dual of dynamorphisms. -} codyna :: (Functor f) => (f b -> b) -> (a -> f (Free f a)) -> a -> b codyna f g = chrono (f . fmap extract) g {-| Generalized codynamorphisms. -} g_codyna :: (Functor f, Functor h, Comonad w) => (forall c. f (w c) -> w (g c)) -> (forall c. h (f c) -> f (h c)) -> (g (w b) -> b) -> (a -> f (Free h a)) -> a -> b g_codyna w = refoldWith w . distribFree