aivika-realtime (empty) → 0.1
raw patch · 13 files changed
+969/−0 lines, 13 filesdep +aivikadep +aivika-transformersdep +asyncsetup-changed
Dependencies added: aivika, aivika-transformers, async, base, containers, mtl, stm, time
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.lhs +3/−0
- Simulation/Aivika/RealTime.hs +18/−0
- Simulation/Aivika/RealTime/Event.hs +18/−0
- Simulation/Aivika/RealTime/Internal/Channel.hs +76/−0
- Simulation/Aivika/RealTime/Internal/Event.hs +224/−0
- Simulation/Aivika/RealTime/Internal/RT.hs +157/−0
- Simulation/Aivika/RealTime/RT.hs +127/−0
- aivika-realtime.cabal +53/−0
- tests/MachRep1.hs +80/−0
- tests/MachRep1Ver2.hs +87/−0
- tests/MachRep1Ver3.hs +91/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@++Version 0.1+-----++* Initial version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016 David Sorokin <david.sorokin@gmail.com>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Simulation/Aivika/RealTime.hs view
@@ -0,0 +1,18 @@++-- |+-- Module : Simulation.Aivika.RealTime+-- Copyright : Copyright (c) 2016, 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 re-exports the library functionality.+--+module Simulation.Aivika.RealTime+ (-- * Modules+ module Simulation.Aivika.RealTime.RT,+ module Simulation.Aivika.RealTime.Event) where++import Simulation.Aivika.RealTime.RT+import Simulation.Aivika.RealTime.Event
+ Simulation/Aivika/RealTime/Event.hs view
@@ -0,0 +1,18 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Simulation.Aivika.RealTime.Event+-- Copyright : Copyright (c) 2016, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 8.0.1+--+-- The module defines an event queue, where 'RT' can be an instance of 'EventQueueing'.+--+module Simulation.Aivika.RealTime.Event () where++import Simulation.Aivika.Trans+import Simulation.Aivika.RealTime.Internal.Event+import Simulation.Aivika.RealTime.Internal.RT
+ Simulation/Aivika/RealTime/Internal/Channel.hs view
@@ -0,0 +1,76 @@++-- |+-- Module : Simulation.Aivika.RealTime.Internal.Channel+-- Copyright : Copyright (c) 2016, 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 a channel with fast checking procedure whether the channel is empty.+--+module Simulation.Aivika.RealTime.Internal.Channel+ (Channel,+ newChannel,+ channelEmpty,+ readChannel,+ writeChannel,+ awaitChannel) where++import Data.List+import Data.IORef++import Control.Concurrent.STM+import Control.Monad++-- | A channel.+data Channel a =+ Channel { channelList :: TVar [a],+ channelListEmpty :: TVar Bool,+ channelListEmptyIO :: IORef Bool+ }++-- | Create a new channel.+newChannel :: IO (Channel a)+newChannel =+ do list <- newTVarIO []+ listEmpty <- newTVarIO True+ listEmptyIO <- newIORef True+ return Channel { channelList = list,+ channelListEmpty = listEmpty,+ channelListEmptyIO = listEmptyIO }++-- | Test quickly whether the channel is empty.+channelEmpty :: Channel a -> IO Bool+channelEmpty ch =+ readIORef (channelListEmptyIO ch)++-- | Read all data from the channel. +readChannel :: Channel a -> IO [a]+readChannel ch =+ do empty <- readIORef (channelListEmptyIO ch)+ if empty+ then return []+ else do writeIORef (channelListEmptyIO ch) True+ xs <- atomically $+ do xs <- readTVar (channelList ch)+ writeTVar (channelList ch) []+ writeTVar (channelListEmpty ch) True+ return xs+ return (reverse xs)++-- | Write the value in the channel.+writeChannel :: Channel a -> a -> IO ()+writeChannel ch a =+ do atomically $+ do xs <- readTVar (channelList ch)+ writeTVar (channelList ch) (a : xs)+ writeTVar (channelListEmpty ch) False+ writeIORef (channelListEmptyIO ch) False++-- | Wait for data in the channel.+awaitChannel :: Channel a -> IO ()+awaitChannel ch =+ atomically $+ do empty <- readTVar (channelListEmpty ch)+ when empty retry
+ Simulation/Aivika/RealTime/Internal/Event.hs view
@@ -0,0 +1,224 @@++{-# LANGUAGE TypeFamilies, FlexibleInstances #-}++-- |+-- Module : Simulation.Aivika.RealTime.Internal.Event+-- Copyright : Copyright (c) 2016, David Sorokin <david.sorokin@gmail.com>+-- License : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability : experimental+-- Tested with: GHC 8.0.1+--+-- The module defines an event queue.+--+module Simulation.Aivika.RealTime.Internal.Event () where++import Data.Maybe+import Data.IORef+import Data.Time.Clock++import System.Timeout++import Control.Monad+import Control.Monad.Trans+import Control.Exception++import qualified Simulation.Aivika.PriorityQueue as PQ++import Simulation.Aivika.Trans+import Simulation.Aivika.Trans.Internal.Types++import Simulation.Aivika.RealTime.Internal.Channel+import Simulation.Aivika.RealTime.Internal.RT++-- | An implementation of the 'EventQueueing' type class.+instance MonadIO m => EventQueueing (RT m) where++ {-# SPECIALIZE instance EventQueueing (RT IO) #-}++ -- | The event queue type.+ data EventQueue (RT m) =+ EventQueueRT { queuePQ :: PQ.PriorityQueue (Point (RT m) -> RT m ()),+ -- ^ the underlying priority queue+ queueBusy :: IORef Bool,+ -- ^ whether the queue is currently processing events+ queueTime :: IORef Double,+ -- ^ the actual time of the event queue+ queueStartUTCTime :: UTCTime+ -- ^ the system time of starting the simulation+ }++ newEventQueue specs =+ do t0 <- liftIO getCurrentTime+ t <- liftIO $ newIORef $ spcStartTime specs+ f <- liftIO $ newIORef False+ pq <- liftIO PQ.newQueue+ return EventQueueRT { queuePQ = pq,+ queueBusy = f,+ queueTime = t,+ queueStartUTCTime = t0 }++ enqueueEvent t (Event m) =+ Event $ \p ->+ let pq = queuePQ $ runEventQueue $ pointRun p+ in liftIO $ PQ.enqueue pq t m++ runEventWith processing (Event e) =+ Dynamics $ \p ->+ do invokeDynamics p $ processEvents processing+ e p++ eventQueueCount =+ Event $ \p ->+ let pq = queuePQ $ runEventQueue $ pointRun p+ in liftIO $ PQ.queueCount pq++-- | Return the current event point.+currentEventPoint :: MonadIO m => Event (RT m) (Point (RT m))+{-# INLINE currentEventPoint #-}+currentEventPoint =+ Event $ \p ->+ do let q = runEventQueue $ pointRun p+ t' <- liftIO $ readIORef (queueTime q)+ if t' == pointTime p+ then return p+ else let sc = pointSpecs p+ t0 = spcStartTime sc+ dt = spcDT sc+ n' = fromIntegral $ floor ((t' - t0) / dt)+ in return p { pointTime = t',+ pointIteration = n',+ pointPhase = -1 }++-- | Process the pending events.+processPendingEventsCore :: MonadIO m => Bool -> Dynamics (RT m) ()+{-# INLINE processPendingEventsCore #-}+processPendingEventsCore includingCurrentEvents = Dynamics r where+ r p =+ do let q = runEventQueue $ pointRun p+ f = queueBusy q+ f' <- liftIO $ readIORef f+ if f'+ then error $+ "Detected an event loop, which may indicate to " +++ "a logical error in the model: processPendingEventsCore"+ else do liftIO $ writeIORef f True+ call q p p+ liftIO $ writeIORef f False+ call q p p0 =+ do let pq = queuePQ q+ r = pointRun p+ -- process external actions+ p1 <- invokeEvent p0 currentEventPoint+ invokeEvent p1 processChannelActions+ -- proceed with processing the events+ f <- liftIO $ PQ.queueNull pq+ unless f $+ do (t2, c2) <- liftIO $ PQ.queueFront pq+ let t = queueTime q+ t' <- liftIO $ readIORef t+ when (t2 < t') $ + -- error "The time value is too small: processPendingEventsCore"+ error $+ "The time value is too small (" ++ show t2 +++ " < " ++ show t' ++ "): processPendingEventsCore"+ when ((t2 < pointTime p) ||+ (includingCurrentEvents && (t2 == pointTime p))) $+ do emulated <- invokeEvent p1 $ emulateRealTimeDelay t2+ if emulated+ then do let sc = pointSpecs p+ t0 = spcStartTime sc+ dt = spcDT sc+ n2 = fromIntegral $ floor ((t2 - t0) / dt)+ p2 = p { pointTime = t2,+ pointIteration = n2,+ pointPhase = -1 }+ liftIO $ writeIORef t t2+ liftIO $ PQ.dequeue pq+ c2 p2+ call q p p2+ else call q p p1++-- | Process the pending events synchronously, i.e. without past.+processPendingEvents :: MonadIO m => Bool -> Dynamics (RT m) ()+{-# INLINE processPendingEvents #-}+processPendingEvents includingCurrentEvents = Dynamics r where+ r p =+ do let q = runEventQueue $ pointRun p+ t = queueTime q+ t' <- liftIO $ readIORef t+ if pointTime p < t'+ then error $+ "The current time is less than " +++ "the time in the queue: processPendingEvents"+ else invokeDynamics p m+ m = processPendingEventsCore includingCurrentEvents++-- | A memoized value.+processEventsIncludingCurrent :: MonadIO m => Dynamics (RT m) ()+{-# INLINE processEventsIncludingCurrent #-}+processEventsIncludingCurrent = processPendingEvents True++-- | A memoized value.+processEventsIncludingEarlier :: MonadIO m => Dynamics (RT m) ()+{-# INLINE processEventsIncludingEarlier #-}+processEventsIncludingEarlier = processPendingEvents False++-- | A memoized value.+processEventsIncludingCurrentCore :: MonadIO m => Dynamics (RT m) ()+{-# INLINE processEventsIncludingCurrentCore #-}+processEventsIncludingCurrentCore = processPendingEventsCore True++-- | A memoized value.+processEventsIncludingEarlierCore :: MonadIO m => Dynamics (RT m) ()+{-# INLINE processEventsIncludingEarlierCore #-}+processEventsIncludingEarlierCore = processPendingEventsCore True++-- | Process the events.+processEvents :: MonadIO m => EventProcessing -> Dynamics (RT m) ()+{-# INLINABLE processEvents #-}+processEvents CurrentEvents = processEventsIncludingCurrent+processEvents EarlierEvents = processEventsIncludingEarlier+processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore+processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore++-- | Process the channel actions.+processChannelActions :: MonadIO m => Event (RT m) ()+{-# INLINABLE processChannelActions #-}+processChannelActions =+ Event $ \p ->+ do ch <- rtChannel+ f <- liftIO $ channelEmpty ch+ unless f $+ do xs <- liftIO $ readChannel ch+ forM_ xs $ invokeEvent p++-- | Try to emulate the real time delay till the specified+-- modeling time without interruption.+emulateRealTimeDelay :: MonadIO m => Double -> Event (RT m) Bool+{-# INLINABLE emulateRealTimeDelay #-}+emulateRealTimeDelay t2 =+ Event $ \p ->+ do ps <- rtParams+ utc <- liftIO getCurrentTime+ let scaling = rtScaling ps+ delta = rtIntervalDelta ps+ sc = pointSpecs p+ t0 = spcStartTime sc+ t = pointTime p+ dt = rtScale scaling t0 t2+ q = runEventQueue (pointRun p)+ utc0 = queueStartUTCTime q+ utc' = addUTCTime (fromRational $ toRational dt) utc0+ rdt = fromRational $ toRational (diffUTCTime utc' utc)+ if rdt < delta+ then return True+ else do ch <- rtChannel+ let dt = secondsToMicroseconds rdt+ interrupted <- liftIO $+ timeout dt $ awaitChannel ch+ return $ isNothing interrupted++-- | Convert seconds to microseconds.+secondsToMicroseconds :: Double -> Int+secondsToMicroseconds x = fromInteger $ toInteger $ round (1000000 * x)
+ Simulation/Aivika/RealTime/Internal/RT.hs view
@@ -0,0 +1,157 @@++-- |+-- Module : Simulation.Aivika.RealTime.Internal.RT+-- Copyright : Copyright (c) 2016, 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 a soft real-time computation based on 'IO'.+--+module Simulation.Aivika.RealTime.Internal.RT+ (RT(..),+ RTParams(..),+ RTContext(..),+ RTScaling(..),+ invokeRT,+ runRT,+ defaultRTParams,+ newRTContext,+ rtParams,+ rtChannel,+ rtScale) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Exception+import Simulation.Aivika.Trans.Internal.Types++import Simulation.Aivika.RealTime.Internal.Channel++-- | How the modeling time is scaled to a real time.+data RTScaling = RTLinearScaling Double+ -- ^ one unit of modeling time interval matches+ -- the specified amount of real seconds+ | RTLogScaling Double+ -- ^ the logarithm of one unit of modeling time+ -- interval matches the specified amount of+ -- real seconds+ | RTScalingFunction (Double -> Double -> Double)+ -- ^ we explicitly define how many real seconds+ -- will we receive for the interval specified by+ -- the provided start time and current modeling time++-- | Scale the modeling time to a real time.+rtScale :: RTScaling+ -- ^ the scaling method+ -> Double+ -- ^ the start modeling time+ -> Double+ -- ^ the current modeling time+ -> Double+ -- ^ the real time interval+rtScale (RTLinearScaling k) t0 t = k * (t - t0)+rtScale (RTLogScaling k) t0 t = k * log (t - t0)+rtScale (RTScalingFunction f) t0 t = f t0 t++-- | The parameters for the 'RT' computation.+data RTParams =+ RTParams { rtScaling :: RTScaling,+ -- ^ The scaling of the modeling time to a real time.+ rtIntervalDelta :: Double+ -- ^ The real time interval accuracy in seconds.+ }++-- | The soft real-time computation based on 'IO'-derived computation @m@.+newtype RT m a = RT { unRT :: RTContext m -> m a+ -- ^ Unwrap the computation.+ }++-- | The context of the 'RT' computation.+data RTContext m =+ RTContext { rtChannel0 :: Channel (Event (RT m) ()),+ -- ^ The channel of pending actions.+ rtParams0 :: RTParams+ -- ^ The parameters of the computation.+ }++instance Monad m => Monad (RT m) where++ {-# INLINE return #-}+ return = RT . const . return++ {-# INLINE (>>=) #-}+ (RT m) >>= k = RT $ \ctx ->+ m ctx >>= \a ->+ let m' = unRT (k a) in m' ctx++instance Applicative m => Applicative (RT m) where++ {-# INLINE pure #-}+ pure = RT . const . pure++ {-# INLINE (<*>) #-}+ (RT f) <*> (RT m) = RT $ \ctx -> f ctx <*> m ctx ++instance Functor m => Functor (RT m) where++ {-# INLINE fmap #-}+ fmap f (RT m) = RT $ fmap f . m ++instance MonadIO m => MonadIO (RT m) where++ {-# INLINE liftIO #-}+ liftIO = RT . const . liftIO+ +instance MonadException m => MonadException (RT m) where++ {-# INLINE catchComp #-}+ catchComp (RT m) h = RT $ \ctx ->+ catchComp (m ctx) (\e -> unRT (h e) ctx)++ {-# INLINE finallyComp #-}+ finallyComp (RT m1) (RT m2) = RT $ \ctx ->+ finallyComp (m1 ctx) (m2 ctx)++ {-# INLINE throwComp #-}+ throwComp e = RT $ \ctx ->+ throwComp e++-- | Invoke the 'RT' computation.+invokeRT :: RTContext m -> RT m a -> m a+{-# INLINE invokeRT #-}+invokeRT ctx (RT m) = m ctx++-- | The default parameters for the 'RT' computation,+-- where one unit of modeling time matches one real second+-- and the real time interval is specified with precision of+-- one millisecond.+defaultRTParams :: RTParams+defaultRTParams =+ RTParams { rtScaling = RTLinearScaling 1,+ rtIntervalDelta = 0.001+ }++-- | Return the parameters of the current computation.+rtParams :: Monad m => RT m RTParams+{-# INLINE rtParams #-}+rtParams = RT $ return . rtParams0++-- | Return the chanel of pending actions.+rtChannel :: Monad m => RT m (Channel (Event (RT m) ()))+{-# INLINE rtChannel #-}+rtChannel = RT $ return . rtChannel0++-- | Run the computation using the specified context.+runRT :: RT m a -> RTContext m -> m a+runRT = unRT++-- | Create a new real-time computation context.+newRTContext :: RTParams -> IO (RTContext m)+newRTContext ps =+ do channel <- newChannel+ return RTContext { rtChannel0 = channel,+ rtParams0 = ps }
+ Simulation/Aivika/RealTime/RT.hs view
@@ -0,0 +1,127 @@++-- |+-- Module : Simulation.Aivika.RealTime.RT+-- Copyright : Copyright (c) 2016, 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 a soft real-time computation based on 'IO'.+--+module Simulation.Aivika.RealTime.RT+ (-- * Soft real-time computation+ RT,+ RTParams(..),+ RTContext,+ RTScaling(..),+ runRT,+ defaultRTParams,+ newRTContext,+ rtParams,+ rtScale,+ -- * Invoking actions within the simulation+ applyEventRT,+ applyEventRT_,+ enqueueEventRT,+ enqueueEventRT_) where++import Control.Monad+import Control.Monad.Trans++import Control.Concurrent.STM+import Control.Concurrent.Async++import Simulation.Aivika.Trans+import Simulation.Aivika.IO.Comp+import Simulation.Aivika.IO.Ref.Base+import Simulation.Aivika.IO.QueueStrategy+import Simulation.Aivika.IO.Exception++import Simulation.Aivika.RealTime.Internal.RT+import Simulation.Aivika.RealTime.Internal.Channel+import Simulation.Aivika.RealTime.Event++-- | An implementation of the 'MonadTemplate' type class.+instance (Monad m, MonadIO m, MonadException m) => MonadTemplate (RT m)++-- | An implementation of the 'MonadDES' type class.+instance (Monad m, MonadIO m, MonadException m) => MonadDES (RT m) where++ {-# SPECIALIZE instance MonadDES (RT IO) #-}++-- | An implementation of the 'EventIOQueueing' type class.+instance (Monad m, MonadIO m, MonadException m) => EventIOQueueing (RT m) where++ {-# SPECIALIZE instance EventIOQueueing (RT IO) #-}++ enqueueEventIO = enqueueEvent++-- | Invoke the action within the soft real-time simulation.+invokeEventRT_ :: MonadIO m+ => RTContext m+ -- ^ the computation context+ -> (Event (RT m) () -> Event (RT m) ())+ -- ^ the computation transform+ -> Event (RT m) ()+ -- ^ the computation to invoke+ -> m ()+ -- ^ the action of invoking the computation+{-# INLINABLE invokeEventRT_ #-}+invokeEventRT_ ctx f m =+ let ch = rtChannel0 ctx+ in liftIO $ writeChannel ch $ f m++-- | Invoke the action within the soft real-time simulation.+invokeEventRT :: MonadIO m+ => RTContext m+ -- ^ the computation context+ -> (Event (RT m) () -> Event (RT m) ())+ -- ^ the computation transform+ -> Event (RT m) a+ -- ^ the computation to invoke+ -> m (Async a)+ -- ^ the result of computation+{-# INLINABLE invokeEventRT #-}+invokeEventRT ctx f m =+ do let ch = rtChannel0 ctx+ v <- liftIO $ newTVarIO Nothing+ liftIO $+ writeChannel ch $+ f $+ do a <- m+ liftIO $+ atomically $+ writeTVar v (Just a)+ liftIO $+ async $+ atomically $+ do b <- readTVar v+ case b of+ Just a -> return a+ Nothing -> retry++-- | Apply the 'Event' computation within the soft real-time simulation+-- with the specified context and return the result.+applyEventRT :: MonadIO m => RTContext m -> Event (RT m) a -> m (Async a)+{-# INLINABLE applyEventRT #-}+applyEventRT ctx m = invokeEventRT ctx id m++-- | Apply the 'Event' computation within the soft real-time simulation+-- with the specified context.+applyEventRT_ :: MonadIO m => RTContext m -> Event (RT m) () -> m ()+{-# INLINABLE applyEventRT_ #-}+applyEventRT_ ctx m = invokeEventRT_ ctx id m++-- | Enqueue the 'Event' computation within the soft real-time simulation+-- with the specified context at the modeling time provided and+-- then return the result.+enqueueEventRT :: MonadIO m => RTContext m -> Double -> Event (RT m) a -> m (Async a)+{-# INLINABLE enqueueEventRT #-}+enqueueEventRT ctx t m = invokeEventRT ctx (enqueueEvent t) m++-- | Enqueue the 'Event' computation within the soft real-time simulation+-- with the specified context at the modeling time provided.+enqueueEventRT_ :: MonadIO m => RTContext m -> Double -> Event (RT m) () -> m ()+{-# INLINABLE enqueueEventRT_ #-}+enqueueEventRT_ ctx t m = invokeEventRT_ ctx (enqueueEvent t) m
+ aivika-realtime.cabal view
@@ -0,0 +1,53 @@+name: aivika-realtime+version: 0.1+synopsis: Soft real-time simulation module for the Aivika library+description:+ This package allows running soft real-time simulations based on the aivika-transformers [1] library.+ .+ \[1] <http://hackage.haskell.org/package/aivika-transformers>+ .+category: Simulation+license: BSD3+license-file: LICENSE+copyright: (c) 2016. David Sorokin <david.sorokin@gmail.com>+author: David Sorokin+maintainer: David Sorokin <david.sorokin@gmail.com>+homepage: http://www.aivikasoft.com/en/products/aivika.html+cabal-version: >= 1.6+build-type: Simple+tested-with: GHC == 7.10.3++extra-source-files: CHANGELOG.md+ tests/MachRep1.hs+ tests/MachRep1Ver2.hs+ tests/MachRep1Ver3.hs++library++ exposed-modules: Simulation.Aivika.RealTime+ Simulation.Aivika.RealTime.Event+ Simulation.Aivika.RealTime.RT++ other-modules: Simulation.Aivika.RealTime.Internal.Channel+ Simulation.Aivika.RealTime.Internal.Event+ Simulation.Aivika.RealTime.Internal.RT++ build-depends: base >= 3 && < 6,+ mtl >= 2.1.1,+ stm >= 2.4.2,+ containers >= 0.4.0.0,+ async >= 2.0,+ time >= 1.5.0.1,+ aivika >= 4.5,+ aivika-transformers >= 4.5.1++ extensions: TypeFamilies,+ MultiParamTypeClasses,+ FlexibleInstances++ ghc-options: -O2++source-repository head++ type: git+ location: https://github.com/dsorokin/aivika-lattice
+ tests/MachRep1.hs view
@@ -0,0 +1,80 @@++-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language+-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/].+-- +-- The model description is as follows.+--+-- Two machines, which sometimes break down.+-- Up time is exponentially distributed with mean 1.0, and repair time is+-- exponentially distributed with mean 0.5. There are two repairpersons,+-- so the two machines can be repaired simultaneously if they are down+-- at the same time.+--+-- Output is long-run proportion of up time. Should get value of about+-- 0.66.++import Control.Monad.Trans++import Data.Time.Clock++import Simulation.Aivika.Trans+import Simulation.Aivika.RealTime++type DES = RT IO++meanUpTime = 1.0+meanRepairTime = 0.5++specs = Specs { spcStartTime = 0.0,+ -- spcStopTime = 1000.0,+ spcStopTime = 30.0,+ spcDT = 1.0,+ spcMethod = RungeKutta4,+ spcGeneratorType = SimpleGenerator }+ +model :: Simulation DES (Results DES)+model =+ do totalUpTime <- newRef 0.0+ + let machine =+ do upTime <-+ liftParameter $+ randomExponential meanUpTime+ holdProcess upTime+ liftEvent $ + modifyRef totalUpTime (+ upTime)+ repairTime <-+ liftParameter $+ randomExponential meanRepairTime+ holdProcess repairTime+ machine++ runEventInStartTime $+ enqueueEventWithIntegTimes $+ do utc <- liftIO getCurrentTime+ traceEvent ("current time: " ++ show utc) $+ return ()++ runProcessInStartTime machine+ runProcessInStartTime machine++ let upTimeProp =+ do x <- readRef totalUpTime+ y <- liftDynamics time+ return $ x / (2 * y)++ return $+ results+ [resultSource+ "upTimeProp"+ "The long-run proportion of up time (~ 0.66)"+ upTimeProp]+ +main =+ do let rt = printSimulationResultsInStopTime+ printResultSourceInEnglish+ model specs+ ctx <- newRTContext $ defaultRTParams { rtScaling = RTLinearScaling 1 }+ runRT rt ctx
+ tests/MachRep1Ver2.hs view
@@ -0,0 +1,87 @@++-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language+-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/].+-- +-- The model description is as follows.+--+-- Two machines, which sometimes break down.+-- Up time is exponentially distributed with mean 1.0, and repair time is+-- exponentially distributed with mean 0.5. There are two repairpersons,+-- so the two machines can be repaired simultaneously if they are down+-- at the same time.+--+-- Output is long-run proportion of up time. Should get value of about+-- 0.66.++import Control.Monad.Trans+import Control.Concurrent++import Data.Time.Clock++import Simulation.Aivika.Trans+import Simulation.Aivika.RealTime++type DES = RT IO++meanUpTime = 1.0+meanRepairTime = 0.5++specs = Specs { spcStartTime = 0.0,+ -- spcStopTime = 1000.0,+ spcStopTime = 30.0,+ spcDT = 1.0,+ spcMethod = RungeKutta4,+ spcGeneratorType = SimpleGenerator }+ +model :: Simulation DES (Results DES)+model =+ do totalUpTime <- newRef 0.0+ + let machine =+ do upTime <-+ liftParameter $+ randomExponential meanUpTime+ holdProcess upTime+ liftEvent $ + modifyRef totalUpTime (+ upTime)+ repairTime <-+ liftParameter $+ randomExponential meanRepairTime+ holdProcess repairTime+ machine++ runEventInStartTime $+ enqueueEventWithIntegTimes $+ do utc <- liftIO getCurrentTime+ traceEvent ("current time: " ++ show utc) $+ return ()++ runProcessInStartTime machine+ runProcessInStartTime machine++ let upTimeProp =+ do x <- readRef totalUpTime+ y <- liftDynamics time+ return $ x / (2 * y)++ return $+ results+ [resultSource+ "upTimeProp"+ "The long-run proportion of up time (~ 0.66)"+ upTimeProp]+ +main =+ do let rt = printSimulationResultsInStopTime+ printResultSourceInEnglish+ model specs+ ctx <- newRTContext $ defaultRTParams { rtScaling = RTLinearScaling 1 }+ forkIO $+ do threadDelay (round $ 15.5 * 1000000)+ putStrLn "Invoking the action (after 15.5 sec.)"+ applyEventRT_ ctx $+ traceEvent "The action was invoked" $+ return ()+ runRT rt ctx
+ tests/MachRep1Ver3.hs view
@@ -0,0 +1,91 @@++-- It corresponds to model MachRep1 described in document +-- Introduction to Discrete-Event Simulation and the SimPy Language+-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/DESimIntro.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/].+-- +-- The model description is as follows.+--+-- Two machines, which sometimes break down.+-- Up time is exponentially distributed with mean 1.0, and repair time is+-- exponentially distributed with mean 0.5. There are two repairpersons,+-- so the two machines can be repaired simultaneously if they are down+-- at the same time.+--+-- Output is long-run proportion of up time. Should get value of about+-- 0.66.++import Control.Monad.Trans+import Control.Concurrent+import Control.Concurrent.Async++import Data.Time.Clock++import Simulation.Aivika.Trans+import Simulation.Aivika.RealTime++type DES = RT IO++meanUpTime = 1.0+meanRepairTime = 0.5++specs = Specs { spcStartTime = 0.0,+ -- spcStopTime = 1000.0,+ spcStopTime = 30.0,+ spcDT = 1.0,+ spcMethod = RungeKutta4,+ spcGeneratorType = SimpleGenerator }+ +model :: Simulation DES (Results DES)+model =+ do totalUpTime <- newRef 0.0+ + let machine =+ do upTime <-+ liftParameter $+ randomExponential meanUpTime+ holdProcess upTime+ liftEvent $ + modifyRef totalUpTime (+ upTime)+ repairTime <-+ liftParameter $+ randomExponential meanRepairTime+ holdProcess repairTime+ machine++ runEventInStartTime $+ enqueueEventWithIntegTimes $+ do utc <- liftIO getCurrentTime+ traceEvent ("current time: " ++ show utc) $+ return ()++ runProcessInStartTime machine+ runProcessInStartTime machine++ let upTimeProp =+ do x <- readRef totalUpTime+ y <- liftDynamics time+ return $ x / (2 * y)++ return $+ results+ [resultSource+ "upTimeProp"+ "The long-run proportion of up time (~ 0.66)"+ upTimeProp]+ +main =+ do let rt = printSimulationResultsInStopTime+ printResultSourceInEnglish+ model specs+ ctx <- newRTContext $ defaultRTParams { rtScaling = RTLinearScaling 1 }+ forkIO $+ do threadDelay (round $ 15.5 * 1000000)+ putStrLn "Invoking the action (after 15.5 sec.)"+ future <-+ applyEventRT ctx $+ traceEvent "The action was invoked" $+ liftDynamics time+ t <- wait future+ putStrLn $ "The time of invocation t = " ++ show t+ runRT rt ctx