diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +Version 4.3.1 +----- + +* Improved the timeoutProcessUsingId function: no need in additional cancellation signal. + Thanks to Gabriel Garcia who pointed to this issue and suggested a possible solution. + +* Added functions delaySignal and delaySignalM to delay a signal in time through + the event queue. + +* Added function runSimulationByIndex to run the simulation with an arbitrary run index. Version 4.3 ----- diff --git a/Simulation/Aivika/Internal/Process.hs b/Simulation/Aivika/Internal/Process.hs --- a/Simulation/Aivika/Internal/Process.hs +++ b/Simulation/Aivika/Internal/Process.hs @@ -673,10 +673,9 @@ do s <- liftSimulation newSignalSource timeoutPid <- liftSimulation newProcessId spawnProcessUsingIdWith CancelChildAfterParent timeoutPid $ - finallyProcess - (holdProcess timeout) - (liftEvent $ - cancelProcessWithId pid) + do holdProcess timeout + liftEvent $ + cancelProcessWithId pid spawnProcessUsingIdWith CancelChildAfterParent pid $ do r <- liftIO $ newIORef Nothing finallyProcess @@ -686,7 +685,8 @@ (\e -> liftIO $ writeIORef r $ Just (Left e))) (liftEvent $ - do x <- liftIO $ readIORef r + do cancelProcessWithId timeoutPid + x <- liftIO $ readIORef r triggerSignal s x) x <- processAwait $ publishSignal s case x of diff --git a/Simulation/Aivika/Internal/Simulation.hs b/Simulation/Aivika/Internal/Simulation.hs --- a/Simulation/Aivika/Internal/Simulation.hs +++ b/Simulation/Aivika/Internal/Simulation.hs @@ -21,6 +21,7 @@ invokeSimulation, runSimulation, runSimulations, + runSimulationByIndex, -- * Error Handling catchSimulation, finallySimulation, @@ -74,6 +75,25 @@ m Run { runSpecs = sc, runIndex = 1, runCount = 1, + runEventQueue = q, + runGenerator = g } + +-- | Run the simulation by the specified specs and run index in series. +runSimulationByIndex :: Simulation a + -- ^ the simulation model + -> Specs + -- ^ the simulation specs + -> Int + -- ^ the number of runs in series + -> Int + -- ^ the index of the current run (started from 1) + -> IO a +runSimulationByIndex (Simulation m) sc runs index = + do q <- newEventQueue sc + g <- newGenerator $ spcGeneratorType sc + m Run { runSpecs = sc, + runIndex = index, + runCount = runs, runEventQueue = q, runGenerator = g } diff --git a/Simulation/Aivika/Signal.hs b/Simulation/Aivika/Signal.hs --- a/Simulation/Aivika/Signal.hs +++ b/Simulation/Aivika/Signal.hs @@ -40,6 +40,9 @@ newSignalInIntegTimes, newSignalInStartTime, newSignalInStopTime, + -- * Delaying Signal + delaySignal, + delaySignalM, -- * Signal History SignalHistory, signalHistorySignal, @@ -397,6 +400,39 @@ 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. diff --git a/Simulation/Aivika/Simulation.hs b/Simulation/Aivika/Simulation.hs --- a/Simulation/Aivika/Simulation.hs +++ b/Simulation/Aivika/Simulation.hs @@ -16,6 +16,7 @@ SimulationLift(..), runSimulation, runSimulations, + runSimulationByIndex, -- * Error Handling catchSimulation, finallySimulation, diff --git a/Simulation/Aivika/Task.hs b/Simulation/Aivika/Task.hs --- a/Simulation/Aivika/Task.hs +++ b/Simulation/Aivika/Task.hs @@ -120,21 +120,21 @@ return (t, m) -- | Run the process with the specified identifier in background and --- return the corresponded task immediately. +-- return the corresponding task immediately. runTaskUsingId :: ProcessId -> Process a -> Event (Task a) runTaskUsingId pid p = do (t, m) <- newTaskUsingId pid p runProcessUsingId pid m return t --- | Run the process in background and return the corresponded task immediately. +-- | Run the process in background and return the corresponding task immediately. runTask :: Process a -> Event (Task a) runTask p = do pid <- liftSimulation newProcessId runTaskUsingId pid p -- | Enqueue the process that will be started at the specified time with the given --- identifier from the event queue. It returns the corresponded task immediately. +-- identifier from the event queue. It returns the corresponding task immediately. enqueueTaskUsingId :: Double -> ProcessId -> Process a -> Event (Task a) enqueueTaskUsingId time pid p = do (t, m) <- newTaskUsingId pid p @@ -142,30 +142,30 @@ return t -- | Enqueue the process that will be started at the specified time from the event queue. --- It returns the corresponded task immediately. +-- It returns the corresponding task immediately. enqueueTask :: Double -> Process a -> Event (Task a) enqueueTask time p = do pid <- liftSimulation newProcessId enqueueTaskUsingId time pid p -- | Run using the specified identifier a child process in background and return --- immediately the corresponded task. +-- immediately the corresponding task. spawnTaskUsingId :: ProcessId -> Process a -> Process (Task a) spawnTaskUsingId = spawnTaskUsingIdWith CancelTogether --- | Run a child process in background and return immediately the corresponded task. +-- | Run a child process in background and return immediately the corresponding task. spawnTask :: Process a -> Process (Task a) spawnTask = spawnTaskWith CancelTogether -- | Run using the specified identifier a child process in background and return --- immediately the corresponded task. +-- immediately the corresponding task. spawnTaskUsingIdWith :: ContCancellation -> ProcessId -> Process a -> Process (Task a) spawnTaskUsingIdWith cancellation pid p = do (t, m) <- liftEvent $ newTaskUsingId pid p spawnProcessUsingIdWith cancellation pid m return t --- | Run a child process in background and return immediately the corresponded task. +-- | Run a child process in background and return immediately the corresponding task. spawnTaskWith :: ContCancellation -> Process a -> Process (Task a) spawnTaskWith cancellation p = do pid <- liftSimulation newProcessId diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -1,5 +1,5 @@ name: aivika -version: 4.3 +version: 4.3.1 synopsis: A multi-paradigm simulation library description: Aivika is a multi-paradigm simulation library with a strong emphasis @@ -73,7 +73,8 @@ . All libraries were tested on Linux, Windows and OS X. . - The PDF documentation is available on the Aivika Wiki [5] website. + The PDF documentation and installation instructions are + available on the Aivika Wiki [5] website. . \[1] . @@ -93,7 +94,7 @@ copyright: (c) 2009-2015. David Sorokin author: David Sorokin maintainer: David Sorokin -homepage: http://github.com/dsorokin/aivika +homepage: http://www.aivikasoft.com/en/products/aivika.html cabal-version: >= 1.10 build-type: Simple tested-with: GHC == 7.10.1