{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE UnboxedTuples     #-}
module Data.IntPSQ.Internal
    ( -- * Type
      Nat
    , Key
    , Mask
    , IntPSQ (..)

      -- * Query
    , null
    , size
    , member
    , lookup
    , findMin

      -- * Construction
    , empty
    , singleton

      -- * Insertion
    , insert

      -- * Delete/update
    , delete
    , deleteMin
    , alter
    , alterMin

      -- * Lists
    , fromList
    , toList
    , keys

      -- * Views
    , insertView
    , deleteView
    , minView
    , atMostView

      -- * Traversal
    , map
    , unsafeMapMonotonic
    , fold'

      -- * Unsafe manipulation
    , unsafeInsertNew
    , unsafeInsertIncreasePriority
    , unsafeInsertIncreasePriorityView
    , unsafeInsertWithIncreasePriority
    , unsafeInsertWithIncreasePriorityView
    , unsafeLookupIncreasePriority

      -- * Testing
    , valid
    , hasBadNils
    , hasDuplicateKeys
    , hasMinHeapProperty
    , validMask
    ) where

import           Control.Applicative ((<$>), (<*>))
import           Control.DeepSeq     (NFData (rnf))
import           Data.Bits
import           Data.BitUtil
import           Data.Foldable       (Foldable)
import           Data.List           (foldl')
import qualified Data.List           as List
import           Data.Maybe          (isJust)
import           Data.Traversable
import           Data.Word           (Word)
import           Prelude             hiding (filter, foldl, foldr, lookup, map,
                                      null)

-- TODO (SM): get rid of bang patterns

{-
-- Use macros to define strictness of functions.
-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.
-- We do not use BangPatterns, because they are not in any standard and we
-- want the compilers to be compiled by as many compilers as possible.
#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined
-}


------------------------------------------------------------------------------
-- Types
------------------------------------------------------------------------------

-- A "Nat" is a natural machine word (an unsigned Int)
type Nat = Word

type Key = Int

-- | We store masks as the index of the bit that determines the branching.
type Mask = Int

-- | A priority search queue with @Int@ keys and priorities of type @p@ and
-- values of type @v@. It is strict in keys, priorities and values.
data IntPSQ p v
    = Bin {-# UNPACK #-} !Key !p !v {-# UNPACK #-} !Mask !(IntPSQ p v) !(IntPSQ p v)
    | Tip {-# UNPACK #-} !Key !p !v
    | Nil
    deriving (IntPSQ p a -> Bool
(a -> m) -> IntPSQ p a -> m
(a -> b -> b) -> b -> IntPSQ p a -> b
(forall m. Monoid m => IntPSQ p m -> m)
-> (forall m a. Monoid m => (a -> m) -> IntPSQ p a -> m)
-> (forall m a. Monoid m => (a -> m) -> IntPSQ p a -> m)
-> (forall a b. (a -> b -> b) -> b -> IntPSQ p a -> b)
-> (forall a b. (a -> b -> b) -> b -> IntPSQ p a -> b)
-> (forall b a. (b -> a -> b) -> b -> IntPSQ p a -> b)
-> (forall b a. (b -> a -> b) -> b -> IntPSQ p a -> b)
-> (forall a. (a -> a -> a) -> IntPSQ p a -> a)
-> (forall a. (a -> a -> a) -> IntPSQ p a -> a)
-> (forall a. IntPSQ p a -> [a])
-> (forall a. IntPSQ p a -> Bool)
-> (forall a. IntPSQ p a -> Int)
-> (forall a. Eq a => a -> IntPSQ p a -> Bool)
-> (forall a. Ord a => IntPSQ p a -> a)
-> (forall a. Ord a => IntPSQ p a -> a)
-> (forall a. Num a => IntPSQ p a -> a)
-> (forall a. Num a => IntPSQ p a -> a)
-> Foldable (IntPSQ p)
forall a. Eq a => a -> IntPSQ p a -> Bool
forall a. Num a => IntPSQ p a -> a
forall a. Ord a => IntPSQ p a -> a
forall m. Monoid m => IntPSQ p m -> m
forall a. IntPSQ p a -> Bool
forall a. IntPSQ p a -> Int
forall a. IntPSQ p a -> [a]
forall a. (a -> a -> a) -> IntPSQ p a -> a
forall p a. Eq a => a -> IntPSQ p a -> Bool
forall p a. Num a => IntPSQ p a -> a
forall p a. Ord a => IntPSQ p a -> a
forall m a. Monoid m => (a -> m) -> IntPSQ p a -> m
forall p m. Monoid m => IntPSQ p m -> m
forall p a. IntPSQ p a -> Bool
forall p a. IntPSQ p a -> Int
forall p a. IntPSQ p a -> [a]
forall b a. (b -> a -> b) -> b -> IntPSQ p a -> b
forall a b. (a -> b -> b) -> b -> IntPSQ p a -> b
forall p a. (a -> a -> a) -> IntPSQ p a -> a
forall p m a. Monoid m => (a -> m) -> IntPSQ p a -> m
forall p b a. (b -> a -> b) -> b -> IntPSQ p a -> b
forall p a b. (a -> b -> b) -> b -> IntPSQ p a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: IntPSQ p a -> a
$cproduct :: forall p a. Num a => IntPSQ p a -> a
sum :: IntPSQ p a -> a
$csum :: forall p a. Num a => IntPSQ p a -> a
minimum :: IntPSQ p a -> a
$cminimum :: forall p a. Ord a => IntPSQ p a -> a
maximum :: IntPSQ p a -> a
$cmaximum :: forall p a. Ord a => IntPSQ p a -> a
elem :: a -> IntPSQ p a -> Bool
$celem :: forall p a. Eq a => a -> IntPSQ p a -> Bool
length :: IntPSQ p a -> Int
$clength :: forall p a. IntPSQ p a -> Int
null :: IntPSQ p a -> Bool
$cnull :: forall p a. IntPSQ p a -> Bool
toList :: IntPSQ p a -> [a]
$ctoList :: forall p a. IntPSQ p a -> [a]
foldl1 :: (a -> a -> a) -> IntPSQ p a -> a
$cfoldl1 :: forall p a. (a -> a -> a) -> IntPSQ p a -> a
foldr1 :: (a -> a -> a) -> IntPSQ p a -> a
$cfoldr1 :: forall p a. (a -> a -> a) -> IntPSQ p a -> a
foldl' :: (b -> a -> b) -> b -> IntPSQ p a -> b
$cfoldl' :: forall p b a. (b -> a -> b) -> b -> IntPSQ p a -> b
foldl :: (b -> a -> b) -> b -> IntPSQ p a -> b
$cfoldl :: forall p b a. (b -> a -> b) -> b -> IntPSQ p a -> b
foldr' :: (a -> b -> b) -> b -> IntPSQ p a -> b
$cfoldr' :: forall p a b. (a -> b -> b) -> b -> IntPSQ p a -> b
foldr :: (a -> b -> b) -> b -> IntPSQ p a -> b
$cfoldr :: forall p a b. (a -> b -> b) -> b -> IntPSQ p a -> b
foldMap' :: (a -> m) -> IntPSQ p a -> m
$cfoldMap' :: forall p m a. Monoid m => (a -> m) -> IntPSQ p a -> m
foldMap :: (a -> m) -> IntPSQ p a -> m
$cfoldMap :: forall p m a. Monoid m => (a -> m) -> IntPSQ p a -> m
fold :: IntPSQ p m -> m
$cfold :: forall p m. Monoid m => IntPSQ p m -> m
Foldable, a -> IntPSQ p b -> IntPSQ p a
(a -> b) -> IntPSQ p a -> IntPSQ p b
(forall a b. (a -> b) -> IntPSQ p a -> IntPSQ p b)
-> (forall a b. a -> IntPSQ p b -> IntPSQ p a)
-> Functor (IntPSQ p)
forall a b. a -> IntPSQ p b -> IntPSQ p a
forall a b. (a -> b) -> IntPSQ p a -> IntPSQ p b
forall p a b. a -> IntPSQ p b -> IntPSQ p a
forall p a b. (a -> b) -> IntPSQ p a -> IntPSQ p b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IntPSQ p b -> IntPSQ p a
$c<$ :: forall p a b. a -> IntPSQ p b -> IntPSQ p a
fmap :: (a -> b) -> IntPSQ p a -> IntPSQ p b
$cfmap :: forall p a b. (a -> b) -> IntPSQ p a -> IntPSQ p b
Functor, Int -> IntPSQ p v -> ShowS
[IntPSQ p v] -> ShowS
IntPSQ p v -> String
(Int -> IntPSQ p v -> ShowS)
-> (IntPSQ p v -> String)
-> ([IntPSQ p v] -> ShowS)
-> Show (IntPSQ p v)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p v. (Show p, Show v) => Int -> IntPSQ p v -> ShowS
forall p v. (Show p, Show v) => [IntPSQ p v] -> ShowS
forall p v. (Show p, Show v) => IntPSQ p v -> String
showList :: [IntPSQ p v] -> ShowS
$cshowList :: forall p v. (Show p, Show v) => [IntPSQ p v] -> ShowS
show :: IntPSQ p v -> String
$cshow :: forall p v. (Show p, Show v) => IntPSQ p v -> String
showsPrec :: Int -> IntPSQ p v -> ShowS
$cshowsPrec :: forall p v. (Show p, Show v) => Int -> IntPSQ p v -> ShowS
Show, Functor (IntPSQ p)
Foldable (IntPSQ p)
Functor (IntPSQ p)
-> Foldable (IntPSQ p)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> IntPSQ p a -> f (IntPSQ p b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    IntPSQ p (f a) -> f (IntPSQ p a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> IntPSQ p a -> m (IntPSQ p b))
-> (forall (m :: * -> *) a.
    Monad m =>
    IntPSQ p (m a) -> m (IntPSQ p a))
-> Traversable (IntPSQ p)
(a -> f b) -> IntPSQ p a -> f (IntPSQ p b)
forall p. Functor (IntPSQ p)
forall p. Foldable (IntPSQ p)
forall p (m :: * -> *) a.
Monad m =>
IntPSQ p (m a) -> m (IntPSQ p a)
forall p (f :: * -> *) a.
Applicative f =>
IntPSQ p (f a) -> f (IntPSQ p a)
forall p (m :: * -> *) a b.
Monad m =>
(a -> m b) -> IntPSQ p a -> m (IntPSQ p b)
forall p (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntPSQ p a -> f (IntPSQ p b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => IntPSQ p (m a) -> m (IntPSQ p a)
forall (f :: * -> *) a.
Applicative f =>
IntPSQ p (f a) -> f (IntPSQ p a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> IntPSQ p a -> m (IntPSQ p b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntPSQ p a -> f (IntPSQ p b)
sequence :: IntPSQ p (m a) -> m (IntPSQ p a)
$csequence :: forall p (m :: * -> *) a.
Monad m =>
IntPSQ p (m a) -> m (IntPSQ p a)
mapM :: (a -> m b) -> IntPSQ p a -> m (IntPSQ p b)
$cmapM :: forall p (m :: * -> *) a b.
Monad m =>
(a -> m b) -> IntPSQ p a -> m (IntPSQ p b)
sequenceA :: IntPSQ p (f a) -> f (IntPSQ p a)
$csequenceA :: forall p (f :: * -> *) a.
Applicative f =>
IntPSQ p (f a) -> f (IntPSQ p a)
traverse :: (a -> f b) -> IntPSQ p a -> f (IntPSQ p b)
$ctraverse :: forall p (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntPSQ p a -> f (IntPSQ p b)
$cp2Traversable :: forall p. Foldable (IntPSQ p)
$cp1Traversable :: forall p. Functor (IntPSQ p)
Traversable)

instance (NFData p, NFData v) => NFData (IntPSQ p v) where
    rnf :: IntPSQ p v -> ()
rnf (Bin Int
_k p
p v
v Int
_m IntPSQ p v
l IntPSQ p v
r) = p -> ()
forall a. NFData a => a -> ()
rnf p
p () -> () -> ()
`seq` v -> ()
forall a. NFData a => a -> ()
rnf v
v () -> () -> ()
`seq` IntPSQ p v -> ()
forall a. NFData a => a -> ()
rnf IntPSQ p v
l () -> () -> ()
`seq` IntPSQ p v -> ()
forall a. NFData a => a -> ()
rnf IntPSQ p v
r
    rnf (Tip Int
_k p
p v
v)        = p -> ()
forall a. NFData a => a -> ()
rnf p
p () -> () -> ()
`seq` v -> ()
forall a. NFData a => a -> ()
rnf v
v
    rnf IntPSQ p v
Nil                 = ()

instance (Ord p, Eq v) => Eq (IntPSQ p v) where
    IntPSQ p v
x == :: IntPSQ p v -> IntPSQ p v -> Bool
== IntPSQ p v
y = case (IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
minView IntPSQ p v
x, IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
minView IntPSQ p v
y) of
        (Maybe (Int, p, v, IntPSQ p v)
Nothing              , Maybe (Int, p, v, IntPSQ p v)
Nothing                ) -> Bool
True
        (Just (Int
xk, p
xp, v
xv, IntPSQ p v
x'), (Just (Int
yk, p
yp, v
yv, IntPSQ p v
y'))) ->
            Int
xk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
yk Bool -> Bool -> Bool
&& p
xp p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
yp Bool -> Bool -> Bool
&& v
xv v -> v -> Bool
forall a. Eq a => a -> a -> Bool
== v
yv Bool -> Bool -> Bool
&& IntPSQ p v
x' IntPSQ p v -> IntPSQ p v -> Bool
forall a. Eq a => a -> a -> Bool
== IntPSQ p v
y'
        (Just (Int, p, v, IntPSQ p v)
_               , Maybe (Int, p, v, IntPSQ p v)
Nothing                ) -> Bool
False
        (Maybe (Int, p, v, IntPSQ p v)
Nothing              , Just (Int, p, v, IntPSQ p v)
_                 ) -> Bool
False


-- bit twiddling
----------------

{-# INLINE natFromInt #-}
natFromInt :: Key -> Nat
natFromInt :: Int -> Nat
natFromInt = Int -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral

{-# INLINE intFromNat #-}
intFromNat :: Nat -> Key
intFromNat :: Nat -> Int
intFromNat = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

{-# INLINE zero #-}
zero :: Key -> Mask -> Bool
zero :: Int -> Int -> Bool
zero Int
i Int
m
  = (Int -> Nat
natFromInt Int
i) Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.&. (Int -> Nat
natFromInt Int
m) Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0

{-# INLINE nomatch #-}
nomatch :: Key -> Key -> Mask -> Bool
nomatch :: Int -> Int -> Int -> Bool
nomatch Int
k1 Int
k2 Int
m =
    Int -> Nat
natFromInt Int
k1 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.&. Nat
m' Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Nat
natFromInt Int
k2 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.&. Nat
m'
  where
    m' :: Nat
m' = Nat -> Nat
maskW (Int -> Nat
natFromInt Int
m)

{-# INLINE maskW #-}
maskW :: Nat -> Nat
maskW :: Nat -> Nat
maskW Nat
m = Nat -> Nat
forall a. Bits a => a -> a
complement (Nat
mNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1) Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
`xor` Nat
m

{-# INLINE branchMask #-}
branchMask :: Key -> Key -> Mask
branchMask :: Int -> Int -> Int
branchMask Int
k1 Int
k2 =
    Nat -> Int
intFromNat (Nat -> Nat
highestBitMask (Int -> Nat
natFromInt Int
k1 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
`xor` Int -> Nat
natFromInt Int
k2))


------------------------------------------------------------------------------
-- Query
------------------------------------------------------------------------------

-- | /O(1)/ True if the queue is empty.
null :: IntPSQ p v -> Bool
null :: IntPSQ p v -> Bool
null IntPSQ p v
Nil = Bool
True
null IntPSQ p v
_   = Bool
False

-- | /O(n)/ The number of elements stored in the queue.
size :: IntPSQ p v -> Int
size :: IntPSQ p v -> Int
size IntPSQ p v
Nil               = Int
0
size (Tip Int
_ p
_ v
_)       = Int
1
size (Bin Int
_ p
_ v
_ Int
_ IntPSQ p v
l IntPSQ p v
r) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ IntPSQ p v -> Int
forall p a. IntPSQ p a -> Int
size IntPSQ p v
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ IntPSQ p v -> Int
forall p a. IntPSQ p a -> Int
size IntPSQ p v
r
-- TODO (SM): benchmark this against a tail-recursive variant

-- | /O(min(n,W))/ Check if a key is present in the the queue.
member :: Int -> IntPSQ p v -> Bool
member :: Int -> IntPSQ p v -> Bool
member Int
k = Maybe (p, v) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (p, v) -> Bool)
-> (IntPSQ p v -> Maybe (p, v)) -> IntPSQ p v -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntPSQ p v -> Maybe (p, v)
forall p v. Int -> IntPSQ p v -> Maybe (p, v)
lookup Int
k

-- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the
-- key is not bound.
lookup :: Int -> IntPSQ p v -> Maybe (p, v)
lookup :: Int -> IntPSQ p v -> Maybe (p, v)
lookup Int
k = IntPSQ p v -> Maybe (p, v)
forall a b. IntPSQ a b -> Maybe (a, b)
go
  where
    go :: IntPSQ a b -> Maybe (a, b)
go IntPSQ a b
t = case IntPSQ a b
t of
        IntPSQ a b
Nil                -> Maybe (a, b)
forall a. Maybe a
Nothing

        Tip Int
k' a
p' b
x'
          | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'        -> (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
p', b
x')
          | Bool
otherwise      -> Maybe (a, b)
forall a. Maybe a
Nothing

        Bin Int
k' a
p' b
x' Int
m IntPSQ a b
l IntPSQ a b
r
          | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m -> Maybe (a, b)
forall a. Maybe a
Nothing
          | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'        -> (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
p', b
x')
          | Int -> Int -> Bool
zero Int
k Int
m       -> IntPSQ a b -> Maybe (a, b)
go IntPSQ a b
l
          | Bool
otherwise      -> IntPSQ a b -> Maybe (a, b)
go IntPSQ a b
r

-- | /O(1)/ The element with the lowest priority.
findMin :: Ord p => IntPSQ p v -> Maybe (Int, p, v)
findMin :: IntPSQ p v -> Maybe (Int, p, v)
findMin IntPSQ p v
t = case IntPSQ p v
t of
    IntPSQ p v
Nil             -> Maybe (Int, p, v)
forall a. Maybe a
Nothing
    Tip Int
k p
p v
x       -> (Int, p, v) -> Maybe (Int, p, v)
forall a. a -> Maybe a
Just (Int
k, p
p, v
x)
    Bin Int
k p
p v
x Int
_ IntPSQ p v
_ IntPSQ p v
_ -> (Int, p, v) -> Maybe (Int, p, v)
forall a. a -> Maybe a
Just (Int
k, p
p, v
x)


------------------------------------------------------------------------------
--- Construction
------------------------------------------------------------------------------

-- | /O(1)/ The empty queue.
empty :: IntPSQ p v
empty :: IntPSQ p v
empty = IntPSQ p v
forall p v. IntPSQ p v
Nil

-- | /O(1)/ Build a queue with one element.
singleton :: Ord p => Int -> p -> v -> IntPSQ p v
singleton :: Int -> p -> v -> IntPSQ p v
singleton = Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip


------------------------------------------------------------------------------
-- Insertion
------------------------------------------------------------------------------

-- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key
-- is already present in the queue, the associated priority and value are
-- replaced with the supplied priority and value.
insert :: Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
insert :: Int -> p -> v -> IntPSQ p v -> IntPSQ p v
insert Int
k p
p v
x IntPSQ p v
t0 = Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
p v
x (Int -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v
delete Int
k IntPSQ p v
t0)

-- | Internal function to insert a key that is *not* present in the priority
-- queue.
{-# INLINABLE unsafeInsertNew #-}
unsafeInsertNew :: Ord p => Key -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew :: Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
p v
x = IntPSQ p v -> IntPSQ p v
go
  where
    go :: IntPSQ p v -> IntPSQ p v
go IntPSQ p v
t = case IntPSQ p v
t of
      IntPSQ p v
Nil       -> Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x

      Tip Int
k' p
p' v
x'
        | (p
p, Int
k) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
p', Int
k') -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k  p
p  v
x  Int
k' IntPSQ p v
t           IntPSQ p v
forall p v. IntPSQ p v
Nil
        | Bool
otherwise         -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k' p
p' v
x' Int
k  (Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x) IntPSQ p v
forall p v. IntPSQ p v
Nil

      Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r
        | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m ->
            if (p
p, Int
k) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
p', Int
k')
              then Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k  p
p  v
x  Int
k' IntPSQ p v
t           IntPSQ p v
forall p v. IntPSQ p v
Nil
              else Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k' p
p' v
x' Int
k  (Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x) (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r)

        | Bool
otherwise ->
            if (p
p, Int
k) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
p', Int
k')
              then
                if Int -> Int -> Bool
zero Int
k' Int
m
                  then Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k  p
p  v
x  Int
m (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k' p
p' v
x' IntPSQ p v
l) IntPSQ p v
r
                  else Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k  p
p  v
x  Int
m IntPSQ p v
l (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k' p
p' v
x' IntPSQ p v
r)
              else
                if Int -> Int -> Bool
zero Int
k Int
m
                  then Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k  p
p  v
x  IntPSQ p v
l) IntPSQ p v
r
                  else Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k  p
p  v
x  IntPSQ p v
r)

-- | Link
link :: Key -> p -> v -> Key -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link :: Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k p
p v
x Int
k' IntPSQ p v
k't IntPSQ p v
otherTree
  | Int -> Int -> Bool
zero Int
m Int
k' = Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p v
x Int
m IntPSQ p v
k't       IntPSQ p v
otherTree
  | Bool
otherwise = Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p v
x Int
m IntPSQ p v
otherTree IntPSQ p v
k't
  where
    m :: Int
m = Int -> Int -> Int
branchMask Int
k Int
k'


------------------------------------------------------------------------------
-- Delete/Alter
------------------------------------------------------------------------------

-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When
-- the key is not a member of the queue, the original queue is returned.
{-# INLINABLE delete #-}
delete :: Ord p => Int -> IntPSQ p v -> IntPSQ p v
delete :: Int -> IntPSQ p v -> IntPSQ p v
delete Int
k = IntPSQ p v -> IntPSQ p v
forall p v. Ord p => IntPSQ p v -> IntPSQ p v
go
  where
    go :: IntPSQ p v -> IntPSQ p v
go IntPSQ p v
t = case IntPSQ p v
t of
        IntPSQ p v
Nil           -> IntPSQ p v
forall p v. IntPSQ p v
Nil

        Tip Int
k' p
_ v
_
          | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'   -> IntPSQ p v
forall p v. IntPSQ p v
Nil
          | Bool
otherwise -> IntPSQ p v
t

        Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r
          | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m -> IntPSQ p v
t
          | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'        -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r
          | Int -> Int -> Bool
zero Int
k Int
m       -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkL Int
k' p
p' v
x' Int
m (IntPSQ p v -> IntPSQ p v
go IntPSQ p v
l) IntPSQ p v
r
          | Bool
otherwise      -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkR Int
k' p
p' v
x' Int
m IntPSQ p v
l      (IntPSQ p v -> IntPSQ p v
go IntPSQ p v
r)

-- | /O(min(n,W))/ Delete the binding with the least priority, and return the
-- rest of the queue stripped of that binding. In case the queue is empty, the
-- empty queue is returned again.
{-# INLINE deleteMin #-}
deleteMin :: Ord p => IntPSQ p v -> IntPSQ p v
deleteMin :: IntPSQ p v -> IntPSQ p v
deleteMin IntPSQ p v
t = case IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
minView IntPSQ p v
t of
    Maybe (Int, p, v, IntPSQ p v)
Nothing            -> IntPSQ p v
t
    Just (Int
_, p
_, v
_, IntPSQ p v
t') -> IntPSQ p v
t'

-- | /O(min(n,W))/ The expression @alter f k queue@ alters the value @x@ at @k@,
-- or absence thereof. 'alter' can be used to insert, delete, or update a value
-- in a queue. It also allows you to calculate an additional value @b@.
{-# INLINE alter #-}
alter
    :: Ord p
    => (Maybe (p, v) -> (b, Maybe (p, v)))
    -> Int
    -> IntPSQ p v
    -> (b, IntPSQ p v)
alter :: (Maybe (p, v) -> (b, Maybe (p, v)))
-> Int -> IntPSQ p v -> (b, IntPSQ p v)
alter Maybe (p, v) -> (b, Maybe (p, v))
f = \Int
k IntPSQ p v
t0 ->
    let (IntPSQ p v
t, Maybe (p, v)
mbX) = case Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)
forall p v. Ord p => Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)
deleteView Int
k IntPSQ p v
t0 of
                            Maybe (p, v, IntPSQ p v)
Nothing          -> (IntPSQ p v
t0, Maybe (p, v)
forall a. Maybe a
Nothing)
                            Just (p
p, v
v, IntPSQ p v
t0') -> (IntPSQ p v
t0', (p, v) -> Maybe (p, v)
forall a. a -> Maybe a
Just (p
p, v
v))
    in case Maybe (p, v) -> (b, Maybe (p, v))
f Maybe (p, v)
mbX of
          (b
b, Maybe (p, v)
mbX') ->
            (b
b, IntPSQ p v -> ((p, v) -> IntPSQ p v) -> Maybe (p, v) -> IntPSQ p v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IntPSQ p v
t (\(p
p, v
v) -> Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
p v
v IntPSQ p v
t) Maybe (p, v)
mbX')

-- | /O(min(n,W))/ A variant of 'alter' which works on the element with the
-- minimum priority. Unlike 'alter', this variant also allows you to change the
-- key of the element.
{-# INLINE alterMin #-}
alterMin :: Ord p
         => (Maybe (Int, p, v) -> (b, Maybe (Int, p, v)))
         -> IntPSQ p v
         -> (b, IntPSQ p v)
alterMin :: (Maybe (Int, p, v) -> (b, Maybe (Int, p, v)))
-> IntPSQ p v -> (b, IntPSQ p v)
alterMin Maybe (Int, p, v) -> (b, Maybe (Int, p, v))
f IntPSQ p v
t = case IntPSQ p v
t of
    IntPSQ p v
Nil             -> case Maybe (Int, p, v) -> (b, Maybe (Int, p, v))
f Maybe (Int, p, v)
forall a. Maybe a
Nothing of
                         (b
b, Maybe (Int, p, v)
Nothing)           -> (b
b, IntPSQ p v
forall p v. IntPSQ p v
Nil)
                         (b
b, Just (Int
k', p
p', v
x')) -> (b
b, Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k' p
p' v
x')

    Tip Int
k p
p v
x       -> case Maybe (Int, p, v) -> (b, Maybe (Int, p, v))
f ((Int, p, v) -> Maybe (Int, p, v)
forall a. a -> Maybe a
Just (Int
k, p
p, v
x)) of
                         (b
b, Maybe (Int, p, v)
Nothing)           -> (b
b, IntPSQ p v
forall p v. IntPSQ p v
Nil)
                         (b
b, Just (Int
k', p
p', v
x')) -> (b
b, Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k' p
p' v
x')

    Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r -> case Maybe (Int, p, v) -> (b, Maybe (Int, p, v))
f ((Int, p, v) -> Maybe (Int, p, v)
forall a. a -> Maybe a
Just (Int
k, p
p, v
x)) of
                         (b
b, Maybe (Int, p, v)
Nothing)           -> (b
b, Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r)
                         (b
b, Just (Int
k', p
p', v
x'))
                           | Int
k  Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
k'  -> (b
b, Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
insert Int
k' p
p' v
x' (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r))
                           | p
p' p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
p   -> (b
b, Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r)
                           | Bool
otherwise -> (b
b, Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
p' v
x' (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r))

-- | Smart constructor for a 'Bin' node whose left subtree could have become
-- 'Nil'.
{-# INLINE binShrinkL #-}
binShrinkL :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkL :: Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkL Int
k p
p v
x Int
m IntPSQ p v
Nil IntPSQ p v
r = case IntPSQ p v
r of IntPSQ p v
Nil -> Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x; IntPSQ p v
_ -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p v
x Int
m IntPSQ p v
forall p v. IntPSQ p v
Nil IntPSQ p v
r
binShrinkL Int
k p
p v
x Int
m IntPSQ p v
l   IntPSQ p v
r = Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r

-- | Smart constructor for a 'Bin' node whose right subtree could have become
-- 'Nil'.
{-# INLINE binShrinkR #-}
binShrinkR :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkR :: Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkR Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
Nil = case IntPSQ p v
l of IntPSQ p v
Nil -> Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x; IntPSQ p v
_ -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
forall p v. IntPSQ p v
Nil
binShrinkR Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r   = Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r


------------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------------

-- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples.
-- If the list contains more than one priority and value for the same key, the
-- last priority and value for the key is retained.
{-# INLINABLE fromList #-}
fromList :: Ord p => [(Int, p, v)] -> IntPSQ p v
fromList :: [(Int, p, v)] -> IntPSQ p v
fromList = (IntPSQ p v -> (Int, p, v) -> IntPSQ p v)
-> IntPSQ p v -> [(Int, p, v)] -> IntPSQ p v
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\IntPSQ p v
im (Int
k, p
p, v
x) -> Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
insert Int
k p
p v
x IntPSQ p v
im) IntPSQ p v
forall p v. IntPSQ p v
empty

-- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The
-- order of the list is not specified.
toList :: IntPSQ p v -> [(Int, p, v)]
toList :: IntPSQ p v -> [(Int, p, v)]
toList =
    [(Int, p, v)] -> IntPSQ p v -> [(Int, p, v)]
forall b c. [(Int, b, c)] -> IntPSQ b c -> [(Int, b, c)]
go []
  where
    go :: [(Int, b, c)] -> IntPSQ b c -> [(Int, b, c)]
go [(Int, b, c)]
acc IntPSQ b c
Nil                   = [(Int, b, c)]
acc
    go [(Int, b, c)]
acc (Tip Int
k' b
p' c
x')        = (Int
k', b
p', c
x') (Int, b, c) -> [(Int, b, c)] -> [(Int, b, c)]
forall a. a -> [a] -> [a]
: [(Int, b, c)]
acc
    go [(Int, b, c)]
acc (Bin Int
k' b
p' c
x' Int
_m IntPSQ b c
l IntPSQ b c
r) = (Int
k', b
p', c
x') (Int, b, c) -> [(Int, b, c)] -> [(Int, b, c)]
forall a. a -> [a] -> [a]
: [(Int, b, c)] -> IntPSQ b c -> [(Int, b, c)]
go ([(Int, b, c)] -> IntPSQ b c -> [(Int, b, c)]
go [(Int, b, c)]
acc IntPSQ b c
r) IntPSQ b c
l

-- | /O(n)/ Obtain the list of present keys in the queue.
keys :: IntPSQ p v -> [Int]
keys :: IntPSQ p v -> [Int]
keys IntPSQ p v
t = [Int
k | (Int
k, p
_, v
_) <- IntPSQ p v -> [(Int, p, v)]
forall p v. IntPSQ p v -> [(Int, p, v)]
toList IntPSQ p v
t]
-- TODO (jaspervdj): More efficient implementations possible


------------------------------------------------------------------------------
-- Views
------------------------------------------------------------------------------

-- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key
-- is already present in the queue, then the evicted priority and value can be
-- found the first element of the returned tuple.
insertView :: Ord p => Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
insertView :: Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
insertView Int
k p
p v
x IntPSQ p v
t0 = case Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)
forall p v. Ord p => Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)
deleteView Int
k IntPSQ p v
t0 of
    Maybe (p, v, IntPSQ p v)
Nothing          -> (Maybe (p, v)
forall a. Maybe a
Nothing,       Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
p v
x IntPSQ p v
t0)
    Just (p
p', v
v', IntPSQ p v
t) -> ((p, v) -> Maybe (p, v)
forall a. a -> Maybe a
Just (p
p', v
v'), Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
p v
x IntPSQ p v
t)

-- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If
-- the key was present, the associated priority and value are returned in
-- addition to the updated queue.
{-# INLINABLE deleteView #-}
deleteView :: Ord p => Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)
deleteView :: Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v)
deleteView Int
k IntPSQ p v
t0 =
    case IntPSQ p v -> (# IntPSQ p v, Maybe (p, v) #)
forall a b. Ord a => IntPSQ a b -> (# IntPSQ a b, Maybe (a, b) #)
delFrom IntPSQ p v
t0 of
      (# IntPSQ p v
_, Maybe (p, v)
Nothing     #) -> Maybe (p, v, IntPSQ p v)
forall a. Maybe a
Nothing
      (# IntPSQ p v
t, Just (p
p, v
x) #) -> (p, v, IntPSQ p v) -> Maybe (p, v, IntPSQ p v)
forall a. a -> Maybe a
Just (p
p, v
x, IntPSQ p v
t)
  where
    delFrom :: IntPSQ a b -> (# IntPSQ a b, Maybe (a, b) #)
delFrom IntPSQ a b
t = case IntPSQ a b
t of
      IntPSQ a b
Nil -> (# IntPSQ a b
forall p v. IntPSQ p v
Nil, Maybe (a, b)
forall a. Maybe a
Nothing #)

      Tip Int
k' a
p' b
x'
        | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'   -> (# IntPSQ a b
forall p v. IntPSQ p v
Nil, (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
p', b
x') #)
        | Bool
otherwise -> (# IntPSQ a b
t,   Maybe (a, b)
forall a. Maybe a
Nothing       #)

      Bin Int
k' a
p' b
x' Int
m IntPSQ a b
l IntPSQ a b
r
        | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m -> (# IntPSQ a b
t, Maybe (a, b)
forall a. Maybe a
Nothing #)
        | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'   -> let t' :: IntPSQ a b
t' = Int -> IntPSQ a b -> IntPSQ a b -> IntPSQ a b
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ a b
l IntPSQ a b
r
                       in  IntPSQ a b
t' IntPSQ a b
-> (# IntPSQ a b, Maybe (a, b) #) -> (# IntPSQ a b, Maybe (a, b) #)
`seq` (# IntPSQ a b
t', (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
p', b
x') #)

        | Int -> Int -> Bool
zero Int
k Int
m  -> case IntPSQ a b -> (# IntPSQ a b, Maybe (a, b) #)
delFrom IntPSQ a b
l of
                         (# IntPSQ a b
l', Maybe (a, b)
mbPX #) -> let t' :: IntPSQ a b
t' = Int -> a -> b -> Int -> IntPSQ a b -> IntPSQ a b -> IntPSQ a b
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkL Int
k' a
p' b
x' Int
m IntPSQ a b
l' IntPSQ a b
r
                                           in  IntPSQ a b
t' IntPSQ a b
-> (# IntPSQ a b, Maybe (a, b) #) -> (# IntPSQ a b, Maybe (a, b) #)
`seq` (# IntPSQ a b
t', Maybe (a, b)
mbPX #)

        | Bool
otherwise -> case IntPSQ a b -> (# IntPSQ a b, Maybe (a, b) #)
delFrom IntPSQ a b
r of
                         (# IntPSQ a b
r', Maybe (a, b)
mbPX #) -> let t' :: IntPSQ a b
t' = Int -> a -> b -> Int -> IntPSQ a b -> IntPSQ a b -> IntPSQ a b
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
binShrinkR Int
k' a
p' b
x' Int
m IntPSQ a b
l  IntPSQ a b
r'
                                           in  IntPSQ a b
t' IntPSQ a b
-> (# IntPSQ a b, Maybe (a, b) #) -> (# IntPSQ a b, Maybe (a, b) #)
`seq` (# IntPSQ a b
t', Maybe (a, b)
mbPX #)

-- | /O(min(n,W))/ Retrieve the binding with the least priority, and the
-- rest of the queue stripped of that binding.
{-# INLINE minView #-}
minView :: Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
minView :: IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
minView IntPSQ p v
t = case IntPSQ p v
t of
    IntPSQ p v
Nil             -> Maybe (Int, p, v, IntPSQ p v)
forall a. Maybe a
Nothing
    Tip Int
k p
p v
x       -> (Int, p, v, IntPSQ p v) -> Maybe (Int, p, v, IntPSQ p v)
forall a. a -> Maybe a
Just (Int
k, p
p, v
x, IntPSQ p v
forall p v. IntPSQ p v
Nil)
    Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r -> (Int, p, v, IntPSQ p v) -> Maybe (Int, p, v, IntPSQ p v)
forall a. a -> Maybe a
Just (Int
k, p
p, v
x, Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r)

-- | Return a list of elements ordered by key whose priorities are at most @pt@,
-- and the rest of the queue stripped of these elements.  The returned list of
-- elements can be in any order: no guarantees there.
{-# INLINABLE atMostView #-}
atMostView :: Ord p => p -> IntPSQ p v -> ([(Int, p, v)], IntPSQ p v)
atMostView :: p -> IntPSQ p v -> ([(Int, p, v)], IntPSQ p v)
atMostView p
pt IntPSQ p v
t0 = [(Int, p, v)] -> IntPSQ p v -> ([(Int, p, v)], IntPSQ p v)
forall c.
[(Int, p, c)] -> IntPSQ p c -> ([(Int, p, c)], IntPSQ p c)
go [] IntPSQ p v
t0
  where
    go :: [(Int, p, c)] -> IntPSQ p c -> ([(Int, p, c)], IntPSQ p c)
go [(Int, p, c)]
acc IntPSQ p c
t = case IntPSQ p c
t of
        IntPSQ p c
Nil             -> ([(Int, p, c)]
acc, IntPSQ p c
t)
        Tip Int
k p
p c
x
            | p
p p -> p -> Bool
forall a. Ord a => a -> a -> Bool
> p
pt    -> ([(Int, p, c)]
acc, IntPSQ p c
t)
            | Bool
otherwise -> ((Int
k, p
p, c
x) (Int, p, c) -> [(Int, p, c)] -> [(Int, p, c)]
forall a. a -> [a] -> [a]
: [(Int, p, c)]
acc, IntPSQ p c
forall p v. IntPSQ p v
Nil)

        Bin Int
k p
p c
x Int
m IntPSQ p c
l IntPSQ p c
r
            | p
p p -> p -> Bool
forall a. Ord a => a -> a -> Bool
> p
pt    -> ([(Int, p, c)]
acc, IntPSQ p c
t)
            | Bool
otherwise ->
                let ([(Int, p, c)]
acc',  IntPSQ p c
l') = [(Int, p, c)] -> IntPSQ p c -> ([(Int, p, c)], IntPSQ p c)
go [(Int, p, c)]
acc  IntPSQ p c
l
                    ([(Int, p, c)]
acc'', IntPSQ p c
r') = [(Int, p, c)] -> IntPSQ p c -> ([(Int, p, c)], IntPSQ p c)
go [(Int, p, c)]
acc' IntPSQ p c
r
                in  ((Int
k, p
p, c
x) (Int, p, c) -> [(Int, p, c)] -> [(Int, p, c)]
forall a. a -> [a] -> [a]
: [(Int, p, c)]
acc'', Int -> IntPSQ p c -> IntPSQ p c -> IntPSQ p c
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p c
l' IntPSQ p c
r')


------------------------------------------------------------------------------
-- Traversal
------------------------------------------------------------------------------

-- | /O(n)/ Modify every value in the queue.
{-# INLINABLE map #-}
map :: (Int -> p -> v -> w) -> IntPSQ p v -> IntPSQ p w
map :: (Int -> p -> v -> w) -> IntPSQ p v -> IntPSQ p w
map Int -> p -> v -> w
f =
    IntPSQ p v -> IntPSQ p w
go
  where
    go :: IntPSQ p v -> IntPSQ p w
go IntPSQ p v
t = case IntPSQ p v
t of
        IntPSQ p v
Nil             -> IntPSQ p w
forall p v. IntPSQ p v
Nil
        Tip Int
k p
p v
x       -> Int -> p -> w -> IntPSQ p w
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p (Int -> p -> v -> w
f Int
k p
p v
x)
        Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r -> Int -> p -> w -> Int -> IntPSQ p w -> IntPSQ p w -> IntPSQ p w
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k p
p (Int -> p -> v -> w
f Int
k p
p v
x) Int
m (IntPSQ p v -> IntPSQ p w
go IntPSQ p v
l) (IntPSQ p v -> IntPSQ p w
go IntPSQ p v
r)

-- | /O(n)/ Maps a function over the values and priorities of the queue.
-- The function @f@ must be monotonic with respect to the priorities. I.e. if
-- @x < y@, then @fst (f k x v) < fst (f k y v)@.
-- /The precondition is not checked./ If @f@ is not monotonic, then the result
-- will be invalid.
{-# INLINABLE unsafeMapMonotonic #-}
unsafeMapMonotonic :: (Key -> p -> v -> (q, w)) -> IntPSQ p v -> IntPSQ q w
unsafeMapMonotonic :: (Int -> p -> v -> (q, w)) -> IntPSQ p v -> IntPSQ q w
unsafeMapMonotonic Int -> p -> v -> (q, w)
f = IntPSQ p v -> IntPSQ q w
go
  where
    go :: IntPSQ p v -> IntPSQ q w
go IntPSQ p v
t = case IntPSQ p v
t of
        IntPSQ p v
Nil             -> IntPSQ q w
forall p v. IntPSQ p v
Nil
        Tip Int
k p
p v
x       -> let (q
p', w
x') = Int -> p -> v -> (q, w)
f Int
k p
p v
x
                           in  Int -> q -> w -> IntPSQ q w
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k q
p' w
x'

        Bin Int
k p
p v
x Int
m IntPSQ p v
l IntPSQ p v
r -> let (q
p', w
x') = Int -> p -> v -> (q, w)
f Int
k p
p v
x
                           in  Int -> q -> w -> Int -> IntPSQ q w -> IntPSQ q w -> IntPSQ q w
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k q
p' w
x' Int
m (IntPSQ p v -> IntPSQ q w
go IntPSQ p v
l) (IntPSQ p v -> IntPSQ q w
go IntPSQ p v
r)

-- | /O(n)/ Strict fold over every key, priority and value in the queue. The order
-- in which the fold is performed is not specified.
{-# INLINABLE fold' #-}
fold' :: (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a
fold' :: (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a
fold' Int -> p -> v -> a -> a
f = a -> IntPSQ p v -> a
go
  where
    go :: a -> IntPSQ p v -> a
go !a
acc IntPSQ p v
Nil                   = a
acc
    go !a
acc (Tip Int
k' p
p' v
x')        = Int -> p -> v -> a -> a
f Int
k' p
p' v
x' a
acc
    go !a
acc (Bin Int
k' p
p' v
x' Int
_m IntPSQ p v
l IntPSQ p v
r) =
        let !acc1 :: a
acc1 = Int -> p -> v -> a -> a
f Int
k' p
p' v
x' a
acc
            !acc2 :: a
acc2 = a -> IntPSQ p v -> a
go a
acc1 IntPSQ p v
l
            !acc3 :: a
acc3 = a -> IntPSQ p v -> a
go a
acc2 IntPSQ p v
r
        in a
acc3


-- | Internal function that merges two *disjoint* 'IntPSQ's that share the
-- same prefix mask.
{-# INLINABLE merge #-}
merge :: Ord p => Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge :: Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r = case IntPSQ p v
l of
    IntPSQ p v
Nil -> IntPSQ p v
r

    Tip Int
lk p
lp v
lx ->
      case IntPSQ p v
r of
        IntPSQ p v
Nil                     -> IntPSQ p v
l
        Tip Int
rk p
rp v
rx
          | (p
lp, Int
lk) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
rp, Int
rk) -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
lk p
lp v
lx Int
m IntPSQ p v
forall p v. IntPSQ p v
Nil IntPSQ p v
r
          | Bool
otherwise           -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
rk p
rp v
rx Int
m IntPSQ p v
l   IntPSQ p v
forall p v. IntPSQ p v
Nil
        Bin Int
rk p
rp v
rx Int
rm IntPSQ p v
rl IntPSQ p v
rr
          | (p
lp, Int
lk) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
rp, Int
rk) -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
lk p
lp v
lx Int
m IntPSQ p v
forall p v. IntPSQ p v
Nil IntPSQ p v
r
          | Bool
otherwise           -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
rk p
rp v
rx Int
m IntPSQ p v
l   (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
rm IntPSQ p v
rl IntPSQ p v
rr)

    Bin Int
lk p
lp v
lx Int
lm IntPSQ p v
ll IntPSQ p v
lr ->
      case IntPSQ p v
r of
        IntPSQ p v
Nil                     -> IntPSQ p v
l
        Tip Int
rk p
rp v
rx
          | (p
lp, Int
lk) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
rp, Int
rk) -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
lk p
lp v
lx Int
m (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
lm IntPSQ p v
ll IntPSQ p v
lr) IntPSQ p v
r
          | Bool
otherwise           -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
rk p
rp v
rx Int
m IntPSQ p v
l                IntPSQ p v
forall p v. IntPSQ p v
Nil
        Bin Int
rk p
rp v
rx Int
rm IntPSQ p v
rl IntPSQ p v
rr
          | (p
lp, Int
lk) (p, Int) -> (p, Int) -> Bool
forall a. Ord a => a -> a -> Bool
< (p
rp, Int
rk) -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
lk p
lp v
lx Int
m (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
lm IntPSQ p v
ll IntPSQ p v
lr) IntPSQ p v
r
          | Bool
otherwise           -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
rk p
rp v
rx Int
m IntPSQ p v
l                (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
rm IntPSQ p v
rl IntPSQ p v
rr)


------------------------------------------------------------------------------
-- Improved insert performance for special cases
------------------------------------------------------------------------------

-- | Internal function to insert a key with priority larger than the
-- maximal priority in the heap. This is always the case when using the PSQ
-- as the basis to implement a LRU cache, which associates a
-- access-tick-number with every element.
{-# INLINE unsafeInsertIncreasePriority #-}
unsafeInsertIncreasePriority
    :: Ord p => Key -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertIncreasePriority :: Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertIncreasePriority =
    (p -> v -> p -> v -> (p, v))
-> Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v.
Ord p =>
(p -> v -> p -> v -> (p, v))
-> Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertWithIncreasePriority (\p
newP v
newX p
_ v
_ -> (p
newP, v
newX))

{-# INLINE unsafeInsertIncreasePriorityView #-}
unsafeInsertIncreasePriorityView
    :: Ord p => Key -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
unsafeInsertIncreasePriorityView :: Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
unsafeInsertIncreasePriorityView =
    (p -> v -> p -> v -> (p, v))
-> Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
forall p v.
Ord p =>
(p -> v -> p -> v -> (p, v))
-> Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
unsafeInsertWithIncreasePriorityView (\p
newP v
newX p
_ v
_ -> (p
newP, v
newX))

-- | This name is not chosen well anymore. This function:
--
-- - Either inserts a value at a new key with a prio higher than the max of the
--   entire PSQ.
-- - Or, overrides the value at the key with a prio strictly higher than the
--   original prio at that key (but not necessarily the max of the entire PSQ).
{-# INLINABLE unsafeInsertWithIncreasePriority #-}
unsafeInsertWithIncreasePriority
    :: Ord p
    => (p -> v -> p -> v -> (p, v))
    -> Key -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertWithIncreasePriority :: (p -> v -> p -> v -> (p, v))
-> Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertWithIncreasePriority p -> v -> p -> v -> (p, v)
f Int
k p
p v
x IntPSQ p v
t0 =
    -- TODO (jaspervdj): Maybe help inliner a bit here, check core.
    IntPSQ p v -> IntPSQ p v
go IntPSQ p v
t0
  where
    go :: IntPSQ p v -> IntPSQ p v
go IntPSQ p v
t = case IntPSQ p v
t of
        IntPSQ p v
Nil -> Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x

        Tip Int
k' p
p' v
x'
            | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'   -> case p -> v -> p -> v -> (p, v)
f p
p v
x p
p' v
x' of (!p
fp, !v
fx) -> Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
fp v
fx
            | Bool
otherwise -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k' p
p' v
x' Int
k  (Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x) IntPSQ p v
forall p v. IntPSQ p v
Nil

        Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r
            | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k' p
p' v
x' Int
k (Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x) (Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r)
            | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'        -> case p -> v -> p -> v -> (p, v)
f p
p v
x p
p' v
x' of
                (!p
fp, !v
fx)
                    | Int -> Int -> Bool
zero Int
k Int
m  -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
fp v
fx IntPSQ p v
l) IntPSQ p v
r
                    | Bool
otherwise -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
fp v
fx IntPSQ p v
r)
            | Int -> Int -> Bool
zero Int
k Int
m       -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m (IntPSQ p v -> IntPSQ p v
go IntPSQ p v
l) IntPSQ p v
r
            | Bool
otherwise      -> Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l      (IntPSQ p v -> IntPSQ p v
go IntPSQ p v
r)

{-# INLINABLE unsafeInsertWithIncreasePriorityView #-}
unsafeInsertWithIncreasePriorityView
    :: Ord p
    => (p -> v -> p -> v -> (p, v))
    -> Key -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
unsafeInsertWithIncreasePriorityView :: (p -> v -> p -> v -> (p, v))
-> Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v)
unsafeInsertWithIncreasePriorityView p -> v -> p -> v -> (p, v)
f Int
k p
p v
x IntPSQ p v
t0 =
    -- TODO (jaspervdj): Maybe help inliner a bit here, check core.
    case IntPSQ p v -> (# IntPSQ p v, Maybe (p, v) #)
go IntPSQ p v
t0 of
        (# IntPSQ p v
t, Maybe (p, v)
mbPX #) -> (Maybe (p, v)
mbPX, IntPSQ p v
t)
  where
    go :: IntPSQ p v -> (# IntPSQ p v, Maybe (p, v) #)
go IntPSQ p v
t = case IntPSQ p v
t of
        IntPSQ p v
Nil -> (# Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x, Maybe (p, v)
forall a. Maybe a
Nothing #)

        Tip Int
k' p
p' v
x'
            | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'   -> case p -> v -> p -> v -> (p, v)
f p
p v
x p
p' v
x' of
                (!p
fp, !v
fx) -> (# Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
fp v
fx, (p, v) -> Maybe (p, v)
forall a. a -> Maybe a
Just (p
p', v
x') #)
            | Bool
otherwise -> (# Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k' p
p' v
x' Int
k  (Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x) IntPSQ p v
forall p v. IntPSQ p v
Nil, Maybe (p, v)
forall a. Maybe a
Nothing #)

        Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r
            | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m ->
                let t' :: IntPSQ p v
t' = Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l IntPSQ p v
r
                in IntPSQ p v
t' IntPSQ p v
-> (# IntPSQ p v, Maybe (p, v) #) -> (# IntPSQ p v, Maybe (p, v) #)
`seq`
                    let t'' :: IntPSQ p v
t'' = Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
link Int
k' p
p' v
x' Int
k (Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
p v
x) IntPSQ p v
t'
                    in IntPSQ p v
t'' IntPSQ p v
-> (# IntPSQ p v, Maybe (p, v) #) -> (# IntPSQ p v, Maybe (p, v) #)
`seq` (# IntPSQ p v
t'', Maybe (p, v)
forall a. Maybe a
Nothing #)

            | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k' -> case p -> v -> p -> v -> (p, v)
f p
p v
x p
p' v
x' of
                (!p
fp, !v
fx)
                    | Int -> Int -> Bool
zero Int
k Int
m  ->
                        let t' :: IntPSQ p v
t' = Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
fp v
fx IntPSQ p v
l) IntPSQ p v
r
                        in IntPSQ p v
t' IntPSQ p v
-> (# IntPSQ p v, Maybe (p, v) #) -> (# IntPSQ p v, Maybe (p, v) #)
`seq` (# IntPSQ p v
t', (p, v) -> Maybe (p, v)
forall a. a -> Maybe a
Just (p
p', v
x') #)
                    | Bool
otherwise ->
                        let t' :: IntPSQ p v
t' = Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
fp v
fx IntPSQ p v
r)
                        in IntPSQ p v
t' IntPSQ p v
-> (# IntPSQ p v, Maybe (p, v) #) -> (# IntPSQ p v, Maybe (p, v) #)
`seq` (# IntPSQ p v
t', (p, v) -> Maybe (p, v)
forall a. a -> Maybe a
Just (p
p', v
x') #)

            | Int -> Int -> Bool
zero Int
k Int
m -> case IntPSQ p v -> (# IntPSQ p v, Maybe (p, v) #)
go IntPSQ p v
l of
                (# IntPSQ p v
l', Maybe (p, v)
mbPX #) -> IntPSQ p v
l' IntPSQ p v
-> (# IntPSQ p v, Maybe (p, v) #) -> (# IntPSQ p v, Maybe (p, v) #)
`seq` (# Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l' IntPSQ p v
r, Maybe (p, v)
mbPX #)

            | Bool
otherwise -> case IntPSQ p v -> (# IntPSQ p v, Maybe (p, v) #)
go IntPSQ p v
r of
                (# IntPSQ p v
r', Maybe (p, v)
mbPX #) -> IntPSQ p v
r' IntPSQ p v
-> (# IntPSQ p v, Maybe (p, v) #) -> (# IntPSQ p v, Maybe (p, v) #)
`seq` (# Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r', Maybe (p, v)
mbPX #)

-- | This can NOT be used to delete elements.
{-# INLINABLE unsafeLookupIncreasePriority #-}
unsafeLookupIncreasePriority
    :: Ord p
    => (p -> v -> (Maybe b, p, v))
    -> Key
    -> IntPSQ p v
    -> (Maybe b, IntPSQ p v)
unsafeLookupIncreasePriority :: (p -> v -> (Maybe b, p, v))
-> Int -> IntPSQ p v -> (Maybe b, IntPSQ p v)
unsafeLookupIncreasePriority p -> v -> (Maybe b, p, v)
f Int
k IntPSQ p v
t0 =
    -- TODO (jaspervdj): Maybe help inliner a bit here, check core.
    case IntPSQ p v -> (# IntPSQ p v, Maybe b #)
go IntPSQ p v
t0 of
        (# IntPSQ p v
t, Maybe b
mbB #) -> (Maybe b
mbB, IntPSQ p v
t)
  where
    go :: IntPSQ p v -> (# IntPSQ p v, Maybe b #)
go IntPSQ p v
t = case IntPSQ p v
t of
        IntPSQ p v
Nil -> (# IntPSQ p v
forall p v. IntPSQ p v
Nil, Maybe b
forall a. Maybe a
Nothing #)

        Tip Int
k' p
p' v
x'
            | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k'   -> case p -> v -> (Maybe b, p, v)
f p
p' v
x' of
                (!Maybe b
fb, !p
fp, !v
fx) -> (# Int -> p -> v -> IntPSQ p v
forall p v. Int -> p -> v -> IntPSQ p v
Tip Int
k p
fp v
fx, Maybe b
fb #)
            | Bool
otherwise -> (# IntPSQ p v
t, Maybe b
forall a. Maybe a
Nothing #)

        Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r
            | Int -> Int -> Int -> Bool
nomatch Int
k Int
k' Int
m -> (# IntPSQ p v
t, Maybe b
forall a. Maybe a
Nothing #)

            | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k' -> case p -> v -> (Maybe b, p, v)
f p
p' v
x' of
                (!Maybe b
fb, !p
fp, !v
fx)
                    | Int -> Int -> Bool
zero Int
k Int
m  ->
                        let t' :: IntPSQ p v
t' = Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
fp v
fx IntPSQ p v
l) IntPSQ p v
r
                        in IntPSQ p v
t' IntPSQ p v
-> (# IntPSQ p v, Maybe b #) -> (# IntPSQ p v, Maybe b #)
`seq` (# IntPSQ p v
t', Maybe b
fb #)
                    | Bool
otherwise ->
                        let t' :: IntPSQ p v
t' = Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
merge Int
m IntPSQ p v
l (Int -> p -> v -> IntPSQ p v -> IntPSQ p v
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
unsafeInsertNew Int
k p
fp v
fx IntPSQ p v
r)
                        in IntPSQ p v
t' IntPSQ p v
-> (# IntPSQ p v, Maybe b #) -> (# IntPSQ p v, Maybe b #)
`seq` (# IntPSQ p v
t', Maybe b
fb #)

            | Int -> Int -> Bool
zero Int
k Int
m -> case IntPSQ p v -> (# IntPSQ p v, Maybe b #)
go IntPSQ p v
l of
                (# IntPSQ p v
l', Maybe b
mbB #) -> IntPSQ p v
l' IntPSQ p v
-> (# IntPSQ p v, Maybe b #) -> (# IntPSQ p v, Maybe b #)
`seq` (# Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l' IntPSQ p v
r, Maybe b
mbB #)

            | Bool
otherwise -> case IntPSQ p v -> (# IntPSQ p v, Maybe b #)
go IntPSQ p v
r of
                (# IntPSQ p v
r', Maybe b
mbB #) -> IntPSQ p v
r' IntPSQ p v
-> (# IntPSQ p v, Maybe b #) -> (# IntPSQ p v, Maybe b #)
`seq` (# Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
forall p v.
Int -> p -> v -> Int -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v
Bin Int
k' p
p' v
x' Int
m IntPSQ p v
l IntPSQ p v
r', Maybe b
mbB #)


------------------------------------------------------------------------------
-- Validity checks for the datastructure invariants
------------------------------------------------------------------------------

-- | /O(n^2)/ Internal function to check if the 'IntPSQ' is valid, i.e. if all
-- invariants hold. This should always be the case.
valid :: Ord p => IntPSQ p v -> Bool
valid :: IntPSQ p v -> Bool
valid IntPSQ p v
psq =
    Bool -> Bool
not (IntPSQ p v -> Bool
forall p a. IntPSQ p a -> Bool
hasBadNils IntPSQ p v
psq) Bool -> Bool -> Bool
&&
    Bool -> Bool
not (IntPSQ p v -> Bool
forall p a. IntPSQ p a -> Bool
hasDuplicateKeys IntPSQ p v
psq) Bool -> Bool -> Bool
&&
    IntPSQ p v -> Bool
forall p v. Ord p => IntPSQ p v -> Bool
hasMinHeapProperty IntPSQ p v
psq Bool -> Bool -> Bool
&&
    IntPSQ p v -> Bool
forall p a. IntPSQ p a -> Bool
validMask IntPSQ p v
psq

hasBadNils :: IntPSQ p v -> Bool
hasBadNils :: IntPSQ p v -> Bool
hasBadNils IntPSQ p v
psq = case IntPSQ p v
psq of
    IntPSQ p v
Nil                 -> Bool
False
    Tip Int
_ p
_ v
_           -> Bool
False
    Bin Int
_ p
_ v
_ Int
_ IntPSQ p v
Nil IntPSQ p v
Nil -> Bool
True
    Bin Int
_ p
_ v
_ Int
_ IntPSQ p v
l IntPSQ p v
r     -> IntPSQ p v -> Bool
forall p a. IntPSQ p a -> Bool
hasBadNils IntPSQ p v
l Bool -> Bool -> Bool
|| IntPSQ p v -> Bool
forall p a. IntPSQ p a -> Bool
hasBadNils IntPSQ p v
r

hasDuplicateKeys :: IntPSQ p v -> Bool
hasDuplicateKeys :: IntPSQ p v -> Bool
hasDuplicateKeys IntPSQ p v
psq =
    ([Int] -> Bool) -> [[Int]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> ([Int] -> Int) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
List.group ([Int] -> [[Int]]) -> ([Int] -> [Int]) -> [Int] -> [[Int]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
List.sort ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int] -> IntPSQ p v -> [Int]
forall p v. [Int] -> IntPSQ p v -> [Int]
collectKeys [] IntPSQ p v
psq)
  where
    collectKeys :: [Int] -> IntPSQ p v -> [Int]
    collectKeys :: [Int] -> IntPSQ p v -> [Int]
collectKeys [Int]
ks IntPSQ p v
Nil = [Int]
ks
    collectKeys [Int]
ks (Tip Int
k p
_ v
_) = Int
k Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ks
    collectKeys [Int]
ks (Bin Int
k p
_ v
_ Int
_ IntPSQ p v
l IntPSQ p v
r) =
        let ks' :: [Int]
ks' = [Int] -> IntPSQ p v -> [Int]
forall p v. [Int] -> IntPSQ p v -> [Int]
collectKeys (Int
k Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ks) IntPSQ p v
l
        in [Int] -> IntPSQ p v -> [Int]
forall p v. [Int] -> IntPSQ p v -> [Int]
collectKeys [Int]
ks' IntPSQ p v
r

hasMinHeapProperty :: Ord p => IntPSQ p v -> Bool
hasMinHeapProperty :: IntPSQ p v -> Bool
hasMinHeapProperty IntPSQ p v
psq = case IntPSQ p v
psq of
    IntPSQ p v
Nil             -> Bool
True
    Tip Int
_ p
_ v
_       -> Bool
True
    Bin Int
_ p
p v
_ Int
_ IntPSQ p v
l IntPSQ p v
r -> p -> IntPSQ p v -> Bool
forall p v. Ord p => p -> IntPSQ p v -> Bool
go p
p IntPSQ p v
l Bool -> Bool -> Bool
&& p -> IntPSQ p v -> Bool
forall p v. Ord p => p -> IntPSQ p v -> Bool
go p
p IntPSQ p v
r
  where
    go :: Ord p => p -> IntPSQ p v -> Bool
    go :: p -> IntPSQ p v -> Bool
go p
_ IntPSQ p v
Nil = Bool
True
    go p
parentPrio (Tip Int
_ p
prio v
_) = p
parentPrio p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
prio
    go p
parentPrio (Bin Int
_ p
prio v
_  Int
_ IntPSQ p v
l IntPSQ p v
r) =
        p
parentPrio p -> p -> Bool
forall a. Ord a => a -> a -> Bool
<= p
prio Bool -> Bool -> Bool
&& p -> IntPSQ p v -> Bool
forall p v. Ord p => p -> IntPSQ p v -> Bool
go p
prio IntPSQ p v
l Bool -> Bool -> Bool
&& p -> IntPSQ p v -> Bool
forall p v. Ord p => p -> IntPSQ p v -> Bool
go p
prio IntPSQ p v
r

data Side = L | R

validMask :: IntPSQ p v -> Bool
validMask :: IntPSQ p v -> Bool
validMask IntPSQ p v
Nil = Bool
True
validMask (Tip Int
_ p
_ v
_) = Bool
True
validMask (Bin Int
_ p
_ v
_ Int
m IntPSQ p v
left IntPSQ p v
right ) =
    Int -> IntPSQ p v -> IntPSQ p v -> Bool
forall p v. Int -> IntPSQ p v -> IntPSQ p v -> Bool
maskOk Int
m IntPSQ p v
left IntPSQ p v
right Bool -> Bool -> Bool
&& Int -> Side -> IntPSQ p v -> Bool
forall p v. Int -> Side -> IntPSQ p v -> Bool
go Int
m Side
L IntPSQ p v
left Bool -> Bool -> Bool
&& Int -> Side -> IntPSQ p v -> Bool
forall p v. Int -> Side -> IntPSQ p v -> Bool
go Int
m Side
R IntPSQ p v
right
  where
    go :: Mask -> Side -> IntPSQ p v -> Bool
    go :: Int -> Side -> IntPSQ p v -> Bool
go Int
parentMask Side
side IntPSQ p v
psq = case IntPSQ p v
psq of
        IntPSQ p v
Nil -> Bool
True
        Tip Int
k p
_ v
_ -> Int -> Side -> Int -> Bool
forall a. (Bits a, Num a) => a -> Side -> a -> Bool
checkMaskAndSideMatchKey Int
parentMask Side
side Int
k
        Bin Int
k p
_ v
_ Int
mask IntPSQ p v
l IntPSQ p v
r ->
            Int -> Side -> Int -> Bool
forall a. (Bits a, Num a) => a -> Side -> a -> Bool
checkMaskAndSideMatchKey Int
parentMask Side
side Int
k Bool -> Bool -> Bool
&&
            Int -> IntPSQ p v -> IntPSQ p v -> Bool
forall p v. Int -> IntPSQ p v -> IntPSQ p v -> Bool
maskOk Int
mask IntPSQ p v
l IntPSQ p v
r Bool -> Bool -> Bool
&&
            Int -> Side -> IntPSQ p v -> Bool
forall p v. Int -> Side -> IntPSQ p v -> Bool
go Int
mask Side
L IntPSQ p v
l Bool -> Bool -> Bool
&&
            Int -> Side -> IntPSQ p v -> Bool
forall p v. Int -> Side -> IntPSQ p v -> Bool
go Int
mask Side
R IntPSQ p v
r

    checkMaskAndSideMatchKey :: a -> Side -> a -> Bool
checkMaskAndSideMatchKey a
parentMask Side
side a
key =
        case Side
side of
            Side
L -> a
parentMask a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
key a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
            Side
R -> a
parentMask a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
key a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
parentMask

    maskOk :: Mask -> IntPSQ p v -> IntPSQ p v -> Bool
    maskOk :: Int -> IntPSQ p v -> IntPSQ p v -> Bool
maskOk Int
mask IntPSQ p v
l IntPSQ p v
r = case Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntPSQ p v -> Maybe Int
forall p v. IntPSQ p v -> Maybe Int
childKey IntPSQ p v
l Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntPSQ p v -> Maybe Int
forall p v. IntPSQ p v -> Maybe Int
childKey IntPSQ p v
r of
        Maybe Int
Nothing -> Bool
True
        Just Int
xoredKeys ->
            Int -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mask Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat -> Nat
highestBitMask (Int -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
xoredKeys)

    childKey :: IntPSQ p v -> Maybe Int
childKey IntPSQ p v
Nil               = Maybe Int
forall a. Maybe a
Nothing
    childKey (Tip Int
k p
_ v
_)       = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
    childKey (Bin Int
k p
_ v
_ Int
_ IntPSQ p v
_ IntPSQ p v
_) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k