content: 
  -- |
  -- Module     : Simulation.Aivika.Signal
  -- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
  -- License    : BSD3
  -- Maintainer : David Sorokin <david.sorokin@gmail.com>
  -- Stability  : experimental
  -- Tested with: GHC 8.0.1
  --
  -- This module defines the signal which we can subscribe handlers to. 
  -- These handlers can be disposed. The signal is triggered in the 
  -- current time point actuating the corresponded computations from 
  -- the handlers. 
  --
  module Simulation.Aivika.Signal
         (-- * Handling and Triggering Signal
          Signal(..),
          handleSignal_,
          handleSignalComposite,
          SignalSource,
          newSignalSource,
          publishSignal,
          triggerSignal,
          -- * Useful Combinators
          mapSignal,
          mapSignalM,
          apSignal,
          filterSignal,
          filterSignal_,
          filterSignalM,
          filterSignalM_,
          emptySignal,
          merge2Signals,
          merge3Signals,
          merge4Signals,
          merge5Signals,
          -- * Signal Arriving
          arrivalSignal,
          -- * Creating Signal in Time Points
          newSignalInTimes,
          newSignalInIntegTimes,
          newSignalInStartTime,
          newSignalInStopTime,
          newSignalInTimeGrid,
          -- * Delaying Signal
          delaySignal,
          delaySignalM,
          -- * Signal History
          SignalHistory,
          signalHistorySignal,
          newSignalHistory,
          newSignalHistoryStartingWith,
          readSignalHistory,
          -- * Signalable Computations
          Signalable(..),
          signalableChanged,
          emptySignalable,
          appendSignalable,
          -- * Debugging
          traceSignal) where
  
  import Data.IORef
  import Data.Monoid hiding ((<>))
  import Data.Semigroup (Semigroup(..))
  import Data.List.NonEmpty (NonEmpty((:|)))
  import Data.List
  import Data.Array
  
  import Control.Monad
  import Control.Monad.Trans
  
  import Simulation.Aivika.Internal.Specs
  import Simulation.Aivika.Internal.Parameter
  import Simulation.Aivika.Internal.Simulation
  import Simulation.Aivika.Internal.Dynamics
  import Simulation.Aivika.Internal.Event
  import Simulation.Aivika.Internal.Arrival
  import Simulation.Aivika.Composite
  
  import qualified Simulation.Aivika.Vector as V
  import qualified Simulation.Aivika.Vector.Unboxed as UV
  
  -- | The signal source that can publish its signal.
  data SignalSource a =
    SignalSource { publishSignal :: Signal a,
                                    -- ^ Publish the signal.
                   triggerSignal :: a -> Event ()
                                    -- ^ Trigger the signal actuating 
                                    -- all its handlers at the current 
                                    -- simulation time point.
                 }
    
  -- | The signal that can have disposable handlers.  
  data Signal a =
    Signal { handleSignal :: (a -> Event ()) -> Event DisposableEvent
             -- ^ Subscribe the handler to the specified 
             -- signal and return a nested computation
             -- within a disposable object that, being applied,
             -- unsubscribes the handler from this signal.
           }
    
  -- | The queue of signal handlers.
  data SignalHandlerQueue a =
    SignalHandlerQueue { queueList :: IORef [SignalHandler a] }
    
  -- | It contains the information about the disposable queue handler.
  data SignalHandler a =
    SignalHandler { handlerComp :: a -> Event (),
                    handlerRef  :: IORef () }
  
  instance Eq (SignalHandler a) where
    x == y = (handlerRef x) == (handlerRef y)
  
  -- | Subscribe the handler to the specified signal forever.
  -- To subscribe the disposable handlers, use function 'handleSignal'.
  handleSignal_ :: Signal a -> (a -> Event ()) -> Event ()
  handleSignal_ signal h = 
    do x <- handleSignal signal h
       return ()
  
  -- | Like 'handleSignal' but within the 'Composite' computation.
  handleSignalComposite :: Signal a -> (a -> Event ()) -> Composite ()
  handleSignalComposite signal h =
    do x <- liftEvent $ handleSignal signal h
       disposableComposite x
       
  -- | Create a new signal source.
  newSignalSource :: Simulation (SignalSource a)
  newSignalSource =
    Simulation $ \r ->
    do list <- newIORef []
       let queue  = SignalHandlerQueue { queueList = list }
           signal = Signal { handleSignal = handle }
           source = SignalSource { publishSignal = signal, 
                                   triggerSignal = trigger }
           handle h =
             Event $ \p ->
             do x <- enqueueSignalHandler queue h
                return $
                  DisposableEvent $
                  Event $ \p -> dequeueSignalHandler queue x
           trigger a =
             Event $ \p -> triggerSignalHandlers queue a p
       return source
  
  -- | Trigger all next signal handlers.
  triggerSignalHandlers :: SignalHandlerQueue a -> a -> Point -> IO ()
  {-# INLINE triggerSignalHandlers #-}
  triggerSignalHandlers q a p =
    do hs <- readIORef (queueList q)
       forM_ hs $ \h ->
         invokeEvent p $ handlerComp h a
              
  -- | Enqueue the handler and return its representative in the queue.            
  enqueueSignalHandler :: SignalHandlerQueue a -> (a -> Event ()) -> IO (SignalHandler a)
  {-# INLINE enqueueSignalHandler #-}
  enqueueSignalHandler q h = 
    do r <- newIORef ()
       let handler = SignalHandler { handlerComp = h,
                                     handlerRef  = r }
       modifyIORef (queueList q) (handler :)
       return handler
  
  -- | Dequeue the handler representative.
  dequeueSignalHandler :: SignalHandlerQueue a -> SignalHandler a -> IO ()
  {-# INLINE dequeueSignalHandler #-}
  dequeueSignalHandler q h = 
    modifyIORef (queueList q) (delete h)
  
  instance Functor Signal where
    fmap = mapSignal
  
  instance Semigroup (Signal a) where
    (<>) = merge2Signals
  
    sconcat (x1 :| []) = x1
    sconcat (x1 :| [x2]) = merge2Signals x1 x2
    sconcat (x1 :| [x2, x3]) = merge3Signals x1 x2 x3
    sconcat (x1 :| [x2, x3, x4]) = merge4Signals x1 x2 x3 x4
    sconcat (x1 :| [x2, x3, x4, x5]) = merge5Signals x1 x2 x3 x4 x5
    sconcat (x1 :| x2 : x3 : x4 : x5 : xs) =
      sconcat $ merge5Signals x1 x2 x3 x4 x5 :| xs
  
  instance Monoid (Signal a) where 
    
    mempty = emptySignal
    
    mappend = (<>)
    
    mconcat [] = emptySignal
    mconcat (h : t) = sconcat (h :| t)
    
  -- | Map the signal according the specified function.
  mapSignal :: (a -> b) -> Signal a -> Signal b
  mapSignal f m =
    Signal { handleSignal = \h -> 
              handleSignal m $ h . f }
  
  -- | Filter only those signal values that satisfy 
  -- the specified predicate.
  filterSignal :: (a -> Bool) -> Signal a -> Signal a
  filterSignal p m =
    Signal { handleSignal = \h ->
              handleSignal m $ \a ->
              when (p a) $ h a }
  
  -- | Filter only those signal values that satisfy
  -- the specified predicate, but then ignoring the values.
  filterSignal_ :: (a -> Bool) -> Signal a -> Signal ()
  filterSignal_ p m =
    Signal { handleSignal = \h ->
              handleSignal m $ \a ->
              when (p a) $ h () }
    
  -- | Filter only those signal values that satisfy
  -- the specified predicate.
  filterSignalM :: (a -> Event Bool) -> Signal a -> Signal a
  filterSignalM p m =
    Signal { handleSignal = \h ->
              handleSignal m $ \a ->
              do x <- p a
                 when x $ h a }
    
  -- | Filter only those signal values that satisfy
  -- the specified predicate, but then ignoring the values.
  filterSignalM_ :: (a -> Event Bool) -> Signal a -> Signal ()
  filterSignalM_ p m =
    Signal { handleSignal = \h ->
              handleSignal m $ \a ->
              do x <- p a
                 when x $ h () }
    
  -- | Merge two signals.
  merge2Signals :: Signal a -> Signal a -> Signal a
  merge2Signals m1 m2 =
    Signal { handleSignal = \h ->
              do x1 <- handleSignal m1 h
                 x2 <- handleSignal m2 h
                 return $ x1 <> x2 }
  
  -- | Merge three signals.
  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 $ x1 <> x2 <> x3 }
  
  -- | Merge four signals.
  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 $ x1 <> x2 <> x3 <> x4 }
             
  -- | Merge five signals.
  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 $ x1 <> x2 <> x3 <> x4 <> x5 }
  
  -- | Compose the signal.
  mapSignalM :: (a -> Event b) -> Signal a -> Signal b
  mapSignalM f m =
    Signal { handleSignal = \h ->
              handleSignal m (f >=> h) }
    
  -- | Transform the signal.
  apSignal :: Event (a -> b) -> Signal a -> Signal b
  apSignal f m =
    Signal { handleSignal = \h ->
              handleSignal m $ \a -> do { x <- f; h (x a) } }
  
  -- | An empty signal which is never triggered.
  emptySignal :: Signal a
  emptySignal =
    Signal { handleSignal = \h -> return mempty }
                                      
  -- | Represents the history of the signal values.
  data SignalHistory a =
    SignalHistory { signalHistorySignal :: Signal a,  
                    -- ^ The signal for which the history is created.
                    signalHistoryTimes  :: UV.Vector Double,
                    signalHistoryValues :: V.Vector a }
  
  -- | Create a history of the signal values.
  newSignalHistory :: Signal a -> Composite (SignalHistory a)
  newSignalHistory =
    newSignalHistoryStartingWith Nothing
  
  -- | Create a history of the signal values starting with
  -- the optional initial value.
  newSignalHistoryStartingWith :: Maybe a -> Signal a -> Composite (SignalHistory a)
  newSignalHistoryStartingWith init signal =
    do ts <- liftIO UV.newVector
       xs <- liftIO V.newVector
       case init of
         Nothing -> return ()
         Just a ->
           do t <- liftDynamics time
              liftIO $
                do UV.appendVector ts t
                   V.appendVector xs a
       handleSignalComposite signal $ \a ->
         Event $ \p ->
         do UV.appendVector ts (pointTime p)
            V.appendVector xs a
       return SignalHistory { signalHistorySignal = signal,
                              signalHistoryTimes  = ts,
                              signalHistoryValues = xs }
         
  -- | Read the history of signal values.
  readSignalHistory :: SignalHistory a -> Event (Array Int Double, Array Int a)
  readSignalHistory history =
    do xs <- liftIO $ UV.freezeVector (signalHistoryTimes history)
       ys <- liftIO $ V.freezeVector (signalHistoryValues history)
       return (xs, ys)     
       
  -- | Trigger the signal with the current time.
  triggerSignalWithCurrentTime :: SignalSource Double -> Event ()
  triggerSignalWithCurrentTime s =
    Event $ \p -> invokeEvent p $ triggerSignal s (pointTime p)
  
  -- | Return a signal that is triggered in the specified time points.
  newSignalInTimes :: [Double] -> Event (Signal Double)
  newSignalInTimes xs =
    do s <- liftSimulation newSignalSource
       enqueueEventWithTimes xs $ triggerSignalWithCurrentTime s
       return $ publishSignal s
         
  -- | Return a signal that is triggered in the integration time points.
  -- It should be called with help of 'runEventInStartTime'.
  newSignalInIntegTimes :: Event (Signal Double)
  newSignalInIntegTimes =
    do s <- liftSimulation newSignalSource
       enqueueEventWithIntegTimes $ triggerSignalWithCurrentTime s
       return $ publishSignal s
       
  -- | Return a signal that is triggered in the start time.
  -- It should be called with help of 'runEventInStartTime'.
  newSignalInStartTime :: Event (Signal Double)
  newSignalInStartTime =
    do s <- liftSimulation newSignalSource
       t <- liftParameter starttime
       enqueueEvent t $ triggerSignalWithCurrentTime s
       return $ publishSignal s
  
  -- | Return a signal that is triggered in the final time.
  newSignalInStopTime :: Event (Signal Double)
  newSignalInStopTime =
    do s <- liftSimulation newSignalSource
       t <- liftParameter stoptime
       enqueueEvent t $ triggerSignalWithCurrentTime s
       return $ publishSignal s
  
  -- | Return a signal that is trigged in the grid by specified size.
  newSignalInTimeGrid :: Int -> Event (Signal Int)
  newSignalInTimeGrid n =
    do sc <- liftParameter simulationSpecs
       s  <- liftSimulation newSignalSource
       let loop []            = return ()
           loop ((i, t) : xs) = enqueueEvent t $
                                do triggerSignal s i
                                   loop xs
       loop $ timeGrid sc n
       return $ publishSignal s
  
  -- | Describes a computation that also signals when changing its value.
  data Signalable a =
    Signalable { readSignalable :: Event a,
                 -- ^ Return a computation of the value.
                 signalableChanged_ :: Signal ()
                 -- ^ Return a signal notifying that the value has changed
                 -- but without providing the information about the changed value.
               }
  
  -- | Return a signal notifying that the value has changed.
  signalableChanged :: Signalable a -> Signal a
  signalableChanged x = mapSignalM (const $ readSignalable x) $ signalableChanged_ x
  
  instance Functor Signalable where
    fmap f x = x { readSignalable = fmap f (readSignalable x) }
  
  instance Semigroup a => Semigroup (Signalable a) where
    (<>) = appendSignalable
  
  instance (Monoid a, Semigroup a) => Monoid (Signalable a) where
  
    mempty = emptySignalable
    mappend = (<>)
  
  -- | Return an identity.
  emptySignalable :: Monoid a => Signalable a
  emptySignalable =
    Signalable { readSignalable = return mempty,
                 signalableChanged_ = mempty }
  
  -- | An associative operation.
  appendSignalable :: Semigroup a => Signalable a -> Signalable a -> Signalable a
  appendSignalable m1 m2 =
    Signalable { readSignalable = liftM2 (<>) (readSignalable m1) (readSignalable m2),
                 signalableChanged_ = (signalableChanged_ m1) <> (signalableChanged_ m2) }
  
  -- | Transform a signal so that the resulting signal returns a sequence of arrivals
  -- saving the information about the time points at which the original signal was received.
  arrivalSignal :: Signal a -> Signal (Arrival a)
  arrivalSignal m = 
    Signal { handleSignal = \h ->
               Event $ \p ->
               do r <- newIORef Nothing
                  invokeEvent p $
                    handleSignal m $ \a ->
                    Event $ \p ->
                    do t0 <- readIORef r
                       let t = pointTime p
                       writeIORef r (Just t)
                       invokeEvent p $
                         h Arrival { arrivalValue = a,
                                     arrivalTime  = t,
                                     arrivalDelay =
                                       case t0 of
                                         Nothing -> Nothing
                                         Just t0 -> Just (t - t0) }
           }
  
  -- | Delay the signal values for the specified time interval.
  delaySignal :: Double -> Signal a -> Signal a
  delaySignal delta m =
    Signal { handleSignal = \h ->
              do r <- liftIO $ newIORef False
                 h <- handleSignal m $ \a ->
                   Event $ \p ->
                   invokeEvent p $
                   enqueueEvent (pointTime p + delta) $ 
                   do x <- liftIO $ readIORef r
                      unless x $ h a
                 return $ DisposableEvent $
                   disposeEvent h >>
                   (liftIO $ writeIORef r True)
           }
  
  -- | Delay the signal values for time intervals recalculated for each value.
  delaySignalM :: Event Double -> Signal a -> Signal a
  delaySignalM delta m =
    Signal { handleSignal = \h ->
              do r <- liftIO $ newIORef False
                 h <- handleSignal m $ \a ->
                   Event $ \p ->
                   do delta' <- invokeEvent p delta
                      invokeEvent p $
                        enqueueEvent (pointTime p + delta') $ 
                        do x <- liftIO $ readIORef r
                           unless x $ h a
                 return $ DisposableEvent $
                   disposeEvent h >>
                   (liftIO $ writeIORef r True)
           }
  
  -- | Show the debug message with the current simulation time.
  traceSignal :: String -> Signal a -> Signal a 
  traceSignal message m =
    Signal { handleSignal = \h ->
              handleSignal m $ traceEvent message . h }
  