aivika-realtime 0.1 → 0.1.2

raw patch · 6 files changed

+510/−8 lines, 6 filesdep +randomdep ~aivika-transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random

Dependency ranges changed: aivika-transformers

API changes (from Hackage documentation)

Files

• Simulation/Aivika/RealTime/Comp.hs +29/−0
• Simulation/Aivika/RealTime/Generator.hs +146/−0
• Simulation/Aivika/RealTime/QueueStrategy.hs +254/−0
• Simulation/Aivika/RealTime/RT.hs +4/−4
• Simulation/Aivika/RealTime/Ref/Base.hs +66/−0
• aivika-realtime.cabal +11/−4

@@ -0,0 +1,29 @@++-- |+-- Module     : Simulation.Aivika.RealTime.Comp+-- 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+--+-- It allows making the 'RT' monad an instance of type class 'MonadComp'+-- on top of which the simulation monads can be built.+--+module Simulation.Aivika.RealTime.Comp () where++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Exception++import Simulation.Aivika.IO.Comp++import Simulation.Aivika.RealTime.Internal.RT+import Simulation.Aivika.RealTime.Generator++-- | An instantiation of the 'MonadComp' type class. +instance (Functor m, Monad m, MonadIO m, MonadException m) => MonadComp (RT m) where++  {-# SPECIALISE instance MonadComp (RT IO) #-}

@@ -0,0 +1,146 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.RealTime.Generator+-- 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+--+-- Here is defined a random number generator, where+-- the 'RT' monad can be an instance of 'MonadGenerator'.+--+module Simulation.Aivika.RealTime.Generator () where++import Control.Monad+import Control.Monad.Trans++import System.Random++import Data.IORef++import Simulation.Aivika.Trans.Generator+import Simulation.Aivika.Trans.Generator.Primitive++import Simulation.Aivika.RealTime.Internal.RT++instance (Functor m, Monad m, MonadIO m) => MonadGenerator (RT m) where++  {-# SPECIALISE instance MonadGenerator (RT IO) #-}++  data Generator (RT m) =+    Generator { generator01 :: RT m Double,+                -- ^ the generator of uniform numbers from 0 to 1+                generatorNormal01 :: RT m Double+                -- ^ the generator of normal numbers with mean 0 and variance 1+              }++  {-# INLINE generateUniform #-}+  generateUniform = generateUniform01 . generator01++  {-# INLINE generateUniformInt #-}+  generateUniformInt = generateUniformInt01 . generator01++  {-# INLINE generateTriangular #-}+  generateTriangular = generateTriangular01 . generator01++  {-# INLINE generateNormal #-}+  generateNormal = generateNormal01 . generatorNormal01++  {-# INLINE generateLogNormal #-}+  generateLogNormal = generateLogNormal01 . generatorNormal01++  {-# INLINE generateExponential #-}+  generateExponential = generateExponential01 . generator01++  {-# INLINE generateErlang #-}+  generateErlang = generateErlang01 . generator01++  {-# INLINE generatePoisson #-}+  generatePoisson = generatePoisson01 . generator01++  {-# INLINE generateBinomial #-}+  generateBinomial = generateBinomial01 . generator01++  {-# INLINE generateGamma #-}+  generateGamma g = generateGamma01 (generatorNormal01 g) (generator01 g)++  {-# INLINE generateBeta #-}+  generateBeta g = generateBeta01 (generatorNormal01 g) (generator01 g)++  {-# INLINE generateWeibull #-}+  generateWeibull = generateWeibull01 . generator01++  {-# INLINE generateDiscrete #-}+  generateDiscrete = generateDiscrete01 . generator01++  {-# INLINABLE newGenerator #-}+  newGenerator tp =+    case tp of+      SimpleGenerator ->+        liftIO newStdGen >>= newRandomGenerator+      SimpleGeneratorWithSeed x ->+        newRandomGenerator $ mkStdGen x+      CustomGenerator g ->+        g+      CustomGenerator01 g ->+        newRandomGenerator01 g++  {-# INLINABLE newRandomGenerator #-}+  newRandomGenerator g = +    do r <- liftIO $ newIORef g+       let g01 = do g <- liftIO $ readIORef r+                    let (x, g') = random g+                    liftIO $ writeIORef r g'+                    return x+       newRandomGenerator01 g01++  {-# INLINABLE newRandomGenerator01 #-}+  newRandomGenerator01 g01 =+    do gNormal01 <- newNormalGenerator01 g01+       return Generator { generator01 = g01,+                          generatorNormal01 = gNormal01 }++-- | Create a normal random number generator with mean 0 and variance 1+-- by the specified generator of uniform random numbers from 0 to 1.+newNormalGenerator01 :: MonadIO m+                        => m Double+                        -- ^ the generator+                        -> m (m Double)+{-# INLINABLE newNormalGenerator01 #-}+newNormalGenerator01 g =+  do nextRef <- liftIO $ newIORef 0.0+     flagRef <- liftIO $ newIORef False+     xi1Ref  <- liftIO $ newIORef 0.0+     xi2Ref  <- liftIO $ newIORef 0.0+     psiRef  <- liftIO $ newIORef 0.0+     let loop =+           do psi <- liftIO $ readIORef psiRef+              if (psi >= 1.0) || (psi == 0.0)+                then do g1 <- g+                        g2 <- g+                        let xi1 = 2.0 * g1 - 1.0+                            xi2 = 2.0 * g2 - 1.0+                            psi = xi1 * xi1 + xi2 * xi2+                        liftIO $ writeIORef xi1Ref xi1+                        liftIO $ writeIORef xi2Ref xi2+                        liftIO $ writeIORef psiRef psi+                        loop+                else liftIO $ writeIORef psiRef $ sqrt (- 2.0 * log psi / psi)+     return $+       do flag <- liftIO $ readIORef flagRef+          if flag+            then do liftIO $ writeIORef flagRef False+                    liftIO $ readIORef nextRef+            else do liftIO $ writeIORef xi1Ref 0.0+                    liftIO $ writeIORef xi2Ref 0.0+                    liftIO $ writeIORef psiRef 0.0+                    loop+                    xi1 <- liftIO $ readIORef xi1Ref+                    xi2 <- liftIO $ readIORef xi2Ref+                    psi <- liftIO $ readIORef psiRef+                    liftIO $ writeIORef flagRef True+                    liftIO $ writeIORef nextRef $ xi2 * psi+                    return $ xi1 * psi

@@ -0,0 +1,254 @@++{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}++-- |+-- Module     : Simulation.Aivika.RealTime.QueueStrategy+-- 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 some queue strategy instances+-- for the 'RT' computations.+--+module Simulation.Aivika.RealTime.QueueStrategy () where++import Control.Monad.Trans++import Simulation.Aivika.Trans.Comp+import Simulation.Aivika.Trans.Parameter+import Simulation.Aivika.Trans.Parameter.Random+import Simulation.Aivika.Trans.Simulation+import Simulation.Aivika.Trans.Event+import Simulation.Aivika.Trans.QueueStrategy++import Simulation.Aivika.RealTime.Internal.RT+import Simulation.Aivika.RealTime.Comp++import qualified Simulation.Aivika.DoubleLinkedList as LL+import qualified Simulation.Aivika.PriorityQueue as PQ+import qualified Simulation.Aivika.Vector as V++-- | An implementation of the 'FCFS' queue strategy.+instance (Monad m, MonadComp m, MonadIO m)+         => QueueStrategy (RT m) FCFS where++  {-# SPECIALISE instance QueueStrategy (RT IO) FCFS #-}++  -- | A queue used by the 'FCFS' strategy.+  newtype StrategyQueue (RT m) FCFS a = FCFSQueue (LL.DoubleLinkedList a)++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap FCFSQueue $+    liftIO LL.newList++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (FCFSQueue q) =+    liftIO $ LL.listNull q++-- | An implementation of the 'FCFS' queue strategy.+instance (QueueStrategy (RT m) FCFS, MonadComp m, MonadIO m)+         => DequeueStrategy (RT m) FCFS where++  {-# SPECIALISE instance DequeueStrategy (RT IO) FCFS #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (FCFSQueue q) =+    liftIO $+    do i <- LL.listFirst q+       LL.listRemoveFirst q+       return i++-- | An implementation of the 'FCFS' queue strategy.+instance (DequeueStrategy (RT m) FCFS, MonadComp m, MonadIO m)+         => EnqueueStrategy (RT m) FCFS where++  {-# SPECIALISE instance EnqueueStrategy (RT IO) FCFS #-}++  {-# INLINABLE strategyEnqueue #-}+  strategyEnqueue (FCFSQueue q) i =+    liftIO $ LL.listAddLast q i++-- | An implementation of the 'FCFS' queue strategy.+instance (DequeueStrategy (RT m) FCFS, MonadComp m, MonadIO m)+         => DeletingQueueStrategy (RT m) FCFS where++  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) FCFS #-}++  {-# INLINABLE strategyQueueDeleteBy #-}+  strategyQueueDeleteBy (FCFSQueue q) p =+    liftIO $ LL.listRemoveBy q p++  {-# INLINABLE strategyQueueContainsBy #-}+  strategyQueueContainsBy (FCFSQueue q) p =+    liftIO $ LL.listContainsBy q p++-- | An implementation of the 'LCFS' queue strategy.+instance (MonadComp m, MonadIO m)+         => QueueStrategy (RT m) LCFS where++  {-# SPECIALISE instance QueueStrategy (RT IO) LCFS #-}++  -- | A queue used by the 'LCFS' strategy.+  newtype StrategyQueue (RT m) LCFS a = LCFSQueue (LL.DoubleLinkedList a)++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap LCFSQueue $+    liftIO LL.newList+       +  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (LCFSQueue q) =+    liftIO $ LL.listNull q++-- | An implementation of the 'LCFS' queue strategy.+instance (QueueStrategy (RT m) LCFS, MonadComp m, MonadIO m)+         => DequeueStrategy (RT m) LCFS where++  {-# SPECIALISE instance DequeueStrategy (RT IO) LCFS #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (LCFSQueue q) =+    liftIO $+    do i <- LL.listFirst q+       LL.listRemoveFirst q+       return i++-- | An implementation of the 'LCFS' queue strategy.+instance (DequeueStrategy (RT m) LCFS, MonadComp m, MonadIO m)+         => EnqueueStrategy (RT m) LCFS where++  {-# SPECIALISE instance EnqueueStrategy (RT IO) LCFS #-}++  {-# INLINABLE strategyEnqueue #-}+  strategyEnqueue (LCFSQueue q) i =+    liftIO $ LL.listInsertFirst q i++-- | An implementation of the 'LCFS' queue strategy.+instance (DequeueStrategy (RT m) LCFS, MonadComp m, MonadIO m)+         => DeletingQueueStrategy (RT m) LCFS where++  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) LCFS #-}++  {-# INLINABLE strategyQueueDeleteBy #-}+  strategyQueueDeleteBy (LCFSQueue q) p =+    liftIO $ LL.listRemoveBy q p++  {-# INLINABLE strategyQueueContainsBy #-}+  strategyQueueContainsBy (LCFSQueue q) p =+    liftIO $ LL.listContainsBy q p++-- | An implementation of the 'StaticPriorities' queue strategy.+instance (MonadComp m, MonadIO m)+         => QueueStrategy (RT m) StaticPriorities where++  {-# SPECIALISE instance QueueStrategy (RT IO) StaticPriorities #-}++  -- | A queue used by the 'StaticPriorities' strategy.+  newtype StrategyQueue (RT m) StaticPriorities a = StaticPriorityQueue (PQ.PriorityQueue a)++  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap StaticPriorityQueue $+    liftIO $ PQ.newQueue++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (StaticPriorityQueue q) =+    liftIO $ PQ.queueNull q++-- | An implementation of the 'StaticPriorities' queue strategy.+instance (QueueStrategy (RT m) StaticPriorities, MonadComp m, MonadIO m)+         => DequeueStrategy (RT m) StaticPriorities where++  {-# SPECIALISE instance DequeueStrategy (RT IO) StaticPriorities #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (StaticPriorityQueue q) =+    liftIO $+    do (_, i) <- PQ.queueFront q+       PQ.dequeue q+       return i++-- | An implementation of the 'StaticPriorities' queue strategy.+instance (DequeueStrategy (RT m) StaticPriorities, MonadComp m, MonadIO m)+         => PriorityQueueStrategy (RT m) StaticPriorities Double where++  {-# SPECIALISE instance PriorityQueueStrategy (RT IO) StaticPriorities Double #-}++  {-# INLINABLE strategyEnqueueWithPriority #-}+  strategyEnqueueWithPriority (StaticPriorityQueue q) p i =+    liftIO $ PQ.enqueue q p i++-- | An implementation of the 'StaticPriorities' queue strategy.+instance (DequeueStrategy (RT m) StaticPriorities, MonadComp m, MonadIO m)+         => DeletingQueueStrategy (RT m) StaticPriorities where++  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) StaticPriorities #-}++  {-# INLINABLE strategyQueueDeleteBy #-}+  strategyQueueDeleteBy (StaticPriorityQueue q) p =+    liftIO $ PQ.queueDeleteBy q p++  {-# INLINABLE strategyQueueContainsBy #-}+  strategyQueueContainsBy (StaticPriorityQueue q) p =+    liftIO $ PQ.queueContainsBy q p++-- | An implementation of the 'SIRO' queue strategy.+instance (MonadComp m, MonadIO m)+         => QueueStrategy (RT m) SIRO where++  {-# SPECIALISE instance QueueStrategy (RT IO) SIRO #-}++  -- | A queue used by the 'SIRO' strategy.+  newtype StrategyQueue (RT m) SIRO a = SIROQueue (V.Vector a)+  +  {-# INLINABLE newStrategyQueue #-}+  newStrategyQueue s =+    fmap SIROQueue $+    liftIO $ V.newVector++  {-# INLINABLE strategyQueueNull #-}+  strategyQueueNull (SIROQueue q) =+    liftIO $+    do n <- V.vectorCount q+       return (n == 0)++-- | An implementation of the 'SIRO' queue strategy.+instance (QueueStrategy (RT m) SIRO, MonadComp m, MonadIO m)+         => DequeueStrategy (RT m) SIRO where++  {-# SPECIALISE instance DequeueStrategy (RT IO) SIRO #-}++  {-# INLINABLE strategyDequeue #-}+  strategyDequeue (SIROQueue q) =+    do n <- liftIO $ V.vectorCount q+       i <- liftParameter $ randomUniformInt 0 (n - 1)+       x <- liftIO $ V.readVector q i+       liftIO $ V.vectorDeleteAt q i+       return x++-- | A template-based implementation of the 'SIRO' queue strategy.+instance (DequeueStrategy (RT m) SIRO, MonadComp m, MonadIO m)+         => EnqueueStrategy (RT m) SIRO where++  {-# SPECIALISE instance EnqueueStrategy (RT IO) SIRO #-}++  {-# INLINABLE strategyEnqueue #-}+  strategyEnqueue (SIROQueue q) i =+    liftIO $ V.appendVector q i++-- | An implementation of the 'SIRO' queue strategy.+instance (DequeueStrategy (RT m) SIRO, MonadComp m, MonadIO m)+         => DeletingQueueStrategy (RT m) SIRO where++  {-# SPECIALISE instance DeletingQueueStrategy (RT IO) SIRO #-}++  {-# INLINABLE strategyQueueDeleteBy #-}+  strategyQueueDeleteBy (SIROQueue q) p =+    liftIO $ V.vectorDeleteBy q p++  {-# INLINABLE strategyQueueContainsBy #-}+  strategyQueueContainsBy (SIROQueue q) p =+    liftIO $ V.vectorContainsBy q p

@@ -41,12 +41,12 @@ 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)+import Simulation.Aivika.RealTime.QueueStrategy+import Simulation.Aivika.RealTime.Comp+import Simulation.Aivika.RealTime.Ref.Base  -- | An implementation of the 'MonadDES' type class.-instance (Monad m, MonadIO m, MonadException m) => MonadDES (RT m) where+instance (Monad m, MonadIO m, MonadException m, MonadComp m) => MonadDES (RT m) where    {-# SPECIALIZE instance MonadDES (RT IO) #-} 

@@ -0,0 +1,66 @@++{-# LANGUAGE TypeFamilies #-}++-- |+-- Module     : Simulation.Aivika.RealTime.Ref.Base+-- 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 'RT' monad can be an instance of 'MonadRef'.+--+module Simulation.Aivika.RealTime.Ref.Base () where++import Data.IORef++import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Trans.Internal.Types+import Simulation.Aivika.Trans.Ref.Base++import Simulation.Aivika.RealTime.Internal.RT++-- | The 'RT' monad is an instance of 'MonadRef'.+instance (Monad m, MonadIO m) => MonadRef (RT m) where++  {-# SPECIALISE instance MonadRef (RT IO) #-}++  -- | A type safe wrapper for the 'IORef' reference.+  newtype Ref (RT m) a = Ref { refValue :: IORef a }++  {-# INLINE newRef #-}+  newRef a =+    Simulation $ \r ->+    do x <- liftIO $ newIORef a+       return Ref { refValue = x }+     +  {-# INLINE readRef #-}+  readRef r = Event $ \p ->+    liftIO $ readIORef (refValue r)++  {-# INLINE writeRef #-}+  writeRef r a = Event $ \p -> +    a `seq` liftIO $ writeIORef (refValue r) a++  {-# INLINE modifyRef #-}+  modifyRef r f = Event $ \p -> +    do a <- liftIO $ readIORef (refValue r)+       let b = f a+       b `seq` liftIO $ writeIORef (refValue r) b++  {-# INLINE equalRef #-}+  equalRef (Ref r1) (Ref r2) = (r1 == r2)++-- | The 'RT' monad is an instance of 'MonadRef0'.+instance MonadIO m => MonadRef0 (RT m) where++  {-# SPECIALISE instance MonadRef0 (RT IO) #-}++  {-# INLINE newRef0 #-}+  newRef0 a =+    do x <- liftIO $ newIORef a+       return Ref { refValue = x }+     

@@ -1,5 +1,5 @@ name:            aivika-realtime-version:         0.1+version:         0.1.2 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.@@ -25,7 +25,11 @@ library      exposed-modules: Simulation.Aivika.RealTime+                     Simulation.Aivika.RealTime.Comp                      Simulation.Aivika.RealTime.Event+                     Simulation.Aivika.RealTime.Generator+                     Simulation.Aivika.RealTime.QueueStrategy+                     Simulation.Aivika.RealTime.Ref.Base                      Simulation.Aivika.RealTime.RT      other-modules:   Simulation.Aivika.RealTime.Internal.Channel@@ -36,18 +40,21 @@                      mtl >= 2.1.1,                      stm >= 2.4.2,                      containers >= 0.4.0.0,+                     random >= 1.0.0.3,                      async >= 2.0,                      time >= 1.5.0.1,                      aivika >= 4.5,-                     aivika-transformers >= 4.5.1+                     aivika-transformers >= 4.6      extensions:      TypeFamilies,                      MultiParamTypeClasses,-                     FlexibleInstances+                     FlexibleInstances,+                     FlexibleContexts,+                     UndecidableInstances      ghc-options:     -O2  source-repository head      type:     git-    location: https://github.com/dsorokin/aivika-lattice+    location: https://github.com/dsorokin/aivika-realtime