Simulation arrows
Simple update of the simulation arrows from Programming with Arrows to work with the modern Arrow libraries.
{-# LANGUAGE Arrows #-}
module Sim where
-- discrete event simulation library.
-- This time, every channel always carries a value, and an *initial* value must
-- be supplied before simulation starts.
import Control.Category
import Control.Monad
import Control.Monad.Fix
import Control.Arrow
import Data.IORef
import Prelude hiding ((.), id)
type Time = Double
infinity :: Time
= 1/0
infinity
data Event a = Event {time::Time, value::a}
instance Show a => Show (Event a) where
show t = show (value t)++"@"++show (time t)
-- The simulation arrow: given initial value of input signal, deliver initial
-- value of output signal and a running simulation.
-- invariant: no output event should precede the first input.
newtype Sim m a b = Sim (a -> m (b, State m a b))
sim :: Monad m => (a -> m (b, State m a b)) -> Sim m a b
= Sim $ \a -> do
sim f <- f a
(b,s) return (b,quiescent s)
quiescent :: Monad m => State m a b -> State m a b
Lift m) = Lift (liftM quiescent m)
quiescent (Wait t s k) = wait t (quiescent s) k
quiescent (Ready _ _) = error "Trying to output before first input"
quiescent (
-- running simulations.
-- invariant: output events are in non-decreasing time order,
-- output events do not precede inputs or timeouts they depend on,
-- enforced by smart constructors
data State m a b = Ready (Event b) (State m a b)
| Lift (m (State m a b))
| Wait Time (State m a b) (Event a -> State m a b)
ready :: Monad m => Event a1 -> State m a a1 -> State m a a1
= Ready e (checkSequence ("Ready "++show (time e)) (time e) r)
ready e r
lift :: Monad m => m (State m a b) -> State m a b
= Lift
lift
wait :: Monad m =>
Time -> State m a b -> (Event a -> State m a b) -> State m a b
= Wait t (checkSequence ("Wait "++show t) t f)
wait t f k -> checkSequence
(\e "Wait "++show t++" \\"++show (time e)++" ->")
(
(time e) (k e))
-- ensure all outputs occur no earlier than t
{-
-- checkSequence is a version of causal which maintains a trace of events
-- to report on an eventual failure. Useful for debugging new arrows.
-- If debugging is unnecessary, it can be replaced by causal.
checkSequence s t (Ready e f) | t <= time e = Ready e f
checkSequence s t (Lift m) =
Lift (liftM (checkSequence (s++"\nLift") t) m)
checkSequence s t (Wait t' f k) =
Wait t' (checkSequence (s++"\nWait "++show t') t f)
(\e -> checkSequence
(s++"\nWait "++show t'++" \\"++show (time e)++" ->")
t (k e))
checkSequence s t (Ready e f) =
error $ "checkSequence: "++show t++" > "++show (time e)++"\n"++s++
"\nReady "++show (time e)
-}
checkSequence :: Monad m => t -> Time -> State m a b -> State m a b
= causal
checkSequence _
causal :: Monad m => Time -> State m a b -> State m a b
Ready e f) | t <= time e = Ready e f
causal t (| otherwise = error "Violation of causality"
Lift m) = Lift (liftM (causal t) m)
causal t (Wait t' s k) = Wait t' (causal t s) (causal t.k)
causal t (
-- run function supplies initial value and input events, and runs simulation
-- in the underlying monad.
runSim :: Monad m => Sim m t t1 -> t -> [Event t] -> m ()
Sim f) a as = do
runSim (<- f a
(_,r)
runState r as
runState :: Monad m => State m t t1 -> [Event t] -> m ()
Ready _ s) as = runState s as
runState (Lift m) as = do s <- m
runState (
runState s asWait t s _) []
runState (| t==infinity = return () -- infinity never comes
| otherwise = runState s [] -- timeout
Wait t s k) (a:as)
runState (| t <= time a = runState s (a:as) -- timeout
| otherwise = runState (k a) as -- receive event
-- Transition function when a simulation receives an input
after :: Monad m => State m a a1 -> Event a -> State m a a1
Ready b s `after` a = ready b (s `after` a)
Lift m `after` a = lift (liftM (`after` a) m)
Wait t s k `after` a
| t <= time a = s `after` a
| otherwise = k a
instance Monad m => Category (Sim m) where
id = simArr id
.) = simComp
(
instance Monad m => Arrow (Sim m) where
= simArr
arr = simFirst
first
simArr :: Monad m => (a -> b) -> Sim m a b
= sim $ \a -> return (f a, s)
simArr f where s = waitInput (\a -> ready (Event (time a) (f (value a))) s)
waitInput :: Monad m => (Event a -> State m a b) -> State m a b
= wait infinity undefined k
waitInput k
simComp :: Monad m => Sim m t1 b -> Sim m t t1 -> Sim m t b
Sim g `simComp` Sim f = sim $ \a -> do
<- f a
(b,sf) <- g b
(c,sg) return (c,sf `stateComp` sg)
stateComp :: Monad m => State m t1 t -> State m t a1 -> State m t1 a1
`stateComp` Ready c sg = ready c (sf `stateComp` sg)
sf `stateComp` Lift m = lift (liftM (sf `stateComp`) m)
sf Ready b sf `stateComp` sg = sf `stateComp` (sg `after` b)
Lift m `stateComp` sg = lift (liftM (`stateComp` sg) m)
Wait tf sf kf `stateComp` Wait tg sg kg =
min tf tg) timeout (\a -> kf a `stateComp` Wait tg sg kg)
wait (where timeout | tf<tg = sf `stateComp` Wait tg sg kg
| tf>tg = Wait tf sf kf `stateComp` sg
| otherwise = sf `stateComp` sg
simFirst :: Monad m => Sim m a b -> Sim m (a, c) (b, c)
Sim f) = sim $ \(a,c) -> do
simFirst (<- f a
(b,s) return ((b,c), stateFirst b c s)
stateFirst :: Monad m => b -> c -> State m a b -> State m (a, c) (b, c)
Ready b' s) =
stateFirst b c (
wait (time b')Event (time b') (value b',c)) (stateFirst (value b') c s))
(ready (Event t' (a,c')) ->
(\(Event t' (b,c'))
ready (`after` (Event t' a)))))
(stateFirst b c' (ready b' (s Lift m) = Lift (liftM (stateFirst b c) m)
stateFirst b c (Wait t s k) =
stateFirst b c ($ \(Event t' (a,c')) ->
wait t (stateFirst b c s) Event t' (b,c')) (stateFirst b c' (k (Event t' a)))
ready (
-- Can we define a loop?
instance MonadFix m => ArrowLoop (Sim m) where
= simLoop
loop
simLoop :: MonadFix m => Sim m (t, t1) (b, t1) -> Sim m t b
Sim f) = sim $ \a -> do
simLoop (<- mfix (\(~((_,c),_)) -> f (a,c))
((b,c),s) return (b,stateLoop a c [] s)
-- stateLoop a c q s
-- a = initial value of input
-- c = initial value of state
-- q = queue of future state changes
-- s = running simulation (a,c) to (b,c)
-- result is a running simulation from a to b, where state changes are
-- fed back at the appropriate times.
stateLoop :: Monad m =>
-> t -> [(Time, t)] -> State m (a, t) (b, t) -> State m a b
a Ready (Event t (b,c')) s) =
stateLoop a c q (Event t b) (stateLoop a c (q++[(t,c')]) s)
ready (Lift m) = lift $ liftM (stateLoop a c q) m
stateLoop a c q (:q) (Wait t s k) =
stateLoop a c ((t',c')min t t') timeout $ \(Event t'' a') ->
wait (:q) (k (Event t'' (a',c)))
stateLoop a' c ((t',c')where timeout | t'<t = stateLoop a c' q (k (Event t' (a,c')))
| t'>t = stateLoop a c ((t',c'):q) s
| otherwise = stateLoop a c' q (s `after` Event t (a,c'))
Wait t s k) =
stateLoop a c [] ($ \(Event t' a') ->
wait t (stateLoop a c [] s) Event t' (a',c)))
stateLoop a' c [] (k (
-- arrM lifts a monadic function into a Sim arrow.
arrM :: Monad m => (a -> m b) -> Sim m a b
= sim $ \a -> do
arrM f <- f a
b return (b,s)
where s = waitInput $ \(Event t a) -> lift $ do
<- f a
b return (ready (Event t b) s)
--printA prints all events that pass through
printA :: Show b => [Char] -> Sim IO b b
= sim $ \a -> do
printA name show a++"@init")
message (return (a,s)
where s = waitInput $ \a -> Lift $ do
show a)
message (return (ready a s)
= if null name then putStrLn a else putStrLn (name++": "++a)
message a
--delay1 d delays events by d, removing events at the same time
delay1 :: Monad m => Time -> Sim m b b
= sim (\a -> return (a,r))
delay1 d where r = waitInput go
Event t a) =
go (+d) (ready (Event (t+d) a) r) $ \(Event t' a') ->
wait (tif t==t'
then go (Event t' a')
else ready (Event (t+d) a) (go (Event t' a'))
initially :: Monad m => b -> Sim m t b -> Sim m t b
Sim f) = Sim $ \a -> do (_,s) <- f a
initially x (return (x,s)
--nubA filters out events that repeat values
nubA :: (Eq a, Monad m) => Sim m a a
= sim $ \a -> return (a,go a)
nubA where go a = waitInput $ \(Event t a') ->
if a==a' then go a else ready (Event t a') (go a')
-- cutoff t s stops a simulation after time t
cutoff :: Monad m => Time -> Sim m t b -> Sim m t b
Sim f) = sim $ \a -> do
cutoff t (<- f a
(b,r) return (b, cutoffState t r)
cutoffState :: Monad m =>
Time -> State m a a1 -> State m a a1
Ready b s)
cutoffState t (| time b<=t = ready b (cutoffState t s)
| otherwise = stop
where stop = waitInput (const stop)
Lift m) = lift (liftM (cutoffState t) m)
cutoffState t (Wait t' s k)
cutoffState t (| t'<=t = wait t' (cutoffState t s) (cutoffState t.k)
| otherwise = wait infinity undefined (cutoffState t.k)
-- Experiments with arrow notation
nor :: Monad m => Sim m (Bool,Bool) Bool
= proc (a,b) -> do
nor <- delay1 0.1 -< (a,b)
(a',b') -< not (a'||b')
returnA
afix :: (MonadFix m, Eq b) => Sim m (a,b) b -> Sim m a b
= loop (f >>> nubA >>> arr id &&& arr id) >>> nubA
afix f
flipflop :: MonadFix m => Sim m (Bool,Bool) (Bool,Bool)
= proc (reset,set) ->
flipflop |afix (\ ~(x,y)->do
(<- initially False nor -< (reset,y)
x' <- initially True nor -< (set,x)
y' -< (x',y'))|)
returnA
oscillator :: MonadFix m => Sim m Bool Bool
= proc enable ->
oscillator |afix (\x -> nor -< (enable,x))|)
(
-- probe counts the transitions on a channel
-- this is useful for estimating power consumption
probe :: Metric a => String -> (Sim IO a a -> IO b) -> IO b
= do r <- newIORef 0
probe s k <- k (probeArr r)
ans <- readIORef r
n putStrLn (s++": "++show n++" transitions")
return ans
where probeArr r = sim $ \a -> return (a, stateProbe r a)
= waitInput $ \(Event t b) ->
stateProbe r a $ do
lift +distance a b)
modifyIORef r (return (ready (Event t b) (stateProbe r b))
class Metric a where
distance :: a -> a -> Double
bound :: a -> Double -- the distance between any two points is below bound
-- bound does not evaluate its argument
instance Metric Bool where
= if a==b then 0 else 1
distance a b = 1
bound _
instance (Metric a, Metric b) => Metric (a,b) where
= distance a c+distance b d
distance (a,b) (c,d) ~(a,b)= bound a + bound b
bound
instance (Metric a, Metric b) => Metric (Either a b) where
Left a) (Left a') = distance a a'
distance (Right b) (Right b') = distance b b'
distance (= 1 + (bound a `max` bound b)
distance x _ where Left a = x
Right b = x
= 1 + (bound l `max` bound r)
bound x where Left l = x
Right r = x
instance Metric a => Metric [a] where
= 0
distance [] [] :xs) (y:ys) = distance x y + distance xs ys
distance (x:ys) = (bound y+1)*(fromInteger (toInteger (length ys))+1)
distance [] (y= distance [] xs
distance xs [] = infinity bound _