diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,4 +1,9 @@
 
+Version 6.0
+-----
+
+* Introduced the discrete event priorities.
+
 Version 5.9
 -----
 
diff --git a/Simulation/Aivika/Circuit.hs b/Simulation/Aivika/Circuit.hs
--- a/Simulation/Aivika/Circuit.hs
+++ b/Simulation/Aivika/Circuit.hs
@@ -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
 
diff --git a/Simulation/Aivika/Composite.hs b/Simulation/Aivika/Composite.hs
--- a/Simulation/Aivika/Composite.hs
+++ b/Simulation/Aivika/Composite.hs
@@ -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 ->
diff --git a/Simulation/Aivika/Event.hs b/Simulation/Aivika/Event.hs
--- a/Simulation/Aivika/Event.hs
+++ b/Simulation/Aivika/Event.hs
@@ -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,
diff --git a/Simulation/Aivika/Internal/Cont.hs b/Simulation/Aivika/Internal/Cont.hs
--- a/Simulation/Aivika/Internal/Cont.hs
+++ b/Simulation/Aivika/Internal/Cont.hs
@@ -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
diff --git a/Simulation/Aivika/Internal/Dynamics.hs b/Simulation/Aivika/Internal/Dynamics.hs
--- a/Simulation/Aivika/Internal/Dynamics.hs
+++ b/Simulation/Aivika/Internal/Dynamics.hs
@@ -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
diff --git a/Simulation/Aivika/Internal/Event.hs b/Simulation/Aivika/Internal/Event.hs
--- a/Simulation/Aivika/Internal/Event.hs
+++ b/Simulation/Aivika/Internal/Event.hs
@@ -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 ()
diff --git a/Simulation/Aivika/Internal/Parameter.hs b/Simulation/Aivika/Internal/Parameter.hs
--- a/Simulation/Aivika/Internal/Parameter.hs
+++ b/Simulation/Aivika/Internal/Parameter.hs
@@ -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
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
@@ -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
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
@@ -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
diff --git a/Simulation/Aivika/Internal/Specs.hs b/Simulation/Aivika/Internal/Specs.hs
--- a/Simulation/Aivika/Internal/Specs.hs
+++ b/Simulation/Aivika/Internal/Specs.hs
@@ -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 }
 
diff --git a/Simulation/Aivika/PriorityQueue/EventQueue.hs b/Simulation/Aivika/PriorityQueue/EventQueue.hs
new file mode 100644
--- /dev/null
+++ b/Simulation/Aivika/PriorityQueue/EventQueue.hs
@@ -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
diff --git a/Simulation/Aivika/PriorityQueue/EventQueue/Pure.hs b/Simulation/Aivika/PriorityQueue/EventQueue/Pure.hs
new file mode 100644
--- /dev/null
+++ b/Simulation/Aivika/PriorityQueue/EventQueue/Pure.hs
@@ -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
diff --git a/Simulation/Aivika/Process.hs b/Simulation/Aivika/Process.hs
--- a/Simulation/Aivika/Process.hs
+++ b/Simulation/Aivika/Process.hs
@@ -78,6 +78,8 @@
         catchProcess,
         finallyProcess,
         throwProcess,
+        -- * Process Priority
+        processWithPriority,
         -- * Utilities
         zipProcessParallel,
         zip3ProcessParallel,
diff --git a/Simulation/Aivika/Results.hs b/Simulation/Aivika/Results.hs
--- a/Simulation/Aivika/Results.hs
+++ b/Simulation/Aivika/Results.hs
@@ -1,5 +1,5 @@
 
-{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification, OverlappingInstances #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-}
 
 -- |
 -- Module     : Simulation.Aivika.Results
diff --git a/aivika.cabal b/aivika.cabal
--- a/aivika.cabal
+++ b/aivika.cabal
@@ -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