1{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2{-# OPTIONS_GHC -Wall #-} 3 4-- http://www.mail-archive.com/haskell@haskell.org/msg17244.html 5module History where 6 7import Control.Category 8import Control.Comonad 9import Data.Foldable hiding (sum) 10import Data.Traversable 11import Prelude hiding (id,(.),sum) 12 13infixl 4 :> 14 15data History a = First a | History a :> a 16 deriving (Functor, Foldable, Traversable, Show) 17 18runHistory :: (History a -> b) -> [a] -> [b] 19runHistory _ [] = [] 20runHistory f (a0:as0) = run (First a0) as0 21 where 22 run az [] = [f az] 23 run az (a:as) = f az : run (az :> a) as 24 25instance Comonad History where 26 extend f w@First{} = First (f w) 27 extend f w@(as :> _) = extend f as :> f w 28 extract (First a) = a 29 extract (_ :> a) = a 30 31instance ComonadApply History where 32 First f <@> First a = First (f a) 33 (_ :> f) <@> First a = First (f a) 34 First f <@> (_ :> a) = First (f a) 35 (fs :> f) <@> (as :> a) = (fs <@> as) :> f a 36 37fby :: a -> History a -> a 38a `fby` First _ = a 39_ `fby` (First b :> _) = b 40_ `fby` ((_ :> b) :> _) = b 41 42pos :: History a -> Int 43pos dx = wfix $ dx $> fby 0 . fmap (+1) 44 45sum :: Num a => History a -> a 46sum dx = extract dx + (0 `fby` extend sum dx) 47 48diff :: Num a => History a -> a 49diff dx = extract dx - fby 0 dx 50 51ini :: History a -> a 52ini dx = extract dx `fby` extend ini dx 53 54fibo :: Num b => History a -> b 55fibo d = wfix $ d $> fby 0 . extend (\dfibo -> extract dfibo + fby 1 dfibo) 56 57fibo' :: Num b => History a -> b 58fibo' d = fst $ wfix $ d $> fby (0, 1) . fmap (\(x, x') -> (x',x+x')) 59 60plus :: Num a => History a -> History a -> History a 61plus = liftW2 (+) 62