packages feed

category-extras (empty) → 0.1

raw patch · 13 files changed

+1133/−0 lines, 13 filesdep +basedep +mtlsetup-changed

Dependencies added: base, mtl

Files

+ Control/Comonad.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Comonad+-- Copyright   :  2004 Dave Menendez+-- License     :  public domain+-- +-- Maintainer  :  dan.doel@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This module declares the 'Comonad' class, with instances for+-- 'Identity' and @((,) a)@, and defines the 'CoKleisli' arrow.+-----------------------------------------------------------------------------++module Control.Comonad+  (+  -- * The Comonad class+    Comonad(..)+  , (=>>)+  , (.>>)+  , liftW+  +  -- * The coKleisli arrow+  , CoKleisli(..)+  +  -- * The product comonad+  , local+  +  -- * Additional functions+  , sequenceW+  , mapW+  , parallelW+  , unfoldW+  )where++import Control.Arrow+import Control.Functor()++import Control.Monad.Identity++infixl 1 =>>, .>>++{-|+There are two ways to define a comonad:++I. Provide definitions for 'fmap', 'extract', and 'duplicate'+satisfying these laws:++> extract . duplicate      == id+> fmap extract . duplicate == id+> duplicate . duplicate    == fmap duplicate . duplicate++II. Provide definitions for 'extract' and 'extend'+satisfying these laws:++> extend extract      == id+> extract . extend f  == f+> extend f . extend g == extend (f . extend g)++('fmap' cannot be defaulted, but a comonad which defines+'extend' may simply set 'fmap' equal to 'liftW'.)++A comonad providing definitions for 'extend' /and/ 'duplicate',+must also satisfy these laws:++> extend f  == fmap f . duplicate+> duplicate == extend id+> fmap f    == extend (f . duplicate)++(The first two are the defaults for 'extend' and 'duplicate',+and the third is the definition of 'liftW'.)+-}++class Functor w => Comonad w where+  extract   :: w a -> a+  duplicate :: w a -> w (w a)+  extend    :: (w a -> b) -> (w a -> w b)+  +  extend f  = fmap f . duplicate+  duplicate = extend id++-- | 'fmap' defined in terms of 'extend'+liftW :: Comonad w => (a -> b) -> (w a -> w b)+liftW f = extend (f . extract)++-- | 'extend' with the arguments swapped. Dual to '>>=' for monads.+(=>>) :: Comonad w => w a -> (w a -> b) -> w b+(=>>) = flip extend++-- | Injects a value into the comonad.+(.>>) :: Comonad w => w a -> b -> w b+w .>> b = extend (\_ -> b) w+++--++instance Comonad Identity where+  extract (Identity x) = x+  duplicate y   = Identity y+  extend c w    = Identity (c w)++instance Comonad ((,) a) where+  extract   (_,x) = x+  duplicate (c,x) = (c,(c,x))++-- | Calls a comonadic function in a modified context+local :: (c -> c') -> ((c',a) -> a) -> ((c,a) -> a)+local g f (c,x) = f (g c, x)++--++newtype CoKleisli w a b = CoKleisli { unCoKleisli :: w a -> b }++instance Functor (CoKleisli w a) where+  fmap f (CoKleisli g) = CoKleisli (f . g)++instance (Comonad w) => Arrow (CoKleisli w) where+  arr f = CoKleisli (f . extract)++  CoKleisli a >>> CoKleisli b+        = CoKleisli (b . fmap a . duplicate)+  +  CoKleisli a &&& CoKleisli b+        = CoKleisli (a &&& b)+  +  CoKleisli a *** CoKleisli b+        = CoKleisli (a . fmap fst &&& b . fmap snd)+  +  first a  = a *** arr id+  second a = arr id *** a++--++mapW :: Comonad w => (w a -> b) -> w [a] -> [b]+mapW f w | null (extract w) = []+         | otherwise        = f (fmap head w) : mapW f (fmap tail w)++parallelW :: Comonad w => w [a] -> [w a]+parallelW w | null (extract w) = []+            | otherwise        = fmap head w : parallelW (fmap tail w)++unfoldW :: Comonad w => (w b -> (a,b)) -> w b -> [a]+unfoldW f w = fst (f w) : unfoldW f (w =>> snd . f)++-- | Converts a list of comonadic functions into a single function+-- returning a list of values+sequenceW :: Comonad w => [w a -> b] -> w a -> [b]+sequenceW []     _ = []+sequenceW (f:fs) w = f w : sequenceW fs w
+ Control/Comonad/Context.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Comonad.Context+-- Copyright   :  2004 Dave Menendez+-- License     :  public domain+-- +-- Maintainer  :  dan.doel@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Defines the state-in-context comonad, which is dual to the state monad.+-- Each operation in the context comonad runs in a context determined+-- by /later/ operations. (Observe, for example, 'experiment', which runs+-- the preceeding operations multiple times in different contexts and+-- returns a list of results.)+--+-----------------------------------------------------------------------------++module Control.Comonad.Context+  ( Context(..)+  , get+  , modify+  , experiment+  , liftCtx+  ) where++import Control.Comonad++data Context c a = Context (c -> a) c++instance Functor (Context c) where+  fmap g (Context f c) = Context (g . f) c++instance Comonad (Context c) where+  extract   (Context f c) = f c+  duplicate (Context f c) = Context (Context f) c++-- | Returns the context+get :: Context c a -> c+get (Context _ c) = c++-- | Returns the result of the preceeding operations running in+-- a modified context+modify :: (c -> c) -> Context c a -> a+modify m (Context f c) = f (m c)++-- | Returns a list of results created by running prior operations+-- in modified contexts created by the list of context-modifiers.+experiment :: [c -> c] -> Context c a -> [a]+experiment ms (Context f c) = map (\m -> f (m c)) ms++{-|+Lifts an operation into the context comonad. Syntactic sugar+for @fmap@ when chaining comonad operations.++@+  liftCtx         == extract . fmap f+  w =>> liftCtx f == fmap f w+@+-}+liftCtx :: (a -> b) -> Context c a -> b+liftCtx g (Context f c) = g (f c)++{-+inContext :: ((c -> a) -> c -> b) -> Context c a -> b+inContext op (Context f c) = op f c++get      = inContext (\f c -> c)+modify m = inContext (\f c -> f (m c))+-}
+ Control/Functor.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Functor+-- Copyright   :  2004 Dave Menendez+-- License     :  public domain+-- +-- Maintainer  :  dan.doel@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Functor composition, standard functors, and more.+--+-----------------------------------------------------------------------------++module Control.Functor+  (+  -- * Unary functors+  -- ** Composition+    O(..)+  , lComp+  , rComp+  -- ** Basic Instances+  -- *** Unit+  , Unit(..)+  +  -- *** Const+  , Const(..)+  +  -- * Binary functors+  , Bifunctor(..)+  +  -- * Trinary functors+  , Trifunctor(..)+  ) where++infixr 2 `O`++{-|+Functor composition.++(Note: Some compilers will let you write @f \`O\` g@ rather than @O f g@;+we'll be doing so here for readability.)++Functor composition is associative, so @f \`O\` (g \`O\` h)@ and @(f \`O\` g) \`O\` h@+are equivalent. The functions 'lComp' and 'rComp' convert between the two.+(Operationally, they are equivalent to @id@. Their only purpose is to affect+the type system.)+-}+newtype (O f g) a = Comp { deComp :: f (g a) }++instance (Functor f, Functor g) => Functor (O f g) where+  fmap f = Comp . fmap (fmap f) . deComp++lComp :: (Functor f) => (O f (O g h)) a -> (O (O f g) h) a+lComp = Comp . Comp . fmap deComp . deComp++rComp :: (Functor f) => (O (O f g) h) a -> (O f (O g h)) a+rComp = Comp . fmap Comp . deComp . deComp++{-|+The unit functor.++(Note: this is not the same as @()@. In fact, 'Unit' is the+fixpoint of @()@.)+-}+data Unit a = Unit deriving (Show)++instance Functor Unit where+  fmap _ _    = Unit++instance Monad Unit where+  return _    = Unit+  _ >>= _     = Unit++{-|+Constant functors. Essentially the same as 'Unit', except that they also+carry a value.+-}+data Const t a = Const { unConst :: t } deriving (Show)++instance Functor (Const t) where+  fmap _ (Const t) = Const t++{-| +A type constructor which takes two arguments and an associated map function.++Informally, @Bifunctor f@ implies @Functor (f a)@ with @fmap = bimap id@.+-}+class Bifunctor f where+  bimap :: (a -> c) -> (b -> d) -> (f a b -> f c d)++instance Bifunctor (,) where+  bimap f g (x,y) = (f x, g y)++instance Bifunctor Either where+  bimap f _ (Left x)  = Left (f x)+  bimap _ g (Right x) = Right (g x)++{-+instance (Trifunctor f) => Bifunctor (f a) where+  bimap = trimap id+-}+{-|+A type constructor which takes three arguments and an associated map function.++Informally, @Trifunctor f@ implies @Bifunctor (f a)@ with @bimap = trimap id@.+-}++class Trifunctor f where+  trimap :: (a -> a') -> (b -> b') -> (c -> c') -> (f a b c -> f a' b' c')++instance Trifunctor (,,) where+  trimap f g h (x,y,z) = (f x, g y, h z)
+ Control/Functor/Adjunction.hs view
@@ -0,0 +1,51 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Functor.Adjunction+-- Copyright   :  2004 Dave Menendez+-- License     :  public domain+-- +-- Maintainer  :  dan.doel@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (fundeps)+--+-----------------------------------------------------------------------------++module Control.Functor.Adjunction where++import Control.Functor+import Control.Comonad++{-|+Minimal definitions:++1. @leftAdjunct@ and @rightAdjunct@++2. @unit@ and @counit@++Given functors @f@ and @g@, @Adjunction f g@ implies @Monad (g `'O'` f)@ and+@'Comonad' (f `'O'` g)@.++-}+class (Functor f, Functor g) => Adjunction f g | f -> g, g -> f where+    leftAdjunct  :: (f a -> b) -> a -> g b+    rightAdjunct :: (a -> g b) -> f a -> b++    unit   :: a -> g (f a)+    counit :: f (g a) -> a++    unit           = leftAdjunct id+    counit         = rightAdjunct id+    leftAdjunct f  = fmap f . unit+    rightAdjunct g = counit . fmap g++instance (Adjunction f g) => Monad (O g f) where+  return  = Comp . unit+  m >>= k = Comp . fmap (rightAdjunct (deComp . k)) . deComp $ m++instance (Adjunction f g) => Comonad (O f g) where+  extract  = counit . deComp+  extend f = Comp . fmap (leftAdjunct (f . Comp)) . deComp+  +instance Adjunction ((,) a) ((->) a) where+  unit t = \x -> (x,t)+  counit (x,f) = f x
+ Control/Functor/Transform.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE Rank2Types, TypeOperators #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Functor.Transform+-- Copyright   :  2004 Dave Menendez+-- License     :  public domain+-- +-- Maintainer  :  dan.doel@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (rank-2 polymorphism, infix type constructors)+--+-- Description+-----------------------------------------------------------------------------++module Control.Functor.Transform+  ( module Control.Functor+  , (:>)+  , funcTrans+  , transFunc+  , (.>)+  ) where++import Control.Functor++{-+Let F,G: C -> D be functors. Then t: F -> G is a natural transformation from+F to G iff:+	1. forall a in Ob(C). t[a] in D[F(a),G(a)]+	2. forall f in C[a,b]. t[b] . F(f) = G(f) . t[a]++Thus, a transformation t must satisfy:+	t . fmap f = fmap f . t+for any f+-}++infix 1 :>++type f :> g = forall a. f a -> g a++{-+maybeToList :: Maybe :> []+listToMaybe :: [] :> Maybe+-}++transFunc :: (Functor k) => f :> g -> k `O` f :> k `O` g+transFunc t = Comp . fmap t . deComp++funcTrans :: f :> g -> f `O` h :> g `O` h+funcTrans t = Comp . t . deComp+++(.>) :: (Functor k) => h :> k -> f :> g -> h `O` f :> k `O` g+s .> t = Comp . fmap t . s . deComp
+ Control/Recursion.hs view
@@ -0,0 +1,321 @@+{-# 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+-}
+ Data/BranchingStream.hs view
@@ -0,0 +1,42 @@+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
+ Data/InfiniteSeq.hs view
@@ -0,0 +1,48 @@+module Data.InfiniteSeq+  ( Seq+  , Nat+  , head+  , tail+  , cons+  , elemAt+  , drop+  , toStream+  , toList+  ) where++import Prelude hiding (head, tail, drop)+import Control.Comonad+import Data.Stream (Stream, mkStream)++type Nat = Int+type Seq a = Nat -> a++-- instance Functor ((->) w) where+--   fmap f = (f .)++instance Comonad ((->) Nat) where+  extract   s = s 0+  duplicate s = \i -> drop i s++head :: Seq a -> a+head s   = s 0++tail :: Seq a -> Seq a+tail s   = \i -> s (i + 1)++cons :: a -> Seq a -> Seq a+cons x s = \i -> if i == 0 then x else s (i - 1)++elemAt :: Nat -> Seq a -> a+elemAt i s = s i++drop :: Nat -> Seq a -> Seq a+drop n s = \i -> s (i+n)++toStream :: Seq a -> Stream a+toStream s = mkStream s head tail++toList :: Seq a -> [a]+toList s   = map s [0..]++
+ Data/InfiniteTree.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ExistentialQuantification #-}++module Data.InfiniteTree+  ( Tree+  , mkTree+  , root+  , left+  , right+  , branchF+  , surreals+  , showTree+  , showTreeWide+  , showTree'+  , showWide+  , rotateR+  , rotateL+  ) where++import Control.Arrow ((&&&))+import Control.Comonad++data Tree a = forall b. T b (b -> a) (b -> b) (b -> b)++mkTree :: seed -> (seed -> a) -> (seed -> seed) -> (seed -> seed) -> Tree a+mkTree seed v l r = T seed v l r++root :: Tree a -> a+root (T s v _ _) = v s++left :: Tree a -> Tree a+left (T s v l r) = T (l s) v l r++right :: Tree a -> Tree a+right (T s v l r) = T (r s) v l r++instance Functor Tree where+  fmap f (T s v l r) = T s (f . v) l r++instance Comonad Tree where+  extract = root+  extend f (T s v l r) = T s (\s' -> f (T s' v l r)) l r++branchF :: Functor f => f (Tree a) -> Tree (f a)+branchF f = mkTree f (fmap root) (fmap left) (fmap right)++surreals :: Fractional a => Tree a+surreals = mkTree (Nothing, Nothing) avg (fst &&& Just . avg) (Just . avg &&& snd)+  where+    avg (Nothing, Nothing) = 0+    avg (Just x,  Nothing) = x + 1+    avg (Nothing, Just y)  = y - 1+    avg (Just x,  Just y)  = (x + y) / 2+    +{-+infix 1 &&&+f &&& g = \x -> (f x, g x)+-}++showTree :: Show a => Int -> Tree a -> String+showTree = showTreeWide True++showTreeWide :: Show a => Bool -> Int -> Tree a -> String+showTreeWide wide d t = showTree' wide [] [] t d ""++showTree' :: Show a => Bool -> [String] -> [String] -> Tree a -> Int -> ShowS+showTree' _    _     _     _ 0 = id+showTree' _    lbars _     t 1+  = showBars lbars . shows (root t) . showString "...\n"+showTree' wide lbars rbars t d+  = showTree' wide (withBar rbars) (withEmpty rbars) (right t) (d - 1) .+    showWide wide rbars .+    showBars lbars . shows (root t) . showChar '\n' .+    showWide wide lbars .+    showTree' wide (withEmpty lbars) (withBar lbars) (left t) (d - 1)++showWide :: Bool -> [String] -> ShowS+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showBars :: [String] -> ShowS+showBars []   = id+showBars bars = showString (concat (reverse (tail bars))) . showString node++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar   bars = "|  " :bars+withEmpty bars = "   " :bars++data Rot = Zero | One | Two | Three+++rotateL :: Tree a -> Tree a+rotateL t' = mkTree (t',Two) n l r+  where+    n (t,Two)  = root (right t)+    n (t,One)  = root t+    n (t,Zero) = root t+    n (_,Three) = error "rotateL n Three"+    +    l (t,Two)  = (t, One)+    l (t,One)  = (left t, Zero)+    l (t,Zero) = (left t, Zero)+    l (_,Three) = error "rotateL l Three"+    +    r (t,Two)  = (right (right t), Zero)+    r (t,One)  = (left (right t), Zero)+    r (t,Zero) = (right t, Zero)+    r (_,Three) = error "rotateL r Three"++rotateR :: Tree a -> Tree a+rotateR t' = mkTree (t',Two) n l r+  where+    n (t,Two)  = root (left t)+    n (t,One)  = root t+    n (t,Zero) = root t+    n (_,Three) = error "rotateR n Three"+    +    l (t,Two)  = (left (left t), Zero)+    l (t,One)  = (right (left t), Zero)+    l (t,Zero) = (left t, Zero)+    l (_,Three) = error "rotateR l Three"+    +    r (t,Two)  = (t, One)+    r (t,One)  = (right t, Zero)+    r (t,Zero) = (right t, Zero)+    r (_,Three) = error "rotateR r Three"
+ Data/Stream.hs view
@@ -0,0 +1,87 @@+module Data.Stream+  ( Stream+  , mkStream+  , head+  , tail+  , cons+  , elemAt+  , toSeq+  , toList+  , mapStreamSt+  , fibs+  ) where++import Prelude hiding (head, tail, drop)+import Control.Comonad+import Control.Arrow ((&&&))++data Stream a = forall b.  S b (b -> a) (b -> b)++mkStream :: b -> (b -> a) -> (b -> b) -> Stream a+mkStream x f g = S x f g++instance Functor Stream where+  fmap = liftW++instance Comonad Stream where+  extract (S s f _)  = f s+  extend h (S s f g) = S s (\s' -> h (S s' f g)) g++head :: Stream a -> a+head (S x f _) = f x++tail :: Stream a -> Stream a+tail (S x f g) = S (g x) f g++cons :: a -> Stream a -> Stream a+cons x s = mkStream (x,s) fst ((head &&& tail) . snd)++elemAt :: Integral i => i -> Stream a -> a+elemAt n = head . drop n++drop :: Integral i => i -> Stream a -> Stream a+drop 0 = id+drop n = drop (n - 1) . tail++toSeq :: Stream a -> Int -> a+toSeq = flip elemAt++toList :: Stream a -> [a]+toList = map head . iterate tail++mapStreamSt :: (a -> s -> b) -> (a -> s -> s) -> s -> Stream a -> Stream b+mapStreamSt f1 f2 s0 xs+  = mkStream (xs,s0) +             (\(x,s) -> f1 (head x) s)+             (\(x,s) -> (tail x, f2 (head x) s))++fibs :: Stream Integer+fibs = mkStream (1,1) fst (\(i,j) -> (j,i+j))++{-+------+-- A stream can be pulled from any comonad++parallelW :: Comonad w => w (Stream a) -> Stream (w a)+parallelW w = mkStream w (fmap head) (fmap tail)++-- in fact, from any functor+parallelF :: (Functor f) => f (Stream a) -> Stream (f a)+parallelF f = mkStream f (fmap head) (fmap tail)+++------+-- What good are these?++mapW :: Comonad w => (w a -> b) -> w (Stream a) -> Stream b+mapW f = fmap f . parallelW++unfold :: (b -> (a,b)) -> b -> Stream a+unfold f i = mkStream i (fst . f) (snd . f)++unfoldW :: Comonad w => (w b -> (a,b)) -> w b -> Stream a+unfoldW f w = mkStream w (fst . f) (=>> snd . f)++mkStreamW :: Comonad w => w b -> (w b -> a) -> (w b -> b) -> Stream a+mkStreamW w f g = mkStream w f (=>> g)+-}
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) David Menendez 2004++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   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+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+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ category-extras.cabal view
@@ -0,0 +1,38 @@+Name:			category-extras+Version:		0.1+Description:		A collection of modules implementing various ideas from+			category theory. Notable bits include: comonads, adjunctions,+			functor fixedpoints and various recursion operaters ala+			/Functional Programming with Bananas, Lenses, Envelopes+			and Barbed Wire/.+Synopsis:		Various modules and constructs inspired by category theory.+Category:		Control, Data+License:		BSD3+License-File:		LICENSE+Copyright:		Copyright (c) 2004--2008 Dave Menendez+Author:			Dave Menendez+Maintainer:		dan.doel@gmail.com+Homepage:		http://code.haskell.org/~dolio/category-extras++Stability:		Experimental+Tested-With:		GHC+Build-Depends:		base, mtl+Build-Type:		Simple++Exposed-Modules:	Control.Comonad+			Control.Comonad.Context+			Control.Functor+			Control.Functor.Adjunction+			Control.Functor.Transform+			Control.Recursion+			Data.BranchingStream+			Data.InfiniteSeq+			Data.InfiniteTree+			Data.Stream+Extensions:		Rank2Types,+			MultiParamTypeClasses,+			FunctionalDependencies,+			TypeOperators,+			FlexibleInstances,+			ExistentialQuantification+GHC-Options:		-O2 -Wall