diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,35 +1,144 @@ # Revision history for pqueue -## 1.3.2.3 -- 2017-08-01 +## 1.7.0.0 -- 2026-04-16 - * Maintenance release for ghc-8.2 +* Remove `insertBehind` ([#145](https://github.com/lspitzner/pqueue/pull/145)) -## 1.3.2.2 -- 2017-03-12 +* Change `Read` and `Show` instances to use `fromList` + ([#144](https://github.com/lspitzner/pqueue/issues/144)) - * Add test-suite from darcs repository for pqueue-1.0.1. +## 1.6.0.0 -- 2025-10-11 -## 1.3.2.1 -- 2017-03-11 +* Deprecate `mapU` and replace it by `mapMonotonic` in `Data.PQeueu.Min` and `Data.PQueue.Max` + ([#129](https://github.com/lspitzner/pqueue/pull/129)) - * Fix documentation errors - - complexity on `toList`, `toListU` - - PQueue.Prio.Max had "ascending" instead of "descending" in some places +* Add ghc-9.8, ghc-9.10 & ghc-9.12 support + ([#133](https://github.com/lspitzner/pqueue/pull/133), [#135](https://github.com/lspitzner/pqueue/pull/135), [#139](https://github.com/lspitzner/pqueue/pull/139)) -## 1.3.2 -- 2016-09-28 +* Drop ghc-7.10 support ([#142](https://github.com/lspitzner/pqueue/pull/142)) - * Add function `insertBehind` as a slight variation of `insert` which differs - in behaviour for elements the compare equal. +* Fix typo in `Data.PQueue.Max.toList` documentation + ([#131](https://github.com/lspitzner/pqueue/pull/131)) -## 1.3.1.1 -- 2016-05-21 +## 1.5.0.0 -- 2023-08-08 - * Ensure compatibility with ghc-8 - * Minor internal refactors +* Fix incorrect behavior of `mapMaybe` and `mapEither` for `MinQueue`. These + previously worked only for monotonic functions. -## 1.3.1 -- 2015-10-03 +* Fix a performance bug that caused queue performance not to improve + when the queue shrinks. + ([#109](https://github.com/lspitzner/pqueue/pull/109)) - * Add Monoid instance for MaxPQueue +* Make `minView` more eager, improving performance in typical cases. + ([#107](https://github.com/lspitzner/pqueue/pull/107)) -## 1.3.0 -- 2015-06-23 +* Make mapping and traversal functions force the full data structure spine. + This should make performance more predictable, and removes the last + remaining reasons to use the `seqSpine` functions. As these are no longer + useful, deprecate them. + ([#103](https://github.com/lspitzner/pqueue/pull/103)) - * Lennart Spitzner starts co-maintaining - * new git repository at github.com:lspitzner/pqueue - * Ensure compatibility with ghc-7.10 +* Deprecate `insertBehind`. This function does not play nicely with merges, + we lack tests to verify it works properly without merges, it imposes a + substantial maintenance burden on the rest of the package, and it is quite + slow. ([#35](https://github.com/lspitzner/pqueue/issues/35)) + +* Add pattern synonyms to work with `MinQueue` and `MinPQueue`. + ([#92](https://github.com/lspitzner/pqueue/pull/92)) + +* Make the `Data` instances respect the queue invariants. Make the + `Constr`s match the pattern synonyms. Make the `Data` instance for + `MinPQueue` work "incrementally", like the one for `MinQueue`. + ([#92](https://github.com/lspitzner/pqueue/pull/92)) + +## 1.4.3.0 -- 2022-10-30 + +* Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable). + ([#85](https://github.com/lspitzner/pqueue/pull/85)) +* Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86)) + +## 1.4.2.0 -- 2022-06-19 + +* Overall performance has improved greatly, especially when there are many + insertions and/or merges in a row. Insertion, deletion, and merge are now + *worst case* logarithmic, while maintaining their previous amortized + bounds. ([#26](https://github.com/lspitzner/pqueue/pull/26)) + +* New `mapMWithKey` functions optimized for working in strict monads. These + are used to implement the `mapM` and `sequence` methods of `Traversable`. + ([#46](https://github.com/lspitzner/pqueue/pull/46)) + +* Define `stimes` in the `Semigroup` instances. + ([#57](https://github.com/lspitzner/pqueue/pull/57)) + +* Add strict left unordered folds (`foldlU'`, `foldlWithKeyU'`) + and monoidal unordered folds (`foldMapU`, `foldMapWithKeyU`). + ([#59](https://github.com/lspitzner/pqueue/pull/59)) + +* New functions for adjusting and updating the min/max of a key-value + priority queue in an `Applicative` context. + ([#66](https://github.com/lspitzner/pqueue/pull/66)) + +* Fixed `Data.PQueue.Max.map` to work on `MaxQueue`s. + ([#76](https://github.com/lspitzner/pqueue/pull/76)) + +## 1.4.1.4 -- 2021-12-04 + +* Maintenance release for ghc-9.0 & ghc-9.2 support +* Change nix-setup to use the seaaye tool + +## 1.4.1.3 -- 2020-06-06 + +* Maintenance release +* Add missing documentation +* Add nix-expressions for testing against different compilers/package sets + +## 1.4.1.2 -- 2018-09-26 + +* Maintenance release for ghc-8.6 +* Drop support for ghc<7.10 + +## 1.4.1.1 -- 2018-02-11 + +* Remove/replace buggy `insertBehind` implementation. + + The existing implementation did not always insert behind. As a fix, + the function was removed from Data.PQueue.Max/Min and was rewritten + with a O(n) complexity (!) for Data.PQueue.Prio.Max/Min. + +* Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release +* Drop support for ghc<7.4 + +## 1.3.2.3 -- 2017-08-01 + +* Maintenance release for ghc-8.2 + +## 1.3.2.2 -- 2017-03-12 + +* Add test-suite from darcs repository for pqueue-1.0.1. + +## 1.3.2.1 -- 2017-03-11 + +* Fix documentation errors + - complexity on `toList`, `toListU` + - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places + +## 1.3.2 -- 2016-09-28 + +* Add function `insertBehind` as a slight variation of `insert` which differs + in behaviour for elements the compare equal. + +## 1.3.1.1 -- 2016-05-21 + +* Ensure compatibility with ghc-8 +* Minor internal refactors + +## 1.3.1 -- 2015-10-03 + +* Add `Monoid` instance for `MaxPQueue` + +## 1.3.0 -- 2015-06-23 + +* Lennart Spitzner starts co-maintaining +* new git repository at github.com:lspitzner/pqueue +* Ensure compatibility with ghc-7.10 diff --git a/Control/Applicative/Identity.hs b/Control/Applicative/Identity.hs deleted file mode 100644 --- a/Control/Applicative/Identity.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Control.Applicative.Identity where - -import Control.Applicative - -import Prelude - -newtype Identity a = Identity {runIdentity :: a} - -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) diff --git a/Data/PQueue/Internals.hs b/Data/PQueue/Internals.hs deleted file mode 100644 --- a/Data/PQueue/Internals.hs +++ /dev/null @@ -1,514 +0,0 @@ -{-# LANGUAGE CPP, StandaloneDeriving #-} - -module Data.PQueue.Internals ( - MinQueue (..), - BinomHeap, - BinomForest(..), - BinomTree(..), - Succ(..), - Zero(..), - LEq, - empty, - null, - size, - getMin, - minView, - singleton, - insert, - insertBehind, - union, - mapMaybe, - mapEither, - mapMonotonic, - foldrAsc, - foldlAsc, - insertMinQ, --- mapU, - foldrU, - foldlU, --- traverseU, - keysQueue, - seqSpine - ) where - -import Control.DeepSeq (NFData(rnf), deepseq) - -import Data.Functor ((<$>)) -import Data.Foldable (Foldable (foldr, foldl)) -import Data.Monoid (mappend) -import qualified Data.PQueue.Prio.Internals as Prio - -#ifdef __GLASGOW_HASKELL__ -import Data.Data -#endif - -import Prelude hiding (foldl, foldr, null) - --- | A priority queue with elements of type @a@. Supports extracting the minimum element. -data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int a !(BinomHeap a) -#if __GLASGOW_HASKELL__>=707 - deriving Typeable -#else -#include "Typeable.h" -INSTANCE_TYPEABLE1(MinQueue,minQTC,"MinQueue") -#endif - -#ifdef __GLASGOW_HASKELL__ -instance (Ord a, Data a) => Data (MinQueue a) where - gfoldl f z q = case minView q of - Nothing -> z Empty - Just (x, q') -> z insertMinQ `f` x `f` q' - - gunfold k z c = case constrIndex c of - 1 -> z Empty - 2 -> k (k (z insertMinQ)) - _ -> error "gunfold" - - dataCast1 x = gcast1 x - - toConstr q - | null q = emptyConstr - | otherwise = consConstr - - dataTypeOf _ = queueDataType - -queueDataType :: DataType -queueDataType = mkDataType "Data.PQueue.Min.MinQueue" [emptyConstr, consConstr] - -emptyConstr, consConstr :: Constr -emptyConstr = mkConstr queueDataType "empty" [] Prefix -consConstr = mkConstr queueDataType "<|" [] Infix - -#endif - -type BinomHeap = BinomForest Zero - -instance Ord a => Eq (MinQueue a) where - Empty == Empty = True - MinQueue n1 x1 q1 == MinQueue n2 x2 q2 = - n1 == n2 && eqExtract (x1,q1) (x2,q2) - _ == _ = False - -eqExtract :: Ord a => (a, BinomHeap a) -> (a, BinomHeap a) -> Bool -eqExtract (x1,q1) (x2,q2) = - x1 == x2 && - case (extractHeap q1, extractHeap q2) of - (Just h1, Just h2) -> eqExtract h1 h2 - (Nothing, Nothing) -> True - _ -> False - -instance Ord a => Ord (MinQueue a) where - Empty `compare` Empty = EQ - Empty `compare` _ = LT - _ `compare` Empty = GT - MinQueue _n1 x1 q1 `compare` MinQueue _n2 x2 q2 = cmpExtract (x1,q1) (x2,q2) - -cmpExtract :: Ord a => (a, BinomHeap a) -> (a, BinomHeap a) -> Ordering -cmpExtract (x1,q1) (x2,q2) = - compare x1 x2 `mappend` - case (extractHeap q1, extractHeap q2) of - (Just h1, Just h2) -> cmpExtract h1 h2 - (Nothing, Nothing) -> EQ - (Just _, Nothing) -> GT - (Nothing, Just _) -> LT - - -- We compare their first elements, then their other elements up to the smaller queue's length, - -- and then the longer queue wins. - -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. - --- We implement tree ranks in the type system with a nicely elegant approach, as follows. --- The goal is to have the type system automatically guarantee that our binomial forest --- has the correct binomial structure. --- --- In the traditional set-theoretic construction of the natural numbers, we define --- each number to be the set of numbers less than it, and Zero to be the empty set, --- as follows: --- --- 0 = {} 1 = {0} 2 = {0, 1} 3={0, 1, 2} ... --- --- Binomial trees have a similar structure: a tree of rank @k@ has one child of each --- rank less than @k@. Let's define the type @rk@ corresponding to rank @k@ to refer --- to a collection of binomial trees of ranks @0..k-1@. Then we can say that --- --- > data Succ rk a = Succ (BinomTree rk a) (rk a) --- --- and this behaves exactly as the successor operator for ranks should behave. Furthermore, --- we immediately obtain that --- --- > data BinomTree rk a = BinomTree a (rk a) --- --- which is nice and compact. With this construction, things work out extremely nicely: --- --- > BinomTree (Succ (Succ (Succ Zero))) --- --- is a type constructor that takes an element type and returns the type of binomial trees --- of rank @3@. -data BinomForest rk a = Nil | Skip (BinomForest (Succ rk) a) | - Cons {-# UNPACK #-} !(BinomTree rk a) (BinomForest (Succ rk) a) - -data BinomTree rk a = BinomTree a (rk a) - --- | If |rk| corresponds to rank @k@, then |'Succ' rk| corresponds to rank @k+1@. -data Succ rk a = Succ {-# UNPACK #-} !(BinomTree rk a) (rk a) - --- | Type corresponding to the Zero rank. -data Zero a = Zero - --- | Type alias for a comparison function. -type LEq a = a -> a -> Bool - --- basics - --- | /O(1)/. The empty priority queue. -empty :: MinQueue a -empty = Empty - --- | /O(1)/. Is this the empty priority queue? -null :: MinQueue a -> Bool -null Empty = True -null _ = False - --- | /O(1)/. The number of elements in the queue. -size :: MinQueue a -> Int -size Empty = 0 -size (MinQueue n _ _) = n - --- | Returns the minimum element of the queue, if the queue is nonempty. -getMin :: MinQueue a -> Maybe a -getMin (MinQueue _ x _) = Just x -getMin _ = Nothing - --- | Retrieves the minimum element of the queue, and the queue stripped of that element, --- or 'Nothing' if passed an empty queue. -minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a) -minView Empty = Nothing -minView (MinQueue n x ts) = Just (x, case extractHeap ts of - Nothing -> Empty - Just (x', ts') -> MinQueue (n-1) x' ts') - --- | /O(1)/. Construct a priority queue with a single element. -singleton :: a -> MinQueue a -singleton x = MinQueue 1 x Nil - --- | Amortized /O(1)/, worst-case /O(log n)/. Insert an element into the priority queue. -insert :: Ord a => a -> MinQueue a -> MinQueue a -insert = insert' (<=) - --- | Amortized /O(1)/, worst-case /O(log n)/. Insert an element into the priority queue, --- putting it behind elements that compare equal to the inserted one. -insertBehind :: Ord a => a -> MinQueue a -> MinQueue a -insertBehind = insert' (<) - --- | Amortized /O(log (min(n,m)))/, worst-case /O(log (max (n,m)))/. Take the union of two priority queues. -union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a -union = union' (<=) - --- | /O(n)/. Map elements and collect the 'Just' results. -mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b -mapMaybe _ Empty = Empty -mapMaybe f (MinQueue _ x ts) = maybe q' (`insert` q') (f x) - where - q' = mapMaybeQueue f (<=) (const Empty) Empty ts - --- | /O(n)/. Map elements and separate the 'Left' and 'Right' results. -mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) -mapEither _ Empty = (Empty, Empty) -mapEither f (MinQueue _ x ts) = case (mapEitherQueue f (<=) (<=) (const (Empty, Empty)) (Empty, Empty) ts, f x) of - ((qL, qR), Left b) -> (insert b qL, qR) - ((qL, qR), Right c) -> (qL, insert c qR) - --- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, --- as in 'fmap'. If it is not, the result is undefined. -mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b -mapMonotonic = mapU - -{-# INLINE foldrAsc #-} --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. -foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b -foldrAsc _ z Empty = z -foldrAsc f z (MinQueue _ x ts) = x `f` foldrUnfold f z extractHeap ts - -{-# INLINE foldrUnfold #-} --- | Equivalent to @foldr f z (unfoldr suc s0)@. -foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c -foldrUnfold f z suc s0 = unf s0 where - unf s = case suc s of - Nothing -> z - Just (x, s') -> x `f` unf s' - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order. -foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b -foldlAsc _ z Empty = z -foldlAsc f z (MinQueue _ x ts) = foldlUnfold f (z `f` x) extractHeap ts - -{-# INLINE foldlUnfold #-} --- | @foldlUnfold f z suc s0@ is equivalent to @foldl f z (unfoldr suc s0)@. -foldlUnfold :: (c -> a -> c) -> c -> (b -> Maybe (a, b)) -> b -> c -foldlUnfold f z0 suc s0 = unf z0 s0 where - unf z s = case suc s of - Nothing -> z - Just (x, s') -> unf (z `f` x) s' - -insert' :: LEq a -> a -> MinQueue a -> MinQueue a -insert' _ x Empty = singleton x -insert' le x (MinQueue n x' ts) - | x `le` x' = MinQueue (n+1) x (incr le (tip x') ts) - | otherwise = MinQueue (n+1) x' (incr le (tip x) ts) - -{-# INLINE union' #-} -union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a -union' _ Empty q = q -union' _ q Empty = q -union' le (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) - | x1 `le` x2 = MinQueue (n1 + n2) x1 (carry le (tip x2) f1 f2) - | otherwise = MinQueue (n1 + n2) x2 (carry le (tip x1) f1 f2) - --- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. -extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) -extractHeap ts = case extractBin (<=) ts of - Yes (Extract x _ ts') -> Just (x, ts') - _ -> Nothing - --- | A specialized type intended to organize the return of extract-min queries --- from a binomial forest. We walk all the way through the forest, and then --- walk backwards. @Extract rk a@ is the result type of an extract-min --- operation that has walked as far backwards of rank @rk@ -- that is, it --- has visited every root of rank @>= rk@. --- --- The interpretation of @Extract minKey children forest@ is --- --- * @minKey@ is the key of the minimum root visited so far. It may have --- any rank @>= rk@. We will denote the root corresponding to --- @minKey@ as @minRoot@. --- --- * @children@ is those children of @minRoot@ which have not yet been --- merged with the rest of the forest. Specifically, these are --- the children with rank @< rk@. --- --- * @forest@ is an accumulating parameter that maintains the partial --- reconstruction of the binomial forest without @minRoot@. It is --- the union of all old roots with rank @>= rk@ (except @minRoot@), --- with the set of all children of @minRoot@ with rank @>= rk@. --- Note that @forest@ is lazy, so if we discover a smaller key --- than @minKey@ later, we haven't wasted significant work. -data Extract rk a = Extract a (rk a) (BinomForest rk a) -data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a) - -incrExtract :: Extract (Succ rk) a -> Extract rk a -incrExtract (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Cons kChild ts) - -incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a -incrExtract' le t (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Skip (incr le (t `cat` kChild) ts)) - where - cat = joinBin le - --- | Walks backward from the biggest key in the forest, as far as rank @rk@. --- Returns its progress. Each successive application of @extractBin@ takes --- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. -extractBin :: LEq a -> BinomForest rk a -> MExtract rk a -extractBin _ Nil = No -extractBin le (Skip f) = case extractBin le f of - Yes ex -> Yes (incrExtract ex) - No -> No -extractBin le (Cons t@(BinomTree x ts) f) = Yes $ case extractBin le f of - Yes ex@(Extract minKey _ _) - | minKey `lt` x -> incrExtract' le t ex - _ -> Extract x ts (Skip f) - where a `lt` b = not (b `le` a) - -mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b -mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of - Nil -> q0 - Skip forest' -> mapMaybeQueue f le fCh' q0 forest' - Cons t forest' -> mapMaybeQueue f le fCh' (union' le (mapMaybeT t) q0) forest' - where fCh' (Succ t tss) = union' le (mapMaybeT t) (fCh tss) - mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\ x -> insert' le x (fCh ts)) (f x0) - -type Partition a b = (MinQueue a, MinQueue b) - -mapEitherQueue :: (a -> Either b c) -> LEq b -> LEq c -> (rk a -> Partition b c) -> Partition b c -> - BinomForest rk a -> Partition b c -mapEitherQueue f0 leB leC fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of - Nil -> (q00, q10) - Skip ts' -> mapEitherQueue f0 leB leC fCh' (q00, q10) ts' - Cons t ts' -> mapEitherQueue f0 leB leC fCh' (both (union' leB) (union' leC) (partitionT t) (q00, q10)) ts' - where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) - fCh' (Succ t tss) = both (union' leB) (union' leC) (partitionT t) (fCh tss) - partitionT (BinomTree x ts) = case fCh ts of - (q0, q1) -> case f0 x of - Left b -> (insert' leB b q0, q1) - Right c -> (q0, insert' leC c q1) - -{-# INLINE tip #-} --- | Constructs a binomial tree of rank 0. -tip :: a -> BinomTree Zero a -tip x = BinomTree x Zero - -insertMinQ :: a -> MinQueue a -> MinQueue a -insertMinQ x Empty = singleton x -insertMinQ x (MinQueue n x' f) = MinQueue (n+1) x (insertMin (tip x') f) - --- | @insertMin t f@ assumes that the root of @t@ compares as less than --- every other root in @f@, and merges accordingly. -insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a -insertMin t Nil = Cons t Nil -insertMin t (Skip f) = Cons t f -insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f) - --- | Given two binomial forests starting at rank @rk@, takes their union. --- Each successive application of this function costs /O(1)/, so applying it --- from the beginning costs /O(log n)/. -merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a -merge le f1 f2 = case (f1, f2) of - (Skip f1', Skip f2') -> Skip (merge le f1' f2') - (Skip f1', Cons t2 f2') -> Cons t2 (merge le f1' f2') - (Cons t1 f1', Skip f2') -> Cons t1 (merge le f1' f2') - (Cons t1 f1', Cons t2 f2') - -> Skip (carry le (t1 `cat` t2) f1' f2') - (Nil, _) -> f2 - (_, Nil) -> f1 - where cat = joinBin le - --- | Merges two binomial forests with another tree. If we are thinking of the trees --- in the binomial forest as binary digits, this corresponds to a carry operation. --- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/. -carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a -carry le t0 f1 f2 = t0 `seq` case (f1, f2) of - (Skip f1', Skip f2') -> Cons t0 (merge le f1' f2') - (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2') - (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2') - (Cons t1 f1', Cons t2 f2') - -> Cons t0 (mergeCarry t1 t2 f1' f2') - (Nil, _f2) -> incr le t0 f2 - (_f1, Nil) -> incr le t0 f1 - where cat = joinBin le - mergeCarry tA tB = carry le (tA `cat` tB) - --- | Merges a binomial tree into a binomial forest. If we are thinking --- of the trees in the binomial forest as binary digits, this corresponds --- to adding a power of 2. This costs amortized /O(1)/ time. -incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -incr le t f0 = t `seq` case f0 of - Nil -> Cons t Nil - Skip f -> Cons t f - Cons t' f' -> Skip (incr le (t `cat` t') f') - where cat = joinBin le - --- | The carrying operation: takes two binomial heaps of the same rank @k@ --- and returns one of rank @k+1@. Takes /O(1)/ time. -joinBin :: LEq a -> BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a -joinBin le t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) - | x1 `le` x2 = BinomTree x1 (Succ t2 ts1) - | otherwise = BinomTree x2 (Succ t1 ts2) - -instance Functor Zero where - fmap _ _ = Zero - -instance Functor rk => Functor (Succ rk) where - fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts) - -instance Functor rk => Functor (BinomTree rk) where - fmap f (BinomTree x ts) = BinomTree (f x) (fmap f ts) - -instance Functor rk => Functor (BinomForest rk) where - fmap _ Nil = Nil - fmap f (Skip ts) = Skip (fmap f ts) - fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts) - -instance Foldable Zero where - foldr _ z _ = z - foldl _ z _ = z - -instance Foldable rk => Foldable (Succ rk) where - foldr f z (Succ t ts) = foldr f (foldr f z ts) t - foldl f z (Succ t ts) = foldl f (foldl f z t) ts - -instance Foldable rk => Foldable (BinomTree rk) where - foldr f z (BinomTree x ts) = x `f` foldr f z ts - foldl f z (BinomTree x ts) = foldl f (z `f` x) ts - -instance Foldable rk => Foldable (BinomForest rk) where - foldr _ z Nil = z - foldr f z (Skip tss) = foldr f z tss - foldr f z (Cons t tss) = foldr f (foldr f z tss) t - foldl _ z Nil = z - foldl f z (Skip tss) = foldl f z tss - foldl f z (Cons t tss) = foldl f (foldl f z t) tss - --- instance Traversable Zero where --- traverse _ _ = pure Zero --- --- instance Traversable rk => Traversable (Succ rk) where --- traverse f (Succ t ts) = Succ <$> traverse f t <*> traverse f ts --- --- instance Traversable rk => Traversable (BinomTree rk) where --- traverse f (BinomTree x ts) = BinomTree <$> f x <*> traverse f ts --- --- instance Traversable rk => Traversable (BinomForest rk) where --- traverse _ Nil = pure Nil --- traverse f (Skip tss) = Skip <$> traverse f tss --- traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss - -mapU :: (a -> b) -> MinQueue a -> MinQueue b -mapU _ Empty = Empty -mapU f (MinQueue n x ts) = MinQueue n (f x) (f <$> ts) - --- | /O(n)/. Unordered right fold on a priority queue. -foldrU :: (a -> b -> b) -> b -> MinQueue a -> b -foldrU _ z Empty = z -foldrU f z (MinQueue _ x ts) = x `f` foldr f z ts - --- | /O(n)/. Unordered left fold on a priority queue. -foldlU :: (b -> a -> b) -> b -> MinQueue a -> b -foldlU _ z Empty = z -foldlU f z (MinQueue _ x ts) = foldl f (z `f` x) ts - --- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) --- traverseU _ Empty = pure Empty --- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts - --- | Forces the spine of the priority queue. -seqSpine :: MinQueue a -> b -> b -seqSpine Empty z = z -seqSpine (MinQueue _ _ ts) z = seqSpineF ts z - -seqSpineF :: BinomForest rk a -> b -> b -seqSpineF Nil z = z -seqSpineF (Skip ts') z = seqSpineF ts' z -seqSpineF (Cons _ ts') z = seqSpineF ts' z - --- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. -keysQueue :: Prio.MinPQueue k a -> MinQueue k -keysQueue Prio.Empty = Empty -keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (keysF (const Zero) ts) - -keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k -keysF f ts0 = case ts0 of - Prio.Nil -> Nil - Prio.Skip ts' -> Skip (keysF f' ts') - Prio.Cons (Prio.BinomTree k _ ts) ts' - -> Cons (BinomTree k (f ts)) (keysF f' ts') - where f' (Prio.Succ (Prio.BinomTree k _ ts) tss) = Succ (BinomTree k (f ts)) (f tss) - -class NFRank rk where - rnfRk :: NFData a => rk a -> () - -instance NFRank Zero where - rnfRk _ = () - -instance NFRank rk => NFRank (Succ rk) where - rnfRk (Succ t ts) = t `deepseq` rnfRk ts - -instance (NFData a, NFRank rk) => NFData (BinomTree rk a) where - rnf (BinomTree x ts) = x `deepseq` rnfRk ts - -instance (NFData a, NFRank rk) => NFData (BinomForest rk a) where - rnf Nil = () - rnf (Skip ts) = rnf ts - rnf (Cons t ts) = t `deepseq` rnf ts - -instance NFData a => NFData (MinQueue a) where - rnf Empty = () - rnf (MinQueue _ x ts) = x `deepseq` rnf ts diff --git a/Data/PQueue/Max.hs b/Data/PQueue/Max.hs deleted file mode 100644 --- a/Data/PQueue/Max.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.PQueue.Max --- Copyright : (c) Louis Wasserman 2010 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- General purpose priority queue, supporting view-maximum operations. --- --- An amortized running time is given for each operation, with /n/ referring --- to the length of the sequence and /k/ being the integral index used by --- some operations. These bounds hold even in a persistent (shared) setting. --- --- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. --- --- This implementation does not guarantee stable behavior. --- --- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for --- unordered. No guarantees whatsoever are made on the execution or traversal order of --- these functions. ------------------------------------------------------------------------------ -module Data.PQueue.Max ( - MaxQueue, - -- * Basic operations - empty, - null, - size, - -- * Query operations - findMax, - getMax, - deleteMax, - deleteFindMax, - delete, - maxView, - -- * Construction operations - singleton, - insert, - insertBehind, - union, - unions, - -- * Subsets - -- ** Extracting subsets - (!!), - take, - drop, - splitAt, - -- ** Predicates - takeWhile, - dropWhile, - span, - break, - -- * Filter/Map - filter, - partition, - mapMaybe, - mapEither, - -- * Fold\/Functor\/Traversable variations - map, - foldrAsc, - foldlAsc, - foldrDesc, - foldlDesc, - -- * List operations - toList, - toAscList, - toDescList, - fromList, - fromAscList, - fromDescList, - -- * Unordered operations - mapU, - foldrU, - foldlU, - elemsU, - toListU, - -- * Miscellaneous operations - keysQueue, - seqSpine) where - -import Control.DeepSeq (NFData(rnf)) - -import Data.Functor ((<$>)) -import Data.Monoid (Monoid(mempty, mappend)) -import Data.Maybe (fromMaybe) -import Data.Foldable (foldl, foldr) - -import qualified Data.PQueue.Min as Min -import qualified Data.PQueue.Prio.Max.Internals as Prio -import Data.PQueue.Prio.Max.Internals (Down(..)) - -import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) -import Data.Data -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - --- | A priority queue with elements of type @a@. Supports extracting the maximum element. --- Implemented as a wrapper around 'Min.MinQueue'. -newtype MaxQueue a = MaxQ (Min.MinQueue (Down a)) -# if __GLASGOW_HASKELL__ - deriving (Eq, Ord, Data, Typeable) -# else - deriving (Eq, Ord) -# endif - -instance NFData a => NFData (MaxQueue a) where - rnf (MaxQ q) = rnf q - -instance (Ord a, Show a) => Show (MaxQueue a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromDescList " . shows (toDescList xs) - -instance Read a => Read (MaxQueue a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromDescList" <- lexP - xs <- readPrec - return (fromDescList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromDescList",s) <- lex r - (xs,t) <- reads s - return (fromDescList xs,t) -#endif - -instance Ord a => Monoid (MaxQueue a) where - mempty = empty - mappend = union - --- | /O(1)/. The empty priority queue. -empty :: MaxQueue a -empty = MaxQ Min.empty - --- | /O(1)/. Is this the empty priority queue? -null :: MaxQueue a -> Bool -null (MaxQ q) = Min.null q - --- | /O(1)/. The number of elements in the queue. -size :: MaxQueue a -> Int -size (MaxQ q) = Min.size q - --- | /O(1)/. Returns the maximum element of the queue. Throws an error on an empty queue. -findMax :: MaxQueue a -> a -findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax - --- | /O(1)/. The top (maximum) element of the queue, if there is one. -getMax :: MaxQueue a -> Maybe a -getMax (MaxQ q) = unDown <$> Min.getMin q - --- | /O(log n)/. Deletes the maximum element of the queue. Does nothing on an empty queue. -deleteMax :: Ord a => MaxQueue a -> MaxQueue a -deleteMax (MaxQ q) = MaxQ (Min.deleteMin q) - --- | /O(log n)/. Extracts the maximum element of the queue. Throws an error on an empty queue. -deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) -deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView - --- | /O(log n)/. Extract the top (maximum) element of the sequence, if there is one. -maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) -maxView (MaxQ q) = case Min.minView q of - Nothing -> Nothing - Just (Down x, q') - -> Just (x, MaxQ q') - --- | /O(log n)/. Delete the top (maximum) element of the sequence, if there is one. -delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) -delete = fmap snd . maxView - --- | /O(1)/. Construct a priority queue with a single element. -singleton :: a -> MaxQueue a -singleton = MaxQ . Min.singleton . Down - --- | /O(1)/. Insert an element into the priority queue. -insert :: Ord a => a -> MaxQueue a -> MaxQueue a -x `insert` MaxQ q = MaxQ (Down x `Min.insert` q) - --- | Amortized /O(1)/, worst-case /O(log n)/. Insert an element into the priority queue, --- putting it behind elements that compare equal to the inserted one. -insertBehind :: Ord a => a -> MaxQueue a -> MaxQueue a -x `insertBehind` MaxQ q = MaxQ (Down x `Min.insertBehind` q) - --- | /O(log (min(n1,n2)))/. Take the union of two priority queues. -union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a -MaxQ q1 `union` MaxQ q2 = MaxQ (q1 `Min.union` q2) - --- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. -unions :: Ord a => [MaxQueue a] -> MaxQueue a -unions qs = MaxQ (Min.unions [q | MaxQ q <- qs]) - --- | /O(k log n)/. Returns the @(k+1)@th largest element of the queue. -(!!) :: Ord a => MaxQueue a -> Int -> a -MaxQ q !! n = unDown ((Min.!!) q n) - -{-# INLINE take #-} --- | /O(k log n)/. Returns the list of the @k@ largest elements of the queue, in descending order, or --- all elements of the queue, if @k >= n@. -take :: Ord a => Int -> MaxQueue a -> [a] -take k (MaxQ q) = [a | Down a <- Min.take k q] - --- | /O(k log n)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. -drop :: Ord a => Int -> MaxQueue a -> MaxQueue a -drop k (MaxQ q) = MaxQ (Min.drop k q) - --- | /O(k log n)/. Equivalent to @(take k queue, drop k queue)@. -splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) -splitAt k (MaxQ q) = (map unDown xs, MaxQ q') where - (xs, q') = Min.splitAt k q - --- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the --- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. -takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] -takeWhile p (MaxQ q) = map unDown (Min.takeWhile (p . unDown) q) - --- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. -dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q) - --- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- satisfy @p@ and second element is the remainder of the queue. --- -span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -span p (MaxQ q) = (map unDown xs, MaxQ q') where - (xs, q') = Min.span (p . unDown) q - --- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- /do not satisfy/ @p@ and second element is the remainder of the queue. -break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -break p = span (not . p) - --- | /O(n)/. Returns a queue of those elements which satisfy the predicate. -filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q) - --- | /O(n)/. Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, --- and the right queue contains those that do not. -partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) -partition p (MaxQ q) = (MaxQ q0, MaxQ q1) - where (q0, q1) = Min.partition (p . unDown) q - --- | /O(n)/. Maps a function over the elements of the queue, and collects the 'Just' values. -mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b -mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\ (Down x) -> Down <$> f x) q) - --- | /O(n)/. Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. -mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) -mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1) - where (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q - --- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue. --- /Does not check the precondition/. -mapU :: (a -> b) -> MaxQueue a -> MaxQueue b -mapU f (MaxQ q) = MaxQ (Min.mapU (\ (Down a) -> Down (f a)) q) - --- | /O(n)/. Unordered right fold on a priority queue. -foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b -foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q - --- | /O(n)/. Unordered left fold on a priority queue. -foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b -foldlU f z (MaxQ q) = Min.foldlU (foldl f) z q - -{-# INLINE elemsU #-} --- | Equivalent to 'toListU'. -elemsU :: MaxQueue a -> [a] -elemsU = toListU - -{-# INLINE toListU #-} --- | /O(n)/. Returns a list of the elements of the priority queue, in no particular order. -toListU :: MaxQueue a -> [a] -toListU (MaxQ q) = map unDown (Min.toListU q) - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. --- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. -foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b -foldrAsc = foldlDesc . flip - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. --- @'foldlAsc' f z q == 'foldrDesc' (flip f) z q@. -foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlAsc = foldrDesc . flip - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. -foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b -foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. -foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q - -{-# INLINE toAscList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. -toAscList :: Ord a => MaxQueue a -> [a] -toAscList q = build (\ c nil -> foldrAsc c nil q) --- I can see no particular reason this does not simply forward to Min.toDescList. (lsp, 2016) - -{-# INLINE toDescList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in descending order. -toDescList :: Ord a => MaxQueue a -> [a] -toDescList q = build (\ c nil -> foldrDesc c nil q) --- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016) - -{-# INLINE toList #-} --- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'. --- --- If the order of the elements is irrelevant, consider using 'toListU'. -toList :: Ord a => MaxQueue a -> [a] -toList (MaxQ q) = map unDown (Min.toList q) - -{-# INLINE fromAscList #-} --- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. -fromAscList :: [a] -> MaxQueue a -fromAscList = MaxQ . Min.fromDescList . map Down - -{-# INLINE fromDescList #-} --- | /O(n)/. Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. -fromDescList :: [a] -> MaxQueue a -fromDescList = MaxQ . Min.fromAscList . map Down - -{-# INLINE fromList #-} --- | /O(n log n)/. Constructs a priority queue from an unordered list. -fromList :: Ord a => [a] -> MaxQueue a -fromList = foldr insert empty - --- | /O(n)/. Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. -keysQueue :: Prio.MaxPQueue k a -> MaxQueue k -keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q) - --- | /O(log n)/. Forces the spine of the heap. -seqSpine :: MaxQueue a -> b -> b -seqSpine (MaxQ q) = Min.seqSpine q diff --git a/Data/PQueue/Min.hs b/Data/PQueue/Min.hs deleted file mode 100644 --- a/Data/PQueue/Min.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.PQueue.Min --- Copyright : (c) Louis Wasserman 2010 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- General purpose priority queue, supporting extract-minimum operations. --- --- An amortized running time is given for each operation, with /n/ referring --- to the length of the sequence and /k/ being the integral index used by --- some operations. These bounds hold even in a persistent (shared) setting. --- --- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. --- --- This implementation does not guarantee stable behavior. --- --- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for --- unordered. No guarantees whatsoever are made on the execution or traversal order of --- these functions. ------------------------------------------------------------------------------ -module Data.PQueue.Min ( - MinQueue, - -- * Basic operations - empty, - null, - size, - -- * Query operations - findMin, - getMin, - deleteMin, - deleteFindMin, - minView, - -- * Construction operations - singleton, - insert, - insertBehind, - union, - unions, - -- * Subsets - -- ** Extracting subsets - (!!), - take, - drop, - splitAt, - -- ** Predicates - takeWhile, - dropWhile, - span, - break, - -- * Filter/Map - filter, - partition, - mapMaybe, - mapEither, - -- * Fold\/Functor\/Traversable variations - map, - foldrAsc, - foldlAsc, - foldrDesc, - foldlDesc, - -- * List operations - toList, - toAscList, - toDescList, - fromList, - fromAscList, - fromDescList, - -- * Unordered operations - mapU, - foldrU, - foldlU, - elemsU, - toListU, - -- * Miscellaneous operations - keysQueue, - seqSpine) where - -import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) - -import Data.Monoid (Monoid(mempty, mappend, mconcat)) -import Data.Foldable (foldl, foldr, foldl') -import Data.Maybe (fromMaybe) - -import qualified Data.List as List - -import Data.PQueue.Internals - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - --- instance - -instance (Ord a, Show a) => Show (MinQueue a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) - -instance Read a => Read (MinQueue a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP - xs <- readPrec - return (fromAscList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromAscList",s) <- lex r - (xs,t) <- reads s - return (fromAscList xs,t) -#endif - -instance Ord a => Monoid (MinQueue a) where - mempty = empty - mappend = union - mconcat = unions - --- | /O(1)/. Returns the minimum element. Throws an error on an empty queue. -findMin :: MinQueue a -> a -findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin - --- | /O(log n)/. Deletes the minimum element. If the queue is empty, does nothing. -deleteMin :: Ord a => MinQueue a -> MinQueue a -deleteMin q = case minView q of - Nothing -> empty - Just (_, q') -> q' - --- | /O(log n)/. Extracts the minimum element. Throws an error on an empty queue. -deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) -deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView - --- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. -unions :: Ord a => [MinQueue a] -> MinQueue a -unions = foldl union empty - --- | /O(k log n)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest --- element in the queue. Equivalent to @toAscList queue !! k@. -(!!) :: Ord a => MinQueue a -> Int -> a -q !! n | n >= size q - = error "Data.PQueue.Min.!!: index too large" -q !! n = (List.!!) (toAscList q) n - -{-# INLINE takeWhile #-} --- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the --- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. -takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] -takeWhile p = foldWhileFB p . toAscList - -{-# INLINE foldWhileFB #-} --- | Equivalent to Data.List.takeWhile, but is a better producer. -foldWhileFB :: (a -> Bool) -> [a] -> [a] -foldWhileFB p xs0 = build (\ c nil -> let - consWhile x xs - | p x = x `c` xs - | otherwise = nil - in foldr consWhile nil xs0) - --- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. -dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a -dropWhile p = drop' where - drop' q = case minView q of - Just (x, q') | p x -> drop' q' - _ -> q - --- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- satisfy @p@ and second element is the remainder of the queue. -span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) -span p queue = case minView queue of - Just (x, q') - | p x -> let (ys, q'') = span p q' in (x:ys, q'') - _ -> ([], queue) - --- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- /do not satisfy/ @p@ and second element is the remainder of the queue. -break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) -break p = span (not . p) - -{-# INLINE take #-} --- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, --- or all elements of @queue@ itself if @k >= 'size' queue@. -take :: Ord a => Int -> MinQueue a -> [a] -take n = List.take n . toAscList - --- | /O(k log n)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, --- or an empty queue if @k >= size 'queue'@. -drop :: Ord a => Int -> MinQueue a -> MinQueue a -drop n queue = n `seq` case minView queue of - Just (_, queue') - | n > 0 -> drop (n-1) queue' - _ -> queue - --- | /O(k log n)/. Equivalent to @('take' k queue, 'drop' k queue)@. -splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) -splitAt n queue = n `seq` case minView queue of - Just (x, queue') - | n > 0 -> let (xs, queue'') = splitAt (n-1) queue' in (x:xs, queue'') - _ -> ([], queue) - --- | /O(n)/. Returns the queue with all elements not satisfying @p@ removed. -filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a -filter p = mapMaybe (\ x -> if p x then Just x else Nothing) - --- | /O(n)/. Returns a pair where the first queue contains all elements satisfying @p@, and the second queue --- contains all elements not satisfying @p@. -partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) -partition p = mapEither (\ x -> if p x then Left x else Right x) - --- | /O(n)/. Creates a new priority queue containing the images of the elements of this queue. --- Equivalent to @'fromList' . 'Data.List.map' f . toList@. -map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b -map f = foldrU (insert . f) empty - -{-# INLINE toAscList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. -toAscList :: Ord a => MinQueue a -> [a] -toAscList queue = build (\ c nil -> foldrAsc c nil queue) - -{-# INLINE toDescList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in descending order. -toDescList :: Ord a => MinQueue a -> [a] -toDescList queue = build (\ c nil -> foldrDesc c nil queue) - -{-# INLINE toList #-} --- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. --- --- If the order of the elements is irrelevant, consider using 'toListU'. -toList :: Ord a => MinQueue a -> [a] -toList = toAscList - -{-# RULES - "toAscList" forall q . toAscList q = build (\ c nil -> foldrAsc c nil q); - -- inlining doesn't seem to be working out =/ - "toDescList" forall q . toDescList q = build (\ c nil -> foldrDesc c nil q); - #-} - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. --- @foldrDesc f z q == foldlAsc (flip f) z q@. -foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b -foldrDesc = foldlAsc . flip - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. --- @foldlDesc f z q == foldrAsc (flip f) z q@. -foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b -foldlDesc = foldrAsc . flip - -{-# INLINE fromList #-} --- | /O(n)/. Constructs a priority queue from an unordered list. -fromList :: Ord a => [a] -> MinQueue a -fromList = foldr insert empty - -{-# RULES - "fromList" fromList = foldr insert empty; - "fromAscList" fromAscList = foldr insertMinQ empty; - #-} - -{-# INLINE fromAscList #-} --- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. -fromAscList :: [a] -> MinQueue a -fromAscList = foldr insertMinQ empty - --- | /O(n)/. Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. -fromDescList :: [a] -> MinQueue a -fromDescList = foldl' (flip insertMinQ) empty - --- | Maps a function over the elements of the queue, ignoring order. This function is only safe if the function is monotonic. --- This function /does not/ check the precondition. -mapU :: (a -> b) -> MinQueue a -> MinQueue b -mapU = mapMonotonic - -{-# INLINE elemsU #-} --- | Equivalent to 'toListU'. -elemsU :: MinQueue a -> [a] -elemsU = toListU - --- | /O(n)/. Returns the elements of the queue, in no particular order. -toListU :: MinQueue a -> [a] -toListU q = build (\ c n -> foldrU c n q) - -{-# RULES - "foldr/toListU" forall f z q . foldr f z (toListU q) = foldrU f z q; - "foldl/toListU" forall f z q . foldl f z (toListU q) = foldlU f z q; - #-} diff --git a/Data/PQueue/Prio/Internals.hs b/Data/PQueue/Prio/Internals.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Internals.hs +++ /dev/null @@ -1,489 +0,0 @@ -{-# LANGUAGE CPP #-} -module Data.PQueue.Prio.Internals ( - MinPQueue(..), - BinomForest(..), - BinomHeap, - BinomTree(..), - Zero(..), - Succ(..), - CompF, - empty, - null, - size, - singleton, - insert, - insertBehind, - union, - getMin, - adjustMinWithKey, - updateMinWithKey, - minViewWithKey, - mapWithKey, - mapKeysMonotonic, - mapMaybeWithKey, - mapEitherWithKey, - foldrWithKey, - foldlWithKey, - insertMin, - foldrWithKeyU, - foldlWithKeyU, - traverseWithKeyU, - seqSpine, - mapForest - ) where - -import Control.Applicative (Applicative(..), (<$>)) -import Control.Applicative.Identity (Identity(Identity, runIdentity)) -import Control.DeepSeq (NFData(rnf), deepseq) - -import Data.Monoid (Monoid (..)) - -import Prelude hiding (null) - -#if __GLASGOW_HASKELL__ - -import Data.Data - -instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where - gfoldl f z m = z (foldr (uncurry' insertMin) empty) `f` foldrWithKey (curry (:)) [] m - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.PQueue.Prio.Min.MinPQueue" - dataCast2 f = gcast2 f - -#endif - -(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -(f .: g) x y = f (g x y) - -first' :: (a -> b) -> (a, c) -> (b, c) -first' f (a, c) = (f a, c) - -second' :: (b -> c) -> (a, b) -> (a, c) -second' f (a, b) = (a, f b) - -uncurry' :: (a -> b -> c) -> (a, b) -> c -uncurry' f (a, b) = f a b - -infixr 8 .: - --- | A priority queue where values of type @a@ are annotated with keys of type @k@. --- The queue supports extracting the element with minimum key. -data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int k a (BinomHeap k a) -#if __GLASGOW_HASKELL__ - deriving (Typeable) -#endif - -data BinomForest rk k a = - Nil | - Skip (BinomForest (Succ rk) k a) | - Cons {-# UNPACK #-} !(BinomTree rk k a) (BinomForest (Succ rk) k a) -type BinomHeap = BinomForest Zero - -data BinomTree rk k a = BinomTree k a (rk k a) -data Zero k a = Zero -data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a) - -type CompF a = a -> a -> Bool - -instance (Ord k, Eq a) => Eq (MinPQueue k a) where - MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 = - n1 == n2 && eqExtract k1 a1 ts1 k2 a2 ts2 - Empty == Empty = True - _ == _ = False - -eqExtract :: - (Ord k, Eq a) => - k -> a -> BinomForest rk k a -> - k -> a -> BinomForest rk k a -> - Bool -eqExtract k10 a10 ts10 k20 a20 ts20 = - k10 == k20 && a10 == a20 && - case (extract ts10, extract ts20) of - (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) - -> eqExtract k1 a1 ts1' k2 a2 ts2' - (No, No) -> True - _ -> False - -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -infixr 6 <> - -instance (Ord k, Ord a) => Ord (MinPQueue k a) where - MinPQ _n1 k10 a10 ts10 `compare` MinPQ _n2 k20 a20 ts20 = - cmpExtract k10 a10 ts10 k20 a20 ts20 - Empty `compare` Empty = EQ - Empty `compare` MinPQ{} = LT - MinPQ{} `compare` Empty = GT - -cmpExtract :: - (Ord k, Ord a) => - k -> a -> BinomForest rk k a -> - k -> a -> BinomForest rk k a -> - Ordering -cmpExtract k10 a10 ts10 k20 a20 ts20 = - k10 `compare` k20 <> a10 `compare` a20 <> - case (extract ts10, extract ts20) of - (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) - -> cmpExtract k1 a1 ts1' k2 a2 ts2' - (No, Yes{}) -> LT - (Yes{}, No) -> GT - (No, No) -> EQ - --- | /O(1)/. Returns the empty priority queue. -empty :: MinPQueue k a -empty = Empty - --- | /O(1)/. Checks if this priority queue is empty. -null :: MinPQueue k a -> Bool -null Empty = True -null _ = False - --- | /O(1)/. Returns the size of this priority queue. -size :: MinPQueue k a -> Int -size Empty = 0 -size (MinPQ n _ _ _) = n - --- | /O(1)/. Constructs a singleton priority queue. -singleton :: k -> a -> MinPQueue k a -singleton k a = MinPQ 1 k a Nil - --- | Amortized /O(1)/, worst-case /O(log n)/. Inserts --- an element with the specified key into the queue. -insert :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a -insert = insert' (<=) - --- | Amortized /O(1)/, worst-case /O(log n)/. Insert an element --- with the specified key into the priority queue, --- putting it behind elements whos key compares equal to the --- inserted one. -insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a -insertBehind = insert' (<) - --- | Internal helper method, using a specific comparator function. -insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a -insert' _ k a Empty = singleton k a -insert' le k a (MinPQ n k' a' ts) - | k `le` k' = MinPQ (n+1) k a (incr le (tip k' a') ts) - | otherwise = MinPQ (n+1) k' a' (incr le (tip k a ) ts) - --- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union --- of the two specified queues. -union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a -union = union' (<=) - --- | Takes the union of the two specified queues, using the given comparison function. -union' :: CompF k -> MinPQueue k a -> MinPQueue k a -> MinPQueue k a -union' le (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2) - | k1 `le` k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2) - | otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1) - where insMerge k a = carryForest le (tip k a) ts1 ts2 -union' _ Empty q2 = q2 -union' _ q1 Empty = q1 - --- | /O(1)/. The minimal (key, element) in the queue, if the queue is nonempty. -getMin :: MinPQueue k a -> Maybe (k, a) -getMin (MinPQ _ k a _) = Just (k, a) -getMin _ = Nothing - --- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. -adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a -adjustMinWithKey _ Empty = Empty -adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. --- If the queue is empty, does nothing. -updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> MinPQueue k a -> MinPQueue k a -updateMinWithKey _ Empty = Empty -updateMinWithKey f (MinPQ n k a ts) = case f k a of - Nothing -> extractHeap (<=) n ts - Just a' -> MinPQ n k a' ts - --- | /O(log n)/. Retrieves the minimal (key, value) pair of the map, and the map stripped of that --- element, or 'Nothing' if passed an empty map. -minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a) -minViewWithKey Empty = Nothing -minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap (<=) n ts) - --- | /O(n)/. Map a function over all values in the queue. -mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b -mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f) - --- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly --- monotonic. /The precondition is not checked./ This function has better performance than --- 'mapKeys'. -mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a -mapKeysMonotonic _ Empty = Empty -mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts) - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b -mapMaybeWithKey _ Empty = Empty -mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF (<=) f (const Empty) ts) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) -mapEitherWithKey _ Empty = (Empty, Empty) -mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a) - (mapEitherF (<=) f (const (Empty, Empty)) ts) - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. --- --- If you do not care about the traversal order, consider using 'foldrWithKeyU'. -foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MinPQueue k a -> b -foldrWithKey _ z Empty = z -foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where - foldF ts = case extract ts of - Yes (Extract k a _ ts') -> f k a (foldF ts') - _ -> z - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. --- --- If you do not care about the traversal order, consider using 'foldlWithKeyU'. -foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MinPQueue k a -> b -foldlWithKey _ z Empty = z -foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where - foldF z ts = case extract ts of - Yes (Extract k a _ ts') -> foldF (f z k a) ts' - _ -> z - --- | Equivalent to 'insert', save the assumption that this key is @<=@ --- every other key in the map. /The precondition is not checked./ -insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a -insertMin k a Empty = MinPQ 1 k a Nil -insertMin k a (MinPQ n k' a' ts) = MinPQ (n+1) k a (incrMin (tip k' a') ts) - --- | /O(1)/. Returns a binomial tree of rank zero containing this --- key and value. -tip :: k -> a -> BinomTree Zero k a -tip k a = BinomTree k a Zero - --- | /O(1)/. Takes the union of two binomial trees of the same rank. -meld :: CompF k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a -meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) - | k1 `le` k2 = BinomTree k1 v1 (Succ t2 ts1) - | otherwise = BinomTree k2 v2 (Succ t1 ts2) - --- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. -mergeForest :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a -mergeForest le f1 f2 = case (f1, f2) of - (Skip ts1, Skip ts2) -> Skip (mergeForest le ts1 ts2) - (Skip ts1, Cons t2 ts2) -> Cons t2 (mergeForest le ts1 ts2) - (Cons t1 ts1, Skip ts2) -> Cons t1 (mergeForest le ts1 ts2) - (Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest le (meld le t1 t2) ts1 ts2) - (Nil, _) -> f2 - (_, Nil) -> f1 - --- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. --- Analogous to binary addition when a digit has been carried. -carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a -carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of - (Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2) - (Cons t1 ts1, Skip ts2) -> Skip (carryMeld t0 t1 ts1 ts2) - (Skip ts1, Cons t2 ts2) -> Skip (carryMeld t0 t2 ts1 ts2) - (Skip ts1, Skip ts2) -> Cons t0 (mergeForest le ts1 ts2) - (Nil, _) -> incr le t0 f2 - (_, Nil) -> incr le t0 f1 - where carryMeld = carryForest le .: meld le - --- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. -incr :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -incr le t ts = t `seq` case ts of - Nil -> Cons t Nil - Skip ts' -> Cons t ts' - Cons t' ts' -> Skip (incr le (meld le t t') ts') - --- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree --- is less than all other roots. Analogous to binary incrementation. Equivalent to --- @'incr' (\ _ _ -> True)@. -incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -incrMin t@(BinomTree k a ts) tss = case tss of - Nil -> Cons t Nil - Skip tss' -> Cons t tss' - Cons t' tss' -> Skip (incrMin (BinomTree k a (Succ t' ts)) tss') - -extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a -extractHeap le n ts = n `seq` case extractForest le ts of - No -> Empty - Yes (Extract k a _ ts') -> MinPQ (n-1) k a ts' - --- | A specialized type intended to organize the return of extract-min queries --- from a binomial forest. We walk all the way through the forest, and then --- walk backwards. @Extract rk a@ is the result type of an extract-min --- operation that has walked as far backwards of rank @rk@ -- that is, it --- has visited every root of rank @>= rk@. --- --- The interpretation of @Extract minKey minVal children forest@ is --- --- * @minKey@ is the key of the minimum root visited so far. It may have --- any rank @>= rk@. We will denote the root corresponding to --- @minKey@ as @minRoot@. --- --- * @minVal@ is the value corresponding to @minKey@. --- --- * @children@ is those children of @minRoot@ which have not yet been --- merged with the rest of the forest. Specifically, these are --- the children with rank @< rk@. --- --- * @forest@ is an accumulating parameter that maintains the partial --- reconstruction of the binomial forest without @minRoot@. It is --- the union of all old roots with rank @>= rk@ (except @minRoot@), --- with the set of all children of @minRoot@ with rank @>= rk@. --- Note that @forest@ is lazy, so if we discover a smaller key --- than @minKey@ later, we haven't wasted significant work. - -data Extract rk k a = Extract k a (rk k a) (BinomForest rk k a) -data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) - -incrExtract :: CompF k -> Maybe (BinomTree rk k a) -> Extract (Succ rk) k a -> Extract rk k a -incrExtract _ Nothing (Extract k a (Succ t ts) tss) - = Extract k a ts (Cons t tss) -incrExtract le (Just t) (Extract k a (Succ t' ts) tss) - = Extract k a ts (Skip (incr le (meld le t t') tss)) - --- | Walks backward from the biggest key in the forest, as far as rank @rk@. --- Returns its progress. Each successive application of @extractBin@ takes --- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. -extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a -extractForest _ Nil = No -extractForest le (Skip tss) = case extractForest le tss of - No -> No - Yes ex -> Yes (incrExtract le Nothing ex) -extractForest le (Cons t@(BinomTree k a0 ts) tss) = Yes $ case extractForest le tss of - Yes ex@(Extract k' _ _ _) - | k' incrExtract le (Just t) ex - _ -> Extract k a0 ts (Skip tss) - where - a BinomForest rk k a -> MExtract rk k a -extract = extractForest (<=) - --- | Utility function for mapping over a forest. -mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b -mapForest f fCh ts0 = case ts0 of - Nil -> Nil - Skip ts' -> Skip (mapForest f fCh' ts') - Cons (BinomTree k a ts) tss - -> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss) - where fCh' (Succ (BinomTree k a ts) tss) - = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss) - --- | Utility function for mapping a 'Maybe' function over a forest. -mapMaybeF :: CompF k -> (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> - BinomForest rk k a -> MinPQueue k b -mapMaybeF le f fCh ts0 = case ts0 of - Nil -> Empty - Skip ts' -> mapMaybeF le f fCh' ts' - Cons (BinomTree k a ts) ts' - -> insF k a (fCh ts) (mapMaybeF le f fCh' ts') - where insF k a = maybe id (insert' le k) (f k a) .: union' le - fCh' (Succ (BinomTree k a ts) tss) = - insF k a (fCh ts) (fCh tss) - --- | Utility function for mapping an 'Either' function over a forest. -mapEitherF :: CompF k -> (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) -> - BinomForest rk k a -> (MinPQueue k b, MinPQueue k c) -mapEitherF le f0 fCh ts0 = case ts0 of - Nil -> (Empty, Empty) - Skip ts' -> mapEitherF le f0 fCh' ts' - Cons (BinomTree k a ts) ts' - -> insF k a (fCh ts) (mapEitherF le f0 fCh' ts') - where - insF k a = either (first' . insert' le k) (second' . insert' le k) (f0 k a) .: - (union' le `both` union' le) - fCh' (Succ (BinomTree k a ts) tss) = - insF k a (fCh ts) (fCh tss) - both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b -foldrWithKeyU _ z Empty = z -foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z) - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b -foldlWithKeyU _ z Empty = z -foldlWithKeyU f z0 (MinPQ _ k0 a0 ts) = foldlWithKeyF_ (\ k a z -> f z k a) (const id) ts (f z0 k0 a0) - -traverseWithKeyU :: Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) -traverseWithKeyU _ Empty = pure Empty -traverseWithKeyU f (MinPQ n k a ts) = MinPQ n k <$> f k a <*> traverseForest f (const (pure Zero)) ts - -{-# SPECIALIZE traverseForest :: (k -> a -> Identity b) -> (rk k a -> Identity (rk k b)) -> BinomForest rk k a -> - Identity (BinomForest rk k b) #-} -traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b) -traverseForest f fCh ts0 = case ts0 of - Nil -> pure Nil - Skip ts' -> Skip <$> traverseForest f fCh' ts' - Cons (BinomTree k a ts) tss - -> Cons <$> (BinomTree k <$> f k a <*> fCh ts) <*> traverseForest f fCh' tss - where - fCh' (Succ (BinomTree k a ts) tss) - = Succ <$> (BinomTree k <$> f k a <*> fCh ts) <*> fCh tss - --- | Unordered right fold on a binomial forest. -foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b -foldrWithKeyF_ f fCh ts0 z0 = case ts0 of - Nil -> z0 - Skip ts' -> foldrWithKeyF_ f fCh' ts' z0 - Cons (BinomTree k a ts) ts' - -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0)) - where - fCh' (Succ (BinomTree k a ts) tss) z = - f k a (fCh ts (fCh tss z)) - --- | Unordered left fold on a binomial forest. -foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b -foldlWithKeyF_ f fCh ts0 = case ts0 of - Nil -> id - Skip ts' -> foldlWithKeyF_ f fCh' ts' - Cons (BinomTree k a ts) ts' - -> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a - where - fCh' (Succ (BinomTree k a ts) tss) = - fCh tss . fCh ts . f k a - --- | Maps a monotonic function over the keys in a binomial forest. -mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a -mapKeysMonoF f fCh ts0 = case ts0 of - Nil -> Nil - Skip ts' -> Skip (mapKeysMonoF f fCh' ts') - Cons (BinomTree k a ts) ts' - -> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts') - where - fCh' (Succ (BinomTree k a ts) tss) = - Succ (BinomTree (f k) a (fCh ts)) (fCh tss) - --- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. -seqSpine :: MinPQueue k a -> b -> b -seqSpine Empty z0 = z0 -seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where - seqSpineF :: BinomForest rk k a -> b -> b - seqSpineF ts z = case ts of - Nil -> z - Skip ts' -> seqSpineF ts' z - Cons _ ts' -> seqSpineF ts' z - -class NFRank rk where - rnfRk :: (NFData k, NFData a) => rk k a -> () - -instance NFRank Zero where - rnfRk _ = () - -instance NFRank rk => NFRank (Succ rk) where - rnfRk (Succ t ts) = t `deepseq` rnfRk ts - -instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where - rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts - -instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where - rnf Nil = () - rnf (Skip tss) = rnf tss - rnf (Cons t tss) = t `deepseq` rnf tss - -instance (NFData k, NFData a) => NFData (MinPQueue k a) where - rnf Empty = () - rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts diff --git a/Data/PQueue/Prio/Max.hs b/Data/PQueue/Prio/Max.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Max.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.PQueue.Prio.Max --- Copyright : (c) Louis Wasserman 2010 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- General purpose priority queue. --- Each element is associated with a /key/, and the priority queue supports --- viewing and extracting the element with the maximum key. --- --- A worst-case bound is given for each operation. In some cases, an amortized --- bound is also specified; these bounds do not hold in a persistent context. --- --- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. --- --- We do not guarantee stable behavior. --- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there --- are no guarantees about the relative order in which @k1@, @k2@, and their associated --- elements are returned. (Unlike Data.Map, we allow multiple elements with the --- same key.) --- --- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for --- unordered. No guarantees whatsoever are made on the execution or traversal order of --- these functions. ------------------------------------------------------------------------------ -module Data.PQueue.Prio.Max ( - MaxPQueue, - -- * Construction - empty, - singleton, - insert, - insertBehind, - union, - unions, - -- * Query - null, - size, - -- ** Maximum view - findMax, - getMax, - deleteMax, - deleteFindMax, - adjustMax, - adjustMaxWithKey, - updateMax, - updateMaxWithKey, - maxView, - maxViewWithKey, - -- * Traversal - -- ** Map - map, - mapWithKey, - mapKeys, - mapKeysMonotonic, - -- ** Fold - foldrWithKey, - foldlWithKey, - -- ** Traverse - traverseWithKey, - -- * Subsets - -- ** Indexed - take, - drop, - splitAt, - -- ** Predicates - takeWhile, - takeWhileWithKey, - dropWhile, - dropWhileWithKey, - span, - spanWithKey, - break, - breakWithKey, - -- *** Filter - filter, - filterWithKey, - partition, - partitionWithKey, - mapMaybe, - mapMaybeWithKey, - mapEither, - mapEitherWithKey, - -- * List operations - -- ** Conversion from lists - fromList, - fromAscList, - fromDescList, - -- ** Conversion to lists - keys, - elems, - assocs, - toAscList, - toDescList, - toList, - -- * Unordered operations - foldrU, - foldrWithKeyU, - foldlU, - foldlWithKeyU, - traverseU, - traverseWithKeyU, - keysU, - elemsU, - assocsU, - toListU, - -- * Helper methods - seqSpine - ) - where - -import Control.Applicative (Applicative, (<$>)) -import Data.Monoid (Monoid(mempty, mappend, mconcat)) -import Data.Traversable (Traversable(traverse)) -import Data.Foldable (Foldable, foldr, foldl) -import Data.Maybe (fromMaybe) -import Data.PQueue.Prio.Max.Internals - -import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null, foldr, foldl) - -import qualified Data.PQueue.Prio.Min as Q - -#ifdef __GLASGOW_HASKELL__ -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - -first' :: (a -> b) -> (a, c) -> (b, c) -first' f (a, c) = (f a, c) - -instance Ord k => Monoid (MaxPQueue k a) where - mempty = empty - mappend = union - mconcat = unions - -instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromDescList " . shows (toDescList xs) - -instance (Read k, Read a) => Read (MaxPQueue k a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromDescList" <- lexP - xs <- readPrec - return (fromDescList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromDescList",s) <- lex r - (xs,t) <- reads s - return (fromDescList xs,t) -#endif - -instance Functor (MaxPQueue k) where - fmap f (MaxPQ q) = MaxPQ (fmap f q) - -instance Ord k => Foldable (MaxPQueue k) where - foldr f z (MaxPQ q) = foldr f z q - foldl f z (MaxPQ q) = foldl f z q - -instance Ord k => Traversable (MaxPQueue k) where - traverse f (MaxPQ q) = MaxPQ <$> traverse f q - --- | /O(1)/. Returns the empty priority queue. -empty :: MaxPQueue k a -empty = MaxPQ Q.empty - --- | /O(1)/. Constructs a singleton priority queue. -singleton :: k -> a -> MaxPQueue k a -singleton k a = MaxPQ (Q.singleton (Down k) a) - --- | Amortized /O(1)/, worst-case /O(log n)/. Inserts --- an element with the specified key into the queue. -insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insert k a (MaxPQ q) = MaxPQ (Q.insert (Down k) a q) - --- | Amortized /O(1)/, worst-case /O(log n)/. Insert an element into the priority queue, --- putting it behind elements that compare equal to the inserted one. -insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) - --- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union --- of the two specified queues. -union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a -MaxPQ q1 `union` MaxPQ q2 = MaxPQ (q1 `Q.union` q2) - --- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). -unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a -unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs]) - --- | /O(1)/. Checks if this priority queue is empty. -null :: MaxPQueue k a -> Bool -null (MaxPQ q) = Q.null q - --- | /O(1)/. Returns the size of this priority queue. -size :: MaxPQueue k a -> Int -size (MaxPQ q) = Q.size q - --- | /O(1)/. The maximal (key, element) in the queue. Calls 'error' if empty. -findMax :: MaxPQueue k a -> (k, a) -findMax = fromMaybe (error "Error: findMax called on an empty queue") . getMax - --- | /O(1)/. The maximal (key, element) in the queue, if the queue is nonempty. -getMax :: MaxPQueue k a -> Maybe (k, a) -getMax (MaxPQ q) = do - (Down k, a) <- Q.getMin q - return (k, a) - --- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. -deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a -deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q) - --- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. -deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) -deleteFindMax = fromMaybe (error "Error: deleteFindMax called on an empty queue") . maxViewWithKey - --- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. -adjustMax :: (a -> a) -> MaxPQueue k a -> MaxPQueue k a -adjustMax = adjustMaxWithKey . const - --- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. -adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a -adjustMaxWithKey f (MaxPQ q) = MaxPQ (Q.adjustMinWithKey (f . unDown) q) - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. --- If the queue is empty, does nothing. -updateMax :: Ord k => (a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a -updateMax = updateMaxWithKey . const - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. --- If the queue is empty, does nothing. -updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a -updateMaxWithKey f (MaxPQ q) = MaxPQ (Q.updateMinWithKey (f . unDown) q) - --- | /O(log n)/. Retrieves the value associated with the maximum key of the queue, and the queue --- stripped of that element, or 'Nothing' if passed an empty queue. -maxView :: Ord k => MaxPQueue k a -> Maybe (a, MaxPQueue k a) -maxView q = do - ((_, a), q') <- maxViewWithKey q - return (a, q') - --- | /O(log n)/. Retrieves the maximal (key, value) pair of the map, and the map stripped of that --- element, or 'Nothing' if passed an empty map. -maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a) -maxViewWithKey (MaxPQ q) = do - ((Down k, a), q') <- Q.minViewWithKey q - return ((k, a), MaxPQ q') - --- | /O(n)/. Map a function over all values in the queue. -map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b -map = mapWithKey . const - --- | /O(n)/. Map a function over all values in the queue. -mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b -mapWithKey f (MaxPQ q) = MaxPQ (Q.mapWithKey (f . unDown) q) - --- | /O(n)/. Map a function over all values in the queue. -mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q) - --- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly --- monotonic. /The precondition is not checked./ This function has better performance than --- 'mapKeys'. -mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q) - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. --- --- If you do not care about the traversal order, consider using 'foldrWithKeyU'. -foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. --- --- If you do not care about the traversal order, consider using 'foldlWithKeyU'. -foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\ z -> f z . unDown) z0 q - --- | /O(n log n)/. Traverses the elements of the queue in descending order by key. --- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) --- --- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. -traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (f . unDown) q - --- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. --- (@'take' k q == 'List.take' k ('toDescList' q)@) -take :: Ord k => Int -> MaxPQueue k a -> [(k, a)] -take k (MaxPQ q) = fmap (first' unDown) (Q.take k q) - --- | /O(k log n)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. -drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a -drop k (MaxPQ q) = MaxPQ (Q.drop k q) - --- | /O(k log n)/. Equivalent to @('take' k q, 'drop' k q)@. -splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -splitAt k (MaxPQ q) = case Q.splitAt k q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) -takeWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhile = takeWhileWithKey . const - --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) -takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q) - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -dropWhile = dropWhileWithKey . const - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -dropWhileWithKey p (MaxPQ q) = MaxPQ (Q.dropWhileWithKey (p . unDown) q) - --- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. -span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -span = spanWithKey . const - --- | Equivalent to @'span' ('not' . p)@. -break :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -break = breakWithKey . const - --- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. -spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -spanWithKey p (MaxPQ q) = case Q.spanWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. -breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | /O(n)/. Filter all values that satisfy the predicate. -filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -filter = filterWithKey . const - --- | /O(n)/. Filter all values that satisfy the predicate. -filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -filterWithKey p (MaxPQ q) = MaxPQ (Q.filterWithKey (p . unDown) q) - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partition :: Ord k => (a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) -partition = partitionWithKey . const - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) -partitionWithKey p (MaxPQ q) = case Q.partitionWithKey (p . unDown) q of - (q1, q0) -> (MaxPQ q1, MaxPQ q0) - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b -mapMaybe = mapMaybeWithKey . const - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b -mapMaybeWithKey f (MaxPQ q) = MaxPQ (Q.mapMaybeWithKey (f . unDown) q) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) -mapEither = mapEitherWithKey . const - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) -mapEitherWithKey f (MaxPQ q) = case Q.mapEitherWithKey (f . unDown) q of - (qL, qR) -> (MaxPQ qL, MaxPQ qR) - --- | /O(n)/. Build a priority queue from the list of (key, value) pairs. -fromList :: Ord k => [(k, a)] -> MaxPQueue k a -fromList = MaxPQ . Q.fromList . fmap (first' Down) - --- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ -fromAscList :: [(k, a)] -> MaxPQueue k a -fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down) - --- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ -fromDescList :: [(k, a)] -> MaxPQueue k a -fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down) - --- | /O(n log n)/. Return all keys of the queue in descending order. -keys :: Ord k => MaxPQueue k a -> [k] -keys = fmap fst . toDescList - --- | /O(n log n)/. Return all elements of the queue in descending order by key. -elems :: Ord k => MaxPQueue k a -> [a] -elems = fmap snd . toDescList - --- | /O(n log n)/. Equivalent to 'toDescList'. -assocs :: Ord k => MaxPQueue k a -> [(k, a)] -assocs = toDescList - --- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. -toAscList :: Ord k => MaxPQueue k a -> [(k, a)] -toAscList (MaxPQ q) = fmap (first' unDown) (Q.toDescList q) - --- | /O(n log n)/. Return all (key, value) pairs in descending order by key. -toDescList :: Ord k => MaxPQueue k a -> [(k, a)] -toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q) - --- | /O(n log n)/. Equivalent to 'toDescList'. --- --- If the traversal order is irrelevant, consider using 'toListU'. -toList :: Ord k => MaxPQueue k a -> [(k, a)] -toList = toDescList - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrU :: (a -> b -> b) -> b -> MaxPQueue k a -> b -foldrU = foldrWithKeyU . const - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (f . unDown) z q - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlU :: (b -> a -> b) -> b -> MaxPQueue k a -> b -foldlU f = foldlWithKeyU (const . f) - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (\ z -> f z . unDown) z0 q - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseU :: (Applicative f) => (a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseU = traverseWithKeyU . const - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseWithKeyU :: (Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (f . unDown) q - --- | /O(n)/. Return all keys of the queue in no particular order. -keysU :: MaxPQueue k a -> [k] -keysU = fmap fst . toListU - --- | /O(n)/. Return all elements of the queue in no particular order. -elemsU :: MaxPQueue k a -> [a] -elemsU = fmap snd . toListU - --- | /O(n)/. Equivalent to 'toListU'. -assocsU :: MaxPQueue k a -> [(k, a)] -assocsU = toListU - --- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. -toListU :: MaxPQueue k a -> [(k, a)] -toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q) - --- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. -seqSpine :: MaxPQueue k a -> b -> b -seqSpine (MaxPQ q) = Q.seqSpine q diff --git a/Data/PQueue/Prio/Max/Internals.hs b/Data/PQueue/Prio/Max/Internals.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Max/Internals.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Data.PQueue.Prio.Max.Internals where - -import Control.DeepSeq (NFData(rnf)) - -import Data.Traversable (Traversable(traverse)) -import Data.Foldable (Foldable(foldr, foldl)) -import Data.Functor ((<$>)) -# if __GLASGOW_HASKELL__ -import Data.Data (Data, Typeable) -# endif - -import Prelude hiding (foldr, foldl) - -import Data.PQueue.Prio.Internals (MinPQueue) - -newtype Down a = Down {unDown :: a} -# if __GLASGOW_HASKELL__ - deriving (Eq, Data, Typeable) -# else - deriving (Eq) -# endif - --- | A priority queue where values of type @a@ are annotated with keys of type @k@. --- The queue supports extracting the element with maximum key. -newtype MaxPQueue k a = MaxPQ (MinPQueue (Down k) a) -# if __GLASGOW_HASKELL__ - deriving (Eq, Ord, Data, Typeable) -# else - deriving (Eq, Ord) -# endif - -instance (NFData k, NFData a) => NFData (MaxPQueue k a) where - rnf (MaxPQ q) = rnf q - -instance NFData a => NFData (Down a) where - rnf (Down a) = rnf a - -instance Ord a => Ord (Down a) where - Down a `compare` Down b = b `compare` a - Down a <= Down b = b <= a - -instance Functor Down where - fmap f (Down a) = Down (f a) - -instance Foldable Down where - foldr f z (Down a) = a `f` z - foldl f z (Down a) = z `f` a - -instance Traversable Down where - traverse f (Down a) = Down <$> f a diff --git a/Data/PQueue/Prio/Min.hs b/Data/PQueue/Prio/Min.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Min.hs +++ /dev/null @@ -1,411 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.PQueue.Prio.Min --- Copyright : (c) Louis Wasserman 2010 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : experimental --- Portability : portable --- --- General purpose priority queue. --- Each element is associated with a /key/, and the priority queue supports --- viewing and extracting the element with the minimum key. --- --- A worst-case bound is given for each operation. In some cases, an amortized --- bound is also specified; these bounds do not hold in a persistent context. --- --- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. --- --- We do not guarantee stable behavior. --- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there --- are no guarantees about the relative order in which @k1@, @k2@, and their associated --- elements are returned. (Unlike Data.Map, we allow multiple elements with the --- same key.) --- --- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for --- unordered. No guarantees whatsoever are made on the execution or traversal order of --- these functions. ------------------------------------------------------------------------------ -module Data.PQueue.Prio.Min ( - MinPQueue, - -- * Construction - empty, - singleton, - insert, - insertBehind, - union, - unions, - -- * Query - null, - size, - -- ** Minimum view - findMin, - getMin, - deleteMin, - deleteFindMin, - adjustMin, - adjustMinWithKey, - updateMin, - updateMinWithKey, - minView, - minViewWithKey, - -- * Traversal - -- ** Map - map, - mapWithKey, - mapKeys, - mapKeysMonotonic, - -- ** Fold - foldrWithKey, - foldlWithKey, - -- ** Traverse - traverseWithKey, - -- * Subsets - -- ** Indexed - take, - drop, - splitAt, - -- ** Predicates - takeWhile, - takeWhileWithKey, - dropWhile, - dropWhileWithKey, - span, - spanWithKey, - break, - breakWithKey, - -- *** Filter - filter, - filterWithKey, - partition, - partitionWithKey, - mapMaybe, - mapMaybeWithKey, - mapEither, - mapEitherWithKey, - -- * List operations - -- ** Conversion from lists - fromList, - fromAscList, - fromDescList, - -- ** Conversion to lists - keys, - elems, - assocs, - toAscList, - toDescList, - toList, - -- * Unordered operations - foldrU, - foldrWithKeyU, - foldlU, - foldlWithKeyU, - traverseU, - traverseWithKeyU, - keysU, - elemsU, - assocsU, - toListU, - -- * Helper methods - seqSpine - ) - where - -import Control.Applicative (Applicative, pure, (<*>), (<$>)) - -import qualified Data.List as List -import qualified Data.Foldable as Fold(Foldable(..)) -import Data.Monoid (Monoid(mempty, mappend, mconcat)) -import Data.Traversable (Traversable(traverse)) -import Data.Foldable (Foldable) -import Data.Maybe (fromMaybe) - -import Data.PQueue.Prio.Internals - -import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - -(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d -(f .: g) x y = f (g x y) - -uncurry' :: (a -> b -> c) -> (a, b) -> c -uncurry' f (a, b) = f a b - -infixr 8 .: - -instance Ord k => Monoid (MinPQueue k a) where - mempty = empty - mappend = union - mconcat = unions - -instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) - -instance (Read k, Read a) => Read (MinPQueue k a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP - xs <- readPrec - return (fromAscList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromAscList",s) <- lex r - (xs,t) <- reads s - return (fromAscList xs,t) -#endif - - --- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). -unions :: Ord k => [MinPQueue k a] -> MinPQueue k a -unions = List.foldl union empty - --- | /O(1)/. The minimal (key, element) in the queue. Calls 'error' if empty. -findMin :: MinPQueue k a -> (k, a) -findMin = fromMaybe (error "Error: findMin called on an empty queue") . getMin - --- | /O(log n)/. Deletes the minimal (key, element) in the queue. Returns an empty queue --- if the queue is empty. -deleteMin :: Ord k => MinPQueue k a -> MinPQueue k a -deleteMin = updateMin (const Nothing) - --- | /O(log n)/. Delete and find the element with the minimum key. Calls 'error' if empty. -deleteFindMin :: Ord k => MinPQueue k a -> ((k, a), MinPQueue k a) -deleteFindMin = fromMaybe (error "Error: deleteFindMin called on an empty queue") . minViewWithKey - --- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. -adjustMin :: (a -> a) -> MinPQueue k a -> MinPQueue k a -adjustMin = adjustMinWithKey . const - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. --- If the queue is empty, does nothing. -updateMin :: Ord k => (a -> Maybe a) -> MinPQueue k a -> MinPQueue k a -updateMin = updateMinWithKey . const - --- | /O(log n)/. Retrieves the value associated with the minimal key of the queue, and the queue --- stripped of that element, or 'Nothing' if passed an empty queue. -minView :: Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a) -minView q = do ((_, a), q') <- minViewWithKey q - return (a, q') - --- | /O(n)/. Map a function over all values in the queue. -map :: (a -> b) -> MinPQueue k a -> MinPQueue k b -map = mapWithKey . const - --- | /O(n)/. @'mapKeys' f q@ is the queue obtained by applying @f@ to each key of @q@. -mapKeys :: Ord k' => (k -> k') -> MinPQueue k a -> MinPQueue k' a -mapKeys f q = fromList [(f k, a) | (k, a) <- toListU q] - --- | /O(n log n)/. Traverses the elements of the queue in ascending order by key. --- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) --- --- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. -traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) -traverseWithKey f q = case minViewWithKey q of - Nothing -> pure empty - Just ((k, a), q') -> insertMin k <$> f k a <*> traverseWithKey f q' - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybe :: Ord k => (a -> Maybe b) -> MinPQueue k a -> MinPQueue k b -mapMaybe = mapMaybeWithKey . const - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEither :: Ord k => (a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) -mapEither = mapEitherWithKey . const - --- | /O(n)/. Filter all values that satisfy the predicate. -filter :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a -filter = filterWithKey . const - --- | /O(n)/. Filter all values that satisfy the predicate. -filterWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a -filterWithKey p = mapMaybeWithKey (\ k a -> if p k a then Just a else Nothing) - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partition :: Ord k => (a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) -partition = partitionWithKey . const - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partitionWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) -partitionWithKey p = mapEitherWithKey (\ k a -> if p k a then Left a else Right a) - -{-# INLINE take #-} --- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. --- (@'take' k q == 'List.take' k ('toAscList' q)@) -take :: Ord k => Int -> MinPQueue k a -> [(k, a)] -take n = List.take n . toAscList - --- | /O(k log n)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. -drop :: Ord k => Int -> MinPQueue k a -> MinPQueue k a -drop n0 q0 - | n0 <= 0 = q0 - | n0 >= size q0 = empty - | otherwise = drop' n0 q0 - where - drop' n q - | n == 0 = q - | otherwise = drop' (n-1) (deleteMin q) - --- | /O(k log n)/. Equivalent to @('take' k q, 'drop' k q)@. -splitAt :: Ord k => Int -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -splitAt n q - | n <= 0 = ([], q) - | otherwise = n `seq` case minViewWithKey q of - Just (ka, q') -> let (kas, q'') = splitAt (n-1) q' in (ka:kas, q'') - _ -> ([], q) - -{-# INLINE takeWhile #-} --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toAscList' q)@) -takeWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> [(k, a)] -takeWhile = takeWhileWithKey . const - -{-# INLINE takeWhileWithKey #-} --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toAscList' q)@) -takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> [(k, a)] -takeWhileWithKey p0 = takeWhileFB (uncurry' p0) . toAscList where - takeWhileFB p xs = build (\ c n -> foldr (\ x z -> if p x then x `c` z else n) n xs) - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a -dropWhile = dropWhileWithKey . const - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a -dropWhileWithKey p q = case minViewWithKey q of - Just ((k, a), q') - | p k a -> dropWhileWithKey p q' - _ -> q - --- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. -span :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) --- | Equivalent to @'span' ('not' . p)@. -break :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -span = spanWithKey . const -break p = span (not . p) - --- | Equivalent to @('takeWhileWithKey' p q, 'dropWhileWithKey' p q)@. -spanWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) --- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. -breakWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -spanWithKey p q = case minViewWithKey q of - Just ((k, a), q') - | p k a -> let (kas, q'') = spanWithKey p q' in ((k, a):kas, q'') - _ -> ([], q) -breakWithKey p = spanWithKey (not .: p) - --- | /O(n)/. Build a priority queue from the list of (key, value) pairs. -fromList :: Ord k => [(k, a)] -> MinPQueue k a -fromList = foldr (uncurry' insert) empty - --- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ -fromAscList :: [(k, a)] -> MinPQueue k a -fromAscList = foldr (uncurry' insertMin) empty - --- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ -fromDescList :: [(k, a)] -> MinPQueue k a -fromDescList = List.foldl' (\ q (k, a) -> insertMin k a q) empty - -{-# RULES - "fromList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . - fromList (build g) = g (uncurry' insert) empty; - "fromAscList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . - fromAscList (build g) = g (uncurry' insertMin) empty; - #-} - -{-# INLINE keys #-} --- | /O(n log n)/. Return all keys of the queue in ascending order. -keys :: Ord k => MinPQueue k a -> [k] -keys = List.map fst . toAscList - -{-# INLINE elems #-} --- | /O(n log n)/. Return all elements of the queue in ascending order by key. -elems :: Ord k => MinPQueue k a -> [a] -elems = List.map snd . toAscList - --- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. -toAscList :: Ord k => MinPQueue k a -> [(k, a)] -toAscList = foldrWithKey (curry (:)) [] - --- | /O(n log n)/. Return all (key, value) pairs in descending order by key. -toDescList :: Ord k => MinPQueue k a -> [(k, a)] -toDescList = foldlWithKey (\ z k a -> (k, a) : z) [] - -{-# RULES - "toAscList" toAscList = \ q -> build (\ c n -> foldrWithKey (curry c) n q); - "toDescList" toDescList = \ q -> build (\ c n -> foldlWithKey (\ z k a -> (k, a) `c` z) n q); - "toListU" toListU = \ q -> build (\ c n -> foldrWithKeyU (curry c) n q); - #-} - -{-# INLINE toList #-} --- | /O(n log n)/. Equivalent to 'toAscList'. --- --- If the traversal order is irrelevant, consider using 'toListU'. -toList :: Ord k => MinPQueue k a -> [(k, a)] -toList = toAscList - -{-# INLINE assocs #-} --- | /O(n log n)/. Equivalent to 'toAscList'. -assocs :: Ord k => MinPQueue k a -> [(k, a)] -assocs = toAscList - -{-# INLINE keysU #-} --- | /O(n)/. Return all keys of the queue in no particular order. -keysU :: MinPQueue k a -> [k] -keysU = List.map fst . toListU - -{-# INLINE elemsU #-} --- | /O(n)/. Return all elements of the queue in no particular order. -elemsU :: MinPQueue k a -> [a] -elemsU = List.map snd . toListU - -{-# INLINE assocsU #-} --- | /O(n)/. Equivalent to 'toListU'. -assocsU :: MinPQueue k a -> [(k, a)] -assocsU = toListU - --- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. -toListU :: MinPQueue k a -> [(k, a)] -toListU = foldrWithKeyU (curry (:)) [] - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrU :: (a -> b -> b) -> b -> MinPQueue k a -> b -foldrU = foldrWithKeyU . const - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlU :: (b -> a -> b) -> b -> MinPQueue k a -> b -foldlU f = foldlWithKeyU (const . f) - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseU :: (Applicative f) => (a -> f b) -> MinPQueue k a -> f (MinPQueue k b) -traverseU = traverseWithKeyU . const - -instance Functor (MinPQueue k) where - fmap = map - -instance Ord k => Foldable (MinPQueue k) where - foldr = foldrWithKey . const - foldl f = foldlWithKey (const . f) - -instance Ord k => Traversable (MinPQueue k) where - traverse = traverseWithKey . const diff --git a/PQueueTests.hs b/PQueueTests.hs deleted file mode 100644 --- a/PQueueTests.hs +++ /dev/null @@ -1,144 +0,0 @@ -module Main (main) where - -import qualified Data.PQueue.Prio.Max as PMax () -import qualified Data.PQueue.Prio.Min as PMin () -import qualified Data.PQueue.Max as Max () -import qualified Data.PQueue.Min as Min - -import Test.QuickCheck - -import System.Exit - -import qualified Data.List as List -import Control.Arrow (second) - - -validMinToAscList :: [Int] -> Bool -validMinToAscList xs = Min.toAscList (Min.fromList xs) == List.sort xs - -validMinToDescList :: [Int] -> Bool -validMinToDescList xs = Min.toDescList (Min.fromList xs) == List.sortBy (flip compare) xs - -validMinUnfoldr :: [Int] -> Bool -validMinUnfoldr xs = List.unfoldr Min.minView (Min.fromList xs) == List.sort xs - -validMinToList :: [Int] -> Bool -validMinToList xs = List.sort (Min.toList (Min.fromList xs)) == List.sort xs - -validMinFromAscList :: [Int] -> Bool -validMinFromAscList xs = Min.fromAscList (List.sort xs) == Min.fromList xs - -validMinFromDescList :: [Int] -> Bool -validMinFromDescList xs = Min.fromDescList (List.sortBy (flip compare) xs) == Min.fromList xs - -validMinUnion :: [Int] -> [Int] -> Bool -validMinUnion xs1 xs2 = Min.union (Min.fromList xs1) (Min.fromList xs2) == Min.fromList (xs1 ++ xs2) - -validMinMapMonotonic :: [Int] -> Bool -validMinMapMonotonic xs = Min.mapU (+1) (Min.fromList xs) == Min.fromList (map (+1) xs) - -validMinFilter :: [Int] -> Bool -validMinFilter xs = Min.filter even (Min.fromList xs) == Min.fromList (List.filter even xs) - -validMinPartition :: [Int] -> Bool -validMinPartition xs = Min.partition even (Min.fromList xs) == (let (xs1, xs2) = List.partition even xs in (Min.fromList xs1, Min.fromList xs2)) - -validMinCmp :: [Int] -> [Int] -> Bool -validMinCmp xs1 xs2 = compare (Min.fromList xs1) (Min.fromList xs2) == compare (List.sort xs1) (List.sort xs2) - -validMinCmp2 :: [Int] -> Bool -validMinCmp2 xs = compare (Min.fromList ys) (Min.fromList (take 30 ys)) == compare ys (take 30 ys) - where ys = List.sort xs - -validSpan :: [Int] -> Bool -validSpan xs = (Min.takeWhile even q, Min.dropWhile even q) == Min.span even q - where q = Min.fromList xs - -validSpan2 :: [Int] -> Bool -validSpan2 xs = - second Min.toAscList (Min.span even (Min.fromList xs)) - == - List.span even (List.sort xs) - -validSplit :: Int -> [Int] -> Bool -validSplit n xs = Min.splitAt n q == (Min.take n q, Min.drop n q) - where q = Min.fromList xs - -validSplit2 :: Int -> [Int] -> Bool -validSplit2 n xs = case Min.splitAt n (Min.fromList xs) of - (ys, q') -> (ys, Min.toAscList q') == List.splitAt n (List.sort xs) - -validMapEither :: [Int] -> Bool -validMapEither xs = - Min.mapEither collatz q == - (Min.mapMaybe (either Just (const Nothing) . collatz) q, - Min.mapMaybe (either (const Nothing) Just . collatz) q) - where q = Min.fromList xs - -validMap :: [Int] -> Bool -validMap xs = Min.map f (Min.fromList xs) == Min.fromList (List.map f xs) - where f = either id id . collatz - -collatz :: Int -> Either Int Int -collatz x = - if even x - then Left $ x `quot` 2 - else Right $ 3 * x + 1 - -validSize :: [Int] -> Bool -validSize xs = Min.size q == List.length xs' - where - q = Min.drop 10 (Min.fromList xs) - xs' = List.drop 10 (List.sort xs) - -validNull :: Int -> [Int] -> Bool -validNull n xs = Min.null q == List.null xs' - where - q = Min.drop n (Min.fromList xs) - xs' = List.drop n (List.sort xs) - -validFoldl :: [Int] -> Bool -validFoldl xs = Min.foldlAsc (flip (:)) [] (Min.fromList xs) == List.foldl (flip (:)) [] (List.sort xs) - -validFoldlU :: [Int] -> Bool -validFoldlU xs = Min.foldlU (flip (:)) [] q == List.reverse (Min.foldrU (:) [] q) - where q = Min.fromList xs - -validFoldrU :: [Int] -> Bool -validFoldrU xs = Min.foldrU (+) 0 q == List.sum xs - where q = Min.fromList xs - -main :: IO () -main = do - check validMinToAscList - check validMinToDescList - check validMinUnfoldr - check validMinToList - check validMinFromAscList - check validMinFromDescList - check validMinUnion - check validMinMapMonotonic - check validMinPartition - check validMinCmp - check validMinCmp2 - check validSpan - check validSpan2 - check validSplit - check validSplit2 - check validMinFilter - check validMapEither - check validMap - check validSize - check validNull - check validFoldl - check validFoldlU - check validFoldrU - -isPass :: Result -> Bool -isPass Success{} = True -isPass _ = False - -check :: Testable prop => prop -> IO () -check p = do - r <- quickCheckResult p - if isPass r then return () else exitFailure diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# pqueue + +A fast, reliable priority queue implementation based on a binomial heap. + +For more information, see [`pqueue` on Hackage](https://hackage.haskell.org/package/pqueue). diff --git a/benchmarks/BenchMinPQueue.hs b/benchmarks/BenchMinPQueue.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchMinPQueue.hs @@ -0,0 +1,64 @@ +import System.Random +import Test.Tasty.Bench + +import qualified KWay.PrioMergeAlg as KWay +import qualified PHeapSort as HS +import qualified Data.PQueue.Prio.Min as P + +kWay :: Int -> Int -> Benchmark +kWay i n = bench + ("k-way merge looking " ++ show i ++ " deep into " ++ show n ++ " streams") + (whnf ((!! i) . KWay.merge . KWay.mkStreams n) $ mkStdGen 5466122035931067691) + +hSort :: Int -> Benchmark +hSort n = bench + ("Heap sort with " ++ show n ++ " elements") + (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) + +filterQ :: Int -> Benchmark +filterQ n = bench + ("filter with " ++ show n ++ " elements") + (whnf (P.drop 1 . P.filterWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 977209486631198655) + +partitionQ :: Int -> Benchmark +partitionQ n = bench + ("partition with " ++ show n ++ " elements") + (whnf (P.drop 1 . snd . P.partitionWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 781928047937198) + + +main :: IO () +main = defaultMain + [ bgroup "heapSort" + [ hSort (10^3) + , hSort (10^4) + , hSort (10^5) + , hSort (10^6) + , hSort (3*10^6) + ] + , bgroup "kWay" + [ kWay (10^3) 1000000 + , kWay (10^5) 1000 + , kWay (10^5) 10000 + , kWay (10^5) 100000 + , kWay (10^6) 1000 + , kWay (10^6) 10000 + , kWay (10^6) 20000 + , kWay (3*10^6) 1000 + , kWay (2*10^6) 2000 + , kWay (4*10^6) 100 + ] + , bgroup "filter" + [ filterQ (10^3) + , filterQ (10^4) + , filterQ (10^5) + , filterQ (10^6) + , filterQ (3*10^6) + ] + , bgroup "partition" + [ partitionQ (10^3) + , partitionQ (10^4) + , partitionQ (10^5) + , partitionQ (10^6) + , partitionQ (3*10^6) + ] + ] diff --git a/benchmarks/BenchMinQueue.hs b/benchmarks/BenchMinQueue.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchMinQueue.hs @@ -0,0 +1,63 @@ +import System.Random +import Test.Tasty.Bench + +import qualified KWay.MergeAlg as KWay +import qualified HeapSort as HS +import qualified Data.PQueue.Min as P + +kWay :: Int -> Int -> Benchmark +kWay i n = bench + (show i ++ " into " ++ show n ++ " streams") + (whnf ((!! i) . KWay.merge . KWay.mkStreams n) $ mkStdGen 5466122035931067691) + +hSort :: Int -> Benchmark +hSort n = bench + ("Heap sort with " ++ show n ++ " elements") + (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) + +filterQ :: Int -> Benchmark +filterQ n = bench + ("filter with " ++ show n ++ " elements") + (whnf (P.drop 1 . P.filter (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 977209486631198655) + +partitionQ :: Int -> Benchmark +partitionQ n = bench + ("partition with " ++ show n ++ " elements") + (whnf (P.drop 1 . snd . P.partition (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 781928047937198) + +main :: IO () +main = defaultMain [ + bgroup "heapSort" + [ hSort (10^3) + , hSort (10^4) + , hSort (10^5) + , hSort (10^6) + , hSort (3*10^6) + ] + , bgroup "kWay" + [ kWay (10^3) 1000000 + , kWay (10^5) 1000 + , kWay (10^5) 10000 + , kWay (10^5) 100000 + , kWay (10^6) 1000 + , kWay (10^6) 10000 + , kWay (10^6) 20000 + , kWay (3*10^6) 1000 + , kWay (2*10^6) 2000 + , kWay (4*10^6) 100 + ] + , bgroup "filter" + [ filterQ (10^3) + , filterQ (10^4) + , filterQ (10^5) + , filterQ (10^6) + , filterQ (3*10^6) + ] + , bgroup "partition" + [ partitionQ (10^3) + , partitionQ (10^4) + , partitionQ (10^5) + , partitionQ (10^6) + , partitionQ (3*10^6) + ] + ] diff --git a/benchmarks/HeapSort.hs b/benchmarks/HeapSort.hs new file mode 100644 --- /dev/null +++ b/benchmarks/HeapSort.hs @@ -0,0 +1,10 @@ +module HeapSort where + +import qualified Data.PQueue.Min as P +import System.Random + +heapSortRandoms :: Int -> StdGen -> [Int] +heapSortRandoms n gen = heapSort $ take n (randoms gen) + +heapSort :: Ord a => [a] -> [a] +heapSort = P.toAscList . P.fromList diff --git a/benchmarks/KWay/MergeAlg.hs b/benchmarks/KWay/MergeAlg.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KWay/MergeAlg.hs @@ -0,0 +1,36 @@ +{-# language BangPatterns #-} +{-# language ViewPatterns #-} + +module KWay.MergeAlg where + +import qualified Data.PQueue.Min as P +import System.Random (StdGen) +import Data.Word +import Data.List (unfoldr) +import qualified KWay.RandomIncreasing as RI +import Data.Function (on) +import Data.Coerce + +newtype Stream = Stream { unStream :: RI.Stream } + +viewStream :: Stream -> (Word64, Stream) +viewStream = coerce RI.viewStream + +instance Eq Stream where + (==) = (==) `on` (fst . viewStream) + +instance Ord Stream where + compare = compare `on` (fst . viewStream) + +type PQ = P.MinQueue + +merge :: [Stream] -> [Word64] +merge = unfoldr go . P.fromList + where + go :: PQ Stream -> Maybe (Word64, PQ Stream) + go (P.minView -> Just (viewStream -> (a, s), ss)) + = Just (a, P.insert s ss) + go _ = Nothing + +mkStreams :: Int -> StdGen -> [Stream] +mkStreams = coerce RI.mkStreams diff --git a/benchmarks/KWay/PrioMergeAlg.hs b/benchmarks/KWay/PrioMergeAlg.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KWay/PrioMergeAlg.hs @@ -0,0 +1,22 @@ +{-# language BangPatterns #-} +{-# language ViewPatterns #-} + +module KWay.PrioMergeAlg + ( merge + , mkStreams + ) where + +import qualified Data.PQueue.Prio.Min as P +import Data.Word +import Data.List (unfoldr) +import KWay.RandomIncreasing + +type PQ = P.MinPQueue + +merge :: [Stream] -> [Word64] +merge = unfoldr go . P.fromList . map viewStream + where + go :: PQ Word64 Stream -> Maybe (Word64, PQ Word64 Stream) + go (P.minViewWithKey -> Just ((a, viewStream -> (b, s)), ss)) + = Just (a, P.insert b s ss) + go _ = Nothing diff --git a/benchmarks/KWay/RandomIncreasing.hs b/benchmarks/KWay/RandomIncreasing.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KWay/RandomIncreasing.hs @@ -0,0 +1,24 @@ +{-# language BangPatterns #-} +{-# language ViewPatterns #-} + +module KWay.RandomIncreasing where + +import System.Random +import Data.Word + +data Stream = Stream !Word64 {-# UNPACK #-} !StdGen + +viewStream :: Stream -> (Word64, Stream) +viewStream (Stream w gen) = (w, case uniform gen of (k, gen') -> Stream (w + fromIntegral (k :: Word16)) gen') + +mkStream :: StdGen -> (Stream, StdGen) +mkStream gen + | (gen1, gen2) <- split gen + , (w16, gen1') <- uniform gen1 + = (Stream (fromIntegral (w16 :: Word16)) gen1', gen2) + +mkStreams :: Int -> StdGen -> [Stream] +mkStreams !n !gen + | n <= 0 = [] + | (s, gen') <- mkStream gen + = s : mkStreams (n - 1) gen' diff --git a/benchmarks/PHeapSort.hs b/benchmarks/PHeapSort.hs new file mode 100644 --- /dev/null +++ b/benchmarks/PHeapSort.hs @@ -0,0 +1,10 @@ +module PHeapSort where + +import qualified Data.PQueue.Prio.Min as P +import System.Random + +heapSortRandoms :: Int -> StdGen -> [Int] +heapSortRandoms n gen = heapSort $ take n (randoms gen) + +heapSort :: Ord a => [a] -> [a] +heapSort xs = [b | (b, ~()) <- P.toAscList . P.fromList . map (\a -> (a, ())) $ xs] diff --git a/include/Typeable.h b/include/Typeable.h deleted file mode 100644 --- a/include/Typeable.h +++ /dev/null @@ -1,69 +0,0 @@ -{- -------------------------------------------------------------------------- -// Macros to help make Typeable instances. -// -// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines -// -// instance Typeable/n/ tc -// instance Typeable a => Typeable/n-1/ (tc a) -// instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) -// ... -// instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) -// -------------------------------------------------------------------------- --} - -#ifndef TYPEABLE_H -#define TYPEABLE_H - -#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } - -#ifdef __GLASGOW_HASKELL__ - --- // For GHC, the extra instances follow from general instance declarations --- // defined in Data.Typeable. - -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } - -#else /* !__GLASGOW_HASKELL__ */ - -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } - -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable1 (tycon a) where { \ - typeOf1 = typeOf1Default }; \ -instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ - typeOf = typeOfDefault } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable2 (tycon a) where { \ - typeOf2 = typeOf2Default }; \ -instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ - typeOf1 = typeOf1Default }; \ -instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ - typeOf = typeOfDefault } - -#endif /* !__GLASGOW_HASKELL__ */ - -#endif diff --git a/pqueue.cabal b/pqueue.cabal --- a/pqueue.cabal +++ b/pqueue.cabal @@ -1,34 +1,52 @@ -Name: pqueue -Version: 1.3.2.3 -Category: Data Structures -Author: Louis Wasserman -License: BSD3 -License-file: LICENSE -Stability: experimental -Synopsis: Reliable, persistent, fast priority queues. -Description: A fast, reliable priority queue implementation based on a binomial heap. -Maintainer: Lennart Spitzner - Louis Wasserman -Bug-reports: https://github.com/lspitzner/pqueue/issues -Build-type: Simple -cabal-version: >= 1.10 -tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 8.0.1 -extra-source-files: { - include/Typeable.h +cabal-version: 2.2 +name: pqueue +version: 1.7.0.0 +category: Data Structures +author: Louis Wasserman +license: BSD-3-Clause +license-file: LICENSE +stability: experimental +synopsis: Reliable, persistent, fast priority queues. +description: A fast, reliable priority queue implementation based on a binomial heap. +maintainer: Lennart Spitzner , + Louis Wasserman , + konsumlamm , + David Feuer +homepage: https://github.com/lspitzner/pqueue +bug-reports: https://github.com/lspitzner/pqueue/issues +build-type: Simple +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.3 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + +extra-doc-files: CHANGELOG.md -} + README.md source-repository head type: git - location: git@github.com:lspitzner/pqueue.git + location: https://github.com/lspitzner/pqueue.git -Library { +library + hs-source-dirs: src default-language: Haskell2010 build-depends: - { base >= 4 && < 4.11 - , deepseq >= 1.3 && < 1.5 - } + , base >= 4.9 && < 4.23 + , deepseq >= 1.3 && < 1.6 + , indexed-traversable >= 0.1 && < 0.2 exposed-modules: Data.PQueue.Prio.Min Data.PQueue.Prio.Max @@ -37,56 +55,93 @@ other-modules: Data.PQueue.Prio.Internals Data.PQueue.Internals + BinomialQueue.Internals + BinomialQueue.Min + BinomialQueue.Max + Data.PQueue.Internals.Classes + Data.PQueue.Internals.Down Data.PQueue.Prio.Max.Internals - Control.Applicative.Identity - if impl(ghc) { + Nattish + if impl(ghc) default-extensions: DeriveDataTypeable - } - ghc-options: { + other-extensions: + BangPatterns + , CPP + ghc-options: + -- We currently need -fspec-constr to get GHC to compile conversions + -- from lists well. We could (and probably should) write those a + -- bit differently so we won't need it. + -fspec-constr -fdicts-strict -Wall - } - if impl(ghc>=7.8) { - ghc-options: { - -fno-warn-inline-rule-shadowing - } - } - if impl(ghc>=7.10) { - ghc-options: { - -fno-warn-unused-imports - } - } -} -Test-Suite test - default-language: - Haskell2010 - Type: exitcode-stdio-1.0 - Main-Is: PQueueTests.hs - Build-Depends: - { base >= 4 && < 4.11 - , deepseq >= 1.3 && < 1.5 - , QuickCheck >=2.5 && <3 - } - ghc-options: -Wall - if impl(ghc>=7.8) { - ghc-options: { - -fno-warn-inline-rule-shadowing - } - } - if impl(ghc>=7.10) { - ghc-options: { - -fno-warn-unused-imports - } - } - If impl(ghc) - default-extensions: DeriveDataTypeable +test-suite test + hs-source-dirs: src, tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: PQueueTests.hs + build-depends: + , base >= 4.9 && < 4.23 + , deepseq >= 1.3 && < 1.6 + , indexed-traversable >= 0.1 && < 0.2 + , tasty + , tasty-quickcheck other-modules: - Data.PQueue.Prio.Internals - Data.PQueue.Internals - Data.PQueue.Prio.Max.Internals - Control.Applicative.Identity Data.PQueue.Prio.Min Data.PQueue.Prio.Max Data.PQueue.Min Data.PQueue.Max + Data.PQueue.Prio.Internals + Data.PQueue.Internals + BinomialQueue.Internals + BinomialQueue.Min + BinomialQueue.Max + Data.PQueue.Internals.Classes + Data.PQueue.Internals.Down + Data.PQueue.Prio.Max.Internals + Nattish + + Validity.BinomialQueue + Validity.PQueue.Min + Validity.PQueue.Prio.BinomialQueue + Validity.PQueue.Prio.Min + Validity.PQueue.Prio.Max + if impl(ghc) + default-extensions: DeriveDataTypeable + ghc-options: + -Wall + -fno-warn-type-defaults + +benchmark minqueue-benchmarks + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: BenchMinQueue.hs + other-modules: + KWay.MergeAlg + HeapSort + KWay.RandomIncreasing + ghc-options: -O2 + build-depends: + , base >= 4.9 && < 5 + , pqueue + , deepseq >= 1.3 && < 1.6 + , random >= 1.2 && < 1.4 + , tasty-bench >= 0.3 && < 0.6 + +benchmark minpqueue-benchmarks + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: BenchMinPQueue.hs + other-modules: + KWay.PrioMergeAlg + PHeapSort + KWay.RandomIncreasing + ghc-options: -O2 + build-depends: + , base >= 4.9 && < 5 + , pqueue + , deepseq >= 1.3 && < 1.6 + , random >= 1.2 && < 1.4 + , tasty-bench >= 0.3 && < 0.6 diff --git a/src/BinomialQueue/Internals.hs b/src/BinomialQueue/Internals.hs new file mode 100644 --- /dev/null +++ b/src/BinomialQueue/Internals.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module BinomialQueue.Internals ( + MinQueue (..), + BinomHeap, + BinomForest(..), + BinomTree(..), + Extract(..), + MExtract(..), + Succ(..), + Zero(..), + empty, + extractHeap, + null, + size, + getMin, + minView, + singleton, + insert, + insertEager, + union, + unionPlusOne, + mapMaybe, + mapEither, + mapMonotonic, + foldrAsc, + foldlAsc, + foldrDesc, + foldrUnfold, + foldlUnfold, + insertMinQ, + insertMinQ', + insertMaxQ', + toAscList, + toDescList, + toListU, + fromList, + fromAscList, + foldMapU, + foldrU, + foldlU, + foldlU', + seqSpine, + unions + ) where + +import Control.DeepSeq (NFData(rnf), deepseq) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif +import Data.Function (on) +import Data.Semigroup (Semigroup(..), stimesMonoid) + +import Data.PQueue.Internals.Classes +#ifdef __GLASGOW_HASKELL__ +import Data.Data +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +import GHC.Exts (build) +#endif + +import Prelude hiding (null) + +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +-- | A priority queue with elements of type @a@. Getting the +-- size or retrieving the minimum element takes \(O(\log n)\) time. +newtype MinQueue a = MinQueue (BinomHeap a) + +#ifdef __GLASGOW_HASKELL__ +instance (Ord a, Data a) => Data (MinQueue a) where + gfoldl f z q = case minView q of + Nothing -> z empty + Just (x, q') -> z insert `f` x `f` q' + + gunfold k z c = case constrIndex c of + 1 -> z empty + 2 -> k (k (z insertMinQ)) + _ -> error "gunfold" + + dataCast1 x = gcast1 x + + toConstr q + | null q = emptyConstr + | otherwise = consConstr + + dataTypeOf _ = queueDataType + +queueDataType :: DataType +queueDataType = mkDataType "Data.PQueue.Min.MinQueue" [emptyConstr, consConstr] + +emptyConstr, consConstr :: Constr +emptyConstr = mkConstr queueDataType "empty" [] Prefix +consConstr = mkConstr queueDataType "<|" [] Infix + +#endif + +type BinomHeap = BinomForest Zero + +instance Ord a => Eq (MinQueue a) where + (==) = (==) `on` minView + +instance Ord a => Ord (MinQueue a) where + compare = compare `on` minView + -- We compare their first elements, then their other elements up to the smaller queue's length, + -- and then the longer queue wins. + -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. + +-- We implement tree ranks in the type system with a nicely elegant approach, as follows. +-- The goal is to have the type system automatically guarantee that our binomial forest +-- has the correct binomial structure. +-- +-- In the traditional set-theoretic construction of the natural numbers, we define +-- each number to be the set of numbers less than it, and Zero to be the empty set, +-- as follows: +-- +-- 0 = {} 1 = {0} 2 = {0, 1} 3={0, 1, 2} ... +-- +-- Binomial trees have a similar structure: a tree of rank @k@ has one child of each +-- rank less than @k@. Let's define the type @rk@ corresponding to rank @k@ to refer +-- to a collection of binomial trees of ranks @0..k-1@. Then we can say that +-- +-- > data Succ rk a = Succ (BinomTree rk a) (rk a) +-- +-- and this behaves exactly as the successor operator for ranks should behave. Furthermore, +-- we immediately obtain that +-- +-- > data BinomTree rk a = BinomTree a (rk a) +-- +-- which is nice and compact. With this construction, things work out extremely nicely: +-- +-- > BinomTree (Succ (Succ (Succ Zero))) +-- +-- is a type constructor that takes an element type and returns the type of binomial trees +-- of rank @3@. +-- +-- The Skip constructor must be lazy to obtain the desired amortized bounds. +-- The forest field of the Cons constructor /could/ be made strict, but that +-- would be worse for heavily persistent use. According to our benchmarks, it +-- doesn't make a significant or consistent difference even in non-persistent +-- code (heap sort and k-way merge). +-- +-- Debit invariant: +-- +-- The next-pointer of a Skip node is allowed 1 debit. No other debits are +-- allowed in the structure. +data BinomForest rk a + = Nil + | Skip (BinomForest (Succ rk) a) + | Cons {-# UNPACK #-} !(BinomTree rk a) (BinomForest (Succ rk) a) + +-- The BinomTree and Succ constructors are entirely strict, primarily because +-- that makes it easier to make sure everything is as strict as it should +-- be. The downside is that this slows down `mapMonotonic`. If that's important, +-- we can do all the forcing manually; it will be a pain. + +data BinomTree rk a = BinomTree !a !(rk a) + +-- | If |rk| corresponds to rank @k@, then |'Succ' rk| corresponds to rank @k+1@. +data Succ rk a = Succ {-# UNPACK #-} !(BinomTree rk a) !(rk a) + +-- | Type corresponding to the Zero rank. +data Zero a = Zero + +-- basics + +-- | \(O(1)\). The empty priority queue. +empty :: MinQueue a +empty = MinQueue Nil + +-- | \(O(1)\). Is this the empty priority queue? +null :: MinQueue a -> Bool +null (MinQueue Nil) = True +null _ = False + +-- | \(O(\log n)\). The number of elements in the queue. +size :: MinQueue a -> Int +size (MinQueue hp) = go 0 1 hp + where + go :: Int -> Int -> BinomForest rk a -> Int + go acc rk Nil = rk `seq` acc + go acc rk (Skip f) = go acc (2 * rk) f + go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f + +-- | \(O(\log n)\). Returns the minimum element of the queue, if the queue is nonempty. +getMin :: Ord a => MinQueue a -> Maybe a +-- TODO: Write this directly to avoid rebuilding the heap. +getMin xs = case minView xs of + Just (a, _) -> Just a + Nothing -> Nothing + +-- | Retrieves the minimum element of the queue, and the queue stripped of that element, +-- or 'Nothing' if passed an empty queue. +minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a) +minView (MinQueue ts) = case extractBin ts of + No -> Nothing + Yes (Extract x ~Zero ts') -> Just (x, MinQueue ts') + +-- | \(O(1)\). Construct a priority queue with a single element. +singleton :: a -> MinQueue a +singleton x = MinQueue (Cons (tip x) Nil) + +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Insert an element into the priority queue. +insert :: Ord a => a -> MinQueue a -> MinQueue a +insert x (MinQueue ts) = MinQueue (incr (tip x) ts) + +-- | \(O(\log n)\), but a fast \(O(1)\) average when inserting repeatedly in +-- an empty queue or at least around \(O(\log n)\) times into a nonempty one. +-- Insert an element into the priority queue. This is good for 'fromList'-like +-- operations. +insertEager :: Ord a => a -> MinQueue a -> MinQueue a +insertEager x (MinQueue ts) = MinQueue (incr' (tip x) ts) +{-# INLINE insertEager #-} + +-- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. +union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a +union (MinQueue f1) (MinQueue f2) = MinQueue (merge f1 f2) + +-- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. +unions :: Ord a => [MinQueue a] -> MinQueue a +unions = foldl' union empty + +-- | \(O(n)\). Map elements and collect the 'Just' results. +mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b +mapMaybe f = flip foldlU' empty $ \q a -> + case f a of + Nothing -> q + Just b -> insertEager b q +-- This seems to be needed for specialization. +{-# INLINABLE mapMaybe #-} + +-- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. +mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) +mapEither f = fromPartition . + foldlU' + (\(Partition ls rs) a -> + case f a of + Left b -> Partition (insertEager b ls) rs + Right b -> Partition ls (insertEager b rs)) + (Partition empty empty) +-- This seems to be needed for specialization. +{-# INLINABLE mapEither #-} + +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic +-- (meaning that @x <= y@ implies @f x <= f y@), and +-- applies this function to every element of the priority queue, as in 'fmap'. +-- If the function is not monotonic, the result is undefined. +mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b +mapMonotonic f (MinQueue ts) = MinQueue (fmap_ f ts) + +{-# INLINABLE [0] foldrAsc #-} +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in +-- ascending order. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrAsc f z (MinQueue ts) = foldrUnfold f z extractHeap ts + +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. +-- @foldrDesc f z q == foldlAsc (flip f) z q@. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrDesc = foldlAsc . flip +{-# INLINE [0] foldrDesc #-} + +{-# INLINE foldrUnfold #-} +-- | Equivalent to @foldr f z (unfoldr suc s0)@. +foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c +foldrUnfold f z suc s0 = unf s0 where + unf s = case suc s of + Nothing -> z + Just (x, s') -> x `f` unf s' + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in +-- ascending order. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlAsc f z (MinQueue ts) = foldlUnfold f z extractHeap ts + +{-# INLINE foldlUnfold #-} +-- | @foldlUnfold f z suc s0@ is equivalent to @foldl f z (unfoldr suc s0)@. +foldlUnfold :: (c -> a -> c) -> c -> (b -> Maybe (a, b)) -> b -> c +foldlUnfold f z0 suc s0 = unf z0 s0 where + unf z s = case suc s of + Nothing -> z + Just (x, s') -> unf (z `f` x) s' + +{-# INLINABLE [1] toAscList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MinQueue a -> [a] +toAscList queue = foldrAsc (:) [] queue + +{-# INLINABLE toAscListApp #-} +toAscListApp :: Ord a => MinQueue a -> [a] -> [a] +toAscListApp (MinQueue ts) app = foldrUnfold (:) app extractHeap ts + +{-# INLINABLE [1] toDescList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MinQueue a -> [a] +toDescList queue = foldrDesc (:) [] queue + +{-# INLINABLE toDescListApp #-} +toDescListApp :: Ord a => MinQueue a -> [a] -> [a] +toDescListApp (MinQueue ts) app = foldlUnfold (flip (:)) app extractHeap ts + +{-# RULES +"toAscList" [~1] forall q. toAscList q = build (\c nil -> foldrAsc c nil q) +"toDescList" [~1] forall q. toDescList q = build (\c nil -> foldrDesc c nil q) +"ascList" [1] forall q add. foldrAsc (:) add q = toAscListApp q add +"descList" [1] forall q add. foldrDesc (:) add q = toDescListApp q add + #-} + +{-# INLINE fromAscList #-} +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +-- +-- Performance note: Code using this function in a performance-sensitive context +-- with an argument that is a "good producer" for list fusion should be compiled +-- with @-fspec-constr@ or @-O2@. For example, @fromAscList . map f@ needs one +-- of these options for best results. +fromAscList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromAscList xs = foldl' (flip insertMaxQ') empty xs + +-- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. +extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) +extractHeap ts = case extractBin ts of + No -> Nothing + Yes (Extract x ~Zero ts') -> Just (x, ts') + +-- | A specialized type intended to organize the return of extract-min queries +-- from a binomial forest. We walk all the way through the forest, and then +-- walk backwards. @Extract rk a@ is the result type of an extract-min +-- operation that has walked as far backwards of rank @rk@ -- that is, it +-- has visited every root of rank @>= rk@. +-- +-- The interpretation of @Extract minKey children forest@ is +-- +-- * @minKey@ is the key of the minimum root visited so far. It may have +-- any rank @>= rk@. We will denote the root corresponding to +-- @minKey@ as @minRoot@. +-- +-- * @children@ is those children of @minRoot@ which have not yet been +-- merged with the rest of the forest. Specifically, these are +-- the children with rank @< rk@. +-- +-- * @forest@ is an accumulating parameter that maintains the partial +-- reconstruction of the binomial forest without @minRoot@. It is +-- the union of all old roots with rank @>= rk@ (except @minRoot@), +-- with the set of all children of @minRoot@ with rank @>= rk@. +data Extract rk a = Extract !a !(rk a) !(BinomForest rk a) +data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a) + +incrExtract :: Extract (Succ rk) a -> Extract rk a +incrExtract (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Cons kChild ts) + +-- Note: We used to apply Skip lazily here, and to use the lazy incr, for fear +-- that the potential cascade of carries would be more expensive than leaving +-- those carries suspended and letting subsequent operations force them. +-- However, our benchmarks indicated that doing these strictly was +-- faster. Note that even if we chose to go back to incr (rather than incr'), +-- it's even more clearly worse to apply Skip lazily— forcing the result of +-- incr in this context doesn't cause a cascade, because the child of any Cons +-- will come from an Extract, and therefore be in WHNF already. +incrExtract' :: Ord a => BinomTree rk a -> Extract (Succ rk) a -> Extract rk a +incrExtract' t (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Skip $! incr' (t `joinBin` kChild) ts) + +-- | Walks backward from the biggest key in the forest, as far as rank @rk@. +-- Returns its progress. Each successive application of @extractBin@ takes +-- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time. +extractBin :: Ord a => BinomForest rk a -> MExtract rk a +extractBin = start + where + start :: Ord a => BinomForest rk a -> MExtract rk a + start Nil = No + start (Skip f) = case start f of + No -> No + Yes ex -> Yes (incrExtract ex) + start (Cons t@(BinomTree x ts) f) = Yes $ case go x f of + No -> Extract x ts (skip f) + Yes ex -> incrExtract' t ex + + go :: Ord a => a -> BinomForest rk a -> MExtract rk a + go _min_above Nil = _min_above `seq` No + go min_above (Skip f) = case go min_above f of + No -> No + Yes ex -> Yes (incrExtract ex) + go min_above (Cons t@(BinomTree x ts) f) + | min_above <= x = case go min_above f of + No -> No + Yes ex -> Yes (incrExtract' t ex) + | otherwise = case go x f of + No -> Yes (Extract x ts (skip f)) + Yes ex -> Yes (incrExtract' t ex) + +-- | When the heap size is a power of two and we extract from it, we have +-- to shrink the spine by one. This function takes care of that. +skip :: BinomForest (Succ rk) a -> BinomForest rk a +skip Nil = Nil +skip f = Skip f +{-# INLINE skip #-} + +data Partition a b = Partition !(MinQueue a) !(MinQueue b) +fromPartition :: Partition a b -> (MinQueue a, MinQueue b) +fromPartition (Partition p q) = (p, q) + +{-# INLINE tip #-} +-- | Constructs a binomial tree of rank 0. +tip :: a -> BinomTree Zero a +tip x = BinomTree x Zero + +insertMinQ :: a -> MinQueue a -> MinQueue a +insertMinQ x (MinQueue f) = MinQueue (insertMin (tip x) f) + +-- | @insertMin t f@ assumes that the root of @t@ compares as less than +-- or equal to every other root in @f@, and merges accordingly. +insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMin t Nil = Cons t Nil +insertMin t (Skip f) = Cons t f +-- See Note [Force on cascade] +insertMin (BinomTree x ts) (Cons t' f) = f `seq` Skip (insertMin (BinomTree x (Succ t' ts)) f) + +-- | @insertMinQ' x h@ assumes that @x@ compares as less +-- than or equal to every element of @h@. +insertMinQ' :: a -> MinQueue a -> MinQueue a +insertMinQ' x (MinQueue f) = MinQueue (insertMin' (tip x) f) + +-- | @insertMin' t f@ assumes that the root of @t@ compares as less than +-- every other root in @f@, and merges accordingly. It eagerly evaluates +-- the modified portion of the structure. +insertMin' :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMin' t Nil = Cons t Nil +insertMin' t (Skip f) = Cons t f +insertMin' (BinomTree x ts) (Cons t' f) = Skip $! insertMin' (BinomTree x (Succ t' ts)) f + +-- | @insertMaxQ' x h@ assumes that @x@ compares as greater +-- than or equal to every element of @h@. It also assumes, +-- and preserves, an extra invariant. See 'insertMax'' for details. +-- tldr: this function can be used safely to build a queue from an +-- ascending list/array/whatever, but that's about it. +insertMaxQ' :: a -> MinQueue a -> MinQueue a +insertMaxQ' x (MinQueue f) = MinQueue (insertMax' (tip x) f) + +-- | @insertMax' t f@ assumes that the root of @t@ compares as greater +-- than or equal to every root in @f@, and further assumes that the roots +-- in @f@ occur in descending order. It produces a forest whose roots are +-- again in descending order. Note: the whole modified portion of the spine +-- is forced. +insertMax' :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMax' t Nil = Cons t Nil +insertMax' t (Skip f) = Cons t f +insertMax' t (Cons (BinomTree x ts) f) = Skip $! insertMax' (BinomTree x (Succ t ts)) f + +{-# INLINABLE fromList #-} +-- | \(O(n)\). Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MinQueue a +fromList xs = foldl' (flip insertEager) empty xs + +-- | Given two binomial forests starting at rank @rk@, takes their union. +-- Each successive application of this function costs \(O(1)\), so applying it +-- from the beginning costs \(O(\log n)\). +merge :: Ord a => BinomForest rk a -> BinomForest rk a -> BinomForest rk a +merge f1 f2 = case (f1, f2) of + (Skip f1', Skip f2') -> Skip $! merge f1' f2' + (Skip f1', Cons t2 f2') -> Cons t2 $! merge f1' f2' + (Cons t1 f1', Skip f2') -> Cons t1 $! merge f1' f2' + (Cons t1 f1', Cons t2 f2') + -> Skip $! carry (t1 `joinBin` t2) f1' f2' + (Nil, _) -> f2 + (_, Nil) -> f1 + +-- | Take the union of two queues and toss in an extra element. +unionPlusOne :: Ord a => a -> MinQueue a -> MinQueue a -> MinQueue a +unionPlusOne a (MinQueue xs) (MinQueue ys) = MinQueue (carry (tip a) xs ys) + +-- | Merges two binomial forests with another tree. If we are thinking of the trees +-- in the binomial forest as binary digits, this corresponds to a carry operation. +-- Each call to this function takes \(O(1)\) time, so in total, it costs \(O(\log n)\). +carry :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a +carry t0 f1 f2 = t0 `seq` case (f1, f2) of + (Skip f1', Skip f2') -> Cons t0 $! merge f1' f2' + (Skip f1', Cons t2 f2') -> Skip $! mergeCarry t0 t2 f1' f2' + (Cons t1 f1', Skip f2') -> Skip $! mergeCarry t0 t1 f1' f2' + (Cons t1 f1', Cons t2 f2') + -> Cons t0 $! mergeCarry t1 t2 f1' f2' + -- Why do these use incr and not incr'? We want the merge to take amortized + -- O(log(min(|f1|, |f2|))) time. If we performed this final increment + -- eagerly, that would degrade to O(log(max(|f1|, |f2|))) time. + (Nil, _f2) -> incr t0 f2 + (_f1, Nil) -> incr t0 f1 + where + mergeCarry tA tB = carry (tA `joinBin` tB) + +-- | Merges a binomial tree into a binomial forest. If we are thinking +-- of the trees in the binomial forest as binary digits, this corresponds +-- to adding a power of 2. This costs amortized \(O(1)\) time. +incr :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a +-- See Note [Amortization] +incr t f0 = t `seq` case f0 of + Nil -> Cons t Nil + Skip f -> Cons t f + Cons t' f' -> f' `seq` Skip (incr (t `joinBin` t') f') + -- See Note [Force on cascade] + + -- Question: should we force t `cat` t' here? We're allowed to; + -- it's not obviously good or obviously bad. + +-- Note [Amortization] +-- +-- In the Skip case, we perform O(1) unshared work and pay a +-- debit. In the Cons case, there are no debits on f', so we can force it for +-- free. We perform O(1) unshared work, and by induction suspend O(1) amortized +-- work. Another way to look at this: We have a string of Conses followed by +-- a Skip or Nil. We change all the Conses to Skips, and change the Skip to +-- a Cons or the Nil to a Cons Nil. Processing each Cons takes O(1) time, which +-- we account for by placing debits below the new Skips. Note: this increment +-- pattern is exactly the same as the one for Hinze-Paterson 2–3 finger trees, +-- and the amortization argument works just the same. + +-- Note [Force on cascade] +-- +-- As Hinze and Patterson noticed in a similar structure, whenever we cascade +-- past a Cons on insertion, we should force its child. If we don't, then +-- multiple insertions in a row will form a chain of thunks just under the root +-- of the structure, which degrades the worst-case bound for deletion from +-- logarithmic to linear and leads to poor real-world performance. + +-- | A version of 'incr' that constructs the spine eagerly. This is +-- intended for implementing @fromList@. +incr' :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a +incr' t f0 = t `seq` case f0 of + Nil -> Cons t Nil + Skip f -> Cons t f + Cons t' f' -> Skip $! incr' (t `joinBin` t') f' + +-- | The carrying operation: takes two binomial heaps of the same rank @k@ +-- and returns one of rank @k+1@. Takes \(O(1)\) time. +joinBin :: Ord a => BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a +joinBin t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) + | x1 <= x2 = BinomTree x1 (Succ t2 ts1) + | otherwise = BinomTree x2 (Succ t1 ts2) + + +instance Fmap Zero where + fmap_ _ _ = Zero + +instance Fmap rk => Fmap (Succ rk) where + fmap_ f (Succ t ts) = Succ (fmap_ f t) (fmap_ f ts) + +instance Fmap rk => Fmap (BinomTree rk) where + fmap_ f (BinomTree x ts) = BinomTree (f x) (fmap_ f ts) + +instance Fmap rk => Fmap (BinomForest rk) where + fmap_ _ Nil = Nil + fmap_ f (Skip ts) = Skip $! fmap_ f ts + fmap_ f (Cons t ts) = Cons (fmap_ f t) $! fmap_ f ts + +instance Foldr Zero where + foldr_ _ z ~Zero = z + +instance Foldl Zero where + foldl_ _ z ~Zero = z + +instance Foldl' Zero where + foldl'_ _ z ~Zero = z + +instance FoldMap Zero where + foldMap_ _ ~Zero = mempty + +instance Foldr rk => Foldr (Succ rk) where + foldr_ f z (Succ t ts) = foldr_ f (foldr_ f z ts) t + +instance Foldl rk => Foldl (Succ rk) where + foldl_ f z (Succ t ts) = foldl_ f (foldl_ f z t) ts + +instance Foldl' rk => Foldl' (Succ rk) where + foldl'_ f !z (Succ t ts) = foldl'_ f (foldl'_ f z t) ts + +instance FoldMap rk => FoldMap (Succ rk) where + foldMap_ f (Succ t ts) = foldMap_ f t `mappend` foldMap_ f ts + +instance Foldr rk => Foldr (BinomTree rk) where + foldr_ f z (BinomTree x ts) = x `f` foldr_ f z ts + +instance Foldl rk => Foldl (BinomTree rk) where + foldl_ f z (BinomTree x ts) = foldl_ f (z `f` x) ts + +instance Foldl' rk => Foldl' (BinomTree rk) where + foldl'_ f !z (BinomTree x ts) = foldl'_ f (z `f` x) ts + +instance FoldMap rk => FoldMap (BinomTree rk) where + foldMap_ f (BinomTree x ts) = f x `mappend` foldMap_ f ts + +instance Foldr rk => Foldr (BinomForest rk) where + foldr_ _ z Nil = z + foldr_ f z (Skip tss) = foldr_ f z tss + foldr_ f z (Cons t tss) = foldr_ f (foldr_ f z tss) t + +instance Foldl rk => Foldl (BinomForest rk) where + foldl_ _ z Nil = z + foldl_ f z (Skip tss) = foldl_ f z tss + foldl_ f z (Cons t tss) = foldl_ f (foldl_ f z t) tss + +instance Foldl' rk => Foldl' (BinomForest rk) where + foldl'_ _ !z Nil = z + foldl'_ f !z (Skip tss) = foldl'_ f z tss + foldl'_ f !z (Cons t tss) = foldl'_ f (foldl'_ f z t) tss + +instance FoldMap rk => FoldMap (BinomForest rk) where + foldMap_ _ Nil = mempty + foldMap_ f (Skip tss) = foldMap_ f tss + foldMap_ f (Cons t tss) = foldMap_ f t `mappend` foldMap_ f tss + +{- +instance Foldable Zero where + foldr _ z ~Zero = z + foldl _ z ~Zero = z + +instance Foldable rk => Foldable (Succ rk) where + foldr f z (Succ t ts) = foldr f (foldr f z ts) t + foldl f z (Succ t ts) = foldl f (foldl f z t) ts + +instance Foldable rk => Foldable (BinomTree rk) where + foldr f z (BinomTree x ts) = x `f` foldr f z ts + foldl f z (BinomTree x ts) = foldl f (z `f` x) ts + +instance Foldable rk => Foldable (BinomForest rk) where + foldr _ z Nil = z + foldr f z (Skip tss) = foldr f z tss + foldr f z (Cons t tss) = foldr f (foldr f z tss) t + foldl _ z Nil = z + foldl f z (Skip tss) = foldl f z tss + foldl f z (Cons t tss) = foldl f (foldl f z t) tss +-} + +-- instance Traversable Zero where +-- traverse _ _ = pure Zero +-- +-- instance Traversable rk => Traversable (Succ rk) where +-- traverse f (Succ t ts) = Succ <$> traverse f t <*> traverse f ts +-- +-- instance Traversable rk => Traversable (BinomTree rk) where +-- traverse f (BinomTree x ts) = BinomTree <$> f x <*> traverse f ts +-- +-- instance Traversable rk => Traversable (BinomForest rk) where +-- traverse _ Nil = pure Nil +-- traverse f (Skip tss) = Skip <$> traverse f tss +-- traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss + +{-# NOINLINE [0] foldrU #-} +-- | \(O(n)\). Unordered right fold on a priority queue. +foldrU :: (a -> b -> b) -> b -> MinQueue a -> b +foldrU f z (MinQueue ts) = foldr_ f z ts + +-- | \(O(n)\). Unordered left fold on a priority queue. This is rarely +-- what you want; 'foldrU' and 'foldlU'' are more likely to perform +-- well. +foldlU :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU f z (MinQueue ts) = foldl_ f z ts + +-- | \(O(n)\). Unordered strict left fold on a priority queue. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU' f z (MinQueue ts) = foldl'_ f z ts + +-- | \(O(n)\). Unordered monoidal fold on a priority queue. +-- +-- @since 1.4.2 +foldMapU :: Monoid m => (a -> m) -> MinQueue a -> m +foldMapU f (MinQueue ts) = foldMap_ f ts + +{-# NOINLINE toListU #-} +-- | \(O(n)\). Returns the elements of the queue, in no particular order. +toListU :: MinQueue a -> [a] +toListU q = foldrU (:) [] q + +{-# NOINLINE toListUApp #-} +toListUApp :: MinQueue a -> [a] -> [a] +toListUApp (MinQueue ts) app = foldr_ (:) app ts + +{-# RULES +"toListU/build" [~1] forall q. toListU q = build (\c n -> foldrU c n q) +"toListU" [1] forall q app. foldrU (:) app q = toListUApp q app + #-} + +-- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) +-- traverseU _ Empty = pure Empty +-- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts + +-- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. +-- +-- Note: The spine of a 'MinQueue' is stored somewhat lazily. Most operations +-- take great care to prevent chains of thunks from accumulating along the +-- spine to the detriment of performance. However, @mapMonotonic@ can leave expensive +-- thunks in the structure and repeated applications of that function can +-- create thunk chains. +seqSpine :: MinQueue a -> b -> b +seqSpine (MinQueue ts) z = seqSpineF ts z + +seqSpineF :: BinomForest rk a -> b -> b +seqSpineF Nil z = z +seqSpineF (Skip ts') z = seqSpineF ts' z +seqSpineF (Cons _ ts') z = seqSpineF ts' z + +class NFRank rk where + rnfRk :: NFData a => rk a -> () + +instance NFRank Zero where + rnfRk _ = () + +instance NFRank rk => NFRank (Succ rk) where + rnfRk (Succ t ts) = t `deepseq` rnfRk ts + +instance (NFData a, NFRank rk) => NFData (BinomTree rk a) where + rnf (BinomTree x ts) = x `deepseq` rnfRk ts + +instance (NFData a, NFRank rk) => NFData (BinomForest rk a) where + rnf Nil = () + rnf (Skip ts) = rnf ts + rnf (Cons t ts) = t `deepseq` rnf ts + +instance NFData a => NFData (MinQueue a) where + rnf (MinQueue ts) = rnf ts + +instance (Ord a, Show a) => Show (MinQueue a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toAscList xs) + +instance (Ord a, Read a) => Read (MinQueue a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) +#endif + +instance Ord a => Semigroup (MinQueue a) where + (<>) = union + stimes = stimesMonoid + {-# INLINABLE stimes #-} + +instance Ord a => Monoid (MinQueue a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions diff --git a/src/BinomialQueue/Max.hs b/src/BinomialQueue/Max.hs new file mode 100644 --- /dev/null +++ b/src/BinomialQueue/Max.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : BinomialQueue.Max +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue. Unlike the queues in "Data.PQueue.Max", +-- these are /not/ augmented with a global root or their size, so 'getMax' +-- and 'size' take logarithmic, rather than constant, time. When those +-- operations are not (often) needed, these queues are generally faster than +-- those in "Data.PQueue.Max". +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /k/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- This implementation is based on a binomial heap. +-- +-- This implementation does not guarantee stable behavior. +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module BinomialQueue.Max ( + MaxQueue, + -- * Basic operations + empty, + null, + size, + -- * Query operations + findMax, + getMax, + deleteMax, + deleteFindMax, + maxView, + -- * Construction operations + singleton, + insert, + union, + unions, + -- * Subsets + -- ** Extracting subsets + (!!), + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + dropWhile, + span, + break, + -- * Filter/Map + filter, + partition, + mapMaybe, + mapEither, + -- * Fold\/Functor\/Traversable variations + map, + foldrAsc, + foldlAsc, + foldrDesc, + foldlDesc, + -- * List operations + toList, + toAscList, + toDescList, + fromList, + fromAscList, + fromDescList, + -- * Unordered operations + foldrU, + foldlU, + foldlU', + foldMapU, + elemsU, + toListU, + -- * Miscellaneous operations +-- keysQueue, -- We want bare Prio queues for this. + seqSpine + ) where + +import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) + +import Data.Coerce (coerce) +import qualified Data.List as List +import Data.Maybe (fromMaybe) + +import qualified BinomialQueue.Min as MinQ +import Data.PQueue.Internals.Down + +newtype MaxQueue a = MaxQueue { unMaxQueue :: MinQ.MinQueue (Down a) } + +-- | \(O(\log n)\). Returns the minimum element. Throws an error on an empty queue. +findMax :: Ord a => MaxQueue a -> a +findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax + +-- | \(O(1)\). The top (maximum) element of the queue, if there is one. +getMax :: Ord a => MaxQueue a -> Maybe a +getMax = coerce MinQ.getMin + +-- | \(O(\log n)\). Deletes the maximum element. If the queue is empty, does nothing. +deleteMax :: Ord a => MaxQueue a -> MaxQueue a +deleteMax = coerce MinQ.deleteMin + +-- | \(O(\log n)\). Extracts the maximum element. Throws an error on an empty queue. +deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) +deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView + +-- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. +maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) +maxView = coerce MinQ.minView + +-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th largest +-- element in the queue. Equivalent to @toDescList queue !! k@. +(!!) :: Ord a => MaxQueue a -> Int -> a +q !! n | n >= size q + = error "BinomialQueue.Max.!!: index too large" +q !! n = toDescList q List.!! n + +{-# INLINE takeWhile #-} +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] +takeWhile = coerce MinQ.takeWhile + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a +dropWhile = coerce MinQ.dropWhile + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +span = coerce MinQ.span + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +break p = span (not . p) + +{-# INLINE take #-} +-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the greatest @k@ elements of @queue@, +-- or all elements of @queue@ itself if @k >= 'size' queue@. +take :: Ord a => Int -> MaxQueue a -> [a] +take n = List.take n . toDescList + +-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the greatest @k@ elements deleted, +-- or an empty queue if @k >= 'size' queue@. +drop :: Ord a => Int -> MaxQueue a -> MaxQueue a +drop = coerce MinQ.drop + +-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. +splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) +splitAt = coerce MinQ.splitAt + +-- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. +filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a +filter = coerce MinQ.filter + +-- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue +-- contains all elements not satisfying @p@. +partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) +partition = coerce MinQ.partition + +-- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. +-- Equivalent to @'fromList' . 'Data.List.map' f . toList@. +map :: Ord b => (a -> b) -> MaxQueue a -> MaxQueue b +map = coerce MinQ.map + +{-# INLINE toList #-} +-- | \(O(n \log n)\). Returns the elements of the priority queue in descending order. Equivalent to 'toDescList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MaxQueue a -> [a] +toList = coerce MinQ.toAscList + +toAscList :: Ord a => MaxQueue a -> [a] +toAscList = coerce MinQ.toDescList + +toDescList :: Ord a => MaxQueue a -> [a] +toDescList = coerce MinQ.toAscList + +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b +foldrDesc f z (MaxQueue q) = MinQ.foldrAsc (coerce f) z q + +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in ascending order. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b +foldrAsc f z (MaxQueue q) = MinQ.foldrDesc (coerce f) z q + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in ascending order. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b +foldlAsc f z (MaxQueue q) = MinQ.foldlDesc (coerce f) z q + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b +foldlDesc f z (MaxQueue q) = MinQ.foldlAsc (coerce f) z q + +{-# INLINE fromAscList #-} +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +fromAscList :: [a] -> MaxQueue a +fromAscList = coerce MinQ.fromDescList + +{-# INLINE fromDescList #-} +-- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MaxQueue a +fromDescList = coerce MinQ.fromAscList + +fromList :: Ord a => [a] -> MaxQueue a +fromList = coerce MinQ.fromList + +-- | Equivalent to 'toListU'. +elemsU :: MaxQueue a -> [a] +elemsU = toListU + +-- | Convert to a list in an arbitrary order. +toListU :: MaxQueue a -> [a] +toListU = coerce MinQ.toListU + +-- | Get the number of elements in a 'MaxQueue'. +size :: MaxQueue a -> Int +size = MinQ.size . unMaxQueue + +empty :: MaxQueue a +empty = MaxQueue MinQ.empty + +foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m +foldMapU f = MinQ.foldMapU (coerce f) . unMaxQueue + +seqSpine :: MaxQueue a -> b -> b +seqSpine = MinQ.seqSpine . unMaxQueue + +foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b +foldlU f b = MinQ.foldlU (coerce f) b . unMaxQueue + +foldlU' :: (b -> a -> b) -> b -> MaxQueue a -> b +foldlU' f b = MinQ.foldlU' (coerce f) b . unMaxQueue + +foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b +foldrU c n = MinQ.foldrU (coerce c) n . unMaxQueue + +null :: MaxQueue a -> Bool +null = MinQ.null . unMaxQueue + +singleton :: a -> MaxQueue a +singleton = coerce MinQ.singleton + +mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b +mapMaybe = coerce MinQ.mapMaybe + +insert :: Ord a => a -> MaxQueue a -> MaxQueue a +insert = coerce MinQ.insert + +mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) +mapEither = coerce MinQ.mapEither + +union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a +union (MaxQueue a) (MaxQueue b) = MaxQueue (MinQ.union a b) + +unions :: Ord a => [MaxQueue a] -> MaxQueue a +unions = MaxQueue . MinQ.unions . fmap unMaxQueue diff --git a/src/BinomialQueue/Min.hs b/src/BinomialQueue/Min.hs new file mode 100644 --- /dev/null +++ b/src/BinomialQueue/Min.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : BinomialQueue.Min +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue. Unlike the queues in "Data.PQueue.Min", +-- these are /not/ augmented with a global root or their size, so 'getMin' +-- and 'size' take logarithmic, rather than constant, time. When those +-- operations are not (often) needed, these queues are generally faster than +-- those in "Data.PQueue.Min". +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /k/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- This implementation is based on a binomial heap. +-- +-- This implementation does not guarantee stable behavior. +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module BinomialQueue.Min ( + MinQueue, + -- * Basic operations + empty, + null, + size, + -- * Query operations + findMin, + getMin, + deleteMin, + deleteFindMin, + minView, + -- * Construction operations + singleton, + insert, + union, + unions, + -- * Subsets + -- ** Extracting subsets + (!!), + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + dropWhile, + span, + break, + -- * Filter/Map + filter, + partition, + mapMaybe, + mapEither, + -- * Fold\/Functor\/Traversable variations + map, + mapMonotonic, + foldrAsc, + foldlAsc, + foldrDesc, + foldlDesc, + -- * List operations + toList, + toAscList, + toDescList, + fromList, + fromAscList, + fromDescList, + -- * Unordered operations + foldrU, + foldlU, + foldlU', + foldMapU, + elemsU, + toListU, + -- * Miscellaneous operations +-- keysQueue, -- We want bare Prio queues for this. + seqSpine + ) where + +import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif +import qualified Data.List as List +import Data.Maybe (fromMaybe) + +import BinomialQueue.Internals + +-- | \(O(\log n)\). Returns the minimum element. Throws an error on an empty queue. +findMin :: Ord a => MinQueue a -> a +findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin + +-- | \(O(\log n)\). Deletes the minimum element. If the queue is empty, does nothing. +deleteMin :: Ord a => MinQueue a -> MinQueue a +deleteMin q = case minView q of + Nothing -> empty + Just (_, q') -> q' + +-- | \(O(\log n)\). Extracts the minimum element. Throws an error on an empty queue. +deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) +deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView + +-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- element in the queue. Equivalent to @toAscList queue !! k@. +(!!) :: Ord a => MinQueue a -> Int -> a +q !! n | n >= size q + = error "Data.PQueue.Min.!!: index too large" +q !! n = toAscList q List.!! n + +{-# INLINE takeWhile #-} +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] +takeWhile p = List.takeWhile p . toAscList + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +dropWhile p = drop' where + drop' q = case minView q of + Just (x, q') | p x -> drop' q' + _ -> q + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +span p queue = case minView queue of + Just (x, q') + | p x -> let (ys, q'') = span p q' in (x : ys, q'') + _ -> ([], queue) + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +break p = span (not . p) + +{-# INLINE take #-} +-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, +-- or all elements of @queue@ itself if @k >= 'size' queue@. +take :: Ord a => Int -> MinQueue a -> [a] +take n = List.take n . toAscList + +-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, +-- or an empty queue if @k >= 'size' queue@. +drop :: Ord a => Int -> MinQueue a -> MinQueue a +drop n queue = n `seq` case minView queue of + Just (_, queue') + | n > 0 -> drop (n - 1) queue' + _ -> queue + +-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. +splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) +splitAt n queue = n `seq` case minView queue of + Just (x, queue') + | n > 0 -> let (xs, queue'') = splitAt (n - 1) queue' in (x : xs, queue'') + _ -> ([], queue) + +-- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. +filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +filter p = mapMaybe (\x -> if p x then Just x else Nothing) + +-- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue +-- contains all elements not satisfying @p@. +partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) +partition p = mapEither (\x -> if p x then Left x else Right x) + +-- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. +-- Equivalent to @'fromList' . 'Data.List.map' f . toList@. +map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b +map f = foldrU (insert . f) empty + +{-# INLINE toList #-} +-- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MinQueue a -> [a] +toList = toAscList + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. +-- @foldlDesc f z q == foldrAsc (flip f) z q@. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlDesc = foldrAsc . flip + +{-# INLINE fromDescList #-} +-- | \(O(n)\). Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromDescList xs = foldl' (flip insertMinQ') empty xs + +-- | Equivalent to 'toListU'. +elemsU :: MinQueue a -> [a] +elemsU = toListU diff --git a/src/Data/PQueue/Internals.hs b/src/Data/PQueue/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module Data.PQueue.Internals ( + MinQueue (..), + BinomHeap, + BinomForest(..), + BinomTree(..), + Succ(..), + Zero(..), + empty, + null, + size, + getMin, + minView, + singleton, + insert, + union, + mapMaybe, + mapEither, + mapMonotonic, + foldrAsc, + foldlAsc, + foldrDesc, + insertMinQ, + insertMinQ', + insertMaxQ', + toAscList, + toDescList, + toListU, + fromList, + fromAscList, + foldMapU, + foldrU, + foldlU, + foldlU', +-- traverseU, + seqSpine, + unions, + ) where + +import BinomialQueue.Internals + ( BinomHeap + , BinomForest (..) + , BinomTree (..) + , Succ (..) + , Zero (..) + ) +import qualified BinomialQueue.Internals as BQ +import Control.DeepSeq (NFData(rnf), deepseq) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif +import Data.Semigroup (Semigroup(..), stimesMonoid) + +#ifdef __GLASGOW_HASKELL__ +import Data.Data +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +import GHC.Exts (build) +#endif + +import Prelude hiding (null) + +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +-- | A priority queue with elements of type @a@. Supports extracting the minimum element. +data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int !a !(BQ.MinQueue a) + +fromBare :: Ord a => BQ.MinQueue a -> MinQueue a +-- Should we fuse the size calculation with the minimum extraction? +fromBare xs = case BQ.minView xs of + Just (x, xs') -> MinQueue (1 + BQ.size xs') x xs' + Nothing -> Empty + +#ifdef __GLASGOW_HASKELL__ + +-- | Treats the priority queue as an empty queue or a minimal element and a +-- priority queue. The constructors, conceptually, are 'Data.PQueue.Min.Empty' +-- and '(Data.PQueue.Min.:<)'. All constructed queues maintain the queue +-- invariants. +instance (Ord a, Data a) => Data (MinQueue a) where + gfoldl f z q = case minView q of + Nothing -> z Empty + Just (x, q') -> z insert `f` x `f` q' + + gunfold k z c = case constrIndex c of + 1 -> z Empty + 2 -> k (k (z insert)) + _ -> error "gunfold: invalid constructor for MinQueue" + + dataCast1 x = gcast1 x + + toConstr q + | null q = emptyConstr + | otherwise = consConstr + + dataTypeOf _ = queueDataType + +queueDataType :: DataType +queueDataType = mkDataType "Data.PQueue.Min.MinQueue" [emptyConstr, consConstr] + +emptyConstr, consConstr :: Constr +emptyConstr = mkConstr queueDataType "Empty" [] Prefix +consConstr = mkConstr queueDataType ":<" [] Infix + +#endif + +instance Ord a => Eq (MinQueue a) where + Empty == Empty = True + MinQueue n1 x1 q1 == MinQueue n2 x2 q2 = + n1 == n2 && x1 == x2 && q1 == q2 + _ == _ = False + +instance Ord a => Ord (MinQueue a) where + Empty `compare` Empty = EQ + Empty `compare` _ = LT + _ `compare` Empty = GT + MinQueue _n1 x1 q1 `compare` MinQueue _n2 x2 q2 = compare (x1,q1) (x2,q2) + + -- We compare their first elements, then their other elements up to the smaller queue's length, + -- and then the longer queue wins. + -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. + +-- basics + +-- | \(O(1)\). The empty priority queue. +empty :: MinQueue a +empty = Empty + +-- | \(O(1)\). Is this the empty priority queue? +null :: MinQueue a -> Bool +null Empty = True +null _ = False + +-- | \(O(1)\). The number of elements in the queue. +size :: MinQueue a -> Int +size Empty = 0 +size (MinQueue n _ _) = n + +-- | \(O(1)\). Returns the minimum element of the queue, if the queue is nonempty. +getMin :: MinQueue a -> Maybe a +getMin (MinQueue _ x _) = Just x +getMin _ = Nothing + +-- | Retrieves the minimum element of the queue, and the queue stripped of that element, +-- or 'Nothing' if passed an empty queue. +minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a) +minView Empty = Nothing +minView (MinQueue n x ts) = Just (x, case BQ.minView ts of + Nothing -> Empty + Just (x', ts') -> MinQueue (n - 1) x' ts') + +-- | \(O(1)\). Construct a priority queue with a single element. +singleton :: a -> MinQueue a +singleton x = MinQueue 1 x BQ.empty + +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Insert an element into the priority queue. +insert :: Ord a => a -> MinQueue a -> MinQueue a +insert x Empty = singleton x +insert x (MinQueue n x' ts) + | x <= x' = MinQueue (n + 1) x (BQ.insertMinQ x' ts) + | otherwise = MinQueue (n + 1) x' (BQ.insert x ts) + +-- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. +union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a +union Empty q = q +union q Empty = q +union (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) + | x1 <= x2 = MinQueue (n1 + n2) x1 (BQ.unionPlusOne x2 f1 f2) + | otherwise = MinQueue (n1 + n2) x2 (BQ.unionPlusOne x1 f1 f2) + + +-- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. +unions :: Ord a => [MinQueue a] -> MinQueue a +unions = foldl' union empty + +-- | \(O(n)\). Map elements and collect the 'Just' results. +mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b +mapMaybe _ Empty = Empty +mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insertEager` q') (f x) + where + q' = BQ.mapMaybe f ts + +-- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. +mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) +mapEither _ Empty = (Empty, Empty) +mapEither f (MinQueue _ x ts) + | (l, r) <- BQ.mapEither f ts + = case f x of + Left y -> + let !l' = fromBare (BQ.insertEager y l) + !r' = fromBare r + in (l', r') + Right z -> + let !l' = fromBare l + !r' = fromBare (BQ.insertEager z r) + in (l', r') + +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic +-- (meaning that @x <= y@ implies @f x <= f y@), and +-- applies this function to every element of the priority queue, as in 'fmap'. +-- If the function is not monotonic, the result is undefined. +mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b +mapMonotonic _ Empty = Empty +mapMonotonic f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapMonotonic f ts) + +{-# INLINABLE [0] foldrAsc #-} +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in +-- ascending order. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrAsc _ z Empty = z +foldrAsc f z (MinQueue _ x ts) = x `f` BQ.foldrUnfold f z BQ.minView ts + +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. +-- @foldrDesc f z q == foldlAsc (flip f) z q@. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrDesc = foldlAsc . flip +{-# INLINE [0] foldrDesc #-} + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in +-- ascending order. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlAsc _ z Empty = z +foldlAsc f z (MinQueue _ x ts) = BQ.foldlUnfold f (z `f` x) BQ.minView ts + +{-# INLINABLE [1] toAscList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MinQueue a -> [a] +toAscList queue = foldrAsc (:) [] queue + +{-# INLINABLE toAscListApp #-} +toAscListApp :: Ord a => MinQueue a -> [a] -> [a] +toAscListApp Empty app = app +toAscListApp (MinQueue _ x ts) app = x : BQ.foldrUnfold (:) app BQ.minView ts + +{-# INLINABLE [1] toDescList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MinQueue a -> [a] +toDescList queue = foldrDesc (:) [] queue + +{-# INLINABLE toDescListApp #-} +toDescListApp :: Ord a => MinQueue a -> [a] -> [a] +toDescListApp Empty app = app +toDescListApp (MinQueue _ x ts) app = BQ.foldlUnfold (flip (:)) (x : app) BQ.minView ts + +{-# RULES +"toAscList" [~1] forall q. toAscList q = build (\c nil -> foldrAsc c nil q) +"toDescList" [~1] forall q. toDescList q = build (\c nil -> foldrDesc c nil q) +"ascList" [1] forall q add. foldrAsc (:) add q = toAscListApp q add +"descList" [1] forall q add. foldrDesc (:) add q = toDescListApp q add + #-} + +{-# INLINE fromAscList #-} +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +-- +-- Performance note: Code using this function in a performance-sensitive context +-- with an argument that is a "good producer" for list fusion should be compiled +-- with @-fspec-constr@ or @-O2@. For example, @fromAscList . map f@ needs one +-- of these options for best results. +fromAscList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromAscList xs = foldl' (flip insertMaxQ') empty xs + +-- | @insertMinQ x h@ assumes that @x@ compares as less +-- than or equal to every element of @h@. +insertMinQ :: a -> MinQueue a -> MinQueue a +insertMinQ x Empty = singleton x +insertMinQ x (MinQueue n x' f) = MinQueue (n + 1) x (BQ.insertMinQ x' f) + +-- | @insertMinQ' x h@ assumes that @x@ compares as less +-- than or equal to every element of @h@. +insertMinQ' :: a -> MinQueue a -> MinQueue a +insertMinQ' x Empty = singleton x +insertMinQ' x (MinQueue n x' f) = MinQueue (n + 1) x (BQ.insertMinQ' x' f) + +-- | @insertMaxQ' x h@ assumes that @x@ compares as greater +-- than or equal to every element of @h@. It also assumes, +-- and preserves, an extra invariant. See 'BQ.insertMax'' for details. +-- tldr: this function can be used safely to build a queue from an +-- ascending list/array/whatever, but that's about it. +insertMaxQ' :: a -> MinQueue a -> MinQueue a +insertMaxQ' x Empty = singleton x +insertMaxQ' x (MinQueue n x' f) = MinQueue (n + 1) x' (BQ.insertMaxQ' x f) + +{-# INLINABLE fromList #-} +-- | \(O(n)\). Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MinQueue a +-- We build a forest first and then extract its minimum at the end. +-- Why not just build the 'MinQueue' directly? This way saves us one +-- comparison per element. +fromList xs = fromBare (BQ.fromList xs) + +{-# NOINLINE [0] foldrU #-} +-- | \(O(n)\). Unordered right fold on a priority queue. +foldrU :: (a -> b -> b) -> b -> MinQueue a -> b +foldrU _ z Empty = z +foldrU f z (MinQueue _ x ts) = x `f` BQ.foldrU f z ts + +-- | \(O(n)\). Unordered left fold on a priority queue. This is rarely +-- what you want; 'foldrU' and 'foldlU'' are more likely to perform +-- well. +foldlU :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU _ z Empty = z +foldlU f z (MinQueue _ x ts) = BQ.foldlU f (z `f` x) ts + +-- | \(O(n)\). Unordered strict left fold on a priority queue. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU' _ z Empty = z +foldlU' f z (MinQueue _ x ts) = BQ.foldlU' f (z `f` x) ts + +-- | \(O(n)\). Unordered monoidal fold on a priority queue. +-- +-- @since 1.4.2 +foldMapU :: Monoid m => (a -> m) -> MinQueue a -> m +foldMapU _ Empty = mempty +foldMapU f (MinQueue _ x ts) = f x `mappend` BQ.foldMapU f ts + +{-# NOINLINE toListU #-} +-- | \(O(n)\). Returns the elements of the queue, in no particular order. +toListU :: MinQueue a -> [a] +toListU q = foldrU (:) [] q + +{-# NOINLINE toListUApp #-} +toListUApp :: MinQueue a -> [a] -> [a] +toListUApp Empty app = app +toListUApp (MinQueue _ x ts) app = x : BQ.foldrU (:) app ts + +{-# RULES +"toListU/build" [~1] forall q. toListU q = build (\c n -> foldrU c n q) +"toListU" [1] forall q app. foldrU (:) app q = toListUApp q app + #-} + +-- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) +-- traverseU _ Empty = pure Empty +-- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts + +-- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. +-- +-- Note: The spine of a 'MinQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} +seqSpine :: MinQueue a -> b -> b +seqSpine Empty z = z +seqSpine (MinQueue _ _ ts) z = BQ.seqSpine ts z + +instance NFData a => NFData (MinQueue a) where + rnf Empty = () + rnf (MinQueue _ x ts) = x `deepseq` rnf ts + +instance (Ord a, Show a) => Show (MinQueue a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toAscList xs) + +instance (Ord a, Read a) => Read (MinQueue a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) +#endif + +instance Ord a => Semigroup (MinQueue a) where + (<>) = union + stimes = stimesMonoid + {-# INLINABLE stimes #-} + +instance Ord a => Monoid (MinQueue a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions diff --git a/src/Data/PQueue/Internals/Classes.hs b/src/Data/PQueue/Internals/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals/Classes.hs @@ -0,0 +1,26 @@ +-- | Writing `Foldable`/`Functor` instances for non-regular (AKA, nested) types in the +-- natural manner leads to full dictionaries being constructed on +-- each recursive call. This is pretty inefficient. It's better to construct +-- exactly what we need instead. +module Data.PQueue.Internals.Classes + ( Foldr(..) + , Foldl(..) + , FoldMap(..) + , Foldl'(..) + , Fmap(..) + ) where + +class Foldr t where + foldr_ :: (a -> b -> b) -> b -> t a -> b + +class Foldl t where + foldl_ :: (b -> a -> b) -> b -> t a -> b + +class FoldMap t where + foldMap_ :: Monoid m => (a -> m) -> t a -> m + +class Foldl' t where + foldl'_ :: (b -> a -> b) -> b -> t a -> b + +class Fmap f where + fmap_ :: (a -> b) -> f a -> f b diff --git a/src/Data/PQueue/Internals/Down.hs b/src/Data/PQueue/Internals/Down.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals/Down.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module Data.PQueue.Internals.Down where + +import Control.DeepSeq (NFData(rnf)) +import Data.Foldable (Foldable (..)) + +#if __GLASGOW_HASKELL__ +import Data.Data (Data) +#endif + +newtype Down a = Down { unDown :: a } +#if __GLASGOW_HASKELL__ + deriving (Eq, Data) +#else + deriving (Eq) +#endif + +instance NFData a => NFData (Down a) where + rnf (Down a) = rnf a + +instance Ord a => Ord (Down a) where + Down a `compare` Down b = b `compare` a + Down a <= Down b = b <= a + Down a >= Down b = b >= a + Down a < Down b = b < a + Down a > Down b = b > a + +instance Functor Down where + fmap f (Down a) = Down (f a) + +instance Foldable Down where + foldr f z (Down a) = a `f` z + foldl f z (Down a) = z `f` a + foldr' f !z (Down a) = a `f` z + foldl' f !z (Down a) = z `f` a diff --git a/src/Data/PQueue/Max.hs b/src/Data/PQueue/Max.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Max.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-deprecations #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.PQueue.Max +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue, supporting view-maximum operations. +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /k/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- This implementation is based on a binomial heap augmented with a global root. +-- +-- This implementation does not guarantee stable behavior. +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module Data.PQueue.Max ( + MaxQueue, + -- * Basic operations + empty, + null, + size, + -- * Query operations + findMax, + getMax, + deleteMax, + deleteFindMax, + delete, + maxView, + -- * Construction operations + singleton, + insert, + union, + unions, + -- * Subsets + -- ** Extracting subsets + (!!), + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + dropWhile, + span, + break, + -- * Filter/Map + filter, + partition, + mapMaybe, + mapEither, + -- * Fold\/Functor\/Traversable variations + map, + mapMonotonic, + foldrAsc, + foldlAsc, + foldrDesc, + foldlDesc, + -- * List operations + toList, + toAscList, + toDescList, + fromList, + fromAscList, + fromDescList, + -- * Unordered operations + mapU, + foldrU, + foldlU, + foldlU', + foldMapU, + elemsU, + toListU, + -- * Miscellaneous operations + keysQueue, + seqSpine) where + +import Control.DeepSeq (NFData(rnf)) + +import Data.Coerce (coerce) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif +import Data.Maybe (fromMaybe) +import Data.Semigroup (Semigroup(..), stimesMonoid) + +import qualified Data.PQueue.Min as Min +import qualified Data.PQueue.Prio.Max.Internals as Prio +import Data.PQueue.Internals.Down (Down(..)) + +import Prelude hiding (null, map, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (build) +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +import Data.Data +#else +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +-- | A priority queue with elements of type @a@. Supports extracting the maximum element. +-- Implemented as a wrapper around 'Min.MinQueue'. +newtype MaxQueue a = MaxQ (Min.MinQueue (Down a)) +# if __GLASGOW_HASKELL__ + deriving (Eq, Ord, Data) +# else + deriving (Eq, Ord) +# endif + +instance NFData a => NFData (MaxQueue a) where + rnf (MaxQ q) = rnf q + +instance (Ord a, Show a) => Show (MaxQueue a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toDescList xs) + +instance (Ord a, Read a) => Read (MaxQueue a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) +#endif + +instance Ord a => Semigroup (MaxQueue a) where + (<>) = union + stimes = stimesMonoid + {-# INLINABLE stimes #-} + +instance Ord a => Monoid (MaxQueue a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions + +-- | \(O(1)\). The empty priority queue. +empty :: MaxQueue a +empty = MaxQ Min.empty + +-- | \(O(1)\). Is this the empty priority queue? +null :: MaxQueue a -> Bool +null (MaxQ q) = Min.null q + +-- | \(O(1)\). The number of elements in the queue. +size :: MaxQueue a -> Int +size (MaxQ q) = Min.size q + +-- | \(O(1)\). Returns the maximum element of the queue. Throws an error on an empty queue. +findMax :: MaxQueue a -> a +findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax + +-- | \(O(1)\). The top (maximum) element of the queue, if there is one. +getMax :: MaxQueue a -> Maybe a +getMax = coerce Min.getMin + +-- | \(O(\log n)\). Deletes the maximum element of the queue. Does nothing on an empty queue. +deleteMax :: Ord a => MaxQueue a -> MaxQueue a +deleteMax = coerce Min.deleteMin + +-- | \(O(\log n)\). Extracts the maximum element of the queue. Throws an error on an empty queue. +deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) +deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView + +-- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. +maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) +maxView = coerce Min.minView + +-- | \(O(\log n)\). Delete the top (maximum) element of the sequence, if there is one. +delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) +delete = fmap snd . maxView + +-- | \(O(1)\). Construct a priority queue with a single element. +singleton :: a -> MaxQueue a +singleton = coerce Min.singleton + +-- | \(O(1)\). Insert an element into the priority queue. +insert :: Ord a => a -> MaxQueue a -> MaxQueue a +insert = coerce Min.insert + +-- | \(O(\log min(n_1,n_2))\). Take the union of two priority queues. +union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a +MaxQ q1 `union` MaxQ q2 = MaxQ (q1 `Min.union` q2) + +-- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. +unions :: Ord a => [MaxQueue a] -> MaxQueue a +unions = coerce Min.unions + +-- | \(O(k \log n)\). Returns the @(k+1)@th largest element of the queue. +(!!) :: Ord a => MaxQueue a -> Int -> a +(!!) = coerce (Min.!!) + +{-# INLINE take #-} +-- | \(O(k \log n)\). Returns the list of the @k@ largest elements of the queue, in descending order, or +-- all elements of the queue, if @k >= n@. +take :: Ord a => Int -> MaxQueue a -> [a] +take = coerce Min.take + +-- | \(O(k \log n)\). Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. +drop :: Ord a => Int -> MaxQueue a -> MaxQueue a +drop = coerce Min.drop + +-- | \(O(k \log n)\). Equivalent to @(take k queue, drop k queue)@. +splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) +splitAt = coerce Min.splitAt + +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] +takeWhile = coerce Min.takeWhile + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a +dropWhile = coerce Min.dropWhile + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +-- +span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +span = coerce Min.span + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +break p = span (not . p) + +-- | \(O(n)\). Returns a queue of those elements which satisfy the predicate. +filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a +filter = coerce Min.filter + +-- | \(O(n)\). Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, +-- and the right queue contains those that do not. +partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) +partition = coerce Min.partition + +-- | \(O(n)\). Maps a function over the elements of the queue, and collects the 'Just' values. +mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b +mapMaybe = coerce Min.mapMaybe + +-- | \(O(n)\). Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. +mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) +mapEither = coerce Min.mapEither + +-- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. +-- Equivalent to @'fromList' . 'Data.List.map' f . toList@. +map :: Ord b => (a -> b) -> MaxQueue a -> MaxQueue b +map = coerce Min.map + +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic +-- (meaning that @x <= y@ implies @f x <= f y@), and +-- applies this function to every element of the priority queue, as in 'fmap'. +-- If the function is not monotonic, the result is undefined. +mapMonotonic :: (a -> b) -> MaxQueue a -> MaxQueue b +mapMonotonic f (MaxQ q) = MaxQ (Min.mapMonotonic (\(Down a) -> Down (f a)) q) + +{-# DEPRECATED mapU "use mapMonotonic instead" #-} +mapU :: (a -> b) -> MaxQueue a -> MaxQueue b +mapU = mapMonotonic + +-- | \(O(n)\). Unordered right fold on a priority queue. +foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b +foldrU f z (MaxQ q) = Min.foldrU (coerce f) z q + +-- | \(O(n)\). Unordered monoidal fold on a priority queue. +-- +-- @since 1.4.2 +foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m +foldMapU f (MaxQ q) = Min.foldMapU (coerce f) q + +-- | \(O(n)\). Unordered left fold on a priority queue. This is rarely +-- what you want; 'foldrU' and 'foldlU'' are more likely to perform +-- well. +foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b +foldlU f z (MaxQ q) = Min.foldlU (coerce f) z q + +-- | \(O(n)\). Unordered strict left fold on a priority queue. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MaxQueue a -> b +foldlU' f z (MaxQ q) = Min.foldlU' (coerce f) z q + +{-# INLINE elemsU #-} +-- | Equivalent to 'toListU'. +elemsU :: MaxQueue a -> [a] +elemsU = toListU + +{-# INLINE toListU #-} +-- | \(O(n)\). Returns a list of the elements of the priority queue, in no particular order. +toListU :: MaxQueue a -> [a] +toListU = coerce Min.toListU + +-- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in ascending order. +-- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b +foldrAsc = foldlDesc . flip + +-- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. +-- @'foldlAsc' f z q == 'foldrDesc' (flip f) z q@. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b +foldlAsc = foldrDesc . flip + +-- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in descending order. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b +foldrDesc f z (MaxQ q) = Min.foldrAsc (coerce f) z q + +-- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b +foldlDesc f z (MaxQ q) = Min.foldlAsc (coerce f) z q + +{-# INLINE toAscList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MaxQueue a -> [a] +toAscList q = build (\c nil -> foldrAsc c nil q) +-- I can see no particular reason this does not simply forward to Min.toDescList. (lsp, 2016) + +{-# INLINE toDescList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MaxQueue a -> [a] +toDescList q = build (\c nil -> foldrDesc c nil q) +-- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016) + +{-# INLINE toList #-} +-- | \(O(n \log n)\). Returns the elements of the priority queue in descending order. Equivalent to 'toDescList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MaxQueue a -> [a] +toList = coerce Min.toList + +{-# INLINE fromAscList #-} +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +fromAscList :: [a] -> MaxQueue a +fromAscList = coerce Min.fromDescList + +{-# INLINE fromDescList #-} +-- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MaxQueue a +fromDescList = coerce Min.fromAscList + +{-# INLINE fromList #-} +-- | \(O(n \log n)\). Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MaxQueue a +fromList = coerce Min.fromList + +-- | \(O(n)\). Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. +keysQueue :: Prio.MaxPQueue k a -> MaxQueue k +keysQueue = coerce Min.keysQueue + +-- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. +-- +-- Note: The spine of a 'MaxQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} +seqSpine :: MaxQueue a -> b -> b +seqSpine (MaxQ q) = Min.seqSpine q diff --git a/src/Data/PQueue/Min.hs b/src/Data/PQueue/Min.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Min.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.PQueue.Min +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue, supporting extract-minimum operations. +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /k/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- This implementation is based on a binomial heap augmented with a global root. +-- +-- This implementation does not guarantee stable behavior. +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module Data.PQueue.Min ( +#if __GLASGOW_HASKELL__ >= 802 + MinQueue (Data.PQueue.Min.Empty, (:<)), +#elif defined (__GLASGOW_HASKELL__) + MinQueue, + pattern Data.PQueue.Min.Empty, + pattern (:<), +#endif + -- * Basic operations + empty, + null, + size, + -- * Query operations + findMin, + getMin, + deleteMin, + deleteFindMin, + minView, + -- * Construction operations + singleton, + insert, + union, + unions, + -- * Subsets + -- ** Extracting subsets + (!!), + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + dropWhile, + span, + break, + -- * Filter/Map + filter, + partition, + mapMaybe, + mapEither, + -- * Fold\/Functor\/Traversable variations + map, + mapMonotonic, + foldrAsc, + foldlAsc, + foldrDesc, + foldlDesc, + -- * List operations + toList, + toAscList, + toDescList, + fromList, + fromAscList, + fromDescList, + -- * Unordered operations + mapU, + foldrU, + foldlU, + foldlU', + foldMapU, + elemsU, + toListU, + -- * Miscellaneous operations + keysQueue, + seqSpine) where + +import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) + +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif +import qualified Data.List as List +import Data.Maybe (fromMaybe) + +import Data.PQueue.Internals hiding (MinQueue (..)) +import Data.PQueue.Internals (MinQueue (MinQueue)) +import qualified Data.PQueue.Internals as Internals +import qualified BinomialQueue.Internals as BQ +import qualified Data.PQueue.Prio.Internals as Prio + +#ifdef __GLASGOW_HASKELL__ +-- | A bidirectional pattern synonym for an empty priority queue. +-- +-- @since 1.5.0 +pattern Empty :: MinQueue a +pattern Empty = Internals.Empty +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE CONLIKE Empty #-} +# endif + +infixr 5 :< + +-- | A bidirectional pattern synonym for working with the minimum view of a +-- 'MinQueue'. Using @:<@ to construct a queue performs an insertion in +-- \(O(1)\) amortized time. When matching on @a :< q@, forcing @q@ takes +-- \(O(\log n)\) time. +-- +-- @since 1.5.0 +# if __GLASGOW_HASKELL__ >= 800 +pattern (:<) :: Ord a => a -> MinQueue a -> MinQueue a +# else +pattern (:<) :: () => Ord a => a -> MinQueue a -> MinQueue a +# endif +pattern a :< q <- (minView -> Just (a, q)) + where + a :< q = insert a q +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE (:<) #-} +# endif + +# if __GLASGOW_HASKELL__ >= 820 +{-# COMPLETE Empty, (:<) #-} +# endif +#endif + +-- | \(O(1)\). Returns the minimum element. Throws an error on an empty queue. +findMin :: MinQueue a -> a +findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin + +-- | \(O(\log n)\). Deletes the minimum element. If the queue is empty, does nothing. +deleteMin :: Ord a => MinQueue a -> MinQueue a +deleteMin q = case minView q of + Nothing -> empty + Just (_, q') -> q' + +-- | \(O(\log n)\). Extracts the minimum element. Throws an error on an empty queue. +deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) +deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView + +-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- element in the queue. Equivalent to @toAscList queue !! k@. +(!!) :: Ord a => MinQueue a -> Int -> a +q !! n | n >= size q + = error "Data.PQueue.Min.!!: index too large" +q !! n = toAscList q List.!! n + +{-# INLINE takeWhile #-} +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] +takeWhile p = List.takeWhile p . toAscList + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +dropWhile p = drop' where + drop' q = case minView q of + Just (x, q') | p x -> drop' q' + _ -> q + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +span p queue = case minView queue of + Just (x, q') + | p x -> let (ys, q'') = span p q' in (x : ys, q'') + _ -> ([], queue) + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +break p = span (not . p) + +{-# INLINE take #-} +-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, +-- or all elements of @queue@ itself if @k >= 'size' queue@. +take :: Ord a => Int -> MinQueue a -> [a] +take n = List.take n . toAscList + +-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, +-- or an empty queue if @k >= 'size' queue@. +drop :: Ord a => Int -> MinQueue a -> MinQueue a +drop n queue = n `seq` case minView queue of + Just (_, queue') + | n > 0 -> drop (n - 1) queue' + _ -> queue + +-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. +splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) +splitAt n queue = n `seq` case minView queue of + Just (x, queue') + | n > 0 -> let (xs, queue'') = splitAt (n - 1) queue' in (x : xs, queue'') + _ -> ([], queue) + +-- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. +filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +filter p = mapMaybe (\x -> if p x then Just x else Nothing) + +-- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue +-- contains all elements not satisfying @p@. +partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) +partition p = mapEither (\x -> if p x then Left x else Right x) + +-- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. +-- Equivalent to @'fromList' . 'Data.List.map' f . toList@. +map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b +map f = foldrU (insert . f) empty + +{-# DEPRECATED mapU "use mapMonotonic instead" #-} +mapU :: (a -> b) -> MinQueue a -> MinQueue b +mapU = mapMonotonic + +{-# INLINE toList #-} +-- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MinQueue a -> [a] +toList = toAscList + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. +-- @foldlDesc f z q == foldrAsc (flip f) z q@. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlDesc = foldrAsc . flip + +{-# INLINE fromDescList #-} +-- | \(O(n)\). Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromDescList xs = foldl' (flip insertMinQ') empty xs + +-- | Equivalent to 'toListU'. +elemsU :: MinQueue a -> [a] +elemsU = toListU + +-- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. +keysQueue :: Prio.MinPQueue k a -> MinQueue k +keysQueue Prio.Empty = Internals.Empty +keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (BQ.MinQueue (keysF (const Zero) ts)) + +keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k +keysF f ts0 = case ts0 of + Prio.Nil -> Nil + Prio.Skip ts' -> Skip $! keysF f' ts' + Prio.Cons (Prio.BinomTree k ts) ts' + -> Cons (BinomTree k (f ts)) $! keysF f' ts' + where f' (Prio.Succ (Prio.BinomTree k ts) tss) = Succ (BinomTree k (f ts)) (f tss) diff --git a/src/Data/PQueue/Prio/Internals.hs b/src/Data/PQueue/Prio/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Internals.hs @@ -0,0 +1,792 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.PQueue.Prio.Internals ( + MinPQueue(..), + BinomForest(..), + BinomHeap, + BinomTree(..), + Zero(..), + Succ(..), + empty, + null, + size, + singleton, + insert, + insertEager, + union, + getMin, + adjustMinWithKey, + adjustMinWithKeyA', + updateMinWithKey, + updateMinWithKeyA', + minViewWithKey, + mapWithKey, + mapKeysMonotonic, + mapMaybeWithKey, + mapEitherWithKey, + foldrWithKey, + foldlWithKey, + foldrU, + toAscList, + toDescList, + toListU, + insertMin, + insertMin', + insertMax', + fromList, + fromAscList, + foldrWithKeyU, + foldMapWithKeyU, + foldlWithKeyU, + foldlWithKeyU', + traverseWithKey, + mapMWithKey, + traverseWithKeyU, + seqSpine, + unions + ) where + +#if MIN_VERSION_base(4,18,0) +import Control.Applicative (Const (..)) +#else +import Control.Applicative (liftA2, Const (..)) +#endif +import Control.DeepSeq (NFData(rnf), deepseq) +import Data.Coerce (coerce) +import Data.Functor.Identity (Identity(Identity, runIdentity)) +import qualified Data.List as List + +import Data.Semigroup (Semigroup(..), stimesMonoid, Endo (..), Dual (..)) + +import Prelude hiding (null, map) +#ifdef __GLASGOW_HASKELL__ +import Data.Data +import GHC.Exts (build, inline) +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +#endif + +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Traversable.WithIndex +import Nattish (Nattish (..)) + +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +#if __GLASGOW_HASKELL__ + +-- | Treats the priority queue as an empty queue or a minimal +-- key-value pair and a priority queue. The constructors, conceptually, +-- are 'Data.PQueue.Prio.Min.Empty' and '(Data.PQueue.Prio.Min.:<)'. +-- +-- 'gfoldl' is nondeterministic; any minimal pair may be chosen as +-- the first. All constructed queues maintain the queue invariants. +instance (Ord k, Data k, Data a) => Data (MinPQueue k a) where + gfoldl f z q = case minViewWithKey q of + Nothing -> z Empty + Just (x, q') -> z (\(k, a) -> insert k a) `f` x `f` q' + + gunfold k z c = case constrIndex c of + 1 -> z Empty + 2 -> k (k (z (\(key, val) -> insert key val))) + _ -> error "gunfold: invalid constructor for MinPQueue" + + toConstr q + | null q = emptyConstr + | otherwise = consConstr + + dataTypeOf _ = queueDataType + dataCast1 f = gcast1 f + dataCast2 f = gcast2 f + +queueDataType :: DataType +queueDataType = mkDataType "Data.PQueue.Prio.Min.MinPQueue" [emptyConstr, consConstr] + +emptyConstr, consConstr :: Constr +emptyConstr = mkConstr queueDataType "Empty" [] Prefix +consConstr = mkConstr queueDataType ":<" [] Infix +#endif + +instance Ord k => Semigroup (MinPQueue k a) where + (<>) = union + stimes = stimesMonoid + {-# INLINABLE stimes #-} + +instance Ord k => Monoid (MinPQueue k a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions + +instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toAscList xs) + +instance (Ord k, Read k, Read a) => Read (MinPQueue k a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) +#endif + +-- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). +unions :: Ord k => [MinPQueue k a] -> MinPQueue k a +unions = List.foldl' union empty + + +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(f .: g) x y = f (g x y) + +infixr 8 .: + +-- | A priority queue where keys of type @k@ are annotated with values of type +-- @a@. The queue supports extracting the key-value pair with minimum key. +data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a) + +data BinomForest rk k a = + Nil | + Skip (BinomForest (Succ rk) k a) | + Cons {-# UNPACK #-} !(BinomTree rk k a) (BinomForest (Succ rk) k a) +type BinomHeap = BinomForest Zero + +data BinomTree rk k a = BinomTree !k (rk k a) +newtype Zero k a = Zero a +data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a) + +instance (Ord k, Eq a) => Eq (MinPQueue k a) where + MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 = + n1 == n2 && eqExtract k1 a1 ts1 k2 a2 ts2 + Empty == Empty = True + _ == _ = False + +eqExtract :: (Ord k, Eq a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Bool +eqExtract k10 a10 ts10 k20 a20 ts20 = + k10 == k20 && a10 == a20 && + case (extract ts10, extract ts20) of + (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero a2) ts2')) + -> eqExtract k1 a1 ts1' k2 a2 ts2' + (No, No) -> True + _ -> False + +instance (Ord k, Ord a) => Ord (MinPQueue k a) where + MinPQ _n1 k10 a10 ts10 `compare` MinPQ _n2 k20 a20 ts20 = + cmpExtract k10 a10 ts10 k20 a20 ts20 + Empty `compare` Empty = EQ + Empty `compare` MinPQ{} = LT + MinPQ{} `compare` Empty = GT + +cmpExtract :: (Ord k, Ord a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Ordering +cmpExtract k10 a10 ts10 k20 a20 ts20 = + k10 `compare` k20 <> a10 `compare` a20 <> + case (extract ts10, extract ts20) of + (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero a2) ts2')) + -> cmpExtract k1 a1 ts1' k2 a2 ts2' + (No, Yes{}) -> LT + (Yes{}, No) -> GT + (No, No) -> EQ + +-- | \(O(1)\). Returns the empty priority queue. +empty :: MinPQueue k a +empty = Empty + +-- | \(O(1)\). Checks if this priority queue is empty. +null :: MinPQueue k a -> Bool +null Empty = True +null _ = False + +-- | \(O(1)\). Returns the size of this priority queue. +size :: MinPQueue k a -> Int +size Empty = 0 +size (MinPQ n _ _ _) = n + +-- | \(O(1)\). Constructs a singleton priority queue. +singleton :: k -> a -> MinPQueue k a +singleton k a = MinPQ 1 k a Nil + +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts +-- an element with the specified key into the queue. +insert :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a +insert k a Empty = singleton k a +insert k a (MinPQ n k' a' ts) + | k <= k' = MinPQ (n + 1) k a (incrMin (tip k' a') ts) + | otherwise = MinPQ (n + 1) k' a' (incr (tip k a ) ts) + +insertEager :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a +insertEager k a Empty = singleton k a +insertEager k a (MinPQ n k' a' ts) + | k <= k' = MinPQ (n + 1) k a (insertEagerHeap k' a' ts) + | otherwise = MinPQ (n + 1) k' a' (insertEagerHeap k a ts) + +-- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union +-- of the two specified queues. +union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a +union (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2) + | k1 <= k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2) + | otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1) + where insMerge k a = carryForest (tip k a) ts1 ts2 +union Empty q2 = q2 +union q1 Empty = q1 + +-- | \(O(1)\). The minimal (key, element) in the queue, if the queue is nonempty. +getMin :: MinPQueue k a -> Maybe (k, a) +getMin (MinPQ _ k a _) = Just (k, a) +getMin _ = Nothing + +-- | \(O(1)\). Alter the value at the minimum key. If the queue is empty, does nothing. +adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a +adjustMinWithKey _ Empty = Empty +adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts + +-- | \(O(1)\) per operation. Alter the value at the minimum key in an 'Applicative' context. If the +-- queue is empty, does nothing. +adjustMinWithKeyA' :: Applicative f => (MinPQueue k a -> r) -> (k -> a -> f a) -> MinPQueue k a -> f r +adjustMinWithKeyA' g _ Empty = pure (g Empty) +adjustMinWithKeyA' g f (MinPQ n k a ts) = fmap (\a' -> g (MinPQ n k a' ts)) (f k a) + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the minimum key. +-- If the queue is empty, does nothing. +updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> MinPQueue k a -> MinPQueue k a +updateMinWithKey _ Empty = Empty +updateMinWithKey f (MinPQ n k a ts) = case f k a of + Nothing -> extractHeap n ts + Just a' -> MinPQ n k a' ts + +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the minimum key in an 'Applicative' context. If the queue is +-- empty, does nothing. +updateMinWithKeyA' + :: (Applicative f, Ord k) + => (MinPQueue k a -> r) + -> (k -> a -> f (Maybe a)) + -> MinPQueue k a + -> f r +updateMinWithKeyA' g _ Empty = pure (g Empty) +updateMinWithKeyA' g f (MinPQ n k a ts) = fmap (g . tweak) (f k a) + where + tweak Nothing = extractHeap n ts + tweak (Just a') = MinPQ n k a' ts + +-- | \(O(\log n)\). Retrieves the minimal (key, value) pair of the map, and the map stripped of that +-- element, or 'Nothing' if passed an empty map. +minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a) +minViewWithKey Empty = Nothing +minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap n ts) + +-- | \(O(n)\). Map a function over all values in the queue. +mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b +mapWithKey f = runIdentity . traverseWithKeyU (coerce f) + +-- | \(O(n)\). @'mapKeysMonotonic' f q == 'Data.PQueue.Prio.Min.mapKeys' f q@, +-- but only works when @f@ is (weakly) monotonic (meaning that @x <= y@ implies +-- @f x <= f y@). /The precondition is not checked./ This function has better +-- performance than 'Data.PQueue.Prio.Min.mapKeys'. +-- +-- Note: if the given function returns bottom for any of the keys in the queue, then the +-- portion of the queue which is bottom is /unspecified/. +mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a +mapKeysMonotonic _ Empty = Empty +mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a $! mapKeysMonoHeap f ts + +mapKeysMonoHeap :: forall k k' a. (k -> k') -> BinomHeap k a -> BinomHeap k' a +mapKeysMonoHeap f = mapKeysMonoForest Zeroy + where + mapKeysMonoForest :: Ranky rk -> BinomForest rk k a -> BinomForest rk k' a + mapKeysMonoForest !_rky Nil = Nil + mapKeysMonoForest !rky (Skip rest) = Skip $! mapKeysMonoForest (Succy rky) rest + mapKeysMonoForest !rky (Cons t rest) = Cons (mapKeysMonoTree rky t) $! mapKeysMonoForest (Succy rky) rest + + {-# INLINE mapKeysMonoTree #-} + mapKeysMonoTree :: Ranky rk -> BinomTree rk k a -> BinomTree rk k' a + mapKeysMonoTree Zeroy (BinomTree k (Zero a)) = + -- We've reached a value, which we must not force. + BinomTree (f k) (Zero a) + -- We're not at a value; we force the result. + mapKeysMonoTree (Succy rky) (BinomTree k ts) = BinomTree (f k) $! mapKeysMonoTrees rky ts + + mapKeysMonoTrees :: Ranky rk -> Succ rk k a -> Succ rk k' a + mapKeysMonoTrees Zeroy (Succ t (Zero a)) = + -- Don't force the value! + Succ (mapKeysMonoTree Zeroy t) (Zero a) + mapKeysMonoTrees (Succy rky) (Succ t ts) = + -- Whew, no values; force the trees. + Succ (mapKeysMonoTree (Succy rky) t) $! mapKeysMonoTrees rky ts + +-- | \(O(n)\). Map values and collect the 'Just' results. +mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b +mapMaybeWithKey f = fromBare . + foldlWithKeyU' + (\q k a -> case f k a of + Nothing -> q + Just b -> insertEagerHeap k b q) + Nil +{-# INLINABLE mapMaybeWithKey #-} + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) +mapEitherWithKey f q + | (l, r) <- mapEitherHeap f q + , let + !l' = fromBare l + !r' = fromBare r + = (l', r') +{-# INLINABLE mapEitherWithKey #-} + +data Partition k a b = Partition !(BinomHeap k a) !(BinomHeap k b) + +fromPartition :: Partition k a b -> (BinomHeap k a, BinomHeap k b) +fromPartition (Partition p q) = (p, q) + +mapEitherHeap :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (BinomHeap k b, BinomHeap k c) +mapEitherHeap f = fromPartition . + foldlWithKeyU' + (\(Partition ls rs) k a -> + case f k a of + Left b -> Partition (insertEagerHeap k b ls) rs + Right b -> Partition ls (insertEagerHeap k b rs)) + (Partition Nil Nil) + +insertEagerHeap :: Ord k => k -> a -> BinomHeap k a -> BinomHeap k a +insertEagerHeap k a h = incr' (tip k a) h +{-# INLINE insertEagerHeap #-} + +-- | \(O(n \log n)\). Fold the keys and values in the map, such that +-- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldrWithKeyU'. +foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MinPQueue k a -> b +foldrWithKey _ z Empty = z +foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where + foldF ts = case extract ts of + Yes (Extract k (Zero a) ts') -> f k a (foldF ts') + No -> z + +-- | \(O(n \log n)\). Fold the keys and values in the map, such that +-- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldlWithKeyU'. +foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MinPQueue k a -> b +foldlWithKey _ z Empty = z +foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where + foldF z ts = case extract ts of + Yes (Extract k (Zero a) ts') -> foldF (f z k a) ts' + No -> z + +{-# INLINABLE [1] toAscList #-} +-- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. +toAscList :: Ord k => MinPQueue k a -> [(k, a)] +toAscList = foldrWithKey (curry (:)) [] + +{-# INLINABLE [1] toDescList #-} +-- | \(O(n \log n)\). Return all (key, value) pairs in descending order by key. +toDescList :: Ord k => MinPQueue k a -> [(k, a)] +toDescList = foldlWithKey (\z k a -> (k, a) : z) [] + +-- | \(O(n)\). Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ +fromAscList :: [(k, a)] -> MinPQueue k a +{-# INLINE fromAscList #-} +fromAscList xs = List.foldl' (\q (k, a) -> insertMax' k a q) empty xs + +{-# RULES + "toAscList" toAscList = \q -> build (\c n -> foldrWithKey (curry c) n q); + "toDescList" toDescList = \q -> build (\c n -> foldlWithKey (\z k a -> (k, a) `c` z) n q); + "toListU" toListU = \q -> build (\c n -> foldrWithKeyU (curry c) n q); + #-} + +{-# NOINLINE toListU #-} +-- | \(O(n)\). Returns all (key, value) pairs in the queue in no particular order. +toListU :: MinPQueue k a -> [(k, a)] +toListU = foldrWithKeyU (curry (:)) [] + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrU :: (a -> b -> b) -> b -> MinPQueue k a -> b +foldrU = foldrWithKeyU . const + +-- | Equivalent to 'insert', save the assumption that this key is @<=@ +-- every other key in the map. /The precondition is not checked./ +insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a +insertMin k a Empty = MinPQ 1 k a Nil +insertMin k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin (tip k' a') ts) + +-- | Equivalent to 'insert', save the assumption that this key is @<=@ +-- every other key in the map. /The precondition is not checked./ Additionally, +-- this eagerly constructs the new portion of the spine. +insertMin' :: k -> a -> MinPQueue k a -> MinPQueue k a +insertMin' k a Empty = MinPQ 1 k a Nil +insertMin' k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin' (tip k' a') ts) + +-- | Inserts an entry with key @>=@ every key in the map. Assumes and preserves +-- an extra invariant: the roots of the binomial trees are decreasing along +-- the spine. +insertMax' :: k -> a -> MinPQueue k a -> MinPQueue k a +insertMax' k a Empty = MinPQ 1 k a Nil +insertMax' k a (MinPQ n k' a' ts) = MinPQ (n + 1) k' a' (incrMax' (tip k a) ts) + +{-# INLINE fromList #-} +-- | \(O(n)\). Constructs a priority queue from an unordered list. +fromList :: Ord k => [(k, a)] -> MinPQueue k a +-- We build a forest first and then extract its minimum at the end. Why not +-- just build the 'MinQueue' directly? This way typically saves us one +-- comparison per element, which roughly halves comparisons. +fromList xs = fromBare (fromListHeap xs) + +fromBare :: Ord k => BinomHeap k a -> MinPQueue k a +fromBare xs = case extract xs of + No -> Empty + -- Should we track the size as we go instead? That saves O(log n) + -- at the end, but it needs an extra register all along the way. + -- The nodes should probably all be in L1 cache already thanks to the + -- extractHeap. + Yes (Extract k (Zero v) f) -> MinPQ (sizeHeap f + 1) k v f + +{-# INLINE fromListHeap #-} +fromListHeap :: Ord k => [(k, a)] -> BinomHeap k a +fromListHeap xs = List.foldl' go Nil xs + where + go fr (k, a) = insertEagerHeap k a fr + +sizeHeap :: BinomHeap k a -> Int +sizeHeap = go 0 1 + where + go :: Int -> Int -> BinomForest rk k a -> Int + go acc rk Nil = rk `seq` acc + go acc rk (Skip f) = go acc (2 * rk) f + go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f + +-- | \(O(1)\). Returns a binomial tree of rank zero containing this +-- key and value. +tip :: k -> a -> BinomTree Zero k a +tip k a = BinomTree k (Zero a) + +-- | \(O(1)\). Takes the union of two binomial trees of the same rank. +meld :: Ord k => BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a +meld t1@(BinomTree k1 ts1) t2@(BinomTree k2 ts2) + | k1 <= k2 = BinomTree k1 (Succ t2 ts1) + | otherwise = BinomTree k2 (Succ t1 ts2) + +-- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. +mergeForest :: Ord k => BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a +mergeForest f1 f2 = case (f1, f2) of + (Skip ts1, Skip ts2) -> Skip $! mergeForest ts1 ts2 + (Skip ts1, Cons t2 ts2) -> Cons t2 $! mergeForest ts1 ts2 + (Cons t1 ts1, Skip ts2) -> Cons t1 $! mergeForest ts1 ts2 + (Cons t1 ts1, Cons t2 ts2) -> Skip $! carryForest (meld t1 t2) ts1 ts2 + (Nil, _) -> f2 + (_, Nil) -> f1 + +-- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. +-- Analogous to binary addition when a digit has been carried. +carryForest :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a +carryForest t0 f1 f2 = t0 `seq` case (f1, f2) of + (Cons t1 ts1, Cons t2 ts2) -> Cons t0 $! carryMeld t1 t2 ts1 ts2 + (Cons t1 ts1, Skip ts2) -> Skip $! carryMeld t0 t1 ts1 ts2 + (Skip ts1, Cons t2 ts2) -> Skip $! carryMeld t0 t2 ts1 ts2 + (Skip ts1, Skip ts2) -> Cons t0 $! mergeForest ts1 ts2 + -- Why do these use incr and not incr'? We want the merge to take + -- O(log(min(|f1|, |f2|))) amortized time. If we performed this final + -- increment eagerly, that would degrade to O(log(max(|f1|, |f2|))) time. + (Nil, _) -> incr t0 f2 + (_, Nil) -> incr t0 f1 + where carryMeld = carryForest .: meld + +-- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. +incr :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incr t ts = t `seq` case ts of + Nil -> Cons t Nil + Skip ts' -> Cons t ts' + Cons t' ts' -> ts' `seq` Skip (incr (meld t t') ts') + +-- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. +-- Forces the rebuilt portion of the spine. +incr' :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incr' t ts = t `seq` case ts of + Nil -> Cons t Nil + Skip ts' -> Cons t ts' + Cons t' ts' -> Skip $! incr' (meld t t') ts' + +-- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree +-- is less than all other roots. Analogous to binary incrementation. Equivalent to +-- @'incr' (\_ _ -> True)@. +incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incrMin t@(BinomTree k ts) tss = case tss of + Nil -> Cons t Nil + Skip tss' -> Cons t tss' + Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k (Succ t' ts)) tss') + +-- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree +-- is less than all other roots. Analogous to binary incrementation. Equivalent to +-- @'incr'' (\_ _ -> True)@. Forces the rebuilt portion of the spine. +incrMin' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incrMin' t@(BinomTree k ts) tss = case tss of + Nil -> Cons t Nil + Skip tss' -> Cons t tss' + Cons t' tss' -> Skip $! incrMin' (BinomTree k (Succ t' ts)) tss' + +-- | See 'insertMax'' for invariant info. +incrMax' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incrMax' t tss = t `seq` case tss of + Nil -> Cons t Nil + Skip tss' -> Cons t tss' + Cons (BinomTree k ts) tss' -> Skip $! incrMax' (BinomTree k (Succ t ts)) tss' + +extractHeap :: Ord k => Int -> BinomHeap k a -> MinPQueue k a +extractHeap n ts = n `seq` case extract ts of + No -> Empty + Yes (Extract k (Zero a) ts') -> MinPQ (n - 1) k a ts' + +-- | A specialized type intended to organize the return of extract-min queries +-- from a binomial forest. We walk all the way through the forest, and then +-- walk backwards. @Extract rk a@ is the result type of an extract-min +-- operation that has walked as far backwards of rank @rk@ -- that is, it +-- has visited every root of rank @>= rk@. +-- +-- The interpretation of @Extract minKey minVal children forest@ is +-- +-- * @minKey@ is the key of the minimum root visited so far. It may have +-- any rank @>= rk@. We will denote the root corresponding to +-- @minKey@ as @minRoot@. +-- +-- * @minVal@ is the value corresponding to @minKey@. +-- +-- * @children@ is those children of @minRoot@ which have not yet been +-- merged with the rest of the forest. Specifically, these are +-- the children with rank @< rk@. +-- +-- * @forest@ is an accumulating parameter that maintains the partial +-- reconstruction of the binomial forest without @minRoot@. It is +-- the union of all old roots with rank @>= rk@ (except @minRoot@), +-- with the set of all children of @minRoot@ with rank @>= rk@. +-- Note that @forest@ is lazy, so if we discover a smaller key +-- than @minKey@ later, we haven't wasted significant work. + +data Extract rk k a = Extract !k (rk k a) !(BinomForest rk k a) +data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) + +incrExtract :: Extract (Succ rk) k a -> Extract rk k a +incrExtract (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Cons kChild ts) + +incrExtract' :: Ord k => BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a +incrExtract' t (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Skip $! incr' (t `meld` kChild) ts) + +-- | Walks backward from the biggest key in the forest, as far as rank @rk@. +-- Returns its progress. Each successive application of @extractBin@ takes +-- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time. +extract :: Ord k => BinomForest rk k a -> MExtract rk k a +extract = start + where + start :: Ord k => BinomForest rk k a -> MExtract rk k a + start Nil = No + start (Skip f) = case start f of + No -> No + Yes ex -> Yes (incrExtract ex) + start (Cons t@(BinomTree k ts) f) = Yes $ case go k f of + No -> Extract k ts (skip f) + Yes ex -> incrExtract' t ex + + go :: Ord k => k -> BinomForest rk k a -> MExtract rk k a + go _min_above Nil = _min_above `seq` No + go min_above (Skip f) = case go min_above f of + No -> No + Yes ex -> Yes (incrExtract ex) + go min_above (Cons t@(BinomTree k ts) f) + | min_above <= k = case go min_above f of + No -> No + Yes ex -> Yes (incrExtract' t ex) + | otherwise = case go k f of + No -> Yes (Extract k ts (skip f)) + Yes ex -> Yes (incrExtract' t ex) + +skip :: BinomForest (Succ rk) k a -> BinomForest rk k a +skip Nil = Nil +skip f = Skip f +{-# INLINE skip #-} + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b +foldrWithKeyU c n = flip appEndo n . inline foldMapWithKeyU (coerce c) + +-- | \(O(n)\). An unordered monoidal fold over the elements of the queue, in no particular order. +-- +-- @since 1.4.2 +foldMapWithKeyU :: forall m k a. Monoid m => (k -> a -> m) -> MinPQueue k a -> m +foldMapWithKeyU = coerce + (inline traverseWithKeyU :: (k -> a -> Const m ()) -> MinPQueue k a -> Const m (MinPQueue k ())) + +-- | \(O(n)\). An unordered left fold over the elements of the queue, in no +-- particular order. This is rarely what you want; 'foldrWithKeyU' and +-- 'foldlWithKeyU'' are more likely to perform well. +foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b +foldlWithKeyU f b = flip appEndo b . getDual . + foldMapWithKeyU (\k a -> Dual $ Endo $ \r -> f r k a) + +-- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no particular order. +-- +-- @since 1.4.2 +foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b +foldlWithKeyU' f !b q = + case q of + Empty -> b + MinPQ _n k a ts -> foldlHeapU' f (f b k a) ts + +foldlHeapU' :: forall k a b. (b -> k -> a -> b) -> b -> BinomHeap k a -> b +foldlHeapU' f = \b -> foldlForest' Zeroy b + where + foldlForest' :: Ranky rk -> b -> BinomForest rk k a -> b + foldlForest' !_rky !acc Nil = acc + foldlForest' !rky !acc (Skip rest) = foldlForest' (Succy rky) acc rest + foldlForest' !rky !acc (Cons t rest) = + foldlForest' (Succy rky) (foldlTree' rky acc t) rest + + {-# INLINE foldlTree' #-} + foldlTree' :: Ranky rk -> b -> BinomTree rk k a -> b + foldlTree' !rky !acc (BinomTree k ts) = foldlTrees' rky acc k ts + + foldlTrees' :: Ranky rk -> b -> k -> rk k a -> b + foldlTrees' Zeroy !acc !k (Zero a) = f acc k a + foldlTrees' (Succy rky) !acc !k (Succ t ts) = + foldlTrees' rky (foldlTree' rky acc t) k ts + +-- | \(O(n \log n)\). Traverses the elements of the queue in ascending order by key. +-- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) +-- +-- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. +-- +-- If you are working in a strict monad, consider using 'mapMWithKey'. +traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) +traverseWithKey f q = case minViewWithKey q of + Nothing -> pure empty + Just ((k, a), q') -> liftA2 (insertMin k) (f k a) (traverseWithKey f q') + +-- | A strictly accumulating version of 'traverseWithKey'. This works well in +-- 'IO' and strict @State@, and is likely what you want for other "strict" monads, +-- where @⊥ >>= pure () = ⊥@. +mapMWithKey :: (Ord k, Monad m) => (k -> a -> m b) -> MinPQueue k a -> m (MinPQueue k b) +mapMWithKey f = go empty + where + go !acc q = + case minViewWithKey q of + Nothing -> pure acc + Just ((k, a), q') -> do + b <- f k a + let !acc' = insertMax' k b acc + go acc' q' + +-- | Natural numbers revealing whether something is 'Zero' or 'Succ'. +type Ranky = Nattish Zero Succ + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +{-# INLINABLE traverseWithKeyU #-} +traverseWithKeyU :: forall f k a b. Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) +traverseWithKeyU _ Empty = pure Empty +traverseWithKeyU f (MinPQ n k a ts) = liftA2 (\a' !ts' -> MinPQ n k a' ts') (f k a) (traverseHeapU f ts) + +{-# INLINABLE traverseHeapU #-} +traverseHeapU :: forall f k a b. Applicative f => (k -> a -> f b) -> BinomHeap k a -> f (BinomHeap k b) +traverseHeapU f = traverseForest Zeroy + where + traverseForest :: Ranky rk -> BinomForest rk k a -> f (BinomForest rk k b) + traverseForest !_rky Nil = pure Nil + traverseForest !rky (Skip rest) = (Skip $!) <$> traverseForest (Succy rky) rest + traverseForest !rky (Cons t rest) = + liftA2 (\ !t' !rest' -> Cons t' rest') (traverseTree rky t) (traverseForest (Succy rky) rest) + + {-# INLINE traverseTree #-} + traverseTree :: Ranky rk -> BinomTree rk k a -> f (BinomTree rk k b) + traverseTree Zeroy (BinomTree k (Zero a)) = + -- We've reached a value, so we don't force the result. + BinomTree k . Zero <$> f k a + traverseTree (Succy rky) (BinomTree k ts) = + -- We're not at a value, so we force the tree list. + (BinomTree k $!) <$> traverseTrees rky k ts + + traverseTrees :: Ranky rk -> k -> Succ rk k a -> f (Succ rk k b) + traverseTrees Zeroy !k2 (Succ (BinomTree k1 (Zero a1)) (Zero a2)) = + -- The right subtree is a value, so we don't force it. + liftA2 (\b1 b2 -> Succ (BinomTree k1 (Zero b1)) (Zero b2)) (f k1 a1) (f k2 a2) + traverseTrees (Succy rky) !k (Succ t ts) = + -- Whew; no values. We're safe to force. + liftA2 (\ !t' !ts' -> Succ t' ts') (traverseTree (Succy rky) t) (traverseTrees rky k ts) + +-- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. +-- +-- Note: The spine of a 'MinPQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} +seqSpine :: MinPQueue k a -> b -> b +seqSpine Empty z0 = z0 +seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where + seqSpineF :: BinomForest rk k a -> b -> b + seqSpineF ts z = case ts of + Nil -> z + Skip ts' -> seqSpineF ts' z + Cons _ ts' -> seqSpineF ts' z + +class NFRank rk where + rnfRk :: (NFData k, NFData a) => rk k a -> () + +instance NFRank Zero where + rnfRk (Zero a) = rnf a + +instance NFRank rk => NFRank (Succ rk) where + rnfRk (Succ t ts) = t `deepseq` rnfRk ts + +instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where + rnf (BinomTree k ts) = k `deepseq` rnfRk ts + +instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where + rnf Nil = () + rnf (Skip tss) = rnf tss + rnf (Cons t tss) = t `deepseq` rnf tss + +instance (NFData k, NFData a) => NFData (MinPQueue k a) where + rnf Empty = () + rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts + +instance Functor (MinPQueue k) where + fmap = imap . const + +instance FunctorWithIndex k (MinPQueue k) where + imap = coerce + (traverseWithKeyU :: (k -> a -> Identity b) -> MinPQueue k a -> Identity (MinPQueue k b)) + +instance Ord k => Foldable (MinPQueue k) where + foldr = foldrWithKey . const + foldl f = foldlWithKey (const . f) + length = size + null = null + +instance Ord k => FoldableWithIndex k (MinPQueue k) where + ifoldr = foldrWithKey + ifoldl f = foldlWithKey (flip f) + +-- | Traverses in ascending order. 'mapM' is strictly accumulating like +-- 'mapMWithKey'. +instance Ord k => Traversable (MinPQueue k) where + traverse = traverseWithKey . const + mapM = mapMWithKey . const + sequence = mapM id + +instance Ord k => TraversableWithIndex k (MinPQueue k) where + itraverse = traverseWithKey diff --git a/src/Data/PQueue/Prio/Max.hs b/src/Data/PQueue/Prio/Max.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Max.hs @@ -0,0 +1,122 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.PQueue.Prio.Max +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue. +-- Each element is associated with a /key/, and the priority queue supports +-- viewing and extracting the element with the maximum key. +-- +-- A worst-case bound is given for each operation. In some cases, an amortized +-- bound is also specified; these bounds hold even in a persistent context. +-- +-- This implementation is based on a binomial heap augmented with a global root. +-- +-- We do not guarantee stable behavior. +-- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there +-- are no guarantees about the relative order in which @k1@, @k2@, and their associated +-- elements are returned. (Unlike Data.Map, we allow multiple elements with the +-- same key.) +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module Data.PQueue.Prio.Max ( + MaxPQueue, + -- * Construction + empty, + singleton, + insert, + union, + unions, + -- * Query + null, + size, + -- ** Maximum view + findMax, + getMax, + deleteMax, + deleteFindMax, + adjustMax, + adjustMaxA, + adjustMaxWithKey, + adjustMaxWithKeyA, + updateMax, + updateMaxA, + updateMaxWithKey, + updateMaxWithKeyA, + maxView, + maxViewWithKey, + -- * Traversal + -- ** Map + map, + mapWithKey, + mapKeys, + mapKeysMonotonic, + -- ** Fold + foldrWithKey, + foldlWithKey, + -- ** Traverse + traverseWithKey, + mapMWithKey, + -- * Subsets + -- ** Indexed + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + takeWhileWithKey, + dropWhile, + dropWhileWithKey, + span, + spanWithKey, + break, + breakWithKey, + -- *** Filter + filter, + filterWithKey, + partition, + partitionWithKey, + mapMaybe, + mapMaybeWithKey, + mapEither, + mapEitherWithKey, + -- * List operations + -- ** Conversion from lists + fromList, + fromAscList, + fromDescList, + -- ** Conversion to lists + keys, + elems, + assocs, + toAscList, + toDescList, + toList, + -- * Unordered operations + foldrU, + foldrWithKeyU, + foldMapWithKeyU, + foldlU, + foldlU', + foldlWithKeyU, + foldlWithKeyU', + traverseU, + traverseWithKeyU, + keysU, + elemsU, + assocsU, + toListU, + -- * Helper methods + seqSpine + ) + where + +import Data.PQueue.Prio.Max.Internals +import Prelude () diff --git a/src/Data/PQueue/Prio/Max/Internals.hs b/src/Data/PQueue/Prio/Max/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Max/Internals.hs @@ -0,0 +1,557 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-# OPTIONS_GHC -Wno-deprecations #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.PQueue.Prio.Max +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Data.PQueue.Prio.Max.Internals ( + MaxPQueue (..), + -- * Construction + empty, + singleton, + insert, + union, + unions, + -- * Query + null, + size, + -- ** Maximum view + findMax, + getMax, + deleteMax, + deleteFindMax, + adjustMax, + adjustMaxA, + adjustMaxWithKey, + adjustMaxWithKeyA, + updateMax, + updateMaxA, + updateMaxWithKey, + updateMaxWithKeyA, + maxView, + maxViewWithKey, + -- * Traversal + -- ** Map + map, + mapWithKey, + mapKeys, + mapKeysMonotonic, + -- ** Fold + foldrWithKey, + foldlWithKey, + -- ** Traverse + traverseWithKey, + mapMWithKey, + -- * Subsets + -- ** Indexed + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + takeWhileWithKey, + dropWhile, + dropWhileWithKey, + span, + spanWithKey, + break, + breakWithKey, + -- *** Filter + filter, + filterWithKey, + partition, + partitionWithKey, + mapMaybe, + mapMaybeWithKey, + mapEither, + mapEitherWithKey, + -- * List operations + -- ** Conversion from lists + fromList, + fromAscList, + fromDescList, + -- ** Conversion to lists + keys, + elems, + assocs, + toAscList, + toDescList, + toList, + -- * Unordered operations + foldrU, + foldMapWithKeyU, + foldrWithKeyU, + foldlU, + foldlU', + foldlWithKeyU, + foldlWithKeyU', + traverseU, + traverseWithKeyU, + keysU, + elemsU, + assocsU, + toListU, + -- * Helper methods + seqSpine + ) + where + +import Data.Coerce +import Data.Maybe (fromMaybe) +import Data.PQueue.Internals.Down +import Data.PQueue.Prio.Internals (MinPQueue) +import qualified Data.PQueue.Prio.Internals as PrioInternals +import Control.DeepSeq (NFData(rnf)) + +import Data.Semigroup (Semigroup(..), stimesMonoid) + +import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) +import qualified Data.Foldable as F + +import qualified Data.PQueue.Prio.Min as Q + +#ifdef __GLASGOW_HASKELL__ +import Data.Data (Data) +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +#endif + +import Data.Functor.WithIndex +import Data.Foldable.WithIndex +import Data.Traversable.WithIndex + +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +-- | A priority queue where values of type @a@ are annotated with keys of type @k@. +-- The queue supports extracting the element with maximum key. +newtype MaxPQueue k a = MaxPQ (MinPQueue (Down k) a) +# if __GLASGOW_HASKELL__ + deriving (Eq, Ord, Data) +# else + deriving (Eq, Ord) +# endif + +instance (NFData k, NFData a) => NFData (MaxPQueue k a) where + rnf (MaxPQ q) = rnf q + +instance Ord k => Semigroup (MaxPQueue k a) where + (<>) = union + stimes = stimesMonoid + {-# INLINABLE stimes #-} + +instance Ord k => Monoid (MaxPQueue k a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions + +instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toDescList xs) + +instance (Ord k, Read k, Read a) => Read (MaxPQueue k a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + return (fromList xs,t) +#endif + +instance Functor (MaxPQueue k) where + fmap f (MaxPQ q) = MaxPQ (fmap f q) + +instance FunctorWithIndex k (MaxPQueue k) where + imap = mapWithKey + +instance Ord k => Foldable (MaxPQueue k) where + foldr f z (MaxPQ q) = foldr f z q + foldl f z (MaxPQ q) = foldl f z q + length = size + null = null + +instance Ord k => FoldableWithIndex k (MaxPQueue k) where + ifoldr = foldrWithKey + ifoldl f = foldlWithKey (flip f) + +-- | Traverses in descending order. 'mapM' is strictly accumulating like +-- 'mapMWithKey'. +instance Ord k => Traversable (MaxPQueue k) where + traverse f (MaxPQ q) = MaxPQ <$> traverse f q + mapM = mapMWithKey . const + sequence = mapM id + +instance Ord k => TraversableWithIndex k (MaxPQueue k) where + itraverse = traverseWithKey + +-- | \(O(1)\). Returns the empty priority queue. +empty :: MaxPQueue k a +empty = MaxPQ Q.empty + +-- | \(O(1)\). Constructs a singleton priority queue. +singleton :: k -> a -> MaxPQueue k a +singleton = coerce Q.singleton + +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts +-- an element with the specified key into the queue. +insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a +insert = coerce Q.insert + +-- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union +-- of the two specified queues. +union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a +union = coerce Q.union + +-- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). +unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a +unions = coerce Q.unions + +-- | \(O(1)\). Checks if this priority queue is empty. +null :: MaxPQueue k a -> Bool +null (MaxPQ q) = Q.null q + +-- | \(O(1)\). Returns the size of this priority queue. +size :: MaxPQueue k a -> Int +size (MaxPQ q) = Q.size q + +-- | \(O(1)\). The maximal (key, element) in the queue. Calls 'error' if empty. +findMax :: MaxPQueue k a -> (k, a) +findMax = fromMaybe (error "Error: findMax called on an empty queue") . getMax + +-- | \(O(1)\). The maximal (key, element) in the queue, if the queue is nonempty. +getMax :: MaxPQueue k a -> Maybe (k, a) +getMax = coerce Q.getMin + +-- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. +deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a +deleteMax = coerce Q.deleteMin + +-- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. +deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) +deleteFindMax = fromMaybe (error "Error: deleteFindMax called on an empty queue") . maxViewWithKey + +-- | \(O(1)\). Alter the value at the maximum key. If the queue is empty, does nothing. +adjustMax :: (a -> a) -> MaxPQueue k a -> MaxPQueue k a +adjustMax = adjustMaxWithKey . const + +-- | \(O(1)\) per operation. Alter the value at the maximum key in an +-- 'Applicative' context. If the queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMaxA :: Applicative f => (a -> f a) -> MaxPQueue k a -> f (MaxPQueue k a) +adjustMaxA = adjustMaxWithKeyA . const + +-- | \(O(1)\). Alter the value at the maximum key. If the queue is empty, does nothing. +adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a +adjustMaxWithKey = coerce Q.adjustMinWithKey + +-- | \(O(1)\) per operation. Alter the value at the maximum key in an +-- 'Applicative' context. If the queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMaxWithKeyA :: Applicative f => (k -> a -> f a) -> MaxPQueue k a -> f (MaxPQueue k a) +adjustMaxWithKeyA f (MaxPQ q) = PrioInternals.adjustMinWithKeyA' MaxPQ (coerce f) q + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. +-- If the queue is empty, does nothing. +updateMax :: Ord k => (a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a +updateMax = updateMaxWithKey . const + +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the maximum key in an 'Applicative' context. If the queue is +-- empty, does nothing. +-- +-- @since 1.4.2 +updateMaxA :: (Applicative f, Ord k) => (a -> f (Maybe a)) -> MaxPQueue k a -> f (MaxPQueue k a) +updateMaxA = updateMaxWithKeyA . const + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. +-- If the queue is empty, does nothing. +updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a +updateMaxWithKey = coerce Q.updateMinWithKey + +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the maximum key in an 'Applicative' context. If the queue is +-- empty, does nothing. +-- +-- @since 1.4.2 +updateMaxWithKeyA :: (Applicative f, Ord k) => (k -> a -> f (Maybe a)) -> MaxPQueue k a -> f (MaxPQueue k a) +updateMaxWithKeyA f (MaxPQ q) = PrioInternals.updateMinWithKeyA' MaxPQ (coerce f) q + +-- | \(O(\log n)\). Retrieves the value associated with the maximum key of the queue, and the queue +-- stripped of that element, or 'Nothing' if passed an empty queue. +maxView :: Ord k => MaxPQueue k a -> Maybe (a, MaxPQueue k a) +maxView q = do + ((_, a), q') <- maxViewWithKey q + return (a, q') + +-- | \(O(\log n)\). Retrieves the maximal (key, value) pair of the map, and the map stripped of that +-- element, or 'Nothing' if passed an empty map. +maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a) +maxViewWithKey = coerce Q.minViewWithKey + +-- | \(O(n)\). Map a function over all values in the queue. +map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b +map = mapWithKey . const + +-- | \(O(n)\). Map a function over all values in the queue. +mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b +mapWithKey = coerce Q.mapWithKey + +-- | \(O(n)\). Map a function over all values in the queue. +mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a +mapKeys = coerce Q.mapKeys + +-- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when +-- @f@ is (weakly) monotonic (meaning that @x <= y@ implies @f x <= f y@). +-- /The precondition is not checked./ This function has better performance than 'mapKeys'. +-- +-- Note: if the given function returns bottom for any of the keys in the queue, then the +-- portion of the queue which is bottom is /unspecified/. +mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a +mapKeysMonotonic = coerce Q.mapKeysMonotonic + +-- | \(O(n \log n)\). Fold the keys and values in the map, such that +-- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldrWithKeyU'. +foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b +foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (coerce f) z q + +-- | \(O(n \log n)\). Fold the keys and values in the map, such that +-- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldlWithKeyU'. +foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b +foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (coerce f) z0 q + +-- | \(O(n \log n)\). Traverses the elements of the queue in descending order by key. +-- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) +-- +-- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. +-- +-- If you are working in a strict monad, consider using 'mapMWithKey'. +traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (coerce f) q + +-- | A strictly accumulating version of 'traverseWithKey'. This works well in +-- 'IO' and strict @State@, and is likely what you want for other "strict" monads, +-- where @⊥ >>= pure () = ⊥@. +mapMWithKey :: (Ord k, Monad m) => (k -> a -> m b) -> MaxPQueue k a -> m (MaxPQueue k b) +mapMWithKey f (MaxPQ q) = MaxPQ <$> Q.mapMWithKey (coerce f) q + +-- | \(O(k \log n)\). Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. +-- (@'take' k q == 'List.take' k ('toDescList' q)@) +take :: Ord k => Int -> MaxPQueue k a -> [(k, a)] +take = coerce Q.take + +-- | \(O(k \log n)\). Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. +drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a +drop = coerce Q.drop + +-- | \(O(k \log n)\). Equivalent to @('take' k q, 'drop' k q)@. +splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +splitAt = coerce Q.splitAt + +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) +takeWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> [(k, a)] +takeWhile = takeWhileWithKey . const + +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) +takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] +takeWhileWithKey = coerce Q.takeWhileWithKey + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +dropWhile = dropWhileWithKey . const + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +dropWhileWithKey = coerce Q.dropWhileWithKey + +-- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. +span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +span = spanWithKey . const + +-- | Equivalent to @'span' ('not' . p)@. +break :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +break = breakWithKey . const + +-- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. +spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +spanWithKey = coerce Q.spanWithKey + +-- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. +breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +breakWithKey = coerce Q.breakWithKey + +-- | \(O(n)\). Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +filter = filterWithKey . const + +-- | \(O(n)\). Filter all values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +filterWithKey = coerce Q.filterWithKey + +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partition :: Ord k => (a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) +partition = partitionWithKey . const + +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) +partitionWithKey = coerce Q.partitionWithKey + +-- | \(O(n)\). Map values and collect the 'Just' results. +mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b +mapMaybe = mapMaybeWithKey . const + +-- | \(O(n)\). Map values and collect the 'Just' results. +mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b +mapMaybeWithKey = coerce Q.mapMaybeWithKey + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) +mapEither = mapEitherWithKey . const + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) +mapEitherWithKey = coerce Q.mapEitherWithKey + +-- | \(O(n)\). Build a priority queue from the list of (key, value) pairs. +fromList :: Ord k => [(k, a)] -> MaxPQueue k a +fromList = coerce Q.fromList + +-- | \(O(n)\). Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ +fromAscList :: [(k, a)] -> MaxPQueue k a +fromAscList = coerce Q.fromDescList + +-- | \(O(n)\). Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ +fromDescList :: [(k, a)] -> MaxPQueue k a +fromDescList = coerce Q.fromAscList + +-- | \(O(n \log n)\). Return all keys of the queue in descending order. +keys :: Ord k => MaxPQueue k a -> [k] +keys = fmap fst . toDescList + +-- | \(O(n \log n)\). Return all elements of the queue in descending order by key. +elems :: Ord k => MaxPQueue k a -> [a] +elems = fmap snd . toDescList + +-- | \(O(n \log n)\). Equivalent to 'toDescList'. +assocs :: Ord k => MaxPQueue k a -> [(k, a)] +assocs = toDescList + +-- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. +toAscList :: Ord k => MaxPQueue k a -> [(k, a)] +toAscList = coerce Q.toDescList + +-- | \(O(n \log n)\). Return all (key, value) pairs in descending order by key. +toDescList :: Ord k => MaxPQueue k a -> [(k, a)] +toDescList = coerce Q.toAscList + +-- | \(O(n \log n)\). Equivalent to 'toDescList'. +-- +-- If the traversal order is irrelevant, consider using 'toListU'. +toList :: Ord k => MaxPQueue k a -> [(k, a)] +toList = toDescList + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrU :: (a -> b -> b) -> b -> MaxPQueue k a -> b +foldrU = foldrWithKeyU . const + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b +foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (coerce f) z q + +-- | \(O(n)\). An unordered monoidal fold over the elements of the queue, in no particular order. +-- +-- @since 1.4.2 +foldMapWithKeyU :: Monoid m => (k -> a -> m) -> MaxPQueue k a -> m +foldMapWithKeyU f (MaxPQ q) = Q.foldMapWithKeyU (coerce f) q + +-- | \(O(n)\). An unordered left fold over the elements of the queue, in no +-- particular order. This is rarely what you want; 'foldrU' and 'foldlU'' are +-- more likely to perform well. +foldlU :: (b -> a -> b) -> b -> MaxPQueue k a -> b +foldlU f = foldlWithKeyU (const . f) + +-- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no +-- particular order. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MaxPQueue k a -> b +foldlU' f = foldlWithKeyU' (const . f) + +-- | \(O(n)\). An unordered left fold over the elements of the queue, in no +-- particular order. This is rarely what you want; 'foldrWithKeyU' and +-- 'foldlWithKeyU'' are more likely to perform well. +foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b +foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (coerce f) z0 q + +-- | \(O(n)\). An unordered left fold over the elements of the queue, in no particular order. +-- +-- @since 1.4.2 +foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b +foldlWithKeyU' f z0 (MaxPQ q) = Q.foldlWithKeyU' (coerce f) z0 q + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseU :: (Applicative f) => (a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseU = traverseWithKeyU . const + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseWithKeyU :: (Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (coerce f) q + +-- | \(O(n)\). Return all keys of the queue in no particular order. +keysU :: MaxPQueue k a -> [k] +keysU = fmap fst . toListU + +-- | \(O(n)\). Return all elements of the queue in no particular order. +elemsU :: MaxPQueue k a -> [a] +elemsU = fmap snd . toListU + +-- | \(O(n)\). Equivalent to 'toListU'. +assocsU :: MaxPQueue k a -> [(k, a)] +assocsU = toListU + +-- | \(O(n)\). Returns all (key, value) pairs in the queue in no particular order. +toListU :: MaxPQueue k a -> [(k, a)] +toListU = coerce Q.toListU + +-- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. +-- +-- Note: The spine of a 'MaxPQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} +seqSpine :: MaxPQueue k a -> b -> b +seqSpine (MaxPQ q) = Q.seqSpine q diff --git a/src/Data/PQueue/Prio/Min.hs b/src/Data/PQueue/Prio/Min.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Min.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.PQueue.Prio.Min +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue. +-- Each element is associated with a /key/, and the priority queue supports +-- viewing and extracting the element with the minimum key. +-- +-- A worst-case bound is given for each operation. In some cases, an amortized +-- bound is also specified; these bounds hold even in a persistent context. +-- +-- This implementation is based on a binomial heap augmented with a global root. +-- +-- We do not guarantee stable behavior. +-- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there +-- are no guarantees about the relative order in which @k1@, @k2@, and their associated +-- elements are returned. (Unlike Data.Map, we allow multiple elements with the +-- same key.) +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module Data.PQueue.Prio.Min ( +#if __GLASGOW_HASKELL__ >= 802 + MinPQueue (Data.PQueue.Prio.Min.Empty, (:<)), +#elif defined (__GLASGOW_HASKELL__) + MinPQueue, + pattern Data.PQueue.Prio.Min.Empty, + pattern (:<), +#endif + -- * Construction + empty, + singleton, + insert, + union, + unions, + -- * Query + null, + size, + -- ** Minimum view + findMin, + getMin, + deleteMin, + deleteFindMin, + adjustMin, + adjustMinA, + adjustMinWithKey, + adjustMinWithKeyA, + updateMin, + updateMinA, + updateMinWithKey, + updateMinWithKeyA, + minView, + minViewWithKey, + -- * Traversal + -- ** Map + map, + mapWithKey, + mapKeys, + mapKeysMonotonic, + -- ** Fold + foldrWithKey, + foldlWithKey, + -- ** Traverse + traverseWithKey, + mapMWithKey, + -- * Subsets + -- ** Indexed + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + takeWhileWithKey, + dropWhile, + dropWhileWithKey, + span, + spanWithKey, + break, + breakWithKey, + -- *** Filter + filter, + filterWithKey, + partition, + partitionWithKey, + mapMaybe, + mapMaybeWithKey, + mapEither, + mapEitherWithKey, + -- * List operations + -- ** Conversion from lists + fromList, + fromAscList, + fromDescList, + -- ** Conversion to lists + keys, + elems, + assocs, + toAscList, + toDescList, + toList, + -- * Unordered operations + foldrU, + foldMapWithKeyU, + foldrWithKeyU, + foldlU, + foldlU', + foldlWithKeyU, + foldlWithKeyU', + traverseU, + traverseWithKeyU, + keysU, + elemsU, + assocsU, + toListU, + -- * Helper methods + seqSpine + ) + where + +import qualified Data.List as List +import Data.Maybe (fromMaybe) + +import Data.PQueue.Prio.Internals hiding (MinPQueue (..)) +import Data.PQueue.Prio.Internals (MinPQueue) +import qualified Data.PQueue.Prio.Internals as Internals + +import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) + +#ifdef __GLASGOW_HASKELL__ +-- | A bidirectional pattern synonym for an empty priority queue. +-- +-- @since 1.5.0 +pattern Empty :: MinPQueue k a +pattern Empty = Internals.Empty +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE CONLIKE Empty #-} +# endif + +infixr 5 :< + +-- | A bidirectional pattern synonym for working with the minimum view of a +-- 'MinPQueue'. Using @:<@ to construct a queue performs an insertion in +-- \(O(1)\) amortized time. When matching on @(k, a) :< q@, forcing @q@ takes +-- \(O(\log n)\) time. +-- +-- @since 1.5.0 +# if __GLASGOW_HASKELL__ >= 800 +pattern (:<) :: Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a +# else +pattern (:<) :: () => Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a +# endif +pattern ka :< q <- (minViewWithKey -> Just (ka, q)) + where + (k, a) :< q = insert k a q +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE (:<) #-} +# endif + +# if __GLASGOW_HASKELL__ >= 820 +{-# COMPLETE Empty, (:<) #-} +# endif +#endif + +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +(f .: g) x y = f (g x y) + +uncurry' :: (a -> b -> c) -> (a, b) -> c +uncurry' f (a, b) = f a b + +infixr 8 .: + +-- | \(O(1)\). The minimal (key, element) in the queue. Calls 'error' if empty. +findMin :: MinPQueue k a -> (k, a) +findMin = fromMaybe (error "Error: findMin called on an empty queue") . getMin + +-- | \(O(\log n)\). Deletes the minimal (key, element) in the queue. Returns an empty queue +-- if the queue is empty. +deleteMin :: Ord k => MinPQueue k a -> MinPQueue k a +deleteMin = updateMin (const Nothing) + +-- | \(O(\log n)\). Delete and find the element with the minimum key. Calls 'error' if empty. +deleteFindMin :: Ord k => MinPQueue k a -> ((k, a), MinPQueue k a) +deleteFindMin = fromMaybe (error "Error: deleteFindMin called on an empty queue") . minViewWithKey + +-- | \(O(1)\). Alter the value at the minimum key. If the queue is empty, does nothing. +adjustMin :: (a -> a) -> MinPQueue k a -> MinPQueue k a +adjustMin = adjustMinWithKey . const + +-- | \(O(1)\). Alter the value at the minimum key in an 'Applicative' context. If +-- the queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMinA :: Applicative f => (a -> f a) -> MinPQueue k a -> f (MinPQueue k a) +adjustMinA = adjustMinWithKeyA . const + +-- | \(O(1)\) per operation. Alter the value at the minimum key in an 'Applicative' context. If the +-- queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMinWithKeyA :: Applicative f => (k -> a -> f a) -> MinPQueue k a -> f (MinPQueue k a) +adjustMinWithKeyA = adjustMinWithKeyA' id + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the minimum key. +-- If the queue is empty, does nothing. +updateMin :: Ord k => (a -> Maybe a) -> MinPQueue k a -> MinPQueue k a +updateMin = updateMinWithKey . const + +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the minimum key. If the queue is empty, does nothing. +-- +-- @since 1.4.2 +updateMinA :: (Applicative f, Ord k) => (a -> f (Maybe a)) -> MinPQueue k a -> f (MinPQueue k a) +updateMinA = updateMinWithKeyA . const + +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the minimum key in an 'Applicative' context. If the queue is +-- empty, does nothing. +-- +-- @since 1.4.2 +updateMinWithKeyA :: (Applicative f, Ord k) => (k -> a -> f (Maybe a)) -> MinPQueue k a -> f (MinPQueue k a) +updateMinWithKeyA = updateMinWithKeyA' id + +-- | \(O(\log n)\). Retrieves the value associated with the minimal key of the queue, and the queue +-- stripped of that element, or 'Nothing' if passed an empty queue. +minView :: Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a) +minView q = do ((_, a), q') <- minViewWithKey q + return (a, q') + +-- | \(O(n)\). Map a function over all values in the queue. +map :: (a -> b) -> MinPQueue k a -> MinPQueue k b +map = mapWithKey . const + +-- | \(O(n)\). @'mapKeys' f q@ is the queue obtained by applying @f@ to each key of @q@. +mapKeys :: Ord k' => (k -> k') -> MinPQueue k a -> MinPQueue k' a +mapKeys f q = fromList [(f k, a) | (k, a) <- toListU q] + +-- | \(O(n)\). Map values and collect the 'Just' results. +mapMaybe :: Ord k => (a -> Maybe b) -> MinPQueue k a -> MinPQueue k b +mapMaybe = mapMaybeWithKey . const + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +mapEither :: Ord k => (a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) +mapEither = mapEitherWithKey . const + +-- | \(O(n)\). Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a +filter = filterWithKey . const + +-- | \(O(n)\). Filter all values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a +filterWithKey p = mapMaybeWithKey (\k a -> if p k a then Just a else Nothing) + +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partition :: Ord k => (a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) +partition = partitionWithKey . const + +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partitionWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) +partitionWithKey p = mapEitherWithKey (\k a -> if p k a then Left a else Right a) + +{-# INLINE take #-} +-- | \(O(k \log n)\). Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. +-- (@'take' k q == 'List.take' k ('toAscList' q)@) +take :: Ord k => Int -> MinPQueue k a -> [(k, a)] +take n = List.take n . toAscList + +-- | \(O(k \log n)\). Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. +drop :: Ord k => Int -> MinPQueue k a -> MinPQueue k a +drop n0 q0 + | n0 <= 0 = q0 + | n0 >= size q0 = empty + | otherwise = drop' n0 q0 + where + drop' n q + | n == 0 = q + | otherwise = drop' (n - 1) (deleteMin q) + +-- | \(O(k \log n)\). Equivalent to @('take' k q, 'drop' k q)@. +splitAt :: Ord k => Int -> MinPQueue k a -> ([(k, a)], MinPQueue k a) +splitAt n q + | n <= 0 = ([], q) + | otherwise = n `seq` case minViewWithKey q of + Just (ka, q') -> let (kas, q'') = splitAt (n - 1) q' in (ka : kas, q'') + _ -> ([], q) + +{-# INLINE takeWhile #-} +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toAscList' q)@) +takeWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> [(k, a)] +takeWhile = takeWhileWithKey . const + +{-# INLINE takeWhileWithKey #-} +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toAscList' q)@) +takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> [(k, a)] +takeWhileWithKey p0 = List.takeWhile (uncurry' p0) . toAscList + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a +dropWhile = dropWhileWithKey . const + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a +dropWhileWithKey p q = case minViewWithKey q of + Just ((k, a), q') + | p k a -> dropWhileWithKey p q' + _ -> q + +-- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. +span :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) +span = spanWithKey . const + +-- | Equivalent to @'span' ('not' . p)@. +break :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) +break p = span (not . p) + +-- | Equivalent to @('takeWhileWithKey' p q, 'dropWhileWithKey' p q)@. +spanWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) +spanWithKey p q = case minViewWithKey q of + Just (t@(k, a), q') + | p k a -> let (kas, q'') = spanWithKey p q' in (t : kas, q'') + _ -> ([], q) + +-- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. +breakWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) +breakWithKey p = spanWithKey (not .: p) + +-- | \(O(n)\). Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ +fromDescList :: [(k, a)] -> MinPQueue k a +{-# INLINE fromDescList #-} +fromDescList xs = List.foldl' (\q (k, a) -> insertMin' k a q) empty xs + +{-# INLINE keys #-} +-- | \(O(n \log n)\). Return all keys of the queue in ascending order. +keys :: Ord k => MinPQueue k a -> [k] +keys = List.map fst . toAscList + +{-# INLINE elems #-} +-- | \(O(n \log n)\). Return all elements of the queue in ascending order by key. +elems :: Ord k => MinPQueue k a -> [a] +elems = List.map snd . toAscList + +{-# INLINE toList #-} +-- | \(O(n \log n)\). Equivalent to 'toAscList'. +-- +-- If the traversal order is irrelevant, consider using 'toListU'. +toList :: Ord k => MinPQueue k a -> [(k, a)] +toList = toAscList + +{-# INLINE assocs #-} +-- | \(O(n \log n)\). Equivalent to 'toAscList'. +assocs :: Ord k => MinPQueue k a -> [(k, a)] +assocs = toAscList + +{-# INLINE keysU #-} +-- | \(O(n)\). Return all keys of the queue in no particular order. +keysU :: MinPQueue k a -> [k] +keysU = List.map fst . toListU + +{-# INLINE elemsU #-} +-- | \(O(n)\). Return all elements of the queue in no particular order. +elemsU :: MinPQueue k a -> [a] +elemsU = List.map snd . toListU + +{-# INLINE assocsU #-} +-- | \(O(n)\). Equivalent to 'toListU'. +assocsU :: MinPQueue k a -> [(k, a)] +assocsU = toListU + +-- | \(O(n)\). An unordered left fold over the elements of the queue, in no +-- particular order. This is rarely what you want; 'foldrU' and 'foldlU'' are +-- more likely to perform well. +foldlU :: (b -> a -> b) -> b -> MinPQueue k a -> b +foldlU f = foldlWithKeyU (const . f) + +-- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no +-- particular order. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MinPQueue k a -> b +foldlU' f = foldlWithKeyU' (const . f) + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseU :: (Applicative f) => (a -> f b) -> MinPQueue k a -> f (MinPQueue k b) +traverseU = traverseWithKeyU . const diff --git a/src/Nattish.hs b/src/Nattish.hs new file mode 100644 --- /dev/null +++ b/src/Nattish.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 904 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE ViewPatterns #-} +#endif + +-- | A facility for faking GADTs that work sufficiently similarly +-- to unary natural numbers. +module Nattish + ( Nattish (Zeroy, Succy) + ) + where +#if __GLASGOW_HASKELL__ >= 904 +import Unsafe.Coerce (unsafeCoerce) +#endif +import Data.Kind (Type) + +-- | Conceptually, +-- +-- @ +-- data Nattish :: forall k. k -> (k -> k) -> k -> Type where +-- Zeroy :: Nattish zero succ zero +-- Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n) +-- @ +-- +-- This abstracts over the zero and successor constructors, so it can be used +-- in any sufficiently Nat-like context. In our case, we can use it for the @Zero@ +-- and @Succ@ constructors of both @MinQueue@ and @MinPQueue@. With recent +-- versions of GHC, @Nattish@ is actually represented as a machine integer, so +-- it is very fast to work with. + +#if __GLASGOW_HASKELL__ < 904 +data Nattish :: k -> (k -> k) -> k -> Type where + Zeroy :: Nattish zero succ zero + Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n) + +toWord :: Nattish zero succ n -> Word +toWord = go 0 + where + go :: Word -> Nattish zero succ n -> Word + go !acc Zeroy = acc + go !acc (Succy n) = go (acc + 1) n + +instance Show (Nattish zero succ n) where + showsPrec p n = showParen (p > 10) $ + showString "Nattish " . showsPrec 11 (toWord n) +#else + +type Nattish :: forall k. k -> (k -> k) -> k -> Type +newtype Nattish zero succ n = Nattish Word + deriving (Show) +type role Nattish nominal nominal nominal + +data Res zero succ n where + ResZero :: Res zero succ zero + ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n) + +check :: Nattish zero succ n -> Res zero succ n +check (Nattish 0) = unsafeCoerce ResZero +check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1)) + +pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n +pattern Zeroy <- (check -> ResZero) + where + Zeroy = Nattish 0 +{-# INLINE Zeroy #-} + +pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n +pattern Succy n <- (check -> ResSucc n) + where + Succy (Nattish n) = Nattish (n + 1) +{-# INLINE Succy #-} + +{-# COMPLETE Zeroy, Succy #-} + +#endif diff --git a/tests/PQueueTests.hs b/tests/PQueueTests.hs new file mode 100644 --- /dev/null +++ b/tests/PQueueTests.hs @@ -0,0 +1,285 @@ +{-# language CPP #-} + +{-# language BangPatterns #-} +{-# language ExtendedDefaultRules #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language ViewPatterns #-} + +{-# options_ghc -Wno-x-partial #-} + +module Main (main) where + +import Data.Bifunctor (bimap, first, second) +import qualified Data.Either as Either +import Data.Function (on) +import Data.Functor.Identity +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Data.Ord (Down(..)) + +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Data.PQueue.Max as Max +import qualified Data.PQueue.Min as Min +import qualified Data.PQueue.Prio.Max as PMax +import qualified Data.PQueue.Prio.Min as PMin +import qualified Validity.PQueue.Min as VMin +import qualified Validity.PQueue.Prio.Min as VPMin +import qualified Validity.PQueue.Prio.Max as VPMax + +default (Int) + +validMinQueue :: Ord a => Min.MinQueue a -> Property +validMinQueue q = VMin.validShape q .&&. VMin.validSize q .&&. VMin.validOrder q + +validPMinQueue :: Ord k => PMin.MinPQueue k a -> Property +validPMinQueue q = VPMin.validShape q .&&. VPMin.validSize q .&&. VPMin.validOrder q + +validPMaxQueue :: Ord k => PMax.MaxPQueue k a -> Property +validPMaxQueue q = VPMax.validShape q .&&. VPMax.validSize q .&&. VPMax.validOrder q + +main :: IO () +main = defaultMain $ testGroup "pqueue" + [ testGroup "Data.PQueue.Min" + [ testProperty "size" $ \xs -> Min.size (Min.fromList xs) === length xs + , testGroup "getMin" + [ testProperty "empty" $ Min.getMin Min.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> Min.getMin (Min.fromList xs) === Just (minimum xs) + ] + , testProperty "minView" $ \xs -> case Min.minView (Min.fromList xs) of + Nothing -> xs === [] + Just (the_min, xs') -> + validMinQueue xs' .&&. + the_min : Min.toList xs' === List.sort xs + , testProperty "insert" $ \x xs -> Min.insert x (Min.fromList xs) === Min.fromList (x : xs) + , testProperty "union" $ \xs ys -> Min.union (Min.fromList xs) (Min.fromList ys) === Min.fromList (xs ++ ys) + , testProperty "filter" $ \xs -> + let xs' = Min.filter even (Min.fromList xs) + in validMinQueue xs' .&&. + Min.toList xs' === List.sort (List.filter even xs) + , testProperty "partition" $ \xs -> + let xs' = Min.fromList xs + (ys, zs) = Min.partition even xs' + in validMinQueue ys .&&. + validMinQueue zs .&&. + (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (List.partition even xs) + , testProperty "mapMaybe" $ \(Fn f) xs -> + let xs' :: Min.MinQueue Char + xs' = Min.mapMaybe f (Min.fromList xs) + in validMinQueue xs' .&&. + Min.toList xs' === List.sort (Maybe.mapMaybe f xs) + , testProperty "mapEither" $ \(Fn f) xs -> + let (ys, zs) = Min.mapEither f (Min.fromList xs) + in validMinQueue ys .&&. + validMinQueue zs .&&. + (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (Either.partitionEithers . List.map f $ xs) + , testProperty "map" $ \xs -> Min.map negate (Min.fromList xs) === Min.fromList (List.map negate xs) + , testProperty "mapMonotonic" $ \xs -> + let + -- Monotonic, but not strictly so + fun x + | even x = x + | otherwise = x + 1 + res = Min.mapMonotonic fun (Min.fromList xs) + in validMinQueue res .&&. Min.toList res === List.map fun (List.sort xs) + , testProperty "take" $ \n xs -> Min.take n (Min.fromList xs) === List.take n (List.sort xs) + , testProperty "drop" $ \n xs -> Min.drop n (Min.fromList xs) === Min.fromList (List.drop n (List.sort xs)) + , testProperty "splitAt" $ \n xs -> Min.splitAt n (Min.fromList xs) === second Min.fromList (List.splitAt n (List.sort xs)) + , testProperty "takeWhile" $ \(Fn f) xs -> Min.takeWhile f (Min.fromList xs) === List.takeWhile f (List.sort xs) + , testProperty "dropWhile" $ \(Fn f) xs -> Min.dropWhile f (Min.fromList xs) === Min.fromList (List.dropWhile f (List.sort xs)) + , testProperty "span" $ \(Fn f) xs -> Min.span f (Min.fromList xs) === second Min.fromList (List.span f (List.sort xs)) + , testProperty "foldrAsc" $ \xs -> Min.foldrAsc (:) [] (Min.fromList xs) === List.sort xs + , testProperty "foldlAsc" $ \xs -> Min.foldlAsc (flip (:)) [] (Min.fromList xs) === List.sortOn Down xs + , testProperty "foldrDesc" $ \xs -> Min.foldrDesc (:) [] (Min.fromList xs) === List.sortOn Down xs + , testProperty "foldlDesc" $ \xs -> Min.foldlDesc (flip (:)) [] (Min.fromList xs) === List.sort xs + , testProperty "toAscList" $ \xs -> Min.toAscList (Min.fromList xs) === List.sort xs + , testProperty "toDescList" $ \xs -> Min.toDescList (Min.fromList xs) === List.sortOn Down xs + , testProperty "fromAscList" $ \xs -> Min.fromAscList (List.sort xs) === Min.fromList xs + , testProperty "fromDescList" $ \xs -> Min.fromDescList (List.sortOn Down xs) === Min.fromList xs + , testProperty "foldrU" $ \xs -> Min.foldrU (+) 0 (Min.fromList xs) === sum xs + , testProperty "foldlU" $ \xs -> Min.foldlU (+) 0 (Min.fromList xs) === sum xs + , testProperty "foldlU'" $ \xs -> Min.foldlU' (+) 0 (Min.fromList xs) === sum xs + , testProperty "toListU" $ \xs -> List.sort (Min.toListU (Min.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` Min.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` Min.fromList) xs ys === (compare `on` List.sort) xs ys + ] + , testGroup "Data.PQueue.Max" + [ testProperty "size" $ \xs -> Max.size (Max.fromList xs) === length xs + , testGroup "getMax" + [ testProperty "empty" $ Max.getMax Max.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> Max.getMax (Max.fromList xs) === Just (maximum xs) + ] + , testProperty "minView" $ \xs -> Max.maxView (Max.fromList xs) === fmap (second Max.fromList) (List.uncons (List.sortOn Down xs)) + , testProperty "insert" $ \x xs -> Max.insert x (Max.fromList xs) === Max.fromList (x : xs) + , testProperty "union" $ \xs ys -> Max.union (Max.fromList xs) (Max.fromList ys) === Max.fromList (xs ++ ys) + , testProperty "filter" $ \xs -> Max.filter even (Max.fromList xs) === Max.fromList (List.filter even xs) + , testProperty "partition" $ \xs -> Max.partition even (Max.fromList xs) === bimap Max.fromList Max.fromList (List.partition even xs) + , testProperty "map" $ \xs -> Max.map negate (Max.fromList xs) === Max.fromList (List.map negate xs) + , testProperty "mapMonotonic" $ \xs -> Max.mapMonotonic (+ 1) (Max.fromList xs) === Max.fromList (List.map (+ 1) xs) + , testProperty "take" $ \n xs -> Max.take n (Max.fromList xs) === List.take n (List.sortOn Down xs) + , testProperty "drop" $ \n xs -> Max.drop n (Max.fromList xs) === Max.fromList (List.drop n (List.sortOn Down xs)) + , testProperty "splitAt" $ \n xs -> Max.splitAt n (Max.fromList xs) === second Max.fromList (List.splitAt n (List.sortOn Down xs)) + , testProperty "takeWhile" $ \(Fn f) xs -> Max.takeWhile f (Max.fromList xs) === List.takeWhile f (List.sortOn Down xs) + , testProperty "dropWhile" $ \(Fn f) xs -> Max.dropWhile f (Max.fromList xs) === Max.fromList (List.dropWhile f (List.sortOn Down xs)) + , testProperty "span" $ \(Fn f) xs -> Max.span f (Max.fromList xs) === second Max.fromList (List.span f (List.sortOn Down xs)) + , testProperty "foldrAsc" $ \xs -> Max.foldrAsc (:) [] (Max.fromList xs) === List.sort xs + , testProperty "foldlAsc" $ \xs -> Max.foldlAsc (flip (:)) [] (Max.fromList xs) === List.sortOn Down xs + , testProperty "foldrDesc" $ \xs -> Max.foldrDesc (:) [] (Max.fromList xs) === List.sortOn Down xs + , testProperty "foldlDesc" $ \xs -> Max.foldlDesc (flip (:)) [] (Max.fromList xs) === List.sort xs + , testProperty "toAscList" $ \xs -> Max.toAscList (Max.fromList xs) === List.sort xs + , testProperty "toDescList" $ \xs -> Max.toDescList (Max.fromList xs) === List.sortOn Down xs + , testProperty "fromAscList" $ \xs -> Max.fromAscList (List.sort xs) === Max.fromList xs + , testProperty "fromDescList" $ \xs -> Max.fromDescList (List.sortOn Down xs) === Max.fromList xs + , testProperty "foldrU" $ \xs -> Max.foldrU (+) 0 (Max.fromList xs) === sum xs + , testProperty "foldlU" $ \xs -> Max.foldlU (+) 0 (Max.fromList xs) === sum xs + , testProperty "foldlU'" $ \xs -> Max.foldlU' (+) 0 (Max.fromList xs) === sum xs + , testProperty "toListU" $ \xs -> List.sort (Max.toListU (Max.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` Max.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` Max.fromList) xs ys === (compare `on` (List.sort . List.map Down)) xs ys + ] + , testGroup "Data.PQueue.Prio.Min" + [ testProperty "size" $ \xs -> PMin.size (PMin.fromList xs) === length xs + , testGroup "getMin" + [ testProperty "empty" $ PMin.getMin PMin.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> fmap fst (PMin.getMin (PMin.fromList xs)) === Just (fst (minimum xs)) + ] + , testProperty "adjustMin" $ \xs -> PMin.adjustMin id (PMin.fromList xs) === PMin.fromList xs + , testProperty "adjustMinA" $ \xs -> PMin.adjustMinA Identity (PMin.fromList xs) === Identity (PMin.fromList xs) + , testGroup "updateMin" + [ testProperty "Just" $ \xs -> PMin.updateMin Just (PMin.fromList xs) === PMin.fromList xs + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMin.updateMin (const Nothing) (PMin.fromList xs) === PMin.fromList (tail (List.sort xs)) + ] + , testGroup "updateMinA" + [ testProperty "Just" $ \xs -> PMin.updateMinA (Identity . Just) (PMin.fromList xs) === Identity (PMin.fromList xs) + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMin.updateMinA (Identity . const Nothing) (PMin.fromList xs) === Identity (PMin.fromList (tail (List.sort xs))) + ] + , testProperty "minViewWithKey" $ \(xs :: [(Int, Int)]) -> case PMin.minViewWithKey (PMin.fromList xs) of + Nothing -> xs === [] + Just ((the_min, the_min_val), xs') -> + validPMinQueue xs' .&&. + List.sort ((the_min, the_min_val) : PMin.toList xs') === List.sort xs + , testProperty "map" $ \(xs :: [(Int, ())]) -> PMin.map id (PMin.fromList xs) === PMin.fromList xs + , testProperty "mapKeysMonotonic" $ \xs -> + let + -- Monotonic, but not strictly so + fun x + | even x = x + | otherwise = x + 1 + res = PMin.mapKeysMonotonic fun (PMin.fromList xs) + in validPMinQueue res .&&. List.sort (PMin.toList res) === List.sort (List.map (first fun) xs) + , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMin.take n (PMin.fromList xs) === List.take n (List.sort xs) + , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMin.drop n (PMin.fromList xs) === PMin.fromList (List.drop n (List.sort xs)) + , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMin.splitAt n (PMin.fromList xs) === second PMin.fromList (List.splitAt n (List.sort xs)) + , testProperty "takeWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMin.takeWhileWithKey f (PMin.fromList xs) === List.takeWhile (uncurry f) (List.sort xs) + , testProperty "dropWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMin.dropWhileWithKey f (PMin.fromList xs) === PMin.fromList (List.dropWhile (uncurry f) (List.sort xs)) + , testProperty "span" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMin.spanWithKey f (PMin.fromList xs) === second PMin.fromList (List.span (uncurry f) (List.sort xs)) + , testProperty "foldrWithKey" $ \(xs :: [(Int, ())]) -> PMin.foldrWithKey (\k x acc -> (k, x) : acc) [] (PMin.fromList xs) === List.sort xs + , testProperty "foldlWithKey" $ \(xs :: [(Int, ())]) -> PMin.foldlWithKey (\acc k x -> (k, x) : acc) [] (PMin.fromList xs) === List.sortOn Down xs + , testProperty "traverseWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.traverseWithKey f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "mapMWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.mapMWithKey f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "insert" $ \k xs -> PMin.insert k () (PMin.fromList xs) === PMin.fromList ((k, ()) : xs) + , testProperty "union" $ \(xs :: [(Int, ())]) ys -> PMin.union (PMin.fromList xs) (PMin.fromList ys) === PMin.fromList (xs ++ ys) + , testProperty "filter" $ \(xs :: [(Int, Int)]) -> + let + -- The probability of a number not being divisible by 3 is 2/3. + -- The probability of a number not being divisible by 4 is 3/4. + -- So the probability of a number being divisible by neither is + -- 1/2. + f x y = x `rem` 3 == 0 || y `rem` 4 == 0 + xs' = PMin.filterWithKey f (PMin.fromList xs) + in validPMinQueue xs' .&&. + List.sort (PMin.toList xs') === List.sort (List.filter (uncurry f) xs) + , testProperty "partition" $ \(xs :: [(Int, Int)]) -> + let + f x y = x `rem` 3 == 0 || y `rem` 4 == 0 + (ys, zs) = PMin.partitionWithKey f (PMin.fromList xs) + in validPMinQueue ys .&&. + validPMinQueue zs .&&. + (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) === + bimap List.sort List.sort (List.partition (uncurry f) xs) + , testProperty "mapMaybe" $ \(Fn2 f) (xs :: [(Int, Int)]) -> + let + xs' = PMin.mapMaybeWithKey f (PMin.fromList xs) + in validPMinQueue xs' .&&. + List.sort (PMin.toList xs') === List.sort (Maybe.mapMaybe (\(k,v) -> fmap (k,) (f k v)) xs) + , testProperty "mapEither" $ \(Fn2 f) (xs :: [(Int, Int)]) -> + let (ys, zs) = PMin.mapEitherWithKey f (PMin.fromList xs) + in validPMinQueue ys .&&. + validPMinQueue zs .&&. + (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) === + bimap List.sort List.sort (Either.partitionEithers . List.map (\(k,v) -> bimap (k,) (k,) (f k v)) $ xs) + , testProperty "toAscList" $ \(xs :: [(Int, ())]) -> PMin.toAscList (PMin.fromList xs) === List.sort xs + , testProperty "toDescList" $ \(xs :: [(Int, ())]) -> PMin.toDescList (PMin.fromList xs) === List.sortOn Down xs + , testProperty "fromAscList" $ \(xs :: [(Int, ())]) -> PMin.fromAscList (List.sort xs) === PMin.fromList xs + , testProperty "fromDescList" $ \(xs :: [(Int, ())]) -> PMin.fromDescList (List.sortOn Down xs) === PMin.fromList xs + , testProperty "foldrU" $ \xs -> PMin.foldrU (+) 0 (PMin.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU" $ \xs -> PMin.foldlU (+) 0 (PMin.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU'" $ \xs -> PMin.foldlU' (+) 0 (PMin.fromList xs) === sum (List.map snd xs) + , testProperty "traverseU" $ + \(Fn (f :: () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.traverseU f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f x)) xs) + , testProperty "toListU" $ \xs -> List.sort (PMin.toListU (PMin.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` PMin.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` PMin.fromList) xs ys === (compare `on` List.sort) xs ys + ] + , testGroup "Data.PQueue.Prio.Max" + [ testProperty "size" $ \xs -> PMax.size (PMax.fromList xs) === length xs + , testGroup "getMax" + [ testProperty "empty" $ PMax.getMax PMax.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> fmap fst (PMax.getMax (PMax.fromList xs)) === Just (fst (maximum xs)) + ] + , testProperty "adjustMin" $ \xs -> PMax.adjustMax id (PMax.fromList xs) === PMax.fromList xs + , testProperty "adjustMinA" $ \xs -> PMax.adjustMaxA Identity (PMax.fromList xs) === Identity (PMax.fromList xs) + , testGroup "updateMin" + [ testProperty "Just" $ \xs -> PMax.updateMax Just (PMax.fromList xs) === PMax.fromList xs + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMax.updateMax (const Nothing) (PMax.fromList xs) === PMax.fromList (tail (List.sortOn Down xs)) + ] + , testGroup "updateMinA" + [ testProperty "Just" $ \xs -> PMax.updateMaxA (Identity . Just) (PMax.fromList xs) === Identity (PMax.fromList xs) + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMax.updateMaxA (Identity . const Nothing) (PMax.fromList xs) === Identity (PMax.fromList (tail (List.sortOn Down xs))) + ] + , testProperty "minViewWithKey" $ \(xs :: [(Int, ())]) -> PMax.maxViewWithKey (PMax.fromList xs) === fmap (second PMax.fromList) (List.uncons (List.sortOn Down xs)) + , testProperty "map" $ \(xs :: [(Int, ())]) -> PMax.map id (PMax.fromList xs) === PMax.fromList xs + , testProperty "mapKeysMonotonic" $ \xs -> + let + -- Monotonic, but not strictly so + fun x + | even x = x + | otherwise = x + 1 + res = PMax.mapKeysMonotonic fun (PMax.fromList xs) + in validPMaxQueue res .&&. List.sort (PMax.toList res) === List.sort (List.map (first fun) xs) + , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMax.take n (PMax.fromList xs) === List.take n (List.sortOn Down xs) + , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMax.drop n (PMax.fromList xs) === PMax.fromList (List.drop n (List.sortOn Down xs)) + , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMax.splitAt n (PMax.fromList xs) === second PMax.fromList (List.splitAt n (List.sortOn Down xs)) + , testProperty "takeWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMax.takeWhileWithKey f (PMax.fromList xs) === List.takeWhile (uncurry f) (List.sortOn Down xs) + , testProperty "dropWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMax.dropWhileWithKey f (PMax.fromList xs) === PMax.fromList (List.dropWhile (uncurry f) (List.sortOn Down xs)) + , testProperty "span" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMax.spanWithKey f (PMax.fromList xs) === second PMax.fromList (List.span (uncurry f) (List.sortOn Down xs)) + , testProperty "foldrWithKey" $ \(xs :: [(Int, ())]) -> PMax.foldrWithKey (\k x acc -> (k, x) : acc) [] (PMax.fromList xs) === List.sortOn Down xs + , testProperty "foldlWithKey" $ \(xs :: [(Int, ())]) -> PMax.foldlWithKey (\acc k x -> (k, x) : acc) [] (PMax.fromList xs) === List.sort xs + , testProperty "traverseWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMax.traverseWithKey f (PMax.fromList xs) === fmap PMax.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "mapMWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMax.mapMWithKey f (PMax.fromList xs) === fmap PMax.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "insert" $ \k xs -> PMax.insert k () (PMax.fromList xs) === PMax.fromList ((k, ()) : xs) + , testProperty "union" $ \(xs :: [(Int, ())]) ys -> PMax.union (PMax.fromList xs) (PMax.fromList ys) === PMax.fromList (xs ++ ys) + , testProperty "filter" $ + \(xs :: [(Int, ())]) -> PMax.filterWithKey (\k _ -> even k) (PMax.fromList xs) === PMax.fromList (List.filter (even . fst) xs) + , testProperty "partition" $ + \(xs :: [(Int, ())]) -> PMax.partitionWithKey (\k _ -> even k) (PMax.fromList xs) === bimap PMax.fromList PMax.fromList (List.partition (even . fst) xs) + , testProperty "toAscList" $ \(xs :: [(Int, ())]) -> PMax.toAscList (PMax.fromList xs) === List.sort xs + , testProperty "toDescList" $ \(xs :: [(Int, ())]) -> PMax.toDescList (PMax.fromList xs) === List.sortOn Down xs + , testProperty "fromAscList" $ \(xs :: [(Int, ())]) -> PMax.fromAscList (List.sort xs) === PMax.fromList xs + , testProperty "fromDescList" $ \(xs :: [(Int, ())]) -> PMax.fromDescList (List.sortOn Down xs) === PMax.fromList xs + , testProperty "foldrU" $ \xs -> PMax.foldrU (+) 0 (PMax.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU" $ \xs -> PMax.foldlU (+) 0 (PMax.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU'" $ \xs -> PMax.foldlU' (+) 0 (PMax.fromList xs) === sum (List.map snd xs) + , testProperty "traverseU" $ + \(Fn (f :: () -> Maybe ())) (xs :: [(Int, ())]) -> PMax.traverseU f (PMax.fromList xs) === fmap PMax.fromList (traverse (\(k, x) -> fmap (k,) (f x)) xs) + , testProperty "toListU" $ \xs -> List.sort (PMax.toListU (PMax.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` PMax.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` PMax.fromList) xs ys === (compare `on` (List.sort . List.map Down)) xs ys + ] + ] diff --git a/tests/Validity/BinomialQueue.hs b/tests/Validity/BinomialQueue.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/BinomialQueue.hs @@ -0,0 +1,49 @@ +-- | Validity testing +module Validity.BinomialQueue + ( validShape + , precedesProperly + ) where + +import BinomialQueue.Internals + +-- | Does the heap have a valid shape? +validShape :: MinQueue a -> Bool +validShape (MinQueue f) = validShapeF f + +validShapeF :: BinomForest rk a -> Bool +validShapeF (Cons _ f) = validShapeF f +validShapeF (Skip Nil) = False +validShapeF (Skip _f) = True +validShapeF Nil = True + +-- | Takes an element and a priority queue. Checks that the queue is in heap +-- order and that the element is less than or equal to all elements of the +-- queue. +precedesProperly :: Ord a => a -> MinQueue a -> Bool +precedesProperly a (MinQueue q) = precedesProperlyF a q + +-- | Takes an element and a forest. Checks that the forest is in heap order +-- and that the element is less than or equal to all elements of the forest. +precedesProperlyF :: (Ord a, TreeValidity rk) => a -> BinomForest rk a -> Bool +precedesProperlyF _ Nil = True +precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f +precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t + && precedesProperlyF the_min ts + +-- | Takes an element and a tree. Checks that the tree is in heap order +-- and that the element is less than or equal to all elements of the tree. +precedesProperlyTree :: (Ord a, TreeValidity rk) => a -> BinomTree rk a -> Bool +precedesProperlyTree the_min (BinomTree a ts) = the_min <= a && precedesProperlyRk a ts + +-- | A helper class for order validity checking +class TreeValidity rk where + -- | Takes an element and a collection of trees. Checks that the collection + -- is in heap order and that the element is less than or equal to all + -- elements of the collection. + precedesProperlyRk :: Ord a => a -> rk a -> Bool +instance TreeValidity Zero where + precedesProperlyRk _ ~Zero = True +instance TreeValidity rk => TreeValidity (Succ rk) where + precedesProperlyRk the_min (Succ t q) = + precedesProperlyTree the_min t && + precedesProperlyRk the_min q diff --git a/tests/Validity/PQueue/Min.hs b/tests/Validity/PQueue/Min.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Min.hs @@ -0,0 +1,21 @@ +module Validity.PQueue.Min + ( validShape + , validSize + , validOrder + ) where + +import Data.PQueue.Internals +import qualified BinomialQueue.Internals as BQ +import qualified Validity.BinomialQueue as VBQ + +validShape :: MinQueue a -> Bool +validShape Empty = True +validShape (MinQueue _ _ f) = VBQ.validShape f + +validSize :: MinQueue a -> Bool +validSize Empty = True +validSize (MinQueue sz _ f) = sz == BQ.size f + 1 + +validOrder :: Ord a => MinQueue a -> Bool +validOrder Empty = True +validOrder (MinQueue _sz a f) = VBQ.precedesProperly a f diff --git a/tests/Validity/PQueue/Prio/BinomialQueue.hs b/tests/Validity/PQueue/Prio/BinomialQueue.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Prio/BinomialQueue.hs @@ -0,0 +1,40 @@ +-- | Validity testing +module Validity.PQueue.Prio.BinomialQueue + ( validShapeF + , precedesProperlyF + ) where + +import Data.PQueue.Prio.Internals + +-- | Does the heap have a valid shape? +validShapeF :: BinomForest rk k a -> Bool +validShapeF (Cons _ f) = validShapeF f +validShapeF (Skip Nil) = False +validShapeF (Skip _f) = True +validShapeF Nil = True + +-- | Takes an element and a forest. Checks that the forest is in heap order +-- and that the element is less than or equal to all elements of the forest. +precedesProperlyF :: (Ord k, TreeValidity rk) => k -> BinomForest rk k a -> Bool +precedesProperlyF _ Nil = True +precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f +precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t + && precedesProperlyF the_min ts + +-- | Takes an element and a tree. Checks that the tree is in heap order +-- and that the element is less than or equal to all elements of the tree. +precedesProperlyTree :: (Ord k, TreeValidity rk) => k -> BinomTree rk k a -> Bool +precedesProperlyTree the_min (BinomTree k ts) = the_min <= k && precedesProperlyRk k ts + +-- | A helper class for order validity checking +class TreeValidity rk where + -- | Takes an element and a collection of trees. Checks that the collection + -- is in heap order and that the element is less than or equal to all + -- elements of the collection. + precedesProperlyRk :: Ord k => k -> rk k a -> Bool +instance TreeValidity Zero where + precedesProperlyRk _ (Zero _) = True +instance TreeValidity rk => TreeValidity (Succ rk) where + precedesProperlyRk the_min (Succ t q) = + precedesProperlyTree the_min t && + precedesProperlyRk the_min q diff --git a/tests/Validity/PQueue/Prio/Max.hs b/tests/Validity/PQueue/Prio/Max.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Prio/Max.hs @@ -0,0 +1,17 @@ +module Validity.PQueue.Prio.Max + ( validShape + , validSize + , validOrder + ) where + +import Data.PQueue.Prio.Max.Internals as PQM +import qualified Validity.PQueue.Prio.Min as VMin + +validShape :: MaxPQueue k a -> Bool +validShape (MaxPQ q) = VMin.validShape q + +validSize :: MaxPQueue k a -> Bool +validSize (MaxPQ q) = VMin.validSize q + +validOrder :: Ord k => MaxPQueue k a -> Bool +validOrder (MaxPQ q) = VMin.validOrder q diff --git a/tests/Validity/PQueue/Prio/Min.hs b/tests/Validity/PQueue/Prio/Min.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Prio/Min.hs @@ -0,0 +1,28 @@ +module Validity.PQueue.Prio.Min + ( validShape + , validSize + , validOrder + ) where + +import Data.PQueue.Prio.Internals as BQ +import qualified Validity.PQueue.Prio.BinomialQueue as VBQ + +validShape :: MinPQueue k a -> Bool +validShape Empty = True +validShape (MinPQ _ _ _ f) = VBQ.validShapeF f + +validSize :: MinPQueue k a -> Bool +validSize Empty = True +validSize (MinPQ sz _ _ f) = sz == sizeH f + 1 + +validOrder :: Ord k => MinPQueue k a -> Bool +validOrder Empty = True +validOrder (MinPQ _sz k _ f) = VBQ.precedesProperlyF k f + +sizeH :: BinomHeap k a -> Int +sizeH = go 0 1 + where + go :: Int -> Int -> BinomForest rk k a -> Int + go acc rk Nil = rk `seq` acc + go acc rk (Skip f) = go acc (2 * rk) f + go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f