summaryrefslogtreecommitdiff
path: root/testsuite/tests/arrows/should_run/arrowrun003.hs
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/arrows/should_run/arrowrun003.hs')
-rw-r--r--testsuite/tests/arrows/should_run/arrowrun003.hs133
1 files changed, 133 insertions, 0 deletions
diff --git a/testsuite/tests/arrows/should_run/arrowrun003.hs b/testsuite/tests/arrows/should_run/arrowrun003.hs
new file mode 100644
index 0000000000..5f4580ab87
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun003.hs
@@ -0,0 +1,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