{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# OPTIONS_GHC -Wall #-} -- http://www.mail-archive.com/haskell@haskell.org/msg17244.html import Prelude hiding (id,(.),sum) import Control.Category import Control.Comonad import Data.Foldable hiding (sum) import Data.Traversable infixl 4 :> data History a = First a | History a :> a deriving (Functor, Foldable, Traversable, Show) runHistory :: (History a -> b) -> [a] -> [b] runHistory _ [] = [] runHistory f (a0:as0) = run (First a0) as0 where run az [] = [f az] run az (a:as) = f az : run (az :> a) as instance Comonad History where extend f w@First{} = First (f w) extend f w@(as :> _) = extend f as :> f w extract (First a) = a extract (_ :> a) = a instance ComonadApply History where First f <@> First a = First (f a) (_ :> f) <@> First a = First (f a) First f <@> (_ :> a) = First (f a) (fs :> f) <@> (as :> a) = (fs <@> as) :> f a fby :: a -> History a -> a a `fby` First _ = a _ `fby` (First b :> _) = b _ `fby` ((_ :> b) :> _) = b pos :: History a -> Int pos dx = wfix \$ dx \$> fby 0 . fmap (+1) sum :: Num a => History a -> a sum dx = extract dx + (0 `fby` extend sum dx) diff :: Num a => History a -> a diff dx = extract dx - fby 0 dx ini :: History a -> a ini dx = extract dx `fby` extend ini dx fibo :: Num b => History a -> b fibo d = wfix \$ d \$> fby 0 . extend (\dfibo -> extract dfibo + fby 1 dfibo) fibo' :: Num b => History a -> b fibo' d = fst \$ wfix \$ d \$> fby (0, 1) . fmap (\(x, x') -> (x',x+x')) plus :: Num a => History a -> History a -> History a plus = liftW2 (+)