{-# 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 { forall a. PriorityQueue a -> IORef (IOUArray Priority Double)
pqKeys  :: IORef (IOUArray Int Double),
                  forall a. PriorityQueue a -> IORef (IOUArray Priority Priority)
pqPris  :: IORef (IOUArray Int Priority),
                  forall a. PriorityQueue a -> IORef (IOArray Priority a)
pqVals  :: IORef (IOArray Int a),
                  forall a. PriorityQueue a -> IORef Priority
pqSize  :: IORef Int }

increase :: PriorityQueue a -> Int -> IO ()
increase :: forall a. PriorityQueue a -> Priority -> IO ()
increase PriorityQueue a
pq Priority
capacity = 
  do let keyRef :: IORef (IOUArray Priority Double)
keyRef = PriorityQueue a -> IORef (IOUArray Priority Double)
forall a. PriorityQueue a -> IORef (IOUArray Priority Double)
pqKeys PriorityQueue a
pq
         priRef :: IORef (IOUArray Priority Priority)
priRef = PriorityQueue a -> IORef (IOUArray Priority Priority)
forall a. PriorityQueue a -> IORef (IOUArray Priority Priority)
pqPris PriorityQueue a
pq
         valRef :: IORef (IOArray Priority a)
valRef = PriorityQueue a -> IORef (IOArray Priority a)
forall a. PriorityQueue a -> IORef (IOArray Priority a)
pqVals PriorityQueue a
pq
     IOUArray Priority Double
keys <- IORef (IOUArray Priority Double) -> IO (IOUArray Priority Double)
forall a. IORef a -> IO a
readIORef IORef (IOUArray Priority Double)
keyRef
     IOUArray Priority Priority
pris <- IORef (IOUArray Priority Priority)
-> IO (IOUArray Priority Priority)
forall a. IORef a -> IO a
readIORef IORef (IOUArray Priority Priority)
priRef
     IOArray Priority a
vals <- IORef (IOArray Priority a) -> IO (IOArray Priority a)
forall a. IORef a -> IO a
readIORef IORef (IOArray Priority a)
valRef
     (Priority
il, Priority
iu)  <- IOUArray Priority Double -> IO (Priority, Priority)
forall i. Ix i => IOUArray i Double -> IO (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOUArray Priority Double
keys
     let len :: Priority
len = (Priority
iu Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
- Priority
il) Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
1
         capacity' :: Priority
capacity' | Priority
len Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
< Priority
64  = Priority -> Priority -> Priority
forall a. Ord a => a -> a -> a
max Priority
capacity ((Priority
len Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
1) Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
* Priority
2)
                   | Bool
otherwise = Priority -> Priority -> Priority
forall a. Ord a => a -> a -> a
max Priority
capacity ((Priority
len Priority -> Priority -> Priority
forall a. Integral a => a -> a -> a
`div` Priority
2) Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
* Priority
3)
         il' :: Priority
il' = Priority
il
         iu' :: Priority
iu' = Priority
il Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
capacity' Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
- Priority
1
     IOUArray Priority Double
keys' <- (Priority, Priority) -> IO (IOUArray Priority Double)
forall i. Ix i => (i, i) -> IO (IOUArray i Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Priority
il', Priority
iu')
     IOUArray Priority Priority
pris' <- (Priority, Priority) -> IO (IOUArray Priority Priority)
forall i. Ix i => (i, i) -> IO (IOUArray i Priority)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Priority
il', Priority
iu')
     IOArray Priority a
vals' <- (Priority, Priority) -> IO (IOArray Priority a)
forall i. Ix i => (i, i) -> IO (IOArray i a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Priority
il', Priority
iu')
     (Priority -> IO ()) -> [Priority] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Priority
i -> do { Double
k <- IOUArray Priority Double -> Priority -> IO Double
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Double
keys Priority
i; IOUArray Priority Double -> Priority -> Double -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys' Priority
i Double
k }) [Priority
il..Priority
iu]
     (Priority -> IO ()) -> [Priority] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Priority
i -> do { Priority
p <- IOUArray Priority Priority -> Priority -> IO Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
i; IOUArray Priority Priority -> Priority -> Priority -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris' Priority
i Priority
p }) [Priority
il..Priority
iu]
     (Priority -> IO ()) -> [Priority] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Priority
i -> do { a
v <- IOArray Priority a -> Priority -> IO a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Priority a
vals Priority
i; IOArray Priority a -> Priority -> a -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals' Priority
i a
v }) [Priority
il..Priority
iu]
     IORef (IOUArray Priority Double)
-> IOUArray Priority Double -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IOUArray Priority Double)
keyRef IOUArray Priority Double
keys'
     IORef (IOUArray Priority Priority)
-> IOUArray Priority Priority -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IOUArray Priority Priority)
priRef IOUArray Priority Priority
pris'
     IORef (IOArray Priority a) -> IOArray Priority a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IOArray Priority a)
valRef IOArray Priority a
vals'

siftUp :: IOUArray Int Double
       -> IOUArray Int Priority
       -> IOArray Int a
       -> Int
       -> Double
       -> Priority
       -> a 
       -> IO ()
siftUp :: forall a.
IOUArray Priority Double
-> IOUArray Priority Priority
-> IOArray Priority a
-> Priority
-> Double
-> Priority
-> a
-> IO ()
siftUp IOUArray Priority Double
keys IOUArray Priority Priority
pris IOArray Priority a
vals Priority
i Double
k Priority
p a
v = Priority -> IO ()
forall {m :: * -> *}.
(MArray IOUArray Double m, MArray IOUArray Priority m,
 MArray IOArray a m) =>
Priority -> m ()
loop Priority
i
  where loop :: Priority -> m ()
loop Priority
i =
          if Priority
i Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
0 
          then do IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
k
                  IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
p
                  IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
v
          else do let n :: Priority
n = (Priority
i Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
- Priority
1) Priority -> Priority -> Priority
forall a. Integral a => a -> a -> a
`div` Priority
2
                  Double
kn <- IOUArray Priority Double -> Priority -> m Double
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Double
keys Priority
n
                  Priority
pn <- IOUArray Priority Priority -> Priority -> m Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
n
                  if Double -> Priority -> Double -> Priority -> Bool
gte Double
k Priority
p Double
kn Priority
pn    -- (k, -p) >= (kn, -pn)
                    then do IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
k
                            IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
p
                            IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
v
                    else do Priority
pn <- IOUArray Priority Priority -> Priority -> m Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
n
                            a
vn <- IOArray Priority a -> Priority -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Priority a
vals Priority
n
                            IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
kn
                            IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
pn
                            IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
vn
                            Priority -> m ()
loop Priority
n

siftDown :: IOUArray Int Double
         -> IOUArray Int Priority
         -> IOArray Int a
         -> Int
         -> Int
         -> Double
         -> Priority
         -> a 
         -> IO ()
siftDown :: forall a.
IOUArray Priority Double
-> IOUArray Priority Priority
-> IOArray Priority a
-> Priority
-> Priority
-> Double
-> Priority
-> a
-> IO ()
siftDown IOUArray Priority Double
keys IOUArray Priority Priority
pris IOArray Priority a
vals Priority
size Priority
i Double
k Priority
p a
v = Priority -> IO ()
forall {m :: * -> *}.
(MArray IOUArray Double m, MArray IOUArray Priority m,
 MArray IOArray a m) =>
Priority -> m ()
loop Priority
i
  where loop :: Priority -> m ()
loop Priority
i =
          if Priority
i Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= (Priority
size Priority -> Priority -> Priority
forall a. Integral a => a -> a -> a
`div` Priority
2)
          then do IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
k
                  IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
p
                  IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
v
          else do let n :: Priority
n  = Priority
2 Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
* Priority
i Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
1
                      n' :: Priority
n' = Priority
n Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
1
                  Double
kn  <- IOUArray Priority Double -> Priority -> m Double
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Double
keys Priority
n
                  Priority
pn  <- IOUArray Priority Priority -> Priority -> m Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
n
                  if Priority
n' Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
size 
                    then if Double -> Priority -> Double -> Priority -> Bool
lte Double
k Priority
p Double
kn Priority
pn    -- (k, -p) <= (kn, -pn)
                    then do IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
k
                            IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
p
                            IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
v
                    else do Priority
pn <- IOUArray Priority Priority -> Priority -> m Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
n
                            a
vn <- IOArray Priority a -> Priority -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Priority a
vals Priority
n
                            IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
kn
                            IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
pn
                            IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
vn
                            Priority -> m ()
loop Priority
n
                    else do Double
kn' <- IOUArray Priority Double -> Priority -> m Double
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Double
keys Priority
n'
                            Priority
pn' <- IOUArray Priority Priority -> Priority -> m Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
n'
                            -- (kn, -pn) > (kn', -pn')
                            let n'' :: Priority
n''  = if Double -> Priority -> Double -> Priority -> Bool
gt Double
kn Priority
pn Double
kn' Priority
pn' then Priority
n' else Priority
n
                                kn'' :: Double
kn'' = if Priority
n'' Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
n' then Double
kn' else Double
kn
                                pn'' :: Priority
pn'' = if Priority
n'' Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
n' then Priority
pn' else Priority
pn
                            if Double -> Priority -> Double -> Priority -> Bool
lte Double
k Priority
p Double
kn'' Priority
pn''    -- (k, -p) <= (kn'', -pn'')
                              then do IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
k
                                      IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
p
                                      IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
v
                              else do Priority
pn'' <- IOUArray Priority Priority -> Priority -> m Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
n''
                                      a
vn'' <- IOArray Priority a -> Priority -> m a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Priority a
vals Priority
n''
                                      IOUArray Priority Double -> Priority -> Double -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
kn''
                                      IOUArray Priority Priority -> Priority -> Priority -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
pn''
                                      IOArray Priority a -> Priority -> a -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
vn''
                                      Priority -> m ()
loop Priority
n''

-- | Test whether the priority queue is empty.
queueNull :: PriorityQueue a -> IO Bool
queueNull :: forall a. PriorityQueue a -> IO Bool
queueNull PriorityQueue a
pq =
  do Priority
size <- IORef Priority -> IO Priority
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq)
     Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Priority
size Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
0

-- | Return the number of elements in the priority queue.
queueCount :: PriorityQueue a -> IO Int
queueCount :: forall a. PriorityQueue a -> IO Priority
queueCount PriorityQueue a
pq = IORef Priority -> IO Priority
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq)

-- | Create a new priority queue.
newQueue :: IO (PriorityQueue a)
newQueue :: forall a. IO (PriorityQueue a)
newQueue =
  do IOUArray Priority Double
keys <- (Priority, Priority) -> IO (IOUArray Priority Double)
forall i. Ix i => (i, i) -> IO (IOUArray i Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Priority
0, Priority
10)
     IOUArray Priority Priority
pris <- (Priority, Priority) -> IO (IOUArray Priority Priority)
forall i. Ix i => (i, i) -> IO (IOUArray i Priority)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Priority
0, Priority
10)
     IOArray Priority a
vals <- (Priority, Priority) -> IO (IOArray Priority a)
forall i. Ix i => (i, i) -> IO (IOArray i a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Priority
0, Priority
10)
     IORef (IOUArray Priority Double)
keyRef  <- IOUArray Priority Double -> IO (IORef (IOUArray Priority Double))
forall a. a -> IO (IORef a)
newIORef IOUArray Priority Double
keys
     IORef (IOUArray Priority Priority)
priRef  <- IOUArray Priority Priority
-> IO (IORef (IOUArray Priority Priority))
forall a. a -> IO (IORef a)
newIORef IOUArray Priority Priority
pris
     IORef (IOArray Priority a)
valRef  <- IOArray Priority a -> IO (IORef (IOArray Priority a))
forall a. a -> IO (IORef a)
newIORef IOArray Priority a
vals
     IORef Priority
sizeRef <- Priority -> IO (IORef Priority)
forall a. a -> IO (IORef a)
newIORef Priority
0
     PriorityQueue a -> IO (PriorityQueue a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PriorityQueue { pqKeys :: IORef (IOUArray Priority Double)
pqKeys = IORef (IOUArray Priority Double)
keyRef,
                            pqPris :: IORef (IOUArray Priority Priority)
pqPris = IORef (IOUArray Priority Priority)
priRef,
                            pqVals :: IORef (IOArray Priority a)
pqVals = IORef (IOArray Priority a)
valRef, 
                            pqSize :: IORef Priority
pqSize = IORef Priority
sizeRef }

-- | Enqueue a new element with the specified priority.
enqueue :: PriorityQueue a -> Double -> Priority -> a -> IO ()
enqueue :: forall a. PriorityQueue a -> Double -> Priority -> a -> IO ()
enqueue PriorityQueue a
pq Double
k Priority
p a
v =
  do Priority
i <- IORef Priority -> IO Priority
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq)
     IOUArray Priority Double
keys <- IORef (IOUArray Priority Double) -> IO (IOUArray Priority Double)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Double)
forall a. PriorityQueue a -> IORef (IOUArray Priority Double)
pqKeys PriorityQueue a
pq)
     (Priority
il, Priority
iu) <- IOUArray Priority Double -> IO (Priority, Priority)
forall i. Ix i => IOUArray i Double -> IO (i, i)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> m (i, i)
getBounds IOUArray Priority Double
keys
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
i Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
iu Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
- Priority
il) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PriorityQueue a -> Priority -> IO ()
forall a. PriorityQueue a -> Priority -> IO ()
increase PriorityQueue a
pq (Priority
i Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
2)  -- plus one element on the end
     IORef Priority -> Priority -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq) (Priority
i Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
+ Priority
1)
     IOUArray Priority Double
keys <- IORef (IOUArray Priority Double) -> IO (IOUArray Priority Double)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Double)
forall a. PriorityQueue a -> IORef (IOUArray Priority Double)
pqKeys PriorityQueue a
pq)  -- it can be another! (side-effect)
     IOUArray Priority Priority
pris <- IORef (IOUArray Priority Priority)
-> IO (IOUArray Priority Priority)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Priority)
forall a. PriorityQueue a -> IORef (IOUArray Priority Priority)
pqPris PriorityQueue a
pq)
     IOArray Priority a
vals <- IORef (IOArray Priority a) -> IO (IOArray Priority a)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOArray Priority a)
forall a. PriorityQueue a -> IORef (IOArray Priority a)
pqVals PriorityQueue a
pq)
     IOUArray Priority Double
-> IOUArray Priority Priority
-> IOArray Priority a
-> Priority
-> Double
-> Priority
-> a
-> IO ()
forall a.
IOUArray Priority Double
-> IOUArray Priority Priority
-> IOArray Priority a
-> Priority
-> Double
-> Priority
-> a
-> IO ()
siftUp IOUArray Priority Double
keys IOUArray Priority Priority
pris IOArray Priority a
vals Priority
i Double
k Priority
p a
v

-- | Dequeue the element with the minimal priority.
dequeue :: PriorityQueue a -> IO ()
dequeue :: forall a. PriorityQueue a -> IO ()
dequeue PriorityQueue a
pq =
  do Priority
size <- IORef Priority -> IO Priority
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq)
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
size Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Empty priority queue: dequeue"
     let i :: Priority
i = Priority
size Priority -> Priority -> Priority
forall a. Num a => a -> a -> a
- Priority
1
     IORef Priority -> Priority -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq) Priority
i
     IOUArray Priority Double
keys <- IORef (IOUArray Priority Double) -> IO (IOUArray Priority Double)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Double)
forall a. PriorityQueue a -> IORef (IOUArray Priority Double)
pqKeys PriorityQueue a
pq)
     IOUArray Priority Priority
pris <- IORef (IOUArray Priority Priority)
-> IO (IOUArray Priority Priority)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Priority)
forall a. PriorityQueue a -> IORef (IOUArray Priority Priority)
pqPris PriorityQueue a
pq)
     IOArray Priority a
vals <- IORef (IOArray Priority a) -> IO (IOArray Priority a)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOArray Priority a)
forall a. PriorityQueue a -> IORef (IOArray Priority a)
pqVals PriorityQueue a
pq)
     Double
k  <- IOUArray Priority Double -> Priority -> IO Double
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Double
keys Priority
i
     Priority
p  <- IOUArray Priority Priority -> Priority -> IO Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
i
     a
v  <- IOArray Priority a -> Priority -> IO a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Priority a
vals Priority
i
     let k0 :: Double
k0 = Double
0.0
         p0 :: Priority
p0 = Priority
0
         v0 :: a
v0 = a
forall a. HasCallStack => a
undefined
     -- k0 <- readArray keys size
     -- p0 <- readArray pris size
     -- v0 <- readArray vals size
     IOUArray Priority Double -> Priority -> Double -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Double
keys Priority
i Double
k0
     IOUArray Priority Priority -> Priority -> Priority -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOUArray Priority Priority
pris Priority
i Priority
p0
     IOArray Priority a -> Priority -> a -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Priority a
vals Priority
i a
forall {a}. a
v0
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
i Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
> Priority
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       IOUArray Priority Double
-> IOUArray Priority Priority
-> IOArray Priority a
-> Priority
-> Priority
-> Double
-> Priority
-> a
-> IO ()
forall a.
IOUArray Priority Double
-> IOUArray Priority Priority
-> IOArray Priority a
-> Priority
-> Priority
-> Double
-> Priority
-> a
-> IO ()
siftDown IOUArray Priority Double
keys IOUArray Priority Priority
pris IOArray Priority a
vals Priority
i Priority
0 Double
k Priority
p a
v

-- | Return the element with the minimal priority.
queueFront :: PriorityQueue a -> IO (Double, Priority, a)
queueFront :: forall a. PriorityQueue a -> IO (Double, Priority, a)
queueFront PriorityQueue a
pq =
  do Priority
size <- IORef Priority -> IO Priority
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef Priority
forall a. PriorityQueue a -> IORef Priority
pqSize PriorityQueue a
pq)
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
size Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
== Priority
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Empty priority queue: front"
     IOUArray Priority Double
keys <- IORef (IOUArray Priority Double) -> IO (IOUArray Priority Double)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Double)
forall a. PriorityQueue a -> IORef (IOUArray Priority Double)
pqKeys PriorityQueue a
pq)
     IOUArray Priority Priority
pris <- IORef (IOUArray Priority Priority)
-> IO (IOUArray Priority Priority)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOUArray Priority Priority)
forall a. PriorityQueue a -> IORef (IOUArray Priority Priority)
pqPris PriorityQueue a
pq)
     IOArray Priority a
vals <- IORef (IOArray Priority a) -> IO (IOArray Priority a)
forall a. IORef a -> IO a
readIORef (PriorityQueue a -> IORef (IOArray Priority a)
forall a. PriorityQueue a -> IORef (IOArray Priority a)
pqVals PriorityQueue a
pq)
     Double
k <- IOUArray Priority Double -> Priority -> IO Double
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Double
keys Priority
0
     Priority
p <- IOUArray Priority Priority -> Priority -> IO Priority
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOUArray Priority Priority
pris Priority
0
     a
v <- IOArray Priority a -> Priority -> IO a
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray IOArray Priority a
vals Priority
0
     (Double, Priority, a) -> IO (Double, Priority, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
k, Priority
p, a
v)

-- | Whether the first pair is greater than the second one.
gt :: Double -> Priority -> Double -> Priority -> Bool
{-# INLINE gt #-}
gt :: Double -> Priority -> Double -> Priority -> Bool
gt Double
k1 Priority
p1 Double
k2 Priority
p2 = (Double
k1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
k2) Bool -> Bool -> Bool
|| (Double
k1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
k2 Bool -> Bool -> Bool
&& Priority
p1 Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
< Priority
p2)

-- | Whether the first pair is greater than or equal to the second one.
gte :: Double -> Priority -> Double -> Priority -> Bool
{-# INLINE gte #-}
gte :: Double -> Priority -> Double -> Priority -> Bool
gte Double
k1 Priority
p1 Double
k2 Priority
p2 = (Double
k1 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
k2) Bool -> Bool -> Bool
|| (Double
k1 Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
k2 Bool -> Bool -> Bool
&& Priority
p1 Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
<= Priority
p2)

-- | Whether the first pair is less than the second one.
lt :: Double -> Priority -> Double -> Priority -> Bool
{-# INLINE lt #-}
lt :: Double -> Priority -> Double -> Priority -> Bool
lt Double
k1 Priority
p1 Double
k2 Priority
p2 = Double -> Priority -> Double -> Priority -> Bool
gt Double
k2 Priority
p2 Double
k1 Priority
p1

-- | Whether the first pair is less than or equal to the second one.
lte :: Double -> Priority -> Double -> Priority -> Bool
{-# INLINE lte #-}
lte :: Double -> Priority -> Double -> Priority -> Bool
lte Double
k1 Priority
p1 Double
k2 Priority
p2 = Double -> Priority -> Double -> Priority -> Bool
gte Double
k2 Priority
p2 Double
k1 Priority
p1