1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
|
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
{-# OPTIONS_GHC -Wall #-}
-- http://www.mail-archive.com/haskell@haskell.org/msg17244.html
module History where
import Control.Category
import Control.Comonad
import Data.Foldable hiding (sum)
import Data.Traversable
import Prelude hiding (id,(.),sum)
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 (+)
|
