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