diff --git a/Control/Comonad.hs b/Control/Comonad.hs --- a/Control/Comonad.hs +++ b/Control/Comonad.hs @@ -2,7 +2,7 @@ -- | -- Module : Control.Comonad -- Copyright : 2004 Dave Menendez --- License : public domain +-- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental diff --git a/Control/Comonad/Cofree.hs b/Control/Comonad/Cofree.hs new file mode 100644 --- /dev/null +++ b/Control/Comonad/Cofree.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free +-- Copyright : 2004 Dave Menendez +-- License : BSD3 +-- +-- Maintainer : dan.doel@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- An implementation of the cofree comonad of a functor, used in +-- histomorphisms and chronomorphisms in Control.Recursion. The +-- cofree comonad can also be seen as a stream parameterized by a +-- functor that controls its branching factor. +-- +----------------------------------------------------------------------------- + +module Control.Comonad.Cofree + ( Cofree(..) + , headCofree + , tailCofree + , anaCofree + , cofreeToList + , distribCofree + ) where + +import Control.Arrow ((&&&),(***),(>>>), second) +import Control.Comonad + +{-| +The cofree comonad of a functor @h@ (also known as an H-branching stream). +Various comonads are a special instance of the cofree comonad: + +* @Cofree Identity@ is an infinite stream + +* @Cofree Maybe@ is a non-empty stream + +* @Cofree []@ is a rose tree + +formally: + +> Cofree H A = nu X. A * HX +-} +data Cofree h a = Cofree { unCofree :: (a, h (Cofree h a)) } + +-- | anamorphism for building a cofree comonad from a seed +anaCofree :: Functor h => (a -> b) -> (a -> h a) -> a -> Cofree h b +anaCofree g1 g2 = g1 &&& fmap (anaCofree g1 g2) . g2 >>> Cofree + +headCofree :: Cofree h a -> a +headCofree = fst . unCofree + +tailCofree :: Cofree h a -> h (Cofree h a) +tailCofree = snd . unCofree + +instance Functor h => Functor (Cofree h) where + fmap g = unCofree >>> g *** fmap (fmap g) >>> Cofree + +instance Functor h => Comonad (Cofree h) where + extract = headCofree + duplicate = anaCofree id tailCofree + +-- | Converts a value of the cofree comonad over Maybe into a non-empty list. +cofreeToList :: Cofree Maybe a -> [a] +cofreeToList = unCofree >>> second (maybe [] cofreeToList) >>> uncurry (:) + +-- | Lifts a distributive law of @f@ over @h@ to a distributive law +-- of @f@ over @Cofree h@. +distribCofree :: (Functor h, Functor f) => + (forall a. f (h a) -> h (f a)) + -> (forall a. f (Cofree h a) -> Cofree h (f a)) +distribCofree d = anaCofree (fmap headCofree) (d . fmap tailCofree) diff --git a/Control/Comonad/Context.hs b/Control/Comonad/Context.hs --- a/Control/Comonad/Context.hs +++ b/Control/Comonad/Context.hs @@ -2,7 +2,7 @@ -- | -- Module : Control.Comonad.Context -- Copyright : 2004 Dave Menendez --- License : public domain +-- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental diff --git a/Control/Functor.hs b/Control/Functor.hs --- a/Control/Functor.hs +++ b/Control/Functor.hs @@ -2,7 +2,7 @@ -- | -- Module : Control.Functor -- Copyright : 2004 Dave Menendez --- License : public domain +-- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental diff --git a/Control/Functor/Adjunction.hs b/Control/Functor/Adjunction.hs --- a/Control/Functor/Adjunction.hs +++ b/Control/Functor/Adjunction.hs @@ -2,7 +2,7 @@ -- | -- Module : Control.Functor.Adjunction -- Copyright : 2004 Dave Menendez --- License : public domain +-- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental diff --git a/Control/Functor/Transform.hs b/Control/Functor/Transform.hs --- a/Control/Functor/Transform.hs +++ b/Control/Functor/Transform.hs @@ -4,7 +4,7 @@ -- | -- Module : Control.Functor.Transform -- Copyright : 2004 Dave Menendez --- License : public domain +-- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental diff --git a/Control/Monad/Free.hs b/Control/Monad/Free.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Free.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE Rank2Types #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Free +-- Copyright : 2008 Dan Doel, Edward Kmett +-- License : BSD3 +-- +-- Maintainer : dan.doel@gmail.com +-- Stability : experimental +-- Portability : non-portable (rank-2 types) +-- +-- An implementation of the free monad of a functor, used in (at the least) +-- futumorphisms and chronomorphisms in Control.Recursion +-- +----------------------------------------------------------------------------- + +module Control.Monad.Free + ( Free() + , inFree + , cataFree + , distribFree + ) where + +import Control.Arrow ((|||), (+++), (>>>)) +import Control.Applicative +import Control.Monad + +-- | The free monad of a functor 'f', formally, +-- +-- > Free F A = mu X. A + FX +newtype Free f a = Free { unFree :: Either a (f (Free f a)) } + +instance (Functor f) => Functor (Free f) where + fmap f = unFree >>> f +++ fmap (fmap f) >>> Free + + +instance (Functor f) => Applicative (Free f) where + pure = return + (<*>) = ap + +instance (Functor f) => Monad (Free f) where + return = Free . Left + (Free e) >>= f = either f (inFree . fmap (>>= f)) e + +-- | The catamorphism for the free monad +cataFree :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b +cataFree f g = unFree >>> f ||| g . fmap (cataFree f g) + +inFree :: f (Free f a) -> Free f a +inFree = Free . Right + +-- | Lifts a distributive law of @h@ over @f@ to a distributive +-- law of @Free h@ over @f@ +distribFree :: (Functor f, Functor h) => + (forall a. h (f a) -> f (h a)) + -> (forall a. Free h (f a) -> f (Free h a)) +distribFree d = cataFree (fmap return) (fmap inFree . d) diff --git a/Control/Recursion.hs b/Control/Recursion.hs --- a/Control/Recursion.hs +++ b/Control/Recursion.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, - FlexibleInstances #-} +{-# LANGUAGE + Rank2Types + , MultiParamTypeClasses + , FunctionalDependencies + , FlexibleInstances + #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Recursion -- Copyright : 2004 Dave Menendez --- License : public domain +-- License : BSD3 -- -- Maintainer : dan.doel@gmail.com -- Stability : experimental @@ -21,6 +25,9 @@ -- 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 @@ -38,10 +45,21 @@ , 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(..) @@ -53,9 +71,10 @@ ---- import Control.Arrow import Control.Functor -import Control.Monad +import Control.Monad.Identity +import Control.Monad.Free import Control.Comonad -import Data.BranchingStream +import Control.Comonad.Cofree class Functor f => Fixpoint f t | t -> f where inF :: f t -> t @@ -64,7 +83,7 @@ outF :: t -> f t -- ^ formally, @in^-1[f]: mu f -> f@ -{-| Creates a fixpoint for any functor. -} +-- | Creates a fixpoint for any functor. newtype Fix f = In (f (Fix f)) instance Functor f => Fixpoint f (Fix f) where @@ -89,8 +108,6 @@ outF n | n > 0 = Just (n - 1) | otherwise = Nothing --- - -- | Fixpoint of lists data ConsPair a b = Nil | Pair a b deriving (Eq, Show) @@ -111,8 +128,6 @@ cons d _ Nil = d cons _ f (Pair a b) = f a b ----- - {-| A generalized @map@, known formally as a /hylomorphism/ and written [| f, g |]. @@ -128,7 +143,7 @@ @ fold f == 'refold' f 'outF' - fold f == 'foldWith' ('Id' . fmap 'unId') (f . fmap 'unId') + fold f == 'foldWith' ('Identity' . fmap 'runIdentity') (f . fmap 'runIdentity') @ -} fold :: Fixpoint f t => (f a -> a) -> t -> a @@ -139,7 +154,7 @@ @ unfold f == 'refold' 'inF' f - unfold f == 'unfoldWith' (fmap 'Id' . 'unId') (fmap 'Id' . f) + unfold f == 'unfoldWith' (fmap 'Identity' . 'unIdentity') (fmap 'Identity' . f) @ -} unfold :: Fixpoint f t => (a -> f a) -> a -> t @@ -189,7 +204,7 @@ {-| Implements course-of-value recursion. At each step, the function -receives an F-branching stream ('Strf') containing the previous +receives an F-branching stream ('Cofree') containing the previous values. Formally known as a /histomorphism/ and written {| f |}. @ @@ -201,7 +216,7 @@ > fibo :: Integer -> Integer > fibo = histo next > where -> next :: Maybe (Strf Maybe Integer) -> Integer +> next :: Maybe (Cofree Maybe Integer) -> Integer > next Nothing = 0 > next (Just (Consf _ Nothing)) = 1 > next (Just (Consf m (Just (Consf n _)))) = m + n @@ -216,7 +231,7 @@ -} -histo :: Fixpoint f t => (f (Strf f a) -> a) -> t -> a +histo :: Fixpoint f t => (f (Cofree f a) -> a) -> t -> a histo = g_histo id ----- @@ -239,13 +254,13 @@ stream functor are distinct. Known as a /g-histomorphism/. @ - g_histo g == 'foldWith' ('genStrf' (fmap 'hdf') (g . fmap 'tlf')) + 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 (Strf h a) -> a) -> t -> a -g_histo g = foldWith (genStrf (fmap hdf) (g . fmap tlf)) + -> (f (Cofree h a) -> a) -> t -> a +g_histo = foldWith . distribCofree {-| @@ -255,11 +270,11 @@ The behavior of @foldWith@ is determined by the comonad /w/. -* 'Id' recovers 'fold' +* 'Identity' recovers 'fold' * @((,) a)@ recovers 'zygo' (and 'para') -* 'Strf' recovers 'g_histo' (and 'histo') +* 'Cofree' recovers 'g_histo' (and 'histo') -} foldWith :: (Fixpoint f t, Comonad w) @@ -290,7 +305,8 @@ apo :: Fixpoint f t => (a -> f (Either t a)) -> a -> t apo = g_apo outF -{-| generalized apomorphisms, dual to 'zygo' +{-| +Generalized apomorphisms, dual to 'zygo' @ g_apo g == 'unfoldWith' (fmap Left . g ||| fmap Right) @@ -300,22 +316,212 @@ g_apo g f = unfold (fmap Left . g ||| f) . Right -{-| generalized anamorphisms parameterized by a monad, dual to 'foldWith' - -* 'Id' recovers 'unfold' +{-| +Generalized anamorphisms parameterized by a monad, dual to 'foldWith' -* @(Either a)@ recovers 'g_apo' (and 'apo') + * @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 ----- --- defined for internal use -{- -infixr 2 &&&, ||| -f &&& g = \x -> (f x, g x) -(|||) = either +{-| +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/ +(): + +> 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/ +() 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 diff --git a/Data/BranchingStream.hs b/Data/BranchingStream.hs deleted file mode 100644 --- a/Data/BranchingStream.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Data.BranchingStream - ( Strf(..) - , hdf - , tlf - , genStrf - , strfToList - ) where - -import Control.Comonad - - -{-| -An H-branching stream. The specific functor chosen for /H/ determines -its behavior: - -* @Strf 'Id'@ is an infinite stream - -* @Strf Maybe@ is a non-empty stream - -* @Strf []@ is a rose tree --} -data Strf h c = Consf c (h (Strf h c)) - -hdf :: Strf h c -> c -hdf (Consf x _) = x - -tlf :: Strf h c -> h (Strf h c) -tlf (Consf _ xs) = xs - -genStrf :: Functor h - => (a -> c) -> (a -> h a) -> a -> Strf h c -genStrf g1 g2 z = Consf (g1 z) (fmap (genStrf g1 g2) (g2 z)) - -instance Functor h => Functor (Strf h) where - fmap g = genStrf (g . hdf) tlf - -instance Functor h => Comonad (Strf h) where - extract = hdf - duplicate = genStrf id tlf - -strfToList :: Strf Maybe a -> [a] -strfToList (Consf x xs) = x : maybe [] strfToList xs diff --git a/Data/Stream.hs b/Data/Stream.hs --- a/Data/Stream.hs +++ b/Data/Stream.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE Rank2Types, ExistentialQuantification #-} + module Data.Stream ( Stream , mkStream diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -14,7 +14,7 @@ may be used to endorse or promote products derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE diff --git a/category-extras.cabal b/category-extras.cabal --- a/category-extras.cabal +++ b/category-extras.cabal @@ -1,5 +1,5 @@ Name: category-extras -Version: 0.1 +Version: 0.2 Description: A collection of modules implementing various ideas from category theory. Notable bits include: comonads, adjunctions, functor fixedpoints and various recursion operaters ala @@ -21,11 +21,12 @@ Exposed-Modules: Control.Comonad Control.Comonad.Context + Control.Comonad.Cofree Control.Functor Control.Functor.Adjunction Control.Functor.Transform Control.Recursion - Data.BranchingStream + Control.Monad.Free Data.InfiniteSeq Data.InfiniteTree Data.Stream