aivika 0.4 → 0.4.1

raw patch · 14 files changed

+344/−51 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Simulation/Aivika/Dynamics/Agent.hs +7/−25
• Simulation/Aivika/Dynamics/Base.hs +1/−0
• Simulation/Aivika/Dynamics/EventQueue.hs +29/−8
• Simulation/Aivika/Dynamics/Internal/Process.hs +2/−2
• Simulation/Aivika/Dynamics/Internal/Signal.hs +15/−3
• Simulation/Aivika/Dynamics/Internal/Time.hs +11/−1
• Simulation/Aivika/Dynamics/Ref.hs +2/−2
• Simulation/Aivika/Dynamics/Resource.hs +3/−3
• Simulation/Aivika/Dynamics/Signal.hs +76/−2
• Simulation/Aivika/Dynamics/UVar.hs +2/−2
• Simulation/Aivika/Dynamics/Var.hs +2/−2
• aivika.cabal +3/−1
• examples/TimeOut.hs +105/−0
• examples/TimeOutInt.hs +86/−0

@@ -44,7 +44,6 @@ -- | Represents an agent. data Agent = Agent { agentQueue :: EventQueue,                      -- ^ Return the bound event queue.-                     agentTimeRef :: IORef Double,                      agentModeRef :: IORef AgentMode,                      agentStateRef :: IORef (Maybe AgentState),                       agentStateChangedSource :: SignalSource (Maybe AgentState), @@ -126,9 +125,8 @@ addTimeout st dt (Dynamics action) =   Dynamics $ \p ->   do let q = agentQueue (stateAgent st)-         Dynamics m0 = queueRun q+         Dynamics m0 = runQueueSync q      m0 p    -- ensure that the agent state is actual-     checkTime p (stateAgent st) "addTimeout"      v <- readIORef (stateVersionRef st)      let m1 = Dynamics $ \p ->            do -- checkTime p (stateAgent st) "addTimeout"@@ -144,9 +142,8 @@ addTimer st (Dynamics dt) (Dynamics action) =   Dynamics $ \p ->   do let q = agentQueue (stateAgent st)-         Dynamics m0 = queueRun q+         Dynamics m0 = runQueueSync q      m0 p    -- ensure that the agent state is actual-     checkTime p (stateAgent st) "addTimer"      v <- readIORef (stateVersionRef st)      let m1 = Dynamics $ \p ->            do -- checkTime p (stateAgent st) "addTimer"@@ -190,15 +187,13 @@ newAgent :: EventQueue -> Simulation Agent newAgent queue =   Simulation $ \r ->-  do timeRef    <- newIORef $ spcStartTime $ runSpecs r-     modeRef    <- newIORef CreationMode+  do modeRef    <- newIORef CreationMode      stateRef   <- newIORef Nothing      let Simulation m1 = newSignalSourceUnsafe-         Simulation m2 = newSignalSourceWithUpdate $ queueRun queue+         Simulation m2 = newSignalSourceWithUpdate $ runQueue queue      stateChangedSource <- m1 r      stateUpdatedSource <- m2 r      return Agent { agentQueue = queue,-                    agentTimeRef = timeRef,                     agentModeRef = modeRef,                     agentStateRef = stateRef,                      agentStateChangedSource = stateChangedSource, @@ -208,9 +203,8 @@ agentState :: Agent -> Dynamics (Maybe AgentState) agentState agent =   Dynamics $ \p -> -  do let Dynamics m = queueRun $ agentQueue agent +  do let Dynamics m = runQueueSync $ agentQueue agent       m p    -- ensure that the agent state is actual-     checkTime p agent "agentState"      readIORef (agentStateRef agent)                     -- | Select the next downmost active state.       @@ -218,9 +212,8 @@ activateState st =   Dynamics $ \p ->   do let agent = stateAgent st-         Dynamics m = queueRun $ agentQueue agent +         Dynamics m = runQueueSync $ agentQueue agent       m p    -- ensure that the agent state is actual-     checkTime p agent "activateState"      mode <- readIORef (agentModeRef agent)      case mode of        CreationMode ->@@ -255,9 +248,8 @@ initState st =   Dynamics $ \p ->   do let agent = stateAgent st-         Dynamics m = queueRun $ agentQueue agent +         Dynamics m = runQueueSync $ agentQueue agent       m p    -- ensure that the agent state is actual-     checkTime p agent "initState"      mode <- readIORef (agentModeRef agent)      case mode of        CreationMode ->@@ -304,13 +296,3 @@ agentStateChanged_ :: Agent -> Signal () agentStateChanged_ agent =   mapSignal (const ()) $ agentStateChanged agent-        --- | Check that we don't request for the past data.-checkTime :: Point -> Agent -> String -> IO ()-{-# INLINE checkTime #-}-checkTime p agent name =-  do t <- readIORef (agentTimeRef agent)-     when (pointTime p < t) $-       error $ "You cannot request for past data: " ++ name-     when (pointTime p > t) $-       writeIORef (agentTimeRef agent) (pointTime p)

@@ -16,6 +16,7 @@         stoptime,         dt,         time,+        integTimes,         -- * Interpolation and Initial Value         initDynamics,         discrete,

@@ -16,7 +16,8 @@        (EventQueue,         newQueue,         enqueue,-        queueRun) where+        runQueue,+        runQueueSync) where  import Data.IORef import Control.Monad@@ -28,9 +29,14 @@ -- | The 'EventQueue' type represents the event queue. data EventQueue = EventQueue {    queuePQ   :: PQ.PriorityQueue (Dynamics ()),-  queueRun  :: Dynamics (),   -- ^ Run the event queue processing its events   queueBusy :: IORef Bool,-  queueTime :: IORef Double }+  queueTime :: IORef Double, +  -- Optimization+  runQueue  :: Dynamics (),+  -- ^ Run the event queue processing its events.+  runQueueSync :: Dynamics ()+  -- ^ Run the event queue synchronously, i.e. without past.+  }  -- | Create a new event queue. newQueue :: Simulation EventQueue@@ -41,9 +47,10 @@      t <- newIORef $ spcStartTime sc      pq <- PQ.newQueue      let q = EventQueue { queuePQ   = pq,-                          queueRun  = runQueue q,                           queueBusy = f,-                          queueTime = t }+                          queueTime = t, +                          runQueue  = runQueueCore q,+                          runQueueSync = runQueueSyncCore q }      return q               -- | Enqueue the event which must be actuated at the specified time.@@ -52,8 +59,8 @@   r p = let pq = queuePQ q in PQ.enqueue pq t c      -- | Run the event queue processing its events.-runQueue :: EventQueue -> Dynamics ()-runQueue q = Dynamics r where+runQueueCore :: EventQueue -> Dynamics ()+runQueueCore q = Dynamics r where   r p =     do let f = queueBusy q        f' <- readIORef f@@ -69,7 +76,7 @@             let t = queueTime q             t' <- readIORef t             when (t2 < t') $ -              error "The time value is too small: subrunQueue"+              error "The time value is too small: runQueue"             when (t2 <= pointTime p) $               do writeIORef t t2                  PQ.dequeue pq@@ -82,3 +89,17 @@                          pointIteration = n2,                          pointPhase = -1 }                  call q p++-- | Run the event queue synchronously, i.e. without past.+runQueueSyncCore :: EventQueue -> Dynamics ()+runQueueSyncCore q = Dynamics r where+  r p =+    do let t = queueTime q+       t' <- readIORef t+       if pointTime p < t'+         then error $+              "The current time is less than " +++              "the time in the queue: runQueueSync"+         else let Dynamics m = runQueue q+              in m p+  

@@ -125,7 +125,7 @@ processPassive :: ProcessID -> Dynamics Bool processPassive pid =   Dynamics $ \p ->-  do let Dynamics m = queueRun $ processQueue pid+  do let Dynamics m = runQueueSync $ processQueue pid      m p      let x = processReactCont pid      a <- readIORef x@@ -135,7 +135,7 @@ reactivateProcess :: ProcessID -> Dynamics () reactivateProcess pid =   Dynamics $ \p ->-  do let Dynamics m = queueRun $ processQueue pid+  do let Dynamics m = runQueueSync $ processQueue pid      m p      let x = processReactCont pid      a <- readIORef x

@@ -24,9 +24,10 @@         handleSignal_,         updateSignal,         mapSignal,-        composeSignal,+        mapSignalM,         apSignal,         filterSignal,+        filterSignalM,         merge2Signals,         merge3Signals,         merge4Signals,@@ -212,6 +213,17 @@            updateSignal =              updateSignal m }   +-- | Filter only those signal values that satisfy to +-- the specified predicate.+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 }+   -- | Merge two signals. merge2Signals :: Signal a -> Signal a -> Signal a merge2Signals m1 m2 =@@ -271,8 +283,8 @@                 updateSignal m5 }  -- | Compose the signal.-composeSignal :: (a -> Dynamics b) -> Signal a -> Signal b-composeSignal f m =+mapSignalM :: (a -> Dynamics b) -> Signal a -> Signal b+mapSignalM f m =   Signal { handleSignal = \h ->             handleSignal m (f >=> h),            updateSignal = 

@@ -14,7 +14,8 @@        (starttime,          stoptime,          dt, -        time) where+        time,+        integTimes) where  import Simulation.Aivika.Dynamics.Internal.Simulation import Simulation.Aivika.Dynamics.Internal.Dynamics@@ -34,3 +35,12 @@ -- | Return the current simulation time. time :: Dynamics Double time = Dynamics $ return . pointTime ++-- | Return the integration time points.+integTimes :: Simulation [Double]+integTimes =+  Simulation $ \r ->+  do let sc  = runSpecs r+         (nl, nu) = iterationBnds sc+         t n = basicTime sc n 0+     return $ map t [nl .. nu]

@@ -43,9 +43,9 @@ newRef q a =   do x <- liftIO $ newIORef a      s <- newSignalSourceUnsafe-     u <- newSignalSourceWithUpdate (queueRun q)+     u <- newSignalSourceWithUpdate (runQueue q)      return Ref { refQueue = q,-                  refRun   = queueRun q,+                  refRun   = runQueueSync q,                   refValue = x,                    refChangedSource = s,                    refUpdatedSource = u }

@@ -83,7 +83,7 @@ resourceCount :: Resource -> Dynamics Int resourceCount r =   Dynamics $ \p ->-  do invokeDynamics p $ queueRun (resourceQueue r)+  do invokeDynamics p $ runQueueSync (resourceQueue r)      readIORef (resourceCountRef r)  -- | Request for the resource decreasing its count in case of success,@@ -116,7 +116,7 @@ releaseResourceInDynamics :: Resource -> Dynamics () releaseResourceInDynamics r =   Dynamics $ \p ->-  do invokeDynamics p $ queueRun (resourceQueue r)+  do invokeDynamics p $ runQueueSync (resourceQueue r)      invokeDynamics p $ releaseResourceUnsafe r  releaseResourceUnsafe :: Resource -> Dynamics ()@@ -147,7 +147,7 @@ tryRequestResourceInDynamics :: Resource -> Dynamics Bool tryRequestResourceInDynamics r =   Dynamics $ \p ->-  do invokeDynamics p $ queueRun (resourceQueue r)+  do invokeDynamics p $ runQueueSync (resourceQueue r)      a <- readIORef (resourceCountRef r)      if a == 0         then return False

@@ -17,6 +17,10 @@         SignalSource,         newSignalSource,         newSignalSourceWithUpdate,+        newSignalInTimes,+        newSignalInIntegTimes,+        newSignalInStartTime,+        newSignalInStopTime,         publishSignal,         triggerSignal,         handleSignal,@@ -24,9 +28,10 @@         updateSignal,         awaitSignal,         mapSignal,-        composeSignal,+        mapSignalM,         apSignal,         filterSignal,+        filterSignalM,         merge2Signals,         merge3Signals,         merge4Signals,@@ -55,7 +60,7 @@ -- | Create a new signal source when the state depends on the event queue. newSignalSource :: EventQueue -> Simulation (SignalSource a) newSignalSource queue = -  newSignalSourceWithUpdate $ queueRun queue+  newSignalSourceWithUpdate $ runQueue queue  -- | Await the signal. awaitSignal :: Signal a -> Process a@@ -106,3 +111,72 @@      xs <- liftIO $ UV.freezeVector (signalHistoryTimes history)      ys <- liftIO $ V.freezeVector (signalHistoryValues history)      return (xs, ys)     ++-- | Return a signal that is triggered in the specified time points.+newSignalInTimes :: EventQueue -> [Double] -> Dynamics (Signal Double)+newSignalInTimes q xs =+  do s <- liftSimulation $ newSignalSource q+     let loop []       = return ()+         loop (x : xs) = enqueue q x $ +                         do triggerSignal s x +                            loop xs+     loop xs+     return $ publishSignal s+       +-- | Return a signal that is triggered in the specified time points.+newSignalInPoints :: EventQueue -> [Point] -> Dynamics (Signal Double)+newSignalInPoints q xs =+  do s <- liftSimulation $ newSignalSource q+     let loop []       = return ()+         loop (x : xs) = enqueue q (pointTime x) $ +                         Dynamics $ \p ->+                         do let Dynamics m = triggerSignal s (pointTime x) +                            m x    -- N.B. we substitute the time point!+                            let Dynamics m = loop xs+                            m p+     loop xs+     return $ publishSignal s+       +-- | Return a signal that is triggered in the integration time points.+-- It should be called with help of 'runDynamicsInStartTime'.+newSignalInIntegTimes :: EventQueue -> Dynamics (Signal Double)+newSignalInIntegTimes q =+  Dynamics $ \p ->+  do let sc  = pointSpecs p+         (nl, nu) = iterationBnds sc+         point n = Point { pointSpecs = sc,+                           pointRun = pointRun p,+                           pointTime = basicTime sc n 0,+                           pointIteration = n,+                           pointPhase = 0 }+         Dynamics m = newSignalInPoints q $ map point [nl .. nu]+     m p+     +-- | Return a signal that is triggered in the start time.+-- It should be called with help of 'runDynamicsInStartTime'.+newSignalInStartTime :: EventQueue -> Dynamics (Signal Double)+newSignalInStartTime q =+  Dynamics $ \p ->+  do let sc  = pointSpecs p+         (nl, nu) = iterationBnds sc+         point n = Point { pointSpecs = sc,+                           pointRun = pointRun p,+                           pointTime = basicTime sc n 0,+                           pointIteration = n,+                           pointPhase = 0 }+         Dynamics m = newSignalInPoints q [point nl]+     m p++-- | Return a signal that is triggered in the stop time.+newSignalInStopTime :: EventQueue -> Dynamics (Signal Double)+newSignalInStopTime q =+  Dynamics $ \p ->+  do let sc  = pointSpecs p+         (nl, nu) = iterationBnds sc+         point n = Point { pointSpecs = sc,+                           pointRun = pointRun p,+                           pointTime = basicTime sc n 0,+                           pointIteration = n,+                           pointPhase = 0 }+         Dynamics m = newSignalInPoints q [point nu]+     m p

@@ -54,9 +54,9 @@      UV.appendVector xs $ spcStartTime $ runSpecs r      UV.appendVector ys a      s  <- invokeSimulation r newSignalSourceUnsafe-     u  <- invokeSimulation r $ newSignalSourceWithUpdate $ queueRun q+     u  <- invokeSimulation r $ newSignalSourceWithUpdate $ runQueue q      return UVar { uvarQueue = q,-                   uvarRun   = queueRun q,+                   uvarRun   = runQueue q,                    uvarXS = xs,                    uvarYS = ys,                     uvarChangedSource = s, 

@@ -54,9 +54,9 @@      UV.appendVector xs $ spcStartTime $ runSpecs r      V.appendVector ys a      s  <- invokeSimulation r newSignalSourceUnsafe-     u  <- invokeSimulation r $ newSignalSourceWithUpdate $ queueRun q+     u  <- invokeSimulation r $ newSignalSourceWithUpdate $ runQueue q      return Var { varQueue = q,-                  varRun   = queueRun q,+                  varRun   = runQueue q,                   varXS = xs,                   varYS = ys,                    varChangedSource = s, 

@@ -1,5 +1,5 @@ name:            aivika-version:         0.4+version:         0.4.1 synopsis:        A multi-paradigm simulation library description:     Aivika is a small simulation library that covers many paradigms. @@ -50,6 +50,8 @@                      examples/MachRep2.hs                      examples/MachRep3.hs                      examples/Furnace.hs+                     examples/TimeOut.hs+                     examples/TimeOutInt.hs  data-files:          doc/aivika.pdf 

@@ -0,0 +1,105 @@++-- It corresponds to model TimeOut described in document +-- Advanced Features of the SimPy Language+-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/].+--   +-- The model description is as follows.+--+-- Introductory example to illustrate the modeling of "competing+-- events" such as timeouts, especially using the cancelProcess function. A+-- network node sends a message but also sets a timeout period; if the+-- node times out, it assumes the message it had sent was lost, and it+-- will send again. The time to get an acknowledgement for a message is+-- exponentially distributed with mean 1.0, and the timeout period is+-- 0.5. Immediately after receiving an acknowledgement, the node sends+-- out a new message.+--+-- We find the proportion of messages which timeout. The output should+-- be about 0.61.++import System.Random+import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.Base+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Ref+import Simulation.Aivika.Dynamics.Process++ackRate = 1.0 / 1.0  -- reciprocal of the acknowledge mean time+toPeriod = 0.5       -- timeout period++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4 }+        +exprnd :: Double -> IO Double+exprnd lambda =+  do x <- getStdRandom random+     return (- log x / lambda)+     +model :: Simulation Double+model =+  do queue <- newQueue+     +     -- number of messages sent+     nMsgs <- newRef queue 0+     +     -- number of timeouts which have occured+     nTimeOuts <- newRef queue 0+     +     -- reactivatedCode will 1 if timeout occurred, +     -- 2 ACK if received+     reactivatedCode <- newRef queue 0+     +     nodePid <- newProcessID queue+     +     let node :: Process ()+         node =+           do liftDynamics $ modifyRef nMsgs $ (+) 1+              -- create process IDs+              timeoutPid <- liftSimulation $ newProcessID queue+              ackPid <- liftSimulation $ newProcessID queue+              -- set up the timeout+              liftDynamics $ runProcessNow (timeout ackPid) timeoutPid+              -- set up the message send/ACK+              liftDynamics $ runProcessNow (acknowledge timeoutPid) ackPid+              passivateProcess+              code <- liftDynamics $ readRef reactivatedCode+              when (code == 1) $+                liftDynamics $ modifyRef nTimeOuts $ (+) 1+              liftDynamics $ writeRef reactivatedCode 0+              node+              +         timeout :: ProcessID -> Process ()+         timeout ackPid =+           do holdProcess toPeriod+              liftDynamics $+                do writeRef reactivatedCode 1+                   reactivateProcess nodePid+                   cancelProcess ackPid+         +         acknowledge :: ProcessID -> Process ()+         acknowledge timeoutPid =+           do ackTime <- liftIO $ exprnd ackRate+              holdProcess ackTime+              liftDynamics $+                do writeRef reactivatedCode 2+                   reactivateProcess nodePid+                   cancelProcess timeoutPid++     runDynamicsInStartTime $+       runProcessNow node nodePid +     +     runDynamicsInStopTime $+       do x <- readRef nTimeOuts+          y <- readRef nMsgs+          return $ x / y+  +main = +  do putStr "The percentage of timeout was "+     runSimulation model specs >>= print

@@ -0,0 +1,86 @@++-- It corresponds to model TimeOutInt described in document +-- Advanced Features of the SimPy Language+-- [http://heather.cs.ucdavis.edu/~matloff/156/PLN/AdvancedSimPy.pdf]. +-- SimPy is available on [http://simpy.sourceforge.net/].+--   +-- The model description is as follows.+--+-- Same as TimeOut.hs but using interrupts. A network node sends a message+-- but also sets a timeout period; if the node times out, it assumes the+-- message it had sent was lost, and it will send again. The time to get+-- an acknowledgement for a message is exponentially distributed with+-- mean 1.0, and the timeout period is 0.5. Immediately after receiving+-- an acknowledgement, the node sends out a new message.+--+-- We find the proportion of messages which timeout. The output should+-- be about 0.61.++import System.Random+import Control.Monad+import Control.Monad.Trans++import Simulation.Aivika.Dynamics+import Simulation.Aivika.Dynamics.Simulation+import Simulation.Aivika.Dynamics.Base+import Simulation.Aivika.Dynamics.EventQueue+import Simulation.Aivika.Dynamics.Ref+import Simulation.Aivika.Dynamics.Process++ackRate = 1.0 / 1.0  -- reciprocal of the acknowledge mean time+toPeriod = 0.5       -- timeout period++specs = Specs { spcStartTime = 0.0,+                spcStopTime = 10000.0,+                spcDT = 1.0,+                spcMethod = RungeKutta4 }+        +exprnd :: Double -> IO Double+exprnd lambda =+  do x <- getStdRandom random+     return (- log x / lambda)+     +model :: Simulation Double+model =+  do queue <- newQueue+     +     -- number of messages sent+     nMsgs <- newRef queue 0+     +     -- number of timeouts which have occured+     nTimeOuts <- newRef queue 0+     +     nodePid <- newProcessID queue+     +     let node :: Process ()+         node =+           do liftDynamics $ modifyRef nMsgs $ (+) 1+              -- create the process ID+              timeoutPid <- liftSimulation $ newProcessID queue+              -- set up the timeout+              liftDynamics $ runProcessNow timeout timeoutPid+              -- wait for ACK, but could be timeout+              ackTime <- liftIO $ exprnd ackRate +              holdProcess ackTime+              interrupted <- liftDynamics $ processInterrupted nodePid+              if interrupted+                then liftDynamics $ modifyRef nTimeOuts $ (+) 1+                else liftDynamics $ cancelProcess timeoutPid+              node+              +         timeout :: Process ()+         timeout =+           do holdProcess toPeriod+              liftDynamics $ interruptProcess nodePid++     runDynamicsInStartTime $+       runProcessNow node nodePid +     +     runDynamicsInStopTime $+       do x <- readRef nTimeOuts+          y <- readRef nMsgs+          return $ x / y+  +main = +  do putStr "The percentage of timeout was "+     runSimulation model specs >>= print