Pure.hs

-- |
-- 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