{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies,
FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Recursion
-- Copyright : 2004 Dave Menendez
-- License : public domain
--
-- 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').
--
-----------------------------------------------------------------------------
module Control.Recursion
(
-- * Folding
fold
, para
, zygo
, histo
, g_histo
, foldWith
-- * Unfolding
, unfold
, apo
, g_apo
, unfoldWith
-- * Transforming
, refold
-- * Functor fixpoints
, Fixpoint(..)
, Fix(..)
, ConsPair(..)
, cons
) where
----
import Control.Arrow
import Control.Functor
import Control.Monad
import Control.Comonad
import Data.BranchingStream
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' ('Id' . fmap 'unId') (f . fmap 'unId')
@
-}
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 'Id' . 'unId') (fmap 'Id' . 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 ('Strf') 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 (Strf 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 (Strf 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' ('genStrf' (fmap 'hdf') (g . fmap 'tlf'))
@
-}
g_histo :: (Functor h, Fixpoint f t)
=> (forall b. f (h b) -> h (f b)) -- distributive law for /h/ and /f/
-> (f (Strf h a) -> a) -> t -> a
g_histo g = foldWith (genStrf (fmap hdf) (g . fmap tlf))
{-|
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/.
* 'Id' recovers 'fold'
* @((,) a)@ recovers 'zygo' (and 'para')
* 'Strf' 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'
* 'Id' 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
----
-- defined for internal use
{-
infixr 2 &&&, |||
f &&& g = \x -> (f x, g x)
(|||) = either
-}