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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
|
{-# LANGUAGE Arrows #-}
module Main(main) where
import Control.Arrow
import Control.Category
import Prelude hiding (id, (.))
class ArrowLoop a => ArrowCircuit a where
delay :: b -> a b b
-- stream map instance
data Stream a = Cons a (Stream a)
instance Functor Stream where
fmap f ~(Cons a as) = Cons (f a) (fmap f as)
zipStream :: Stream a -> Stream b -> Stream (a,b)
zipStream ~(Cons a as) ~(Cons b bs) = Cons (a,b) (zipStream as bs)
unzipStream :: Stream (a,b) -> (Stream a, Stream b)
unzipStream abs = (fmap fst abs, fmap snd abs)
newtype StreamMap a b = StreamMap (Stream a -> Stream b)
unStreamMap (StreamMap f) = f
instance Category StreamMap where
id = StreamMap id
StreamMap f . StreamMap g = StreamMap (f . g)
instance Arrow StreamMap where
arr f = StreamMap (fmap f)
first (StreamMap f) =
StreamMap (uncurry zipStream . first f . unzipStream)
instance ArrowLoop StreamMap where
loop (StreamMap f) =
StreamMap (loop (unzipStream . f . uncurry zipStream))
instance ArrowCircuit StreamMap where
delay a = StreamMap (Cons a)
listToStream :: [a] -> Stream a
listToStream = foldr Cons undefined
streamToList :: Stream a -> [a]
streamToList (Cons a as) = a:streamToList as
runStreamMap :: StreamMap a b -> [a] -> [b]
runStreamMap (StreamMap f) as =
take (length as) (streamToList (f (listToStream as)))
-- simple automaton instance
data Auto a b = Auto (a -> (b, Auto a b))
instance Category Auto where
id = Auto $ \a -> (a, id)
Auto f . Auto g = Auto $ \b ->
let (c, g') = g b
(d, f') = f c
in (d, f' . g')
instance Arrow Auto where
arr f = Auto $ \a -> (f a, arr f)
first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f')
instance ArrowLoop Auto where
loop (Auto f) = Auto $ \b ->
let (~(c,d), f') = f (b,d)
in (c, loop f')
instance ArrowCircuit Auto where
delay a = Auto $ \a' -> (a, delay a')
runAuto :: Auto a b -> [a] -> [b]
runAuto (Auto f) [] = []
runAuto (Auto f) (a:as) = let (b, f') = f a in b:runAuto f' as
-- Some simple example circuits
-- A resettable counter (first example in several Hawk papers):
counter :: ArrowCircuit a => a Bool Int
counter = proc reset -> do
rec output <- returnA -< if reset then 0 else next
next <- delay 0 -< output+1
returnA -< output
-- Some other basic circuits from the Hawk library.
-- flush: when reset is True, return d for n ticks, otherwise copy value.
-- (a variation on the resettable counter)
flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b
flush n d = proc (value, reset) -> do
rec count <- returnA -< if reset then n else max (next-1) 0
next <- delay 0 -< count
returnA -< if count > 0 then d else value
-- latch: on each tick, return the last value for which reset was True,
-- or init if there was none.
--
latch :: ArrowCircuit a => b -> a (b, Bool) b
latch init = proc (value, reset) -> do
rec out <- returnA -< if reset then value else last
last <- delay init -< out
returnA -< out
-- Some tests using the counter
test_input = [True, False, True, False, False, True, False, True]
test_input2 = zip [1..] test_input
-- A test of the resettable counter.
main = do
print (runStreamMap counter test_input)
print (runAuto counter test_input)
print (runStreamMap (flush 2 0) test_input2)
print (runAuto (flush 2 0) test_input2)
print (runStreamMap (latch 0) test_input2)
print (runAuto (latch 0) test_input2)
-- A step function (cf current in Lustre)
step :: ArrowCircuit a => b -> a (Either b c) b
step b = proc x -> do
rec last_b <- delay b -< getLeft last_b x
returnA -< last_b
where getLeft _ (Left b) = b
getLeft b (Right _) = b
|
