aivika 5.9.1 → 6.0.0

raw patch · 16 files changed

+493/−62 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Simulation/Aivika/Circuit.hs +8/−8
• Simulation/Aivika/Composite.hs +1/−3
• Simulation/Aivika/Event.hs +3/−0
• Simulation/Aivika/Internal/Cont.hs +32/−4
• Simulation/Aivika/Internal/Dynamics.hs +3/−4
• Simulation/Aivika/Internal/Event.hs +21/−5
• Simulation/Aivika/Internal/Parameter.hs +1/−2
• Simulation/Aivika/Internal/Process.hs +54/−17
• Simulation/Aivika/Internal/Simulation.hs +1/−2
• Simulation/Aivika/Internal/Specs.hs +16/−6
• Simulation/Aivika/PriorityQueue/EventQueue.hs +236/−0
• Simulation/Aivika/PriorityQueue/EventQueue/Pure.hs +102/−0
• Simulation/Aivika/Process.hs +2/−0
• Simulation/Aivika/Results.hs +1/−1
• aivika.cabal +7/−10

@@ -1,4 +1,9 @@ +Version 6.0+-----++* Introduced the discrete event priorities.+ Version 5.9 ----- 

@@ -446,7 +446,7 @@ iterateCircuitInPoints_ :: [Point] -> Circuit a a -> a -> Event () iterateCircuitInPoints_ [] cir a = return () iterateCircuitInPoints_ (p : ps) cir a =-  enqueueEvent (pointTime p) $+  enqueueEventWithPriority (pointTime p) (pointPriority p) $   Event $ \p' ->   do (a', cir') <- invokeEvent p $ runCircuit cir a      invokeEvent p $ iterateCircuitInPoints_ ps cir' a'@@ -457,7 +457,7 @@ iterateCircuitInPoints ps cir a =   do let loop [] cir a source = triggerSignal source a          loop (p : ps) cir a source =-           enqueueEvent (pointTime p) $+           enqueueEventWithPriority (pointTime p) (pointPriority p) $            Event $ \p' ->            do (a', cir') <- invokeEvent p $ runCircuit cir a               invokeEvent p $ loop ps cir' a' source@@ -478,7 +478,7 @@ iterateCircuitInTimes_ :: [Double] -> Circuit a a -> a -> Event () iterateCircuitInTimes_ ts cir a =   Event $ \p ->-  do let ps = map (pointAt $ pointRun p) ts+  do let ps = map (\t -> pointAt (pointRun p) t 0) ts      invokeEvent p $         iterateCircuitInPoints_ ps cir a  @@ -496,7 +496,7 @@ iterateCircuitInTimes :: [Double] -> Circuit a a -> a -> Event (Task a) iterateCircuitInTimes ts cir a =   Event $ \p ->-  do let ps = map (pointAt $ pointRun p) ts+  do let ps = map (\t -> pointAt (pointRun p) t 0) ts      invokeEvent p $         iterateCircuitInPoints ps cir a  @@ -505,7 +505,7 @@ iterateCircuitInPointsMaybe :: [Point] -> Circuit a (Maybe a) -> a -> Event () iterateCircuitInPointsMaybe [] cir a = return () iterateCircuitInPointsMaybe (p : ps) cir a =-  enqueueEvent (pointTime p) $+  enqueueEventWithPriority (pointTime p) (pointPriority p) $   Event $ \p' ->   do (a', cir') <- invokeEvent p $ runCircuit cir a      case a' of@@ -527,7 +527,7 @@ iterateCircuitInTimesMaybe :: [Double] -> Circuit a (Maybe a) -> a -> Event () iterateCircuitInTimesMaybe ts cir a =   Event $ \p ->-  do let ps = map (pointAt $ pointRun p) ts+  do let ps = map (\t -> pointAt (pointRun p) t 0) ts      invokeEvent p $         iterateCircuitInPointsMaybe ps cir a @@ -540,7 +540,7 @@   do let loop [] cir ba source = triggerSignal source ba          loop ps cir ba@(Left b) source = triggerSignal source ba           loop (p : ps) cir (Right a) source =-           enqueueEvent (pointTime p) $+           enqueueEventWithPriority (pointTime p) (pointPriority p) $            Event $ \p' ->            do (ba', cir') <- invokeEvent p $ runCircuit cir a               invokeEvent p $ loop ps cir' ba' source@@ -567,7 +567,7 @@ iterateCircuitInTimesEither :: [Double] -> Circuit a (Either b a) -> a -> Event (Task (Either b a)) iterateCircuitInTimesEither ts cir a =   Event $ \p ->-  do let ps = map (pointAt $ pointRun p) ts+  do let ps = map (\t -> pointAt (pointRun p) t 0) ts      invokeEvent p $         iterateCircuitInPointsEither ps cir a 

@@ -72,12 +72,10 @@  instance Applicative Composite where -  pure = return+  pure a = Composite $ \h0 -> pure (a, h0)   (<*>) = ap  instance Monad Composite where--  return a = Composite $ \h0 -> return (a, h0)    (Composite m) >>= k =     Composite $ \h0 ->

@@ -26,7 +26,9 @@         runEventInStartTime,         runEventInStopTime,         -- * Event Queue+        EventPriority(..),         enqueueEvent,+        enqueueEventWithPriority,         enqueueEventWithCancellation,         enqueueEventWithStartTime,         enqueueEventWithStopTime,@@ -34,6 +36,7 @@         enqueueEventWithIntegTimes,         yieldEvent,         eventQueueCount,+        eventPriority,         -- * Cancelling Event         EventCancellation,         cancelEvent,

@@ -49,6 +49,7 @@         freezeContReentering,         unfreezeCont,         substituteCont,+        substituteContPriority,         contCanceled,         contAwait,         transferCont,@@ -260,7 +261,6 @@                   contCatchFlag  :: Bool }  instance Monad Cont where-  return  = returnC   m >>= k = bindC m k  instance ParameterLift Cont where@@ -279,7 +279,7 @@   fmap = liftM  instance Applicative Cont where-  pure = return+  pure = returnC   (<*>) = ap  instance MonadIO Cont where@@ -712,7 +712,7 @@ freezeCont c =   Event $ \p ->   do rh <- newIORef Nothing-     rc <- newIORef $ Just c+     rc <- newIORef $ Just $ substituteContPriority c (pointPriority p)      h <- invokeEvent p $           handleSignal (contCancellationInitiating $                         contId $ contAux c) $ \e ->@@ -747,7 +747,7 @@ freezeContReentering c a m =   Event $ \p ->   do rh <- newIORef Nothing-     rc <- newIORef $ Just c+     rc <- newIORef $ Just $ substituteContPriority c (pointPriority p)      h <- invokeEvent p $           handleSignal (contCancellationInitiating $                         contId $ contAux c) $ \e ->@@ -845,6 +845,34 @@ substituteCont :: ContParams a -> (a -> Event ()) -> ContParams a {-# INLINE substituteCont #-} substituteCont c m = c { contCont = m }++-- | Substitute the continuation priority.+substituteContPriority :: ContParams a -> EventPriority -> ContParams a+{-# INLINABLE substituteContPriority #-}+substituteContPriority c priority = c { contCont = cont,+                                        contAux  = (contAux c) { contECont = econt,+                                                                 contCCont = ccont } }+  where cont a =+          Event $ \p ->+          if priority == pointPriority p+          then invokeEvent p $ contCont c a+          else invokeEvent p $+               enqueueEventWithPriority (pointTime p) priority $+               resumeCont c a+        econt e =+          Event $ \p ->+          if priority == pointPriority p+          then invokeEvent p $ contECont (contAux c) e+          else invokeEvent p $+               enqueueEventWithPriority (pointTime p) priority $+               resumeECont c e+        ccont e =+          Event $ \p ->+          if priority == pointPriority p+          then invokeEvent p $ contCCont (contAux c) e+          else invokeEvent p $+               enqueueEventWithPriority (pointTime p) priority $+               contCCont (contAux c) e  -- | Await the signal. contAwait :: Signal a -> Cont a

@@ -53,7 +53,6 @@ newtype Dynamics a = Dynamics (Point -> IO a)  instance Monad Dynamics where-  return  = returnD   m >>= k = bindD m k  returnD :: a -> Dynamics a@@ -86,18 +85,18 @@ -- | Run the 'Dynamics' computation in the specified time point. runDynamicsInTime :: Double -> Dynamics a -> Simulation a runDynamicsInTime t (Dynamics m) =-  Simulation $ \r -> m $ pointAt r t+  Simulation $ \r -> m $ pointAt r t 0  -- | Run the 'Dynamics' computation in the specified time points. runDynamicsInTimes :: [Double] -> Dynamics a -> Simulation [IO a] runDynamicsInTimes ts (Dynamics m) =-  Simulation $ \r -> return $ map (m . pointAt r) ts +  Simulation $ \r -> return $ map (\t -> m $ pointAt r t 0) ts   instance Functor Dynamics where   fmap = liftMD  instance Applicative Dynamics where-  pure = return+  pure = returnD   (<*>) = ap  instance MonadFail Dynamics where

@@ -31,7 +31,9 @@         runEventInStartTime,         runEventInStopTime,         -- * Event Queue+        EventPriority(..),         enqueueEvent,+        enqueueEventWithPriority,         enqueueEventWithCancellation,         enqueueEventWithStartTime,         enqueueEventWithStopTime,@@ -40,6 +42,7 @@         enqueueEventWithIntegTimes,         yieldEvent,         eventQueueCount,+        eventPriority,         -- * Cancelling Event         EventCancellation,         cancelEvent,@@ -73,7 +76,7 @@  import Debug.Trace (trace) -import qualified Simulation.Aivika.PriorityQueue as PQ+import qualified Simulation.Aivika.PriorityQueue.EventQueue as PQ  import Simulation.Aivika.Internal.Specs import Simulation.Aivika.Internal.Parameter@@ -85,7 +88,6 @@ newtype Event a = Event (Point -> IO a)  instance Monad Event where-  return  = returnE   m >>= k = bindE m k  returnE :: a -> Event a@@ -104,7 +106,7 @@   fmap = liftME  instance Applicative Event where-  pure = return+  pure = returnE   (<*>) = ap  instance MonadFail Event where@@ -246,8 +248,16 @@ enqueueEvent t (Event m) =   Event $ \p ->   let pq = queuePQ $ runEventQueue $ pointRun p-  in PQ.enqueue pq t m+  in PQ.enqueue pq t (pointPriority p) m +-- | Enqueue the event which must be actuated at the specified time+-- given the priority.+enqueueEventWithPriority :: Double -> EventPriority -> Event () -> Event ()+enqueueEventWithPriority t priority (Event m) =+  Event $ \p ->+  let pq = queuePQ $ runEventQueue $ pointRun p+  in PQ.enqueue pq t priority m+ -- | Process the pending events. processPendingEventsCore :: Bool -> Dynamics () processPendingEventsCore includingCurrentEvents = Dynamics r where@@ -264,7 +274,7 @@            r  = pointRun p        f <- PQ.queueNull pq        unless f $-         do (t2, c2) <- PQ.queueFront pq+         do (t2, priority2, c2) <- PQ.queueFront pq             let t = queueTime q             t' <- readIORef t             when (t2 < t') $ @@ -278,6 +288,7 @@                      dt = spcDT sc                      n2 = fromIntegral $ floor ((t2 - t0) / dt)                  c2 $ p { pointTime = t2,+                          pointPriority = priority2,                           pointIteration = n2,                           pointPhase = -1 }                  call q p@@ -345,6 +356,11 @@ eventQueueCount :: Event Int eventQueueCount =   Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun++-- | Return the current event priority.+eventPriority :: Event EventPriority+eventPriority =+  Event $ return . pointPriority  -- | Actuate the event handler in the specified time points. enqueueEventWithTimes :: [Double] -> Event () -> Event ()

@@ -66,7 +66,6 @@ newtype Parameter a = Parameter (Run -> IO a)  instance Monad Parameter where-  return  = returnP   m >>= k = bindP m k  returnP :: a -> Parameter a@@ -124,7 +123,7 @@   fmap = liftMP  instance Applicative Parameter where-  pure = return+  pure = returnP   (<*>) = ap  instance MonadFail Parameter where

@@ -83,6 +83,8 @@         catchProcess,         finallyProcess,         throwProcess,+        -- * Process Priority+        processWithPriority,         -- * Utilities         zipProcessParallel,         zip3ProcessParallel,@@ -119,12 +121,14 @@ -- | Represents a process identifier. data ProcessId =    ProcessId { processStarted :: IORef Bool,-              processReactCont     :: IORef (Maybe (ContParams ())), +              processReactCont     :: IORef (Maybe (ContParams ())),+              processReactPriority :: IORef Int,               processContId  :: ContId,               processInterruptRef  :: IORef Bool,                processInterruptCont :: IORef (Maybe (ContParams ())),               processInterruptTime :: IORef Double,-              processInterruptVersion :: IORef Int }+              processInterruptVersion :: IORef Int,+              processInterruptPriority :: IORef Int }  -- | Specifies a discontinuous process that can suspend at any time -- and then resume later.@@ -157,6 +161,7 @@      writeIORef x $ Just c      writeIORef (processInterruptRef pid) False      writeIORef (processInterruptTime pid) t+     writeIORef (processInterruptPriority pid) (pointPriority p)      v <- readIORef (processInterruptVersion pid)      invokeEvent p $        enqueueEvent t $@@ -176,10 +181,13 @@      case a of        Nothing -> return ()        Just c ->-         do writeIORef x Nothing+         do priority <- readIORef (processInterruptPriority pid)+            writeIORef x Nothing             writeIORef (processInterruptRef pid) True             modifyIORef (processInterruptVersion pid) $ (+) 1-            invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()+            invokeEvent p $+              enqueueEventWithPriority (pointTime p) priority $+              resumeCont c ()              -- | Test whether the process with the specified identifier was interrupted. processInterrupted :: ProcessId -> Event Bool@@ -209,7 +217,8 @@      a <- readIORef x      case a of        Just c ->-         do writeIORef x Nothing+         do priority <- readIORef (processInterruptPriority pid)+            writeIORef x Nothing             writeIORef (processInterruptRef pid) True             modifyIORef (processInterruptVersion pid) $ (+) 1             t <- readIORef (processInterruptTime pid)@@ -219,7 +228,7 @@                   invokeEvent p $                   invokeCont c $                   invokeProcess pid $-                  holdProcess dt+                  processWithPriority priority >> holdProcess dt             invokeEvent p $               reenterCont c' ()        Nothing ->@@ -241,8 +250,11 @@   do let x = processReactCont pid      a <- readIORef x      case a of-       Nothing -> writeIORef x $ Just c-       Just _  -> error "Cannot passivate the process twice: passivateProcess"+       Nothing ->+         do writeIORef x $ Just c+            writeIORef (processReactPriority pid) (pointPriority p)+       Just _  ->+         error "Cannot passivate the process twice: passivateProcess"  -- | Passivate the process before performing some action. passivateProcessBefore :: Event () -> Process ()@@ -255,8 +267,10 @@      case a of        Nothing ->          do writeIORef x $ Just c+            writeIORef (processReactPriority pid) (pointPriority p)             invokeEvent p m-       Just _  -> error "Cannot passivate the process twice: passivateProcessBefore"+       Just _  ->+         error "Cannot passivate the process twice: passivateProcessBefore"  -- | Test whether the process with the specified identifier is passivated. processPassive :: ProcessId -> Event Bool@@ -276,8 +290,11 @@        Nothing ->           return ()        Just c ->-         do writeIORef x Nothing-            invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c ()+         do priority <- readIORef (processReactPriority pid)+            writeIORef x Nothing+            invokeEvent p $+              enqueueEventWithPriority (pointTime p) priority $+              resumeCont c ()  -- | Reactivate a process with the specified identifier immediately. reactivateProcessImmediately :: ProcessId -> Event ()@@ -289,8 +306,13 @@        Nothing ->           return ()        Just c ->-         do writeIORef x Nothing-            invokeEvent p $ resumeCont c ()+         do priority <- readIORef (processReactPriority pid)+            writeIORef x Nothing+            if priority == pointPriority p+              then invokeEvent p $ resumeCont c ()+              else invokeEvent p $+                   enqueueEventWithPriority (pointTime p) priority $+                   resumeCont c ()  -- | Prepare the processes identifier for running. processIdPrepare :: ProcessId -> Event ()@@ -391,13 +413,17 @@      z <- liftIO $ newIORef Nothing      t <- liftIO $ newIORef 0      v <- liftIO $ newIORef 0+     priority1 <- liftIO $ newIORef 0+     priority2 <- liftIO $ newIORef 0      return ProcessId { processStarted = y,-                        processReactCont     = x, +                        processReactCont     = x,+                        processReactPriority = priority1,                         processContId  = c,                          processInterruptRef  = i,                         processInterruptCont = z,                         processInterruptTime = t,-                        processInterruptVersion = v }+                        processInterruptVersion = v,+                        processInterruptPriority = priority2 }  -- | Cancel a process with the specified identifier, interrupting it if needed. cancelProcessWithId :: ProcessId -> Event ()@@ -447,14 +473,13 @@   x == y = processReactCont x == processReactCont y    -- for the references are unique  instance Monad Process where-  return  = returnP   m >>= k = bindP m k  instance Functor Process where   fmap = liftM  instance Applicative Process where-  pure = return+  pure = returnP   (<*>) = ap  instance MonadFail Process where@@ -535,6 +560,18 @@ -- which allows already handling the exception. throwProcess :: Exception e => e -> Process a throwProcess = liftIO . throw++-- | Proceed with the process that would use the specified event priority.+processWithPriority :: EventPriority -> Process ()+processWithPriority priority =+  Process $ \pid ->+  Cont $ \c ->+  Event $ \p ->+  if priority == pointPriority p+  then invokeEvent p $ resumeCont c ()+  else invokeEvent p $+       enqueueEventWithPriority (pointTime p) priority $+       resumeCont c ()  -- | Execute the specified computations in parallel within -- the current computation and return their results. The cancellation

@@ -55,7 +55,6 @@ newtype Simulation a = Simulation (Run -> IO a)  instance Monad Simulation where-  return  = returnS   m >>= k = bindS m k  returnS :: a -> Simulation a@@ -120,7 +119,7 @@   fmap = liftMS  instance Applicative Simulation where-  pure = return+  pure = returnS   (<*>) = ap  instance MonadFail Simulation where

@@ -13,6 +13,7 @@         Method(..),         Run(..),         Point(..),+        EventPriority(..),         EventQueue(..),         newEventQueue,         basicTime,@@ -35,7 +36,7 @@ import Data.IORef  import Simulation.Aivika.Generator-import qualified Simulation.Aivika.PriorityQueue as PQ+import qualified Simulation.Aivika.PriorityQueue.EventQueue as PQ  -- | It defines the simulation specs. data Specs = Specs { spcStartTime :: Double,    -- ^ the start time@@ -65,10 +66,14 @@ data Point = Point { pointSpecs :: Specs,    -- ^ the simulation specs                      pointRun :: Run,        -- ^ the simulation run                      pointTime :: Double,    -- ^ the current time+                     pointPriority :: EventPriority,    -- ^ the current priority                      pointIteration :: Int,  -- ^ the current iteration                      pointPhase :: Int       -- ^ the current phase                    } +-- | The event priority (greater is higher).+type EventPriority = Int+ -- | It represents the event queue. data EventQueue = EventQueue { queuePQ :: PQ.PriorityQueue (Point -> IO ()),                                -- ^ the underlying priority queue@@ -196,6 +201,7 @@         point n  = Point { pointSpecs = sc,                            pointRun = r,                            pointTime = basicTime sc n 0,+                           pointPriority = 0,                            pointIteration = n,                            pointPhase = 0 } @@ -207,6 +213,7 @@         point n  = Point { pointSpecs = sc,                            pointRun = r,                            pointTime = basicTime sc n 0,+                           pointPriority = 0,                            pointIteration = n,                            pointPhase = 0 } @@ -218,16 +225,17 @@         point n  = Point { pointSpecs = sc,                            pointRun = r,                            pointTime = basicTime sc n 0,+                           pointPriority = 0,                            pointIteration = n,                            pointPhase = 0 }  -- | Return the simulation stop time point. simulationStopPoint :: Run -> Point-simulationStopPoint r = pointAt r (spcStopTime $ runSpecs r)+simulationStopPoint r = pointAt r (spcStopTime $ runSpecs r) 0 --- | Return the point at the specified time.-pointAt :: Run -> Double -> Point-pointAt r t = p+-- | Return the point at the specified time given the priority.+pointAt :: Run -> Double -> EventPriority -> Point+pointAt r t priority = p   where sc = runSpecs r         t0 = spcStartTime sc         dt = spcDT sc@@ -235,10 +243,11 @@         p = Point { pointSpecs = sc,                     pointRun = r,                     pointTime = t,+                    pointPriority = priority,                     pointIteration = n,                     pointPhase = -1 } --- | Return the integration time points startin from the specified iteration.+-- | Return the integration time points starting from the specified iteration. integPointsStartingFrom :: Point -> [Point] integPointsStartingFrom p = points   where r  = pointRun p@@ -251,6 +260,7 @@         point n  = Point { pointSpecs = sc,                            pointRun = r,                            pointTime = basicTime sc n 0,+                           pointPriority = 0,                            pointIteration = n,                            pointPhase = 0 } 

@@ -0,0 +1,236 @@++{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module     : Simulation.Aivika.PriorityQueue+-- 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+--+-- An imperative heap-based priority queue to implement the event queue.+--+module Simulation.Aivika.PriorityQueue.EventQueue+       (PriorityQueue, +        Priority,+        queueNull, +        queueCount,+        newQueue, +        enqueue, +        dequeue, +        queueFront) where ++import Data.Array+import Data.Array.MArray.Safe+import Data.Array.IO.Safe+import Data.IORef+import Data.Maybe++import Control.Monad++-- | The priority value (greater is higher).+type Priority = Int++-- | The 'PriorityQueue' type represents an imperative heap-based +-- priority queue.+data PriorityQueue a = +  PriorityQueue { pqKeys  :: IORef (IOUArray Int Double),+                  pqPris  :: IORef (IOUArray Int Priority),+                  pqVals  :: IORef (IOArray Int a),+                  pqSize  :: IORef Int }++increase :: PriorityQueue a -> Int -> IO ()+increase pq capacity = +  do let keyRef = pqKeys pq+         priRef = pqPris pq+         valRef = pqVals pq+     keys <- readIORef keyRef+     pris <- readIORef priRef+     vals <- readIORef valRef+     (il, iu)  <- getBounds keys+     let len = (iu - il) + 1+         capacity' | len < 64  = max capacity ((len + 1) * 2)+                   | otherwise = max capacity ((len `div` 2) * 3)+         il' = il+         iu' = il + capacity' - 1+     keys' <- newArray_ (il', iu')+     pris' <- newArray_ (il', iu')+     vals' <- newArray_ (il', iu')+     mapM_ (\i -> do { k <- readArray keys i; writeArray keys' i k }) [il..iu]+     mapM_ (\i -> do { p <- readArray pris i; writeArray pris' i p }) [il..iu]+     mapM_ (\i -> do { v <- readArray vals i; writeArray vals' i v }) [il..iu]+     writeIORef keyRef keys'+     writeIORef priRef pris'+     writeIORef valRef vals'++siftUp :: IOUArray Int Double+       -> IOUArray Int Priority+       -> IOArray Int a+       -> Int+       -> Double+       -> Priority+       -> a +       -> IO ()+siftUp keys pris vals i k p v = loop i+  where loop i =+          if i == 0 +          then do writeArray keys i k+                  writeArray pris i p+                  writeArray vals i v+          else do let n = (i - 1) `div` 2+                  kn <- readArray keys n+                  pn <- readArray pris n+                  if gte k p kn pn    -- (k, -p) >= (kn, -pn)+                    then do writeArray keys i k+                            writeArray pris i p+                            writeArray vals i v+                    else do pn <- readArray pris n+                            vn <- readArray vals n+                            writeArray keys i kn+                            writeArray pris i pn+                            writeArray vals i vn+                            loop n++siftDown :: IOUArray Int Double+         -> IOUArray Int Priority+         -> IOArray Int a+         -> Int+         -> Int+         -> Double+         -> Priority+         -> a +         -> IO ()+siftDown keys pris vals size i k p v = loop i+  where loop i =+          if i >= (size `div` 2)+          then do writeArray keys i k+                  writeArray pris i p+                  writeArray vals i v+          else do let n  = 2 * i + 1+                      n' = n + 1+                  kn  <- readArray keys n+                  pn  <- readArray pris n+                  if n' >= size +                    then if lte k p kn pn    -- (k, -p) <= (kn, -pn)+                    then do writeArray keys i k+                            writeArray pris i p+                            writeArray vals i v+                    else do pn <- readArray pris n+                            vn <- readArray vals n+                            writeArray keys i kn+                            writeArray pris i pn+                            writeArray vals i vn+                            loop n+                    else do kn' <- readArray keys n'+                            pn' <- readArray pris n'+                            -- (kn, -pn) > (kn', -pn')+                            let n''  = if gt kn pn kn' pn' then n' else n+                                kn'' = if n'' == n' then kn' else kn+                                pn'' = if n'' == n' then pn' else pn+                            if lte k p kn'' pn''    -- (k, -p) <= (kn'', -pn'')+                              then do writeArray keys i k+                                      writeArray pris i p+                                      writeArray vals i v+                              else do pn'' <- readArray pris n''+                                      vn'' <- readArray vals n''+                                      writeArray keys i kn''+                                      writeArray pris i pn''+                                      writeArray vals i vn''+                                      loop n''++-- | Test whether the priority queue is empty.+queueNull :: PriorityQueue a -> IO Bool+queueNull pq =+  do size <- readIORef (pqSize pq)+     return $ size == 0++-- | Return the number of elements in the priority queue.+queueCount :: PriorityQueue a -> IO Int+queueCount pq = readIORef (pqSize pq)++-- | Create a new priority queue.+newQueue :: IO (PriorityQueue a)+newQueue =+  do keys <- newArray_ (0, 10)+     pris <- newArray_ (0, 10)+     vals <- newArray_ (0, 10)+     keyRef  <- newIORef keys+     priRef  <- newIORef pris+     valRef  <- newIORef vals+     sizeRef <- newIORef 0+     return PriorityQueue { pqKeys = keyRef,+                            pqPris = priRef,+                            pqVals = valRef, +                            pqSize = sizeRef }++-- | Enqueue a new element with the specified priority.+enqueue :: PriorityQueue a -> Double -> Priority -> a -> IO ()+enqueue pq k p v =+  do i <- readIORef (pqSize pq)+     keys <- readIORef (pqKeys pq)+     (il, iu) <- getBounds keys+     when (i >= iu - il) $ increase pq (i + 2)  -- plus one element on the end+     writeIORef (pqSize pq) (i + 1)+     keys <- readIORef (pqKeys pq)  -- it can be another! (side-effect)+     pris <- readIORef (pqPris pq)+     vals <- readIORef (pqVals pq)+     siftUp keys pris vals i k p v++-- | Dequeue the element with the minimal priority.+dequeue :: PriorityQueue a -> IO ()+dequeue pq =+  do size <- readIORef (pqSize pq)+     when (size == 0) $ error "Empty priority queue: dequeue"+     let i = size - 1+     writeIORef (pqSize pq) i+     keys <- readIORef (pqKeys pq)+     pris <- readIORef (pqPris pq)+     vals <- readIORef (pqVals pq)+     k  <- readArray keys i+     p  <- readArray pris i+     v  <- readArray vals i+     let k0 = 0.0+         p0 = 0+         v0 = undefined+     -- k0 <- readArray keys size+     -- p0 <- readArray pris size+     -- v0 <- readArray vals size+     writeArray keys i k0+     writeArray pris i p0+     writeArray vals i v0+     when (i > 0) $+       siftDown keys pris vals i 0 k p v++-- | Return the element with the minimal priority.+queueFront :: PriorityQueue a -> IO (Double, Priority, a)+queueFront pq =+  do size <- readIORef (pqSize pq)+     when (size == 0) $ error "Empty priority queue: front"+     keys <- readIORef (pqKeys pq)+     pris <- readIORef (pqPris pq)+     vals <- readIORef (pqVals pq)+     k <- readArray keys 0+     p <- readArray pris 0+     v <- readArray vals 0+     return (k, p, v)++-- | Whether the first pair is greater than the second one.+gt :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE gt #-}+gt k1 p1 k2 p2 = (k1 > k2) || (k1 == k2 && p1 < p2)++-- | Whether the first pair is greater than or equal to the second one.+gte :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE gte #-}+gte k1 p1 k2 p2 = (k1 > k2) || (k1 == k2 && p1 <= p2)++-- | Whether the first pair is less than the second one.+lt :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE lt #-}+lt k1 p1 k2 p2 = gt k2 p2 k1 p1++-- | Whether the first pair is less than or equal to the second one.+lte :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE lte #-}+lte k1 p1 k2 p2 = gte k2 p2 k1 p1

@@ -0,0 +1,102 @@++-- |+-- Module     : Simulation.Aivika.PriorityQueue.EventQueue.Pure+-- Copyright  : Copyright (c) 2023, David Sorokin <davsor@mail.ru>+-- License    : BSD3+-- Maintainer : David Sorokin <david.sorokin@gmail.com>+-- Stability  : experimental+-- Tested with: GHC 9.2.8+--+-- An immutable heap-based priority queue based on book+-- Algorithms: A Functional Programming Approach by+-- Fethi Rabhi and Guy Lapalme.+--+-- The queue allows specifying priorities along with keys.+--+module Simulation.Aivika.PriorityQueue.EventQueue.Pure +       (PriorityQueue, +        Priority,+        queueNull, +        queueCount,+        emptyQueue, +        enqueue, +        dequeue, +        queueFront) where ++import Control.Monad++-- | The priority value (greater is higher).+type Priority = Int++-- | The 'PriorityQueue' type represents an immutable heap-based priority queue.+data PriorityQueue a = EmptyQueue+                     | Queue !Int !Double !Priority a !Int (PriorityQueue a) (PriorityQueue a)+                       deriving Show++-- | Test whether the priority queue is empty.+queueNull :: PriorityQueue a -> Bool+queueNull EmptyQueue = True+queueNull _          = False++-- | Return the number of elements in the priority queue.+queueCount :: PriorityQueue a -> Int+queueCount EmptyQueue = 0+queueCount (Queue n k p v r a b) = n++-- | An empty priority queue.+emptyQueue :: PriorityQueue a+emptyQueue = EmptyQueue++-- | Enqueue a new element with the specified priority.+enqueue :: PriorityQueue a -> Double -> Priority -> a -> PriorityQueue a+enqueue pq k p v = mergeQueues pq (Queue 1 k p v 1 EmptyQueue EmptyQueue)++-- | Dequeue the element with the minimal priority.+dequeue :: PriorityQueue a -> PriorityQueue a+dequeue EmptyQueue = error "The queue is empty: dequeue"+dequeue (Queue n k p v r a b) = mergeQueues a b++-- | Return the element with the minimal priority.+queueFront :: PriorityQueue a -> (Double, Priority, a)+queueFront EmptyQueue = error "The queue is empty: queueFront"+queueFront (Queue n k p v r a b) = (k, p, v)++-- | Return the rank of the priority queue.+queueRank :: PriorityQueue a -> Int+queueRank EmptyQueue = 0+queueRank (Queue n k p v r a b) = r++-- | Construct a new priority queue.+makeQueue :: Double -> Priority -> a -> PriorityQueue a -> PriorityQueue a -> PriorityQueue a+makeQueue k p v a b+  | queueRank a >= queueRank b = n `seq` Queue n k p v (queueRank b + 1) a b+  | otherwise                  = n `seq` Queue n k p v (queueRank a + 1) b a+  where n = queueCount a + queueCount b + 1++-- | Merge two priority queues.+mergeQueues :: PriorityQueue a -> PriorityQueue a -> PriorityQueue a+mergeQueues h EmptyQueue = h+mergeQueues EmptyQueue h = h+mergeQueues h1@(Queue _ k1 p1 v1 _ a1 b1) h2@(Queue _ k2 p2 v2 _ a2 b2)+  | lte k1 p1 k2 p2 = makeQueue k1 p1 v1 a1 (mergeQueues b1 h2)+  | otherwise       = makeQueue k2 p2 v2 a2 (mergeQueues h1 b2)++-- | Whether the first pair is greater than the second one.+gt :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE gt #-}+gt k1 p1 k2 p2 = (k1 > k2) || (k1 == k2 && p1 < p2)++-- | Whether the first pair is greater than or equal to the second one.+gte :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE gte #-}+gte k1 p1 k2 p2 = (k1 > k2) || (k1 == k2 && p1 <= p2)++-- | Whether the first pair is less than the second one.+lt :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE lt #-}+lt k1 p1 k2 p2 = gt k2 p2 k1 p1++-- | Whether the first pair is less than or equal to the second one.+lte :: Double -> Priority -> Double -> Priority -> Bool+{-# INLINE lte #-}+lte k1 p1 k2 p2 = gte k2 p2 k1 p1

@@ -78,6 +78,8 @@         catchProcess,         finallyProcess,         throwProcess,+        -- * Process Priority+        processWithPriority,         -- * Utilities         zipProcessParallel,         zip3ProcessParallel,

@@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, OverlappingInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-}  -- | -- Module     : Simulation.Aivika.Results

@@ -1,5 +1,5 @@ name:            aivika-version:         5.9.1+version:         6.0.0 synopsis:        A multi-method simulation library description:     Aivika is a discrete event simulation (DES) framework with support of activity-oriented,@@ -88,9 +88,6 @@     .     The libraries were tested on Linux, Windows and OS X.     .-    The PDF documentation, installation instructions and a more full information about Aivika -    are available on the the AivikaSoft website [8].-    .     \[1] <http://hackage.haskell.org/package/aivika-experiment>     .     \[2] <http://hackage.haskell.org/package/aivika-experiment-chart>@@ -105,18 +102,16 @@     .     \[7] <http://hackage.haskell.org/package/aivika-distributed>     .-    \[8] <http://www.aivikasoft.com>-    .     P.S. Aivika is actually a genuine female Mari name which is pronounced      with stress on the last syllable.     . category:        Simulation license:         BSD3 license-file:    LICENSE-copyright:       (c) 2009-2018. David Sorokin <david.sorokin@gmail.com>+copyright:       (c) 2009-2023. David Sorokin <davsor@mail.ru> author:          David Sorokin-maintainer:      David Sorokin <david.sorokin@gmail.com>-homepage:        http://www.aivikasoft.com+maintainer:      David Sorokin <davsor@mail.ru>+homepage:        https://gitflic.ru/project/dsorokin/aivika cabal-version:   >= 1.10 build-type:      Simple tested-with:     GHC == 8.0.2@@ -184,6 +179,8 @@                      Simulation.Aivika.Parameter.Random                      Simulation.Aivika.PriorityQueue                      Simulation.Aivika.PriorityQueue.Pure+                     Simulation.Aivika.PriorityQueue.EventQueue+                     Simulation.Aivika.PriorityQueue.EventQueue.Pure                      Simulation.Aivika.Process                      Simulation.Aivika.Process.Random                      Simulation.Aivika.Processor@@ -265,4 +262,4 @@ source-repository head      type:     git-    location: https://github.com/dsorokin/aivika+    location: https://gitflic.ru/project/dsorokin/aivika