packages feed

pqueue 1.3.2.3 → 1.7.0.0

raw patch · 39 files changed

Files

CHANGELOG.md view
@@ -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
− Control/Applicative/Identity.hs 
@@ -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)
− Data/PQueue/Internals.hs 
@@ -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
− Data/PQueue/Max.hs 
@@ -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
− Data/PQueue/Min.hs 
@@ -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;-  #-}
− Data/PQueue/Prio/Internals.hs 
@@ -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' <? k  -> incrExtract le (Just t) ex-  _            -> Extract k a0 ts (Skip tss)-  where-    a <? b = not (b `le` a)--extract :: (Ord k) => 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
− Data/PQueue/Prio/Max.hs 
@@ -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
− Data/PQueue/Prio/Max/Internals.hs 
@@ -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
− Data/PQueue/Prio/Min.hs 
@@ -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
− PQueueTests.hs 
@@ -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
+ README.md view
@@ -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).
+ benchmarks/BenchMinPQueue.hs view
@@ -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)+      ]+  ]
+ benchmarks/BenchMinQueue.hs view
@@ -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)+      ]+  ]
+ benchmarks/HeapSort.hs view
@@ -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
+ benchmarks/KWay/MergeAlg.hs view
@@ -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
+ benchmarks/KWay/PrioMergeAlg.hs view
@@ -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
+ benchmarks/KWay/RandomIncreasing.hs view
@@ -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'
+ benchmarks/PHeapSort.hs view
@@ -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]
− include/Typeable.h 
@@ -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
pqueue.cabal view
@@ -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 <hexagoxel@hexagoxel.de>-                    Louis Wasserman <wasserman.louis@gmail.com>-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 <hexagoxel@hexagoxel.de>,+                    Louis Wasserman <wasserman.louis@gmail.com>,+                    konsumlamm <konsumlamm@gmail.com>,+                    David Feuer <David.Feuer@gmail.com>+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
+ src/BinomialQueue/Internals.hs view
@@ -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
+ src/BinomialQueue/Max.hs view
@@ -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
+ src/BinomialQueue/Min.hs view
@@ -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
+ src/Data/PQueue/Internals.hs view
@@ -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
+ src/Data/PQueue/Internals/Classes.hs view
@@ -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
+ src/Data/PQueue/Internals/Down.hs view
@@ -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
+ src/Data/PQueue/Max.hs view
@@ -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
+ src/Data/PQueue/Min.hs view
@@ -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)
+ src/Data/PQueue/Prio/Internals.hs view
@@ -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
+ src/Data/PQueue/Prio/Max.hs view
@@ -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 ()
+ src/Data/PQueue/Prio/Max/Internals.hs view
@@ -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
+ src/Data/PQueue/Prio/Min.hs view
@@ -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
+ src/Nattish.hs view
@@ -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
+ tests/PQueueTests.hs view
@@ -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+    ]+  ]
+ tests/Validity/BinomialQueue.hs view
@@ -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
+ tests/Validity/PQueue/Min.hs view
@@ -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
+ tests/Validity/PQueue/Prio/BinomialQueue.hs view
@@ -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
+ tests/Validity/PQueue/Prio/Max.hs view
@@ -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
+ tests/Validity/PQueue/Prio/Min.hs view
@@ -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