module Simulation.Aivika.Dynamics.Internal.Signal
(Signal,
SignalSource,
newSignalSourceWithUpdate,
newSignalSourceUnsafe,
publishSignal,
triggerSignal,
handleSignal,
handleSignal_,
updateSignal,
mapSignal,
mapSignalM,
apSignal,
filterSignal,
filterSignalM,
merge2Signals,
merge3Signals,
merge4Signals,
merge5Signals) where
import Data.IORef
import Control.Monad
import Control.Monad.Trans
import Simulation.Aivika.Dynamics.Internal.Dynamics
import Simulation.Aivika.Dynamics.Internal.Simulation
data SignalSource a =
SignalSource { publishSignal :: Signal a,
triggerSignal :: a -> Dynamics ()
}
data Signal a =
Signal { handleSignal :: (a -> Dynamics ()) ->
Simulation (Simulation ()),
updateSignal :: Dynamics ()
}
data SignalHandlerQueue a =
SignalHandlerQueue { queueStart :: IORef (Maybe (SignalHandler a)),
queueEnd :: IORef (Maybe (SignalHandler a)) }
data SignalHandler a =
SignalHandler { handlerComp :: a -> Dynamics (),
handlerPrev :: IORef (Maybe (SignalHandler a)),
handlerNext :: IORef (Maybe (SignalHandler a)) }
handleSignal_ :: Signal a -> (a -> Dynamics ()) -> Simulation ()
handleSignal_ signal h =
do x <- handleSignal signal h
return ()
newSignalSourceWithUpdate :: Dynamics () -> Simulation (SignalSource a)
newSignalSourceWithUpdate update =
Simulation $ \r ->
do start <- newIORef Nothing
end <- newIORef Nothing
let queue = SignalHandlerQueue { queueStart = start,
queueEnd = end }
signal = Signal { handleSignal = handle,
updateSignal = update }
source = SignalSource { publishSignal = signal,
triggerSignal = trigger }
handle h =
Simulation $ \r ->
do x <- enqueueSignalHandler queue h
return $ liftIO $ dequeueSignalHandler queue x
trigger a =
Dynamics $ \p ->
do let Dynamics m = update
m p
let h = queueStart queue
triggerSignalHandlers h a p
return source
newSignalSourceUnsafe :: Simulation (SignalSource a)
newSignalSourceUnsafe =
Simulation $ \r ->
do start <- newIORef Nothing
end <- newIORef Nothing
let queue = SignalHandlerQueue { queueStart = start,
queueEnd = end }
signal = Signal { handleSignal = handle,
updateSignal = update }
source = SignalSource { publishSignal = signal,
triggerSignal = trigger }
handle h =
Simulation $ \r ->
do x <- enqueueSignalHandler queue h
return $ liftIO $ dequeueSignalHandler queue x
trigger a =
Dynamics $ \p ->
let h = queueStart queue
in triggerSignalHandlers h a p
update = return ()
return source
triggerSignalHandlers :: IORef (Maybe (SignalHandler a)) -> a -> Point -> IO ()
triggerSignalHandlers r a p =
do x <- readIORef r
case x of
Nothing -> return ()
Just h ->
do let Dynamics m = handlerComp h a
m p
triggerSignalHandlers (handlerNext h) a p
enqueueSignalHandler :: SignalHandlerQueue a -> (a -> Dynamics ()) -> IO (SignalHandler a)
enqueueSignalHandler q h =
do tail <- readIORef (queueEnd q)
case tail of
Nothing ->
do prev <- newIORef Nothing
next <- newIORef Nothing
let handler = SignalHandler { handlerComp = h,
handlerPrev = prev,
handlerNext = next }
writeIORef (queueStart q) (Just handler)
writeIORef (queueEnd q) (Just handler)
return handler
Just x ->
do prev <- newIORef tail
next <- newIORef Nothing
let handler = SignalHandler { handlerComp = h,
handlerPrev = prev,
handlerNext = next }
writeIORef (handlerNext x) (Just handler)
writeIORef (queueEnd q) (Just handler)
return handler
dequeueSignalHandler :: SignalHandlerQueue a -> SignalHandler a -> IO ()
dequeueSignalHandler q h =
do prev <- readIORef (handlerPrev h)
case prev of
Nothing ->
do next <- readIORef (handlerNext h)
case next of
Nothing ->
do writeIORef (queueStart q) Nothing
writeIORef (queueEnd q) Nothing
Just y ->
do writeIORef (handlerPrev y) Nothing
writeIORef (handlerNext h) Nothing
writeIORef (queueStart q) next
Just x ->
do next <- readIORef (handlerNext h)
case next of
Nothing ->
do writeIORef (handlerPrev h) Nothing
writeIORef (handlerNext x) Nothing
writeIORef (queueEnd q) prev
Just y ->
do writeIORef (handlerPrev h) Nothing
writeIORef (handlerNext h) Nothing
writeIORef (handlerPrev y) prev
writeIORef (handlerNext x) next
mapSignal :: (a -> b) -> Signal a -> Signal b
mapSignal f m =
Signal { handleSignal = \h ->
handleSignal m $ h . f,
updateSignal =
updateSignal m }
instance Functor Signal where
fmap = mapSignal
filterSignal :: (a -> Bool) -> Signal a -> Signal a
filterSignal p m =
Signal { handleSignal = \h ->
handleSignal m $ \a ->
when (p a) $ h a,
updateSignal =
updateSignal m }
filterSignalM :: (a -> Dynamics Bool) -> Signal a -> Signal a
filterSignalM p m =
Signal { handleSignal = \h ->
handleSignal m $ \a ->
do x <- p a
when x $ h a,
updateSignal =
updateSignal m }
merge2Signals :: Signal a -> Signal a -> Signal a
merge2Signals m1 m2 =
Signal { handleSignal = \h ->
do x1 <- handleSignal m1 h
x2 <- handleSignal m2 h
return $ do { x1; x2 },
updateSignal =
do updateSignal m1
updateSignal m2 }
merge3Signals :: Signal a -> Signal a -> Signal a -> Signal a
merge3Signals m1 m2 m3 =
Signal { handleSignal = \h ->
do x1 <- handleSignal m1 h
x2 <- handleSignal m2 h
x3 <- handleSignal m3 h
return $ do { x1; x2; x3 },
updateSignal =
do updateSignal m1
updateSignal m2
updateSignal m3 }
merge4Signals :: Signal a -> Signal a -> Signal a ->
Signal a -> Signal a
merge4Signals m1 m2 m3 m4 =
Signal { handleSignal = \h ->
do x1 <- handleSignal m1 h
x2 <- handleSignal m2 h
x3 <- handleSignal m3 h
x4 <- handleSignal m4 h
return $ do { x1; x2; x3; x4 },
updateSignal =
do updateSignal m1
updateSignal m2
updateSignal m3
updateSignal m4 }
merge5Signals :: Signal a -> Signal a -> Signal a ->
Signal a -> Signal a -> Signal a
merge5Signals m1 m2 m3 m4 m5 =
Signal { handleSignal = \h ->
do x1 <- handleSignal m1 h
x2 <- handleSignal m2 h
x3 <- handleSignal m3 h
x4 <- handleSignal m4 h
x5 <- handleSignal m5 h
return $ do { x1; x2; x3; x4; x5 },
updateSignal =
do updateSignal m1
updateSignal m2
updateSignal m3
updateSignal m4
updateSignal m5 }
mapSignalM :: (a -> Dynamics b) -> Signal a -> Signal b
mapSignalM f m =
Signal { handleSignal = \h ->
handleSignal m (f >=> h),
updateSignal =
updateSignal m }
apSignal :: Dynamics (a -> b) -> Signal a -> Signal b
apSignal f m =
Signal { handleSignal = \h ->
handleSignal m $ \a -> do { x <- f; h (x a) },
updateSignal =
updateSignal m }