diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for pqueue +## 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 diff --git a/Control/Applicative/Identity.hs b/Control/Applicative/Identity.hs deleted file mode 100644 --- a/Control/Applicative/Identity.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Control.Applicative.Identity where - -import Control.Applicative - -import Prelude - -newtype Identity a = Identity {runIdentity :: a} - -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) diff --git a/Data/PQueue/Internals.hs b/Data/PQueue/Internals.hs deleted file mode 100644 --- a/Data/PQueue/Internals.hs +++ /dev/null @@ -1,508 +0,0 @@ -{-# LANGUAGE CPP, StandaloneDeriving #-} - -module Data.PQueue.Internals ( - MinQueue (..), - BinomHeap, - BinomForest(..), - BinomTree(..), - Succ(..), - Zero(..), - LEq, - empty, - null, - size, - getMin, - minView, - singleton, - insert, - 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(log (min(n,m)))/, worst-case /O(log (max (n,m)))/. Take the union of two priority queues. -union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a -union = union' (<=) - --- | /O(n)/. Map elements and collect the 'Just' results. -mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b -mapMaybe _ Empty = Empty -mapMaybe f (MinQueue _ x ts) = maybe q' (`insert` q') (f x) - where - q' = mapMaybeQueue f (<=) (const Empty) Empty ts - --- | /O(n)/. Map elements and separate the 'Left' and 'Right' results. -mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) -mapEither _ Empty = (Empty, Empty) -mapEither f (MinQueue _ x ts) = case (mapEitherQueue f (<=) (<=) (const (Empty, Empty)) (Empty, Empty) ts, f x) of - ((qL, qR), Left b) -> (insert b qL, qR) - ((qL, qR), Right c) -> (qL, insert c qR) - --- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, --- as in 'fmap'. If it is not, the result is undefined. -mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b -mapMonotonic = mapU - -{-# INLINE foldrAsc #-} --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. -foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b -foldrAsc _ z Empty = z -foldrAsc f z (MinQueue _ x ts) = x `f` foldrUnfold f z extractHeap ts - -{-# INLINE foldrUnfold #-} --- | Equivalent to @foldr f z (unfoldr suc s0)@. -foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c -foldrUnfold f z suc s0 = unf s0 where - unf s = case suc s of - Nothing -> z - Just (x, s') -> x `f` unf s' - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order. -foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b -foldlAsc _ z Empty = z -foldlAsc f z (MinQueue _ x ts) = foldlUnfold f (z `f` x) extractHeap ts - -{-# INLINE foldlUnfold #-} --- | @foldlUnfold f z suc s0@ is equivalent to @foldl f z (unfoldr suc s0)@. -foldlUnfold :: (c -> a -> c) -> c -> (b -> Maybe (a, b)) -> b -> c -foldlUnfold f z0 suc s0 = unf z0 s0 where - unf z s = case suc s of - Nothing -> z - Just (x, s') -> unf (z `f` x) s' - -insert' :: LEq a -> a -> MinQueue a -> MinQueue a -insert' _ x Empty = singleton x -insert' le x (MinQueue n x' ts) - | x `le` x' = MinQueue (n+1) x (incr le (tip x') ts) - | otherwise = MinQueue (n+1) x' (incr le (tip x) ts) - -{-# INLINE union' #-} -union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a -union' _ Empty q = q -union' _ q Empty = q -union' le (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) - | x1 `le` x2 = MinQueue (n1 + n2) x1 (carry le (tip x2) f1 f2) - | otherwise = MinQueue (n1 + n2) x2 (carry le (tip x1) f1 f2) - --- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. -extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) -extractHeap ts = case extractBin (<=) ts of - Yes (Extract x _ ts') -> Just (x, ts') - _ -> Nothing - --- | A specialized type intended to organize the return of extract-min queries --- from a binomial forest. We walk all the way through the forest, and then --- walk backwards. @Extract rk a@ is the result type of an extract-min --- operation that has walked as far backwards of rank @rk@ -- that is, it --- has visited every root of rank @>= rk@. --- --- The interpretation of @Extract minKey children forest@ is --- --- * @minKey@ is the key of the minimum root visited so far. It may have --- any rank @>= rk@. We will denote the root corresponding to --- @minKey@ as @minRoot@. --- --- * @children@ is those children of @minRoot@ which have not yet been --- merged with the rest of the forest. Specifically, these are --- the children with rank @< rk@. --- --- * @forest@ is an accumulating parameter that maintains the partial --- reconstruction of the binomial forest without @minRoot@. It is --- the union of all old roots with rank @>= rk@ (except @minRoot@), --- with the set of all children of @minRoot@ with rank @>= rk@. --- Note that @forest@ is lazy, so if we discover a smaller key --- than @minKey@ later, we haven't wasted significant work. -data Extract rk a = Extract a (rk a) (BinomForest rk a) -data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a) - -incrExtract :: Extract (Succ rk) a -> Extract rk a -incrExtract (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Cons kChild ts) - -incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a -incrExtract' le t (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Skip (incr le (t `cat` kChild) ts)) - where - cat = joinBin le - --- | Walks backward from the biggest key in the forest, as far as rank @rk@. --- Returns its progress. Each successive application of @extractBin@ takes --- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. -extractBin :: LEq a -> BinomForest rk a -> MExtract rk a -extractBin _ Nil = No -extractBin le (Skip f) = case extractBin le f of - Yes ex -> Yes (incrExtract ex) - No -> No -extractBin le (Cons t@(BinomTree x ts) f) = Yes $ case extractBin le f of - Yes ex@(Extract minKey _ _) - | minKey `lt` x -> incrExtract' le t ex - _ -> Extract x ts (Skip f) - where a `lt` b = not (b `le` a) - -mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b -mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of - Nil -> q0 - Skip forest' -> mapMaybeQueue f le fCh' q0 forest' - Cons t forest' -> mapMaybeQueue f le fCh' (union' le (mapMaybeT t) q0) forest' - where fCh' (Succ t tss) = union' le (mapMaybeT t) (fCh tss) - mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\ x -> insert' le x (fCh ts)) (f x0) - -type Partition a b = (MinQueue a, MinQueue b) - -mapEitherQueue :: (a -> Either b c) -> LEq b -> LEq c -> (rk a -> Partition b c) -> Partition b c -> - BinomForest rk a -> Partition b c -mapEitherQueue f0 leB leC fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of - Nil -> (q00, q10) - Skip ts' -> mapEitherQueue f0 leB leC fCh' (q00, q10) ts' - Cons t ts' -> mapEitherQueue f0 leB leC fCh' (both (union' leB) (union' leC) (partitionT t) (q00, q10)) ts' - where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) - fCh' (Succ t tss) = both (union' leB) (union' leC) (partitionT t) (fCh tss) - partitionT (BinomTree x ts) = case fCh ts of - (q0, q1) -> case f0 x of - Left b -> (insert' leB b q0, q1) - Right c -> (q0, insert' leC c q1) - -{-# INLINE tip #-} --- | Constructs a binomial tree of rank 0. -tip :: a -> BinomTree Zero a -tip x = BinomTree x Zero - -insertMinQ :: a -> MinQueue a -> MinQueue a -insertMinQ x Empty = singleton x -insertMinQ x (MinQueue n x' f) = MinQueue (n+1) x (insertMin (tip x') f) - --- | @insertMin t f@ assumes that the root of @t@ compares as less than --- every other root in @f@, and merges accordingly. -insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a -insertMin t Nil = Cons t Nil -insertMin t (Skip f) = Cons t f -insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f) - --- | Given two binomial forests starting at rank @rk@, takes their union. --- Each successive application of this function costs /O(1)/, so applying it --- from the beginning costs /O(log n)/. -merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a -merge le f1 f2 = case (f1, f2) of - (Skip f1', Skip f2') -> Skip (merge le f1' f2') - (Skip f1', Cons t2 f2') -> Cons t2 (merge le f1' f2') - (Cons t1 f1', Skip f2') -> Cons t1 (merge le f1' f2') - (Cons t1 f1', Cons t2 f2') - -> Skip (carry le (t1 `cat` t2) f1' f2') - (Nil, _) -> f2 - (_, Nil) -> f1 - where cat = joinBin le - --- | Merges two binomial forests with another tree. If we are thinking of the trees --- in the binomial forest as binary digits, this corresponds to a carry operation. --- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/. -carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a -carry le t0 f1 f2 = t0 `seq` case (f1, f2) of - (Skip f1', Skip f2') -> Cons t0 (merge le f1' f2') - (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2') - (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2') - (Cons t1 f1', Cons t2 f2') - -> Cons t0 (mergeCarry t1 t2 f1' f2') - (Nil, _f2) -> incr le t0 f2 - (_f1, Nil) -> incr le t0 f1 - where cat = joinBin le - mergeCarry tA tB = carry le (tA `cat` tB) - --- | Merges a binomial tree into a binomial forest. If we are thinking --- of the trees in the binomial forest as binary digits, this corresponds --- to adding a power of 2. This costs amortized /O(1)/ time. -incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -incr le t f0 = t `seq` case f0 of - Nil -> Cons t Nil - Skip f -> Cons t f - Cons t' f' -> Skip (incr le (t `cat` t') f') - where cat = joinBin le - --- | The carrying operation: takes two binomial heaps of the same rank @k@ --- and returns one of rank @k+1@. Takes /O(1)/ time. -joinBin :: LEq a -> BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a -joinBin le t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) - | x1 `le` x2 = BinomTree x1 (Succ t2 ts1) - | otherwise = BinomTree x2 (Succ t1 ts2) - -instance Functor Zero where - fmap _ _ = Zero - -instance Functor rk => Functor (Succ rk) where - fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts) - -instance Functor rk => Functor (BinomTree rk) where - fmap f (BinomTree x ts) = BinomTree (f x) (fmap f ts) - -instance Functor rk => Functor (BinomForest rk) where - fmap _ Nil = Nil - fmap f (Skip ts) = Skip (fmap f ts) - fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts) - -instance Foldable Zero where - foldr _ z _ = z - foldl _ z _ = z - -instance Foldable rk => Foldable (Succ rk) where - foldr f z (Succ t ts) = foldr f (foldr f z ts) t - foldl f z (Succ t ts) = foldl f (foldl f z t) ts - -instance Foldable rk => Foldable (BinomTree rk) where - foldr f z (BinomTree x ts) = x `f` foldr f z ts - foldl f z (BinomTree x ts) = foldl f (z `f` x) ts - -instance Foldable rk => Foldable (BinomForest rk) where - foldr _ z Nil = z - foldr f z (Skip tss) = foldr f z tss - foldr f z (Cons t tss) = foldr f (foldr f z tss) t - foldl _ z Nil = z - foldl f z (Skip tss) = foldl f z tss - foldl f z (Cons t tss) = foldl f (foldl f z t) tss - --- instance Traversable Zero where --- traverse _ _ = pure Zero --- --- instance Traversable rk => Traversable (Succ rk) where --- traverse f (Succ t ts) = Succ <$> traverse f t <*> traverse f ts --- --- instance Traversable rk => Traversable (BinomTree rk) where --- traverse f (BinomTree x ts) = BinomTree <$> f x <*> traverse f ts --- --- instance Traversable rk => Traversable (BinomForest rk) where --- traverse _ Nil = pure Nil --- traverse f (Skip tss) = Skip <$> traverse f tss --- traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss - -mapU :: (a -> b) -> MinQueue a -> MinQueue b -mapU _ Empty = Empty -mapU f (MinQueue n x ts) = MinQueue n (f x) (f <$> ts) - --- | /O(n)/. Unordered right fold on a priority queue. -foldrU :: (a -> b -> b) -> b -> MinQueue a -> b -foldrU _ z Empty = z -foldrU f z (MinQueue _ x ts) = x `f` foldr f z ts - --- | /O(n)/. Unordered left fold on a priority queue. -foldlU :: (b -> a -> b) -> b -> MinQueue a -> b -foldlU _ z Empty = z -foldlU f z (MinQueue _ x ts) = foldl f (z `f` x) ts - --- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) --- traverseU _ Empty = pure Empty --- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts - --- | Forces the spine of the priority queue. -seqSpine :: MinQueue a -> b -> b -seqSpine Empty z = z -seqSpine (MinQueue _ _ ts) z = seqSpineF ts z - -seqSpineF :: BinomForest rk a -> b -> b -seqSpineF Nil z = z -seqSpineF (Skip ts') z = seqSpineF ts' z -seqSpineF (Cons _ ts') z = seqSpineF ts' z - --- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. -keysQueue :: Prio.MinPQueue k a -> MinQueue k -keysQueue Prio.Empty = Empty -keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (keysF (const Zero) ts) - -keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k -keysF f ts0 = case ts0 of - Prio.Nil -> Nil - Prio.Skip ts' -> Skip (keysF f' ts') - Prio.Cons (Prio.BinomTree k _ ts) ts' - -> Cons (BinomTree k (f ts)) (keysF f' ts') - where f' (Prio.Succ (Prio.BinomTree k _ ts) tss) = Succ (BinomTree k (f ts)) (f tss) - -class NFRank rk where - rnfRk :: NFData a => rk a -> () - -instance NFRank Zero where - rnfRk _ = () - -instance NFRank rk => NFRank (Succ rk) where - rnfRk (Succ t ts) = t `deepseq` rnfRk ts - -instance (NFData a, NFRank rk) => NFData (BinomTree rk a) where - rnf (BinomTree x ts) = x `deepseq` rnfRk ts - -instance (NFData a, NFRank rk) => NFData (BinomForest rk a) where - rnf Nil = () - rnf (Skip ts) = rnf ts - rnf (Cons t ts) = t `deepseq` rnf ts - -instance NFData a => NFData (MinQueue a) where - rnf Empty = () - rnf (MinQueue _ x ts) = x `deepseq` rnf ts diff --git a/Data/PQueue/Max.hs b/Data/PQueue/Max.hs deleted file mode 100644 --- a/Data/PQueue/Max.hs +++ /dev/null @@ -1,349 +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, - 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) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - -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 - -#if MIN_VERSION_base(4,9,0) -instance Ord a => Semigroup (MaxQueue a) where - (<>) = union -#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) - --- | /O(log (min(n1,n2)))/. Take the union of two priority queues. -union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a -MaxQ q1 `union` MaxQ q2 = MaxQ (q1 `Min.union` q2) - --- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. -unions :: Ord a => [MaxQueue a] -> MaxQueue a -unions qs = MaxQ (Min.unions [q | MaxQ q <- qs]) - --- | /O(k log n)/. Returns the @(k+1)@th largest element of the queue. -(!!) :: Ord a => MaxQueue a -> Int -> a -MaxQ q !! n = unDown ((Min.!!) q n) - -{-# INLINE take #-} --- | /O(k log n)/. Returns the list of the @k@ largest elements of the queue, in descending order, or --- all elements of the queue, if @k >= n@. -take :: Ord a => Int -> MaxQueue a -> [a] -take k (MaxQ q) = [a | Down a <- Min.take k q] - --- | /O(k log n)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. -drop :: Ord a => Int -> MaxQueue a -> MaxQueue a -drop k (MaxQ q) = MaxQ (Min.drop k q) - --- | /O(k log n)/. Equivalent to @(take k queue, drop k queue)@. -splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) -splitAt k (MaxQ q) = (map unDown xs, MaxQ q') where - (xs, q') = Min.splitAt k q - --- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the --- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. -takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] -takeWhile p (MaxQ q) = map unDown (Min.takeWhile (p . unDown) q) - --- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. -dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q) - --- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- satisfy @p@ and second element is the remainder of the queue. --- -span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -span p (MaxQ q) = (map unDown xs, MaxQ q') where - (xs, q') = Min.span (p . unDown) q - --- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- /do not satisfy/ @p@ and second element is the remainder of the queue. -break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -break p = span (not . p) - --- | /O(n)/. Returns a queue of those elements which satisfy the predicate. -filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q) - --- | /O(n)/. Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, --- and the right queue contains those that do not. -partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) -partition p (MaxQ q) = (MaxQ q0, MaxQ q1) - where (q0, q1) = Min.partition (p . unDown) q - --- | /O(n)/. Maps a function over the elements of the queue, and collects the 'Just' values. -mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b -mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\ (Down x) -> Down <$> f x) q) - --- | /O(n)/. Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. -mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) -mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1) - where (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q - --- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue. --- /Does not check the precondition/. -mapU :: (a -> b) -> MaxQueue a -> MaxQueue b -mapU f (MaxQ q) = MaxQ (Min.mapU (\ (Down a) -> Down (f a)) q) - --- | /O(n)/. Unordered right fold on a priority queue. -foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b -foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q - --- | /O(n)/. Unordered left fold on a priority queue. -foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b -foldlU f z (MaxQ q) = Min.foldlU (foldl f) z q - -{-# INLINE elemsU #-} --- | Equivalent to 'toListU'. -elemsU :: MaxQueue a -> [a] -elemsU = toListU - -{-# INLINE toListU #-} --- | /O(n)/. Returns a list of the elements of the priority queue, in no particular order. -toListU :: MaxQueue a -> [a] -toListU (MaxQ q) = map unDown (Min.toListU q) - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. --- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. -foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b -foldrAsc = foldlDesc . flip - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. --- @'foldlAsc' f z q == 'foldrDesc' (flip f) z q@. -foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlAsc = foldrDesc . flip - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. -foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b -foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. -foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q - -{-# INLINE toAscList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. -toAscList :: Ord a => MaxQueue a -> [a] -toAscList q = build (\ c nil -> foldrAsc c nil q) --- I can see no particular reason this does not simply forward to Min.toDescList. (lsp, 2016) - -{-# INLINE toDescList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in descending order. -toDescList :: Ord a => MaxQueue a -> [a] -toDescList q = build (\ c nil -> foldrDesc c nil q) --- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016) - -{-# INLINE toList #-} --- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'. --- --- If the order of the elements is irrelevant, consider using 'toListU'. -toList :: Ord a => MaxQueue a -> [a] -toList (MaxQ q) = map unDown (Min.toList q) - -{-# INLINE fromAscList #-} --- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. -fromAscList :: [a] -> MaxQueue a -fromAscList = MaxQ . Min.fromDescList . map Down - -{-# INLINE fromDescList #-} --- | /O(n)/. Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. -fromDescList :: [a] -> MaxQueue a -fromDescList = MaxQ . Min.fromAscList . map Down - -{-# INLINE fromList #-} --- | /O(n log n)/. Constructs a priority queue from an unordered list. -fromList :: Ord a => [a] -> MaxQueue a -fromList = foldr insert empty - --- | /O(n)/. Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. -keysQueue :: Prio.MaxPQueue k a -> MaxQueue k -keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q) - --- | /O(log n)/. Forces the spine of the heap. -seqSpine :: MaxQueue a -> b -> b -seqSpine (MaxQ q) = Min.seqSpine q diff --git a/Data/PQueue/Min.hs b/Data/PQueue/Min.hs deleted file mode 100644 --- a/Data/PQueue/Min.hs +++ /dev/null @@ -1,305 +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, - 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) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - -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 - -#if MIN_VERSION_base(4,9,0) -instance Ord a => Semigroup (MinQueue a) where - (<>) = union -#endif - -instance Ord a => Monoid (MinQueue a) where - mempty = empty - mappend = union - mconcat = unions - --- | /O(1)/. Returns the minimum element. Throws an error on an empty queue. -findMin :: MinQueue a -> a -findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin - --- | /O(log n)/. Deletes the minimum element. If the queue is empty, does nothing. -deleteMin :: Ord a => MinQueue a -> MinQueue a -deleteMin q = case minView q of - Nothing -> empty - Just (_, q') -> q' - --- | /O(log n)/. Extracts the minimum element. Throws an error on an empty queue. -deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) -deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView - --- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. -unions :: Ord a => [MinQueue a] -> MinQueue a -unions = foldl union empty - --- | /O(k log n)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest --- element in the queue. Equivalent to @toAscList queue !! k@. -(!!) :: Ord a => MinQueue a -> Int -> a -q !! n | n >= size q - = error "Data.PQueue.Min.!!: index too large" -q !! n = (List.!!) (toAscList q) n - -{-# INLINE takeWhile #-} --- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the --- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. -takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] -takeWhile p = foldWhileFB p . toAscList - -{-# INLINE foldWhileFB #-} --- | Equivalent to Data.List.takeWhile, but is a better producer. -foldWhileFB :: (a -> Bool) -> [a] -> [a] -foldWhileFB p xs0 = build (\ c nil -> let - consWhile x xs - | p x = x `c` xs - | otherwise = nil - in foldr consWhile nil xs0) - --- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. -dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a -dropWhile p = drop' where - drop' q = case minView q of - Just (x, q') | p x -> drop' q' - _ -> q - --- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- satisfy @p@ and second element is the remainder of the queue. -span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) -span p queue = case minView queue of - Just (x, q') - | p x -> let (ys, q'') = span p q' in (x:ys, q'') - _ -> ([], queue) - --- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where --- first element is longest prefix (possibly empty) of @queue@ of elements that --- /do not satisfy/ @p@ and second element is the remainder of the queue. -break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) -break p = span (not . p) - -{-# INLINE take #-} --- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, --- or all elements of @queue@ itself if @k >= 'size' queue@. -take :: Ord a => Int -> MinQueue a -> [a] -take n = List.take n . toAscList - --- | /O(k log n)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, --- or an empty queue if @k >= size 'queue'@. -drop :: Ord a => Int -> MinQueue a -> MinQueue a -drop n queue = n `seq` case minView queue of - Just (_, queue') - | n > 0 -> drop (n-1) queue' - _ -> queue - --- | /O(k log n)/. Equivalent to @('take' k queue, 'drop' k queue)@. -splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) -splitAt n queue = n `seq` case minView queue of - Just (x, queue') - | n > 0 -> let (xs, queue'') = splitAt (n-1) queue' in (x:xs, queue'') - _ -> ([], queue) - --- | /O(n)/. Returns the queue with all elements not satisfying @p@ removed. -filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a -filter p = mapMaybe (\ x -> if p x then Just x else Nothing) - --- | /O(n)/. Returns a pair where the first queue contains all elements satisfying @p@, and the second queue --- contains all elements not satisfying @p@. -partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) -partition p = mapEither (\ x -> if p x then Left x else Right x) - --- | /O(n)/. Creates a new priority queue containing the images of the elements of this queue. --- Equivalent to @'fromList' . 'Data.List.map' f . toList@. -map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b -map f = foldrU (insert . f) empty - -{-# INLINE toAscList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. -toAscList :: Ord a => MinQueue a -> [a] -toAscList queue = build (\ c nil -> foldrAsc c nil queue) - -{-# INLINE toDescList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in descending order. -toDescList :: Ord a => MinQueue a -> [a] -toDescList queue = build (\ c nil -> foldrDesc c nil queue) - -{-# INLINE toList #-} --- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. --- --- If the order of the elements is irrelevant, consider using 'toListU'. -toList :: Ord a => MinQueue a -> [a] -toList = toAscList - -{-# RULES - "toAscList" forall q . toAscList q = build (\ c nil -> foldrAsc c nil q); - -- inlining doesn't seem to be working out =/ - "toDescList" forall q . toDescList q = build (\ c nil -> foldrDesc c nil q); - #-} - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. --- @foldrDesc f z q == foldlAsc (flip f) z q@. -foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b -foldrDesc = foldlAsc . flip - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. --- @foldlDesc f z q == foldrAsc (flip f) z q@. -foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b -foldlDesc = foldrAsc . flip - -{-# INLINE fromList #-} --- | /O(n)/. Constructs a priority queue from an unordered list. -fromList :: Ord a => [a] -> MinQueue a -fromList = foldr insert empty - -{-# RULES - "fromList" fromList = foldr insert empty; - "fromAscList" fromAscList = foldr insertMinQ empty; - #-} - -{-# INLINE fromAscList #-} --- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. -fromAscList :: [a] -> MinQueue a -fromAscList = foldr insertMinQ empty - --- | /O(n)/. Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. -fromDescList :: [a] -> MinQueue a -fromDescList = foldl' (flip insertMinQ) empty - --- | Maps a function over the elements of the queue, ignoring order. This function is only safe if the function is monotonic. --- This function /does not/ check the precondition. -mapU :: (a -> b) -> MinQueue a -> MinQueue b -mapU = mapMonotonic - -{-# INLINE elemsU #-} --- | Equivalent to 'toListU'. -elemsU :: MinQueue a -> [a] -elemsU = toListU - --- | /O(n)/. Returns the elements of the queue, in no particular order. -toListU :: MinQueue a -> [a] -toListU q = build (\ c n -> foldrU c n q) - -{-# RULES - "foldr/toListU" forall f z q . foldr f z (toListU q) = foldrU f z q; - "foldl/toListU" forall f z q . foldl f z (toListU q) = foldlU f z q; - #-} diff --git a/Data/PQueue/Prio/Internals.hs b/Data/PQueue/Prio/Internals.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Internals.hs +++ /dev/null @@ -1,493 +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 ((<>)) - -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 - -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' (<=) - --- | /O(n)/ (an earlier implementation had /O(1)/ but was buggy). --- Insert an element with the specified key into the priority queue, --- putting it behind elements whose key compares equal to the --- inserted one. -insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a -insertBehind k v q = - let (smaller, larger) = spanKey (<= k) q - in foldr (uncurry insert) (insert k v larger) smaller - -spanKey :: Ord k => (k -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -spanKey p q = case minViewWithKey q of - Just (t@(k, _), q') | p k -> - let (kas, q'') = spanKey p q' in (t : kas, q'') - _ -> ([], q) - --- | Internal helper method, using a specific comparator function. -insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a -insert' _ k a Empty = singleton k a -insert' le k a (MinPQ n k' a' ts) - | k `le` k' = MinPQ (n+1) k a (incr le (tip k' a') ts) - | otherwise = MinPQ (n+1) k' a' (incr le (tip k a ) ts) - --- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union --- of the two specified queues. -union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a -union = union' (<=) - --- | Takes the union of the two specified queues, using the given comparison function. -union' :: CompF k -> MinPQueue k a -> MinPQueue k a -> MinPQueue k a -union' le (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2) - | k1 `le` k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2) - | otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1) - where insMerge k a = carryForest le (tip k a) ts1 ts2 -union' _ Empty q2 = q2 -union' _ q1 Empty = q1 - --- | /O(1)/. The minimal (key, element) in the queue, if the queue is nonempty. -getMin :: MinPQueue k a -> Maybe (k, a) -getMin (MinPQ _ k a _) = Just (k, a) -getMin _ = Nothing - --- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. -adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a -adjustMinWithKey _ Empty = Empty -adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. --- If the queue is empty, does nothing. -updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> MinPQueue k a -> MinPQueue k a -updateMinWithKey _ Empty = Empty -updateMinWithKey f (MinPQ n k a ts) = case f k a of - Nothing -> extractHeap (<=) n ts - Just a' -> MinPQ n k a' ts - --- | /O(log n)/. Retrieves the minimal (key, value) pair of the map, and the map stripped of that --- element, or 'Nothing' if passed an empty map. -minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a) -minViewWithKey Empty = Nothing -minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap (<=) n ts) - --- | /O(n)/. Map a function over all values in the queue. -mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b -mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f) - --- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly --- monotonic. /The precondition is not checked./ This function has better performance than --- 'mapKeys'. -mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a -mapKeysMonotonic _ Empty = Empty -mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts) - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b -mapMaybeWithKey _ Empty = Empty -mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF (<=) f (const Empty) ts) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) -mapEitherWithKey _ Empty = (Empty, Empty) -mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a) - (mapEitherF (<=) f (const (Empty, Empty)) ts) - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. --- --- If you do not care about the traversal order, consider using 'foldrWithKeyU'. -foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MinPQueue k a -> b -foldrWithKey _ z Empty = z -foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where - foldF ts = case extract ts of - Yes (Extract k a _ ts') -> f k a (foldF ts') - _ -> z - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. --- --- If you do not care about the traversal order, consider using 'foldlWithKeyU'. -foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MinPQueue k a -> b -foldlWithKey _ z Empty = z -foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where - foldF z ts = case extract ts of - Yes (Extract k a _ ts') -> foldF (f z k a) ts' - _ -> z - --- | Equivalent to 'insert', save the assumption that this key is @<=@ --- every other key in the map. /The precondition is not checked./ -insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a -insertMin k a Empty = MinPQ 1 k a Nil -insertMin k a (MinPQ n k' a' ts) = MinPQ (n+1) k a (incrMin (tip k' a') ts) - --- | /O(1)/. Returns a binomial tree of rank zero containing this --- key and value. -tip :: k -> a -> BinomTree Zero k a -tip k a = BinomTree k a Zero - --- | /O(1)/. Takes the union of two binomial trees of the same rank. -meld :: CompF k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a -meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) - | k1 `le` k2 = BinomTree k1 v1 (Succ t2 ts1) - | otherwise = BinomTree k2 v2 (Succ t1 ts2) - --- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. -mergeForest :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a -mergeForest le f1 f2 = case (f1, f2) of - (Skip ts1, Skip ts2) -> Skip (mergeForest le ts1 ts2) - (Skip ts1, Cons t2 ts2) -> Cons t2 (mergeForest le ts1 ts2) - (Cons t1 ts1, Skip ts2) -> Cons t1 (mergeForest le ts1 ts2) - (Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest le (meld le t1 t2) ts1 ts2) - (Nil, _) -> f2 - (_, Nil) -> f1 - --- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. --- Analogous to binary addition when a digit has been carried. -carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a -carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of - (Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2) - (Cons t1 ts1, Skip ts2) -> Skip (carryMeld t0 t1 ts1 ts2) - (Skip ts1, Cons t2 ts2) -> Skip (carryMeld t0 t2 ts1 ts2) - (Skip ts1, Skip ts2) -> Cons t0 (mergeForest le ts1 ts2) - (Nil, _) -> incr le t0 f2 - (_, Nil) -> incr le t0 f1 - where carryMeld = carryForest le .: meld le - --- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. -incr :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -incr le t ts = t `seq` case ts of - Nil -> Cons t Nil - Skip ts' -> Cons t ts' - Cons t' ts' -> Skip (incr le (meld le t t') ts') - --- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree --- is less than all other roots. Analogous to binary incrementation. Equivalent to --- @'incr' (\ _ _ -> True)@. -incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -incrMin t@(BinomTree k a ts) tss = case tss of - Nil -> Cons t Nil - Skip tss' -> Cons t tss' - Cons t' tss' -> Skip (incrMin (BinomTree k a (Succ t' ts)) tss') - -extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a -extractHeap le n ts = n `seq` case extractForest le ts of - No -> Empty - Yes (Extract k a _ ts') -> MinPQ (n-1) k a ts' - --- | A specialized type intended to organize the return of extract-min queries --- from a binomial forest. We walk all the way through the forest, and then --- walk backwards. @Extract rk a@ is the result type of an extract-min --- operation that has walked as far backwards of rank @rk@ -- that is, it --- has visited every root of rank @>= rk@. --- --- The interpretation of @Extract minKey minVal children forest@ is --- --- * @minKey@ is the key of the minimum root visited so far. It may have --- any rank @>= rk@. We will denote the root corresponding to --- @minKey@ as @minRoot@. --- --- * @minVal@ is the value corresponding to @minKey@. --- --- * @children@ is those children of @minRoot@ which have not yet been --- merged with the rest of the forest. Specifically, these are --- the children with rank @< rk@. --- --- * @forest@ is an accumulating parameter that maintains the partial --- reconstruction of the binomial forest without @minRoot@. It is --- the union of all old roots with rank @>= rk@ (except @minRoot@), --- with the set of all children of @minRoot@ with rank @>= rk@. --- Note that @forest@ is lazy, so if we discover a smaller key --- than @minKey@ later, we haven't wasted significant work. - -data Extract rk k a = Extract k a (rk k a) (BinomForest rk k a) -data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) - -incrExtract :: CompF k -> Maybe (BinomTree rk k a) -> Extract (Succ rk) k a -> Extract rk k a -incrExtract _ Nothing (Extract k a (Succ t ts) tss) - = Extract k a ts (Cons t tss) -incrExtract le (Just t) (Extract k a (Succ t' ts) tss) - = Extract k a ts (Skip (incr le (meld le t t') tss)) - --- | Walks backward from the biggest key in the forest, as far as rank @rk@. --- Returns its progress. Each successive application of @extractBin@ takes --- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. -extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a -extractForest _ Nil = No -extractForest le (Skip tss) = case extractForest le tss of - No -> No - Yes ex -> Yes (incrExtract le Nothing ex) -extractForest le (Cons t@(BinomTree k a0 ts) tss) = Yes $ case extractForest le tss of - Yes ex@(Extract k' _ _ _) - | k' incrExtract le (Just t) ex - _ -> Extract k a0 ts (Skip tss) - where - a BinomForest rk k a -> MExtract rk k a -extract = extractForest (<=) - --- | Utility function for mapping over a forest. -mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b -mapForest f fCh ts0 = case ts0 of - Nil -> Nil - Skip ts' -> Skip (mapForest f fCh' ts') - Cons (BinomTree k a ts) tss - -> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss) - where fCh' (Succ (BinomTree k a ts) tss) - = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss) - --- | Utility function for mapping a 'Maybe' function over a forest. -mapMaybeF :: CompF k -> (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> - BinomForest rk k a -> MinPQueue k b -mapMaybeF le f fCh ts0 = case ts0 of - Nil -> Empty - Skip ts' -> mapMaybeF le f fCh' ts' - Cons (BinomTree k a ts) ts' - -> insF k a (fCh ts) (mapMaybeF le f fCh' ts') - where insF k a = maybe id (insert' le k) (f k a) .: union' le - fCh' (Succ (BinomTree k a ts) tss) = - insF k a (fCh ts) (fCh tss) - --- | Utility function for mapping an 'Either' function over a forest. -mapEitherF :: CompF k -> (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) -> - BinomForest rk k a -> (MinPQueue k b, MinPQueue k c) -mapEitherF le f0 fCh ts0 = case ts0 of - Nil -> (Empty, Empty) - Skip ts' -> mapEitherF le f0 fCh' ts' - Cons (BinomTree k a ts) ts' - -> insF k a (fCh ts) (mapEitherF le f0 fCh' ts') - where - insF k a = either (first' . insert' le k) (second' . insert' le k) (f0 k a) .: - (union' le `both` union' le) - fCh' (Succ (BinomTree k a ts) tss) = - insF k a (fCh ts) (fCh tss) - both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b -foldrWithKeyU _ z Empty = z -foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z) - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b -foldlWithKeyU _ z Empty = z -foldlWithKeyU f z0 (MinPQ _ k0 a0 ts) = foldlWithKeyF_ (\ k a z -> f z k a) (const id) ts (f z0 k0 a0) - -traverseWithKeyU :: Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) -traverseWithKeyU _ Empty = pure Empty -traverseWithKeyU f (MinPQ n k a ts) = MinPQ n k <$> f k a <*> traverseForest f (const (pure Zero)) ts - -{-# SPECIALIZE traverseForest :: (k -> a -> Identity b) -> (rk k a -> Identity (rk k b)) -> BinomForest rk k a -> - Identity (BinomForest rk k b) #-} -traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b) -traverseForest f fCh ts0 = case ts0 of - Nil -> pure Nil - Skip ts' -> Skip <$> traverseForest f fCh' ts' - Cons (BinomTree k a ts) tss - -> Cons <$> (BinomTree k <$> f k a <*> fCh ts) <*> traverseForest f fCh' tss - where - fCh' (Succ (BinomTree k a ts) tss) - = Succ <$> (BinomTree k <$> f k a <*> fCh ts) <*> fCh tss - --- | Unordered right fold on a binomial forest. -foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b -foldrWithKeyF_ f fCh ts0 z0 = case ts0 of - Nil -> z0 - Skip ts' -> foldrWithKeyF_ f fCh' ts' z0 - Cons (BinomTree k a ts) ts' - -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0)) - where - fCh' (Succ (BinomTree k a ts) tss) z = - f k a (fCh ts (fCh tss z)) - --- | Unordered left fold on a binomial forest. -foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b -foldlWithKeyF_ f fCh ts0 = case ts0 of - Nil -> id - Skip ts' -> foldlWithKeyF_ f fCh' ts' - Cons (BinomTree k a ts) ts' - -> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a - where - fCh' (Succ (BinomTree k a ts) tss) = - fCh tss . fCh ts . f k a - --- | Maps a monotonic function over the keys in a binomial forest. -mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a -mapKeysMonoF f fCh ts0 = case ts0 of - Nil -> Nil - Skip ts' -> Skip (mapKeysMonoF f fCh' ts') - Cons (BinomTree k a ts) ts' - -> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts') - where - fCh' (Succ (BinomTree k a ts) tss) = - Succ (BinomTree (f k) a (fCh ts)) (fCh tss) - --- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. -seqSpine :: MinPQueue k a -> b -> b -seqSpine Empty z0 = z0 -seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where - seqSpineF :: BinomForest rk k a -> b -> b - seqSpineF ts z = case ts of - Nil -> z - Skip ts' -> seqSpineF ts' z - Cons _ ts' -> seqSpineF ts' z - -class NFRank rk where - rnfRk :: (NFData k, NFData a) => rk k a -> () - -instance NFRank Zero where - rnfRk _ = () - -instance NFRank rk => NFRank (Succ rk) where - rnfRk (Succ t ts) = t `deepseq` rnfRk ts - -instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where - rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts - -instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where - rnf Nil = () - rnf (Skip tss) = rnf tss - rnf (Cons t tss) = t `deepseq` rnf tss - -instance (NFData k, NFData a) => NFData (MinPQueue k a) where - rnf Empty = () - rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts diff --git a/Data/PQueue/Prio/Max.hs b/Data/PQueue/Prio/Max.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Max.hs +++ /dev/null @@ -1,480 +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 - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - -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) - -#if MIN_VERSION_base(4,9,0) -instance Ord k => Semigroup (MaxPQueue k a) where - (<>) = union -#endif - -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) - --- | /O(n)/ (an earlier implementation had /O(1)/ but was buggy). --- Insert an element with the specified key into the priority queue, --- putting it behind elements whose key compares equal to the --- inserted one. -insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) - --- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union --- of the two specified queues. -union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a -MaxPQ q1 `union` MaxPQ q2 = MaxPQ (q1 `Q.union` q2) - --- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). -unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a -unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs]) - --- | /O(1)/. Checks if this priority queue is empty. -null :: MaxPQueue k a -> Bool -null (MaxPQ q) = Q.null q - --- | /O(1)/. Returns the size of this priority queue. -size :: MaxPQueue k a -> Int -size (MaxPQ q) = Q.size q - --- | /O(1)/. The maximal (key, element) in the queue. Calls 'error' if empty. -findMax :: MaxPQueue k a -> (k, a) -findMax = fromMaybe (error "Error: findMax called on an empty queue") . getMax - --- | /O(1)/. The maximal (key, element) in the queue, if the queue is nonempty. -getMax :: MaxPQueue k a -> Maybe (k, a) -getMax (MaxPQ q) = do - (Down k, a) <- Q.getMin q - return (k, a) - --- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. -deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a -deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q) - --- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. -deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) -deleteFindMax = fromMaybe (error "Error: deleteFindMax called on an empty queue") . maxViewWithKey - --- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. -adjustMax :: (a -> a) -> MaxPQueue k a -> MaxPQueue k a -adjustMax = adjustMaxWithKey . const - --- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. -adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a -adjustMaxWithKey f (MaxPQ q) = MaxPQ (Q.adjustMinWithKey (f . unDown) q) - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. --- If the queue is empty, does nothing. -updateMax :: Ord k => (a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a -updateMax = updateMaxWithKey . const - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. --- If the queue is empty, does nothing. -updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a -updateMaxWithKey f (MaxPQ q) = MaxPQ (Q.updateMinWithKey (f . unDown) q) - --- | /O(log n)/. Retrieves the value associated with the maximum key of the queue, and the queue --- stripped of that element, or 'Nothing' if passed an empty queue. -maxView :: Ord k => MaxPQueue k a -> Maybe (a, MaxPQueue k a) -maxView q = do - ((_, a), q') <- maxViewWithKey q - return (a, q') - --- | /O(log n)/. Retrieves the maximal (key, value) pair of the map, and the map stripped of that --- element, or 'Nothing' if passed an empty map. -maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a) -maxViewWithKey (MaxPQ q) = do - ((Down k, a), q') <- Q.minViewWithKey q - return ((k, a), MaxPQ q') - --- | /O(n)/. Map a function over all values in the queue. -map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b -map = mapWithKey . const - --- | /O(n)/. Map a function over all values in the queue. -mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b -mapWithKey f (MaxPQ q) = MaxPQ (Q.mapWithKey (f . unDown) q) - --- | /O(n)/. Map a function over all values in the queue. -mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q) - --- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly --- monotonic. /The precondition is not checked./ This function has better performance than --- 'mapKeys'. -mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q) - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. --- --- If you do not care about the traversal order, consider using 'foldrWithKeyU'. -foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. --- --- If you do not care about the traversal order, consider using 'foldlWithKeyU'. -foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\ z -> f z . unDown) z0 q - --- | /O(n log n)/. Traverses the elements of the queue in descending order by key. --- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) --- --- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. -traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (f . unDown) q - --- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. --- (@'take' k q == 'List.take' k ('toDescList' q)@) -take :: Ord k => Int -> MaxPQueue k a -> [(k, a)] -take k (MaxPQ q) = fmap (first' unDown) (Q.take k q) - --- | /O(k log n)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. -drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a -drop k (MaxPQ q) = MaxPQ (Q.drop k q) - --- | /O(k log n)/. Equivalent to @('take' k q, 'drop' k q)@. -splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -splitAt k (MaxPQ q) = case Q.splitAt k q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) -takeWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhile = takeWhileWithKey . const - --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) -takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q) - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -dropWhile = dropWhileWithKey . const - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -dropWhileWithKey p (MaxPQ q) = MaxPQ (Q.dropWhileWithKey (p . unDown) q) - --- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. -span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -span = spanWithKey . const - --- | Equivalent to @'span' ('not' . p)@. -break :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -break = breakWithKey . const - --- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. -spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -spanWithKey p (MaxPQ q) = case Q.spanWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. -breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | /O(n)/. Filter all values that satisfy the predicate. -filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -filter = filterWithKey . const - --- | /O(n)/. Filter all values that satisfy the predicate. -filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -filterWithKey p (MaxPQ q) = MaxPQ (Q.filterWithKey (p . unDown) q) - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partition :: Ord k => (a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) -partition = partitionWithKey . const - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) -partitionWithKey p (MaxPQ q) = case Q.partitionWithKey (p . unDown) q of - (q1, q0) -> (MaxPQ q1, MaxPQ q0) - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b -mapMaybe = mapMaybeWithKey . const - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b -mapMaybeWithKey f (MaxPQ q) = MaxPQ (Q.mapMaybeWithKey (f . unDown) q) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) -mapEither = mapEitherWithKey . const - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) -mapEitherWithKey f (MaxPQ q) = case Q.mapEitherWithKey (f . unDown) q of - (qL, qR) -> (MaxPQ qL, MaxPQ qR) - --- | /O(n)/. Build a priority queue from the list of (key, value) pairs. -fromList :: Ord k => [(k, a)] -> MaxPQueue k a -fromList = MaxPQ . Q.fromList . fmap (first' Down) - --- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ -fromAscList :: [(k, a)] -> MaxPQueue k a -fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down) - --- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ -fromDescList :: [(k, a)] -> MaxPQueue k a -fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down) - --- | /O(n log n)/. Return all keys of the queue in descending order. -keys :: Ord k => MaxPQueue k a -> [k] -keys = fmap fst . toDescList - --- | /O(n log n)/. Return all elements of the queue in descending order by key. -elems :: Ord k => MaxPQueue k a -> [a] -elems = fmap snd . toDescList - --- | /O(n log n)/. Equivalent to 'toDescList'. -assocs :: Ord k => MaxPQueue k a -> [(k, a)] -assocs = toDescList - --- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. -toAscList :: Ord k => MaxPQueue k a -> [(k, a)] -toAscList (MaxPQ q) = fmap (first' unDown) (Q.toDescList q) - --- | /O(n log n)/. Return all (key, value) pairs in descending order by key. -toDescList :: Ord k => MaxPQueue k a -> [(k, a)] -toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q) - --- | /O(n log n)/. Equivalent to 'toDescList'. --- --- If the traversal order is irrelevant, consider using 'toListU'. -toList :: Ord k => MaxPQueue k a -> [(k, a)] -toList = toDescList - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrU :: (a -> b -> b) -> b -> MaxPQueue k a -> b -foldrU = foldrWithKeyU . const - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (f . unDown) z q - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlU :: (b -> a -> b) -> b -> MaxPQueue k a -> b -foldlU f = foldlWithKeyU (const . f) - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (\ z -> f z . unDown) z0 q - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseU :: (Applicative f) => (a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseU = traverseWithKeyU . const - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseWithKeyU :: (Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (f . unDown) q - --- | /O(n)/. Return all keys of the queue in no particular order. -keysU :: MaxPQueue k a -> [k] -keysU = fmap fst . toListU - --- | /O(n)/. Return all elements of the queue in no particular order. -elemsU :: MaxPQueue k a -> [a] -elemsU = fmap snd . toListU - --- | /O(n)/. Equivalent to 'toListU'. -assocsU :: MaxPQueue k a -> [(k, a)] -assocsU = toListU - --- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. -toListU :: MaxPQueue k a -> [(k, a)] -toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q) - --- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. -seqSpine :: MaxPQueue k a -> b -> b -seqSpine (MaxPQ q) = Q.seqSpine q diff --git a/Data/PQueue/Prio/Max/Internals.hs b/Data/PQueue/Prio/Max/Internals.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Max/Internals.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Data.PQueue.Prio.Max.Internals where - -import Control.DeepSeq (NFData(rnf)) - -import Data.Traversable (Traversable(traverse)) -import Data.Foldable (Foldable(foldr, foldl)) -import Data.Functor ((<$>)) -# if __GLASGOW_HASKELL__ -import Data.Data (Data, Typeable) -# endif - -import Prelude hiding (foldr, foldl) - -import Data.PQueue.Prio.Internals (MinPQueue) - -newtype Down a = Down {unDown :: a} -# if __GLASGOW_HASKELL__ - deriving (Eq, Data, Typeable) -# else - deriving (Eq) -# endif - --- | A priority queue where values of type @a@ are annotated with keys of type @k@. --- The queue supports extracting the element with maximum key. -newtype MaxPQueue k a = MaxPQ (MinPQueue (Down k) a) -# if __GLASGOW_HASKELL__ - deriving (Eq, Ord, Data, Typeable) -# else - deriving (Eq, Ord) -# endif - -instance (NFData k, NFData a) => NFData (MaxPQueue k a) where - rnf (MaxPQ q) = rnf q - -instance NFData a => NFData (Down a) where - rnf (Down a) = rnf a - -instance Ord a => Ord (Down a) where - Down a `compare` Down b = b `compare` a - Down a <= Down b = b <= a - -instance Functor Down where - fmap f (Down a) = Down (f a) - -instance Foldable Down where - foldr f z (Down a) = a `f` z - foldl f z (Down a) = z `f` a - -instance Traversable Down where - traverse f (Down a) = Down <$> f a diff --git a/Data/PQueue/Prio/Min.hs b/Data/PQueue/Prio/Min.hs deleted file mode 100644 --- a/Data/PQueue/Prio/Min.hs +++ /dev/null @@ -1,420 +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) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - -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 .: - -#if MIN_VERSION_base(4,9,0) -instance Ord k => Semigroup (MinPQueue k a) where - (<>) = union -#endif - -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 (t@(k, a), q') - | p k a -> let (kas, q'') = spanWithKey p q' in (t:kas, q'') - _ -> ([], q) -breakWithKey p = spanWithKey (not .: p) - --- | /O(n)/. Build a priority queue from the list of (key, value) pairs. -fromList :: Ord k => [(k, a)] -> MinPQueue k a -fromList = foldr (uncurry' insert) empty - --- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ -fromAscList :: [(k, a)] -> MinPQueue k a -fromAscList = foldr (uncurry' insertMin) empty - --- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ -fromDescList :: [(k, a)] -> MinPQueue k a -fromDescList = List.foldl' (\ q (k, a) -> insertMin k a q) empty - -{-# RULES - "fromList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . - fromList (build g) = g (uncurry' insert) empty; - "fromAscList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . - fromAscList (build g) = g (uncurry' insertMin) empty; - #-} - -{-# INLINE keys #-} --- | /O(n log n)/. Return all keys of the queue in ascending order. -keys :: Ord k => MinPQueue k a -> [k] -keys = List.map fst . toAscList - -{-# INLINE elems #-} --- | /O(n log n)/. Return all elements of the queue in ascending order by key. -elems :: Ord k => MinPQueue k a -> [a] -elems = List.map snd . toAscList - --- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. -toAscList :: Ord k => MinPQueue k a -> [(k, a)] -toAscList = foldrWithKey (curry (:)) [] - --- | /O(n log n)/. Return all (key, value) pairs in descending order by key. -toDescList :: Ord k => MinPQueue k a -> [(k, a)] -toDescList = foldlWithKey (\ z k a -> (k, a) : z) [] - -{-# RULES - "toAscList" toAscList = \ q -> build (\ c n -> foldrWithKey (curry c) n q); - "toDescList" toDescList = \ q -> build (\ c n -> foldlWithKey (\ z k a -> (k, a) `c` z) n q); - "toListU" toListU = \ q -> build (\ c n -> foldrWithKeyU (curry c) n q); - #-} - -{-# INLINE toList #-} --- | /O(n log n)/. Equivalent to 'toAscList'. --- --- If the traversal order is irrelevant, consider using 'toListU'. -toList :: Ord k => MinPQueue k a -> [(k, a)] -toList = toAscList - -{-# INLINE assocs #-} --- | /O(n log n)/. Equivalent to 'toAscList'. -assocs :: Ord k => MinPQueue k a -> [(k, a)] -assocs = toAscList - -{-# INLINE keysU #-} --- | /O(n)/. Return all keys of the queue in no particular order. -keysU :: MinPQueue k a -> [k] -keysU = List.map fst . toListU - -{-# INLINE elemsU #-} --- | /O(n)/. Return all elements of the queue in no particular order. -elemsU :: MinPQueue k a -> [a] -elemsU = List.map snd . toListU - -{-# INLINE assocsU #-} --- | /O(n)/. Equivalent to 'toListU'. -assocsU :: MinPQueue k a -> [(k, a)] -assocsU = toListU - --- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. -toListU :: MinPQueue k a -> [(k, a)] -toListU = foldrWithKeyU (curry (:)) [] - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrU :: (a -> b -> b) -> b -> MinPQueue k a -> b -foldrU = foldrWithKeyU . const - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlU :: (b -> a -> b) -> b -> MinPQueue k a -> b -foldlU f = foldlWithKeyU (const . f) - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseU :: (Applicative f) => (a -> f b) -> MinPQueue k a -> f (MinPQueue k b) -traverseU = traverseWithKeyU . const - -instance Functor (MinPQueue k) where - fmap = map - -instance Ord k => Foldable (MinPQueue k) where - foldr = foldrWithKey . const - foldl f = foldlWithKey (const . f) - -instance Ord k => Traversable (MinPQueue k) where - traverse = traverseWithKey . const diff --git a/PQueueTests.hs b/PQueueTests.hs deleted file mode 100644 --- a/PQueueTests.hs +++ /dev/null @@ -1,144 +0,0 @@ -module Main (main) where - -import qualified Data.PQueue.Prio.Max as PMax () -import qualified Data.PQueue.Prio.Min as PMin () -import qualified Data.PQueue.Max as Max () -import qualified Data.PQueue.Min as Min - -import Test.QuickCheck - -import System.Exit - -import qualified Data.List as List -import Control.Arrow (second) - - -validMinToAscList :: [Int] -> Bool -validMinToAscList xs = Min.toAscList (Min.fromList xs) == List.sort xs - -validMinToDescList :: [Int] -> Bool -validMinToDescList xs = Min.toDescList (Min.fromList xs) == List.sortBy (flip compare) xs - -validMinUnfoldr :: [Int] -> Bool -validMinUnfoldr xs = List.unfoldr Min.minView (Min.fromList xs) == List.sort xs - -validMinToList :: [Int] -> Bool -validMinToList xs = List.sort (Min.toList (Min.fromList xs)) == List.sort xs - -validMinFromAscList :: [Int] -> Bool -validMinFromAscList xs = Min.fromAscList (List.sort xs) == Min.fromList xs - -validMinFromDescList :: [Int] -> Bool -validMinFromDescList xs = Min.fromDescList (List.sortBy (flip compare) xs) == Min.fromList xs - -validMinUnion :: [Int] -> [Int] -> Bool -validMinUnion xs1 xs2 = Min.union (Min.fromList xs1) (Min.fromList xs2) == Min.fromList (xs1 ++ xs2) - -validMinMapMonotonic :: [Int] -> Bool -validMinMapMonotonic xs = Min.mapU (+1) (Min.fromList xs) == Min.fromList (map (+1) xs) - -validMinFilter :: [Int] -> Bool -validMinFilter xs = Min.filter even (Min.fromList xs) == Min.fromList (List.filter even xs) - -validMinPartition :: [Int] -> Bool -validMinPartition xs = Min.partition even (Min.fromList xs) == (let (xs1, xs2) = List.partition even xs in (Min.fromList xs1, Min.fromList xs2)) - -validMinCmp :: [Int] -> [Int] -> Bool -validMinCmp xs1 xs2 = compare (Min.fromList xs1) (Min.fromList xs2) == compare (List.sort xs1) (List.sort xs2) - -validMinCmp2 :: [Int] -> Bool -validMinCmp2 xs = compare (Min.fromList ys) (Min.fromList (take 30 ys)) == compare ys (take 30 ys) - where ys = List.sort xs - -validSpan :: [Int] -> Bool -validSpan xs = (Min.takeWhile even q, Min.dropWhile even q) == Min.span even q - where q = Min.fromList xs - -validSpan2 :: [Int] -> Bool -validSpan2 xs = - second Min.toAscList (Min.span even (Min.fromList xs)) - == - List.span even (List.sort xs) - -validSplit :: Int -> [Int] -> Bool -validSplit n xs = Min.splitAt n q == (Min.take n q, Min.drop n q) - where q = Min.fromList xs - -validSplit2 :: Int -> [Int] -> Bool -validSplit2 n xs = case Min.splitAt n (Min.fromList xs) of - (ys, q') -> (ys, Min.toAscList q') == List.splitAt n (List.sort xs) - -validMapEither :: [Int] -> Bool -validMapEither xs = - Min.mapEither collatz q == - (Min.mapMaybe (either Just (const Nothing) . collatz) q, - Min.mapMaybe (either (const Nothing) Just . collatz) q) - where q = Min.fromList xs - -validMap :: [Int] -> Bool -validMap xs = Min.map f (Min.fromList xs) == Min.fromList (List.map f xs) - where f = either id id . collatz - -collatz :: Int -> Either Int Int -collatz x = - if even x - then Left $ x `quot` 2 - else Right $ 3 * x + 1 - -validSize :: [Int] -> Bool -validSize xs = Min.size q == List.length xs' - where - q = Min.drop 10 (Min.fromList xs) - xs' = List.drop 10 (List.sort xs) - -validNull :: Int -> [Int] -> Bool -validNull n xs = Min.null q == List.null xs' - where - q = Min.drop n (Min.fromList xs) - xs' = List.drop n (List.sort xs) - -validFoldl :: [Int] -> Bool -validFoldl xs = Min.foldlAsc (flip (:)) [] (Min.fromList xs) == List.foldl (flip (:)) [] (List.sort xs) - -validFoldlU :: [Int] -> Bool -validFoldlU xs = Min.foldlU (flip (:)) [] q == List.reverse (Min.foldrU (:) [] q) - where q = Min.fromList xs - -validFoldrU :: [Int] -> Bool -validFoldrU xs = Min.foldrU (+) 0 q == List.sum xs - where q = Min.fromList xs - -main :: IO () -main = do - check validMinToAscList - check validMinToDescList - check validMinUnfoldr - check validMinToList - check validMinFromAscList - check validMinFromDescList - check validMinUnion - check validMinMapMonotonic - check validMinPartition - check validMinCmp - check validMinCmp2 - check validSpan - check validSpan2 - check validSplit - check validSplit2 - check validMinFilter - check validMapEither - check validMap - check validSize - check validNull - check validFoldl - check validFoldlU - check validFoldrU - -isPass :: Result -> Bool -isPass Success{} = True -isPass _ = False - -check :: Testable prop => prop -> IO () -check p = do - r <- quickCheckResult p - if isPass r then return () else exitFailure diff --git a/pqueue.cabal b/pqueue.cabal --- a/pqueue.cabal +++ b/pqueue.cabal @@ -1,5 +1,5 @@ Name: pqueue -Version: 1.4.1.2 +Version: 1.4.1.3 Category: Data Structures Author: Louis Wasserman License: BSD3 @@ -12,7 +12,7 @@ Bug-reports: https://github.com/lspitzner/pqueue/issues Build-type: Simple cabal-version: >= 1.10 -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1 +tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 extra-source-files: { include/Typeable.h CHANGELOG.md @@ -23,10 +23,11 @@ location: git@github.com:lspitzner/pqueue.git Library { + hs-source-dirs: src default-language: Haskell2010 build-depends: - { base >= 4.8 && < 4.13 + { base >= 4.8 && < 4.15 , deepseq >= 1.3 && < 1.5 } exposed-modules: @@ -55,14 +56,16 @@ } Test-Suite test + hs-source-dirs: tests default-language: Haskell2010 Type: exitcode-stdio-1.0 Main-Is: PQueueTests.hs Build-Depends: - { base >= 4.8 && < 4.13 + { base >= 4.8 && < 4.15 , deepseq >= 1.3 && < 1.5 - , QuickCheck >=2.5 && <3 + , QuickCheck >= 2.5 && < 3 + , pqueue } ghc-options: { -Wall @@ -73,14 +76,3 @@ -fno-warn-unused-imports } } - If impl(ghc) - default-extensions: DeriveDataTypeable - 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 diff --git a/src/Control/Applicative/Identity.hs b/src/Control/Applicative/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Control/Applicative/Identity.hs @@ -0,0 +1,14 @@ +module Control.Applicative.Identity where + +import Control.Applicative + +import Prelude + +newtype Identity a = Identity { runIdentity :: a } + +instance Functor Identity where + fmap f (Identity x) = Identity (f x) + +instance Applicative Identity where + pure = Identity + Identity f <*> Identity x = Identity (f x) diff --git a/src/Data/PQueue/Internals.hs b/src/Data/PQueue/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE CPP, StandaloneDeriving #-} + +module Data.PQueue.Internals ( + MinQueue (..), + BinomHeap, + BinomForest(..), + BinomTree(..), + Succ(..), + Zero(..), + LEq, + empty, + null, + size, + getMin, + minView, + singleton, + insert, + 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(log (min(n,m)))/, worst-case /O(log (max (n,m)))/. Take the union of two priority queues. +union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a +union = union' (<=) + +-- | /O(n)/. Map elements and collect the 'Just' results. +mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b +mapMaybe _ Empty = Empty +mapMaybe f (MinQueue _ x ts) = maybe q' (`insert` q') (f x) + where + q' = mapMaybeQueue f (<=) (const Empty) Empty ts + +-- | /O(n)/. Map elements and separate the 'Left' and 'Right' results. +mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) +mapEither _ Empty = (Empty, Empty) +mapEither f (MinQueue _ x ts) = case (mapEitherQueue f (<=) (<=) (const (Empty, Empty)) (Empty, Empty) ts, f x) of + ((qL, qR), Left b) -> (insert b qL, qR) + ((qL, qR), Right c) -> (qL, insert c qR) + +-- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, +-- as in 'fmap'. If it is not, the result is undefined. +mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b +mapMonotonic = mapU + +{-# INLINE foldrAsc #-} +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrAsc _ z Empty = z +foldrAsc f z (MinQueue _ x ts) = x `f` foldrUnfold f z extractHeap ts + +{-# INLINE foldrUnfold #-} +-- | Equivalent to @foldr f z (unfoldr suc s0)@. +foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c +foldrUnfold f z suc s0 = unf s0 where + unf s = case suc s of + Nothing -> z + Just (x, s') -> x `f` unf s' + +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlAsc _ z Empty = z +foldlAsc f z (MinQueue _ x ts) = foldlUnfold f (z `f` x) extractHeap ts + +{-# INLINE foldlUnfold #-} +-- | @foldlUnfold f z suc s0@ is equivalent to @foldl f z (unfoldr suc s0)@. +foldlUnfold :: (c -> a -> c) -> c -> (b -> Maybe (a, b)) -> b -> c +foldlUnfold f z0 suc s0 = unf z0 s0 where + unf z s = case suc s of + Nothing -> z + Just (x, s') -> unf (z `f` x) s' + +insert' :: LEq a -> a -> MinQueue a -> MinQueue a +insert' _ x Empty = singleton x +insert' le x (MinQueue n x' ts) + | x `le` x' = MinQueue (n + 1) x (incr le (tip x') ts) + | otherwise = MinQueue (n + 1) x' (incr le (tip x) ts) + +{-# INLINE union' #-} +union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a +union' _ Empty q = q +union' _ q Empty = q +union' le (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) + | x1 `le` x2 = MinQueue (n1 + n2) x1 (carry le (tip x2) f1 f2) + | otherwise = MinQueue (n1 + n2) x2 (carry le (tip x1) f1 f2) + +-- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. +extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) +extractHeap ts = case extractBin (<=) ts of + Yes (Extract x _ ts') -> Just (x, ts') + _ -> Nothing + +-- | A specialized type intended to organize the return of extract-min queries +-- from a binomial forest. We walk all the way through the forest, and then +-- walk backwards. @Extract rk a@ is the result type of an extract-min +-- operation that has walked as far backwards of rank @rk@ -- that is, it +-- has visited every root of rank @>= rk@. +-- +-- The interpretation of @Extract minKey children forest@ is +-- +-- * @minKey@ is the key of the minimum root visited so far. It may have +-- any rank @>= rk@. We will denote the root corresponding to +-- @minKey@ as @minRoot@. +-- +-- * @children@ is those children of @minRoot@ which have not yet been +-- merged with the rest of the forest. Specifically, these are +-- the children with rank @< rk@. +-- +-- * @forest@ is an accumulating parameter that maintains the partial +-- reconstruction of the binomial forest without @minRoot@. It is +-- the union of all old roots with rank @>= rk@ (except @minRoot@), +-- with the set of all children of @minRoot@ with rank @>= rk@. +-- Note that @forest@ is lazy, so if we discover a smaller key +-- than @minKey@ later, we haven't wasted significant work. +data Extract rk a = Extract a (rk a) (BinomForest rk a) +data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a) + +incrExtract :: Extract (Succ rk) a -> Extract rk a +incrExtract (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Cons kChild ts) + +incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a +incrExtract' le t (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Skip (incr le (t `cat` kChild) ts)) + where + cat = joinBin le + +-- | Walks backward from the biggest key in the forest, as far as rank @rk@. +-- Returns its progress. Each successive application of @extractBin@ takes +-- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. +extractBin :: LEq a -> BinomForest rk a -> MExtract rk a +extractBin _ Nil = No +extractBin le (Skip f) = case extractBin le f of + Yes ex -> Yes (incrExtract ex) + No -> No +extractBin le (Cons t@(BinomTree x ts) f) = Yes $ case extractBin le f of + Yes ex@(Extract minKey _ _) + | minKey `lt` x -> incrExtract' le t ex + _ -> Extract x ts (Skip f) + where a `lt` b = not (b `le` a) + +mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b +mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of + Nil -> q0 + Skip forest' -> mapMaybeQueue f le fCh' q0 forest' + Cons t forest' -> mapMaybeQueue f le fCh' (union' le (mapMaybeT t) q0) forest' + where fCh' (Succ t tss) = union' le (mapMaybeT t) (fCh tss) + mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\x -> insert' le x (fCh ts)) (f x0) + +type Partition a b = (MinQueue a, MinQueue b) + +mapEitherQueue :: (a -> Either b c) -> LEq b -> LEq c -> (rk a -> Partition b c) -> Partition b c -> + BinomForest rk a -> Partition b c +mapEitherQueue f0 leB leC fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of + Nil -> (q00, q10) + Skip ts' -> mapEitherQueue f0 leB leC fCh' (q00, q10) ts' + Cons t ts' -> mapEitherQueue f0 leB leC fCh' (both (union' leB) (union' leC) (partitionT t) (q00, q10)) ts' + where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) + fCh' (Succ t tss) = both (union' leB) (union' leC) (partitionT t) (fCh tss) + partitionT (BinomTree x ts) = case fCh ts of + (q0, q1) -> case f0 x of + Left b -> (insert' leB b q0, q1) + Right c -> (q0, insert' leC c q1) + +{-# INLINE tip #-} +-- | Constructs a binomial tree of rank 0. +tip :: a -> BinomTree Zero a +tip x = BinomTree x Zero + +insertMinQ :: a -> MinQueue a -> MinQueue a +insertMinQ x Empty = singleton x +insertMinQ x (MinQueue n x' f) = MinQueue (n + 1) x (insertMin (tip x') f) + +-- | @insertMin t f@ assumes that the root of @t@ compares as less than +-- every other root in @f@, and merges accordingly. +insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMin t Nil = Cons t Nil +insertMin t (Skip f) = Cons t f +insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f) + +-- | Given two binomial forests starting at rank @rk@, takes their union. +-- Each successive application of this function costs /O(1)/, so applying it +-- from the beginning costs /O(log n)/. +merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a +merge le f1 f2 = case (f1, f2) of + (Skip f1', Skip f2') -> Skip (merge le f1' f2') + (Skip f1', Cons t2 f2') -> Cons t2 (merge le f1' f2') + (Cons t1 f1', Skip f2') -> Cons t1 (merge le f1' f2') + (Cons t1 f1', Cons t2 f2') + -> Skip (carry le (t1 `cat` t2) f1' f2') + (Nil, _) -> f2 + (_, Nil) -> f1 + where cat = joinBin le + +-- | Merges two binomial forests with another tree. If we are thinking of the trees +-- in the binomial forest as binary digits, this corresponds to a carry operation. +-- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/. +carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a +carry le t0 f1 f2 = t0 `seq` case (f1, f2) of + (Skip f1', Skip f2') -> Cons t0 (merge le f1' f2') + (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2') + (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2') + (Cons t1 f1', Cons t2 f2') + -> Cons t0 (mergeCarry t1 t2 f1' f2') + (Nil, _f2) -> incr le t0 f2 + (_f1, Nil) -> incr le t0 f1 + where cat = joinBin le + mergeCarry tA tB = carry le (tA `cat` tB) + +-- | Merges a binomial tree into a binomial forest. If we are thinking +-- of the trees in the binomial forest as binary digits, this corresponds +-- to adding a power of 2. This costs amortized /O(1)/ time. +incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a +incr le t f0 = t `seq` case f0 of + Nil -> Cons t Nil + Skip f -> Cons t f + Cons t' f' -> Skip (incr le (t `cat` t') f') + where cat = joinBin le + +-- | The carrying operation: takes two binomial heaps of the same rank @k@ +-- and returns one of rank @k+1@. Takes /O(1)/ time. +joinBin :: LEq a -> BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a +joinBin le t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) + | x1 `le` x2 = BinomTree x1 (Succ t2 ts1) + | otherwise = BinomTree x2 (Succ t1 ts2) + +instance Functor Zero where + fmap _ _ = Zero + +instance Functor rk => Functor (Succ rk) where + fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts) + +instance Functor rk => Functor (BinomTree rk) where + fmap f (BinomTree x ts) = BinomTree (f x) (fmap f ts) + +instance Functor rk => Functor (BinomForest rk) where + fmap _ Nil = Nil + fmap f (Skip ts) = Skip (fmap f ts) + fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts) + +instance Foldable Zero where + foldr _ z _ = z + foldl _ z _ = z + +instance Foldable rk => Foldable (Succ rk) where + foldr f z (Succ t ts) = foldr f (foldr f z ts) t + foldl f z (Succ t ts) = foldl f (foldl f z t) ts + +instance Foldable rk => Foldable (BinomTree rk) where + foldr f z (BinomTree x ts) = x `f` foldr f z ts + foldl f z (BinomTree x ts) = foldl f (z `f` x) ts + +instance Foldable rk => Foldable (BinomForest rk) where + foldr _ z Nil = z + foldr f z (Skip tss) = foldr f z tss + foldr f z (Cons t tss) = foldr f (foldr f z tss) t + foldl _ z Nil = z + foldl f z (Skip tss) = foldl f z tss + foldl f z (Cons t tss) = foldl f (foldl f z t) tss + +-- instance Traversable Zero where +-- traverse _ _ = pure Zero +-- +-- instance Traversable rk => Traversable (Succ rk) where +-- traverse f (Succ t ts) = Succ <$> traverse f t <*> traverse f ts +-- +-- instance Traversable rk => Traversable (BinomTree rk) where +-- traverse f (BinomTree x ts) = BinomTree <$> f x <*> traverse f ts +-- +-- instance Traversable rk => Traversable (BinomForest rk) where +-- traverse _ Nil = pure Nil +-- traverse f (Skip tss) = Skip <$> traverse f tss +-- traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss + +mapU :: (a -> b) -> MinQueue a -> MinQueue b +mapU _ Empty = Empty +mapU f (MinQueue n x ts) = MinQueue n (f x) (f <$> ts) + +-- | /O(n)/. Unordered right fold on a priority queue. +foldrU :: (a -> b -> b) -> b -> MinQueue a -> b +foldrU _ z Empty = z +foldrU f z (MinQueue _ x ts) = x `f` foldr f z ts + +-- | /O(n)/. Unordered left fold on a priority queue. +foldlU :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU _ z Empty = z +foldlU f z (MinQueue _ x ts) = foldl f (z `f` x) ts + +-- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) +-- traverseU _ Empty = pure Empty +-- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts + +-- | Forces the spine of the priority queue. +seqSpine :: MinQueue a -> b -> b +seqSpine Empty z = z +seqSpine (MinQueue _ _ ts) z = seqSpineF ts z + +seqSpineF :: BinomForest rk a -> b -> b +seqSpineF Nil z = z +seqSpineF (Skip ts') z = seqSpineF ts' z +seqSpineF (Cons _ ts') z = seqSpineF ts' z + +-- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. +keysQueue :: Prio.MinPQueue k a -> MinQueue k +keysQueue Prio.Empty = Empty +keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (keysF (const Zero) ts) + +keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k +keysF f ts0 = case ts0 of + Prio.Nil -> Nil + Prio.Skip ts' -> Skip (keysF f' ts') + Prio.Cons (Prio.BinomTree k _ ts) ts' + -> Cons (BinomTree k (f ts)) (keysF f' ts') + where f' (Prio.Succ (Prio.BinomTree k _ ts) tss) = Succ (BinomTree k (f ts)) (f tss) + +class NFRank rk where + rnfRk :: NFData a => rk a -> () + +instance NFRank Zero where + rnfRk _ = () + +instance NFRank rk => NFRank (Succ rk) where + rnfRk (Succ t ts) = t `deepseq` rnfRk ts + +instance (NFData a, NFRank rk) => NFData (BinomTree rk a) where + rnf (BinomTree x ts) = x `deepseq` rnfRk ts + +instance (NFData a, NFRank rk) => NFData (BinomForest rk a) where + rnf Nil = () + rnf (Skip ts) = rnf ts + rnf (Cons t ts) = t `deepseq` rnf ts + +instance NFData a => NFData (MinQueue a) where + rnf Empty = () + rnf (MinQueue _ x ts) = x `deepseq` rnf ts diff --git a/src/Data/PQueue/Max.hs b/src/Data/PQueue/Max.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Max.hs @@ -0,0 +1,349 @@ +{-# 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, + 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) + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup((<>))) +#endif + +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 + +#if MIN_VERSION_base(4,9,0) +instance Ord a => Semigroup (MaxQueue a) where + (<>) = union +#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) + +-- | /O(log (min(n1,n2)))/. Take the union of two priority queues. +union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a +MaxQ q1 `union` MaxQ q2 = MaxQ (q1 `Min.union` q2) + +-- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. +unions :: Ord a => [MaxQueue a] -> MaxQueue a +unions qs = MaxQ (Min.unions [q | MaxQ q <- qs]) + +-- | /O(k log n)/. Returns the @(k+1)@th largest element of the queue. +(!!) :: Ord a => MaxQueue a -> Int -> a +MaxQ q !! n = unDown ((Min.!!) q n) + +{-# INLINE take #-} +-- | /O(k log n)/. Returns the list of the @k@ largest elements of the queue, in descending order, or +-- all elements of the queue, if @k >= n@. +take :: Ord a => Int -> MaxQueue a -> [a] +take k (MaxQ q) = [a | Down a <- Min.take k q] + +-- | /O(k log n)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. +drop :: Ord a => Int -> MaxQueue a -> MaxQueue a +drop k (MaxQ q) = MaxQ (Min.drop k q) + +-- | /O(k log n)/. Equivalent to @(take k queue, drop k queue)@. +splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) +splitAt k (MaxQ q) = (map unDown xs, MaxQ q') where + (xs, q') = Min.splitAt k q + +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] +takeWhile p (MaxQ q) = map unDown (Min.takeWhile (p . unDown) q) + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a +dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q) + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +-- +span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +span p (MaxQ q) = (map unDown xs, MaxQ q') where + (xs, q') = Min.span (p . unDown) q + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +break p = span (not . p) + +-- | /O(n)/. Returns a queue of those elements which satisfy the predicate. +filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a +filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q) + +-- | /O(n)/. Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, +-- and the right queue contains those that do not. +partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) +partition p (MaxQ q) = (MaxQ q0, MaxQ q1) + where (q0, q1) = Min.partition (p . unDown) q + +-- | /O(n)/. Maps a function over the elements of the queue, and collects the 'Just' values. +mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b +mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\(Down x) -> Down <$> f x) q) + +-- | /O(n)/. Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. +mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) +mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1) + where (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q + +-- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue. +-- /Does not check the precondition/. +mapU :: (a -> b) -> MaxQueue a -> MaxQueue b +mapU f (MaxQ q) = MaxQ (Min.mapU (\(Down a) -> Down (f a)) q) + +-- | /O(n)/. Unordered right fold on a priority queue. +foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b +foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q + +-- | /O(n)/. Unordered left fold on a priority queue. +foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b +foldlU f z (MaxQ q) = Min.foldlU (foldl f) z q + +{-# INLINE elemsU #-} +-- | Equivalent to 'toListU'. +elemsU :: MaxQueue a -> [a] +elemsU = toListU + +{-# INLINE toListU #-} +-- | /O(n)/. Returns a list of the elements of the priority queue, in no particular order. +toListU :: MaxQueue a -> [a] +toListU (MaxQ q) = map unDown (Min.toListU q) + +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. +-- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b +foldrAsc = foldlDesc . flip + +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. +-- @'foldlAsc' f z q == 'foldrDesc' (flip f) z q@. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b +foldlAsc = foldrDesc . flip + +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b +foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q + +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b +foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q + +{-# INLINE toAscList #-} +-- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MaxQueue a -> [a] +toAscList q = build (\c nil -> foldrAsc c nil q) +-- I can see no particular reason this does not simply forward to Min.toDescList. (lsp, 2016) + +{-# INLINE toDescList #-} +-- | /O(n log n)/. Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MaxQueue a -> [a] +toDescList q = build (\c nil -> foldrDesc c nil q) +-- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016) + +{-# INLINE toList #-} +-- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MaxQueue a -> [a] +toList (MaxQ q) = map unDown (Min.toList q) + +{-# INLINE fromAscList #-} +-- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +fromAscList :: [a] -> MaxQueue a +fromAscList = MaxQ . Min.fromDescList . map Down + +{-# INLINE fromDescList #-} +-- | /O(n)/. Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MaxQueue a +fromDescList = MaxQ . Min.fromAscList . map Down + +{-# INLINE fromList #-} +-- | /O(n log n)/. Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MaxQueue a +fromList = foldr insert empty + +-- | /O(n)/. Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. +keysQueue :: Prio.MaxPQueue k a -> MaxQueue k +keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q) + +-- | /O(log n)/. Forces the spine of the heap. +seqSpine :: MaxQueue a -> b -> b +seqSpine (MaxQ q) = Min.seqSpine q diff --git a/src/Data/PQueue/Min.hs b/src/Data/PQueue/Min.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Min.hs @@ -0,0 +1,305 @@ +{-# 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, + 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) + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup((<>))) +#endif + +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 + +#if MIN_VERSION_base(4,9,0) +instance Ord a => Semigroup (MinQueue a) where + (<>) = union +#endif + +instance Ord a => Monoid (MinQueue a) where + mempty = empty + mappend = union + mconcat = unions + +-- | /O(1)/. Returns the minimum element. Throws an error on an empty queue. +findMin :: MinQueue a -> a +findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin + +-- | /O(log n)/. Deletes the minimum element. If the queue is empty, does nothing. +deleteMin :: Ord a => MinQueue a -> MinQueue a +deleteMin q = case minView q of + Nothing -> empty + Just (_, q') -> q' + +-- | /O(log n)/. Extracts the minimum element. Throws an error on an empty queue. +deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) +deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView + +-- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. +unions :: Ord a => [MinQueue a] -> MinQueue a +unions = foldl union empty + +-- | /O(k log n)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- element in the queue. Equivalent to @toAscList queue !! k@. +(!!) :: Ord a => MinQueue a -> Int -> a +q !! n | n >= size q + = error "Data.PQueue.Min.!!: index too large" +q !! n = (List.!!) (toAscList q) n + +{-# INLINE takeWhile #-} +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] +takeWhile p = foldWhileFB p . toAscList + +{-# INLINE foldWhileFB #-} +-- | Equivalent to Data.List.takeWhile, but is a better producer. +foldWhileFB :: (a -> Bool) -> [a] -> [a] +foldWhileFB p xs0 = build (\c nil -> let + consWhile x xs + | p x = x `c` xs + | otherwise = nil + in foldr consWhile nil xs0) + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +dropWhile p = drop' where + drop' q = case minView q of + Just (x, q') | p x -> drop' q' + _ -> q + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +span p queue = case minView queue of + Just (x, q') + | p x -> let (ys, q'') = span p q' in (x : ys, q'') + _ -> ([], queue) + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +break p = span (not . p) + +{-# INLINE take #-} +-- | /O(k log n)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, +-- or all elements of @queue@ itself if @k >= 'size' queue@. +take :: Ord a => Int -> MinQueue a -> [a] +take n = List.take n . toAscList + +-- | /O(k log n)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, +-- or an empty queue if @k >= size 'queue'@. +drop :: Ord a => Int -> MinQueue a -> MinQueue a +drop n queue = n `seq` case minView queue of + Just (_, queue') + | n > 0 -> drop (n - 1) queue' + _ -> queue + +-- | /O(k log n)/. Equivalent to @('take' k queue, 'drop' k queue)@. +splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) +splitAt n queue = n `seq` case minView queue of + Just (x, queue') + | n > 0 -> let (xs, queue'') = splitAt (n - 1) queue' in (x : xs, queue'') + _ -> ([], queue) + +-- | /O(n)/. Returns the queue with all elements not satisfying @p@ removed. +filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +filter p = mapMaybe (\x -> if p x then Just x else Nothing) + +-- | /O(n)/. Returns a pair where the first queue contains all elements satisfying @p@, and the second queue +-- contains all elements not satisfying @p@. +partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) +partition p = mapEither (\x -> if p x then Left x else Right x) + +-- | /O(n)/. Creates a new priority queue containing the images of the elements of this queue. +-- Equivalent to @'fromList' . 'Data.List.map' f . toList@. +map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b +map f = foldrU (insert . f) empty + +{-# INLINE toAscList #-} +-- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MinQueue a -> [a] +toAscList queue = build (\c nil -> foldrAsc c nil queue) + +{-# INLINE toDescList #-} +-- | /O(n log n)/. Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MinQueue a -> [a] +toDescList queue = build (\c nil -> foldrDesc c nil queue) + +{-# INLINE toList #-} +-- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MinQueue a -> [a] +toList = toAscList + +{-# RULES + "toAscList" forall q . toAscList q = build (\c nil -> foldrAsc c nil q); + -- inlining doesn't seem to be working out =/ + "toDescList" forall q . toDescList q = build (\c nil -> foldrDesc c nil q); + #-} + +-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. +-- @foldrDesc f z q == foldlAsc (flip f) z q@. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrDesc = foldlAsc . flip + +-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. +-- @foldlDesc f z q == foldrAsc (flip f) z q@. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlDesc = foldrAsc . flip + +{-# INLINE fromList #-} +-- | /O(n)/. Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MinQueue a +fromList = foldr insert empty + +{-# RULES + "fromList" fromList = foldr insert empty; + "fromAscList" fromAscList = foldr insertMinQ empty; + #-} + +{-# INLINE fromAscList #-} +-- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +fromAscList :: [a] -> MinQueue a +fromAscList = foldr insertMinQ empty + +-- | /O(n)/. Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MinQueue a +fromDescList = foldl' (flip insertMinQ) empty + +-- | Maps a function over the elements of the queue, ignoring order. This function is only safe if the function is monotonic. +-- This function /does not/ check the precondition. +mapU :: (a -> b) -> MinQueue a -> MinQueue b +mapU = mapMonotonic + +{-# INLINE elemsU #-} +-- | Equivalent to 'toListU'. +elemsU :: MinQueue a -> [a] +elemsU = toListU + +-- | /O(n)/. Returns the elements of the queue, in no particular order. +toListU :: MinQueue a -> [a] +toListU q = build (\c n -> foldrU c n q) + +{-# RULES + "foldr/toListU" forall f z q . foldr f z (toListU q) = foldrU f z q; + "foldl/toListU" forall f z q . foldl f z (toListU q) = foldlU f z q; + #-} diff --git a/src/Data/PQueue/Prio/Internals.hs b/src/Data/PQueue/Prio/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Internals.hs @@ -0,0 +1,489 @@ +{-# 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 ((<>)) + +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 + +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' (<=) + +-- | /O(n)/ (an earlier implementation had /O(1)/ but was buggy). +-- Insert an element with the specified key into the priority queue, +-- putting it behind elements whose key compares equal to the +-- inserted one. +insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a +insertBehind k v q = + let (smaller, larger) = spanKey (<= k) q + in foldr (uncurry insert) (insert k v larger) smaller + +spanKey :: Ord k => (k -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) +spanKey p q = case minViewWithKey q of + Just (t@(k, _), q') | p k -> + let (kas, q'') = spanKey p q' in (t : kas, q'') + _ -> ([], q) + +-- | Internal helper method, using a specific comparator function. +insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a +insert' _ k a Empty = singleton k a +insert' le k a (MinPQ n k' a' ts) + | k `le` k' = MinPQ (n + 1) k a (incr le (tip k' a') ts) + | otherwise = MinPQ (n + 1) k' a' (incr le (tip k a ) ts) + +-- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union +-- of the two specified queues. +union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a +union = union' (<=) + +-- | Takes the union of the two specified queues, using the given comparison function. +union' :: CompF k -> MinPQueue k a -> MinPQueue k a -> MinPQueue k a +union' le (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2) + | k1 `le` k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2) + | otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1) + where insMerge k a = carryForest le (tip k a) ts1 ts2 +union' _ Empty q2 = q2 +union' _ q1 Empty = q1 + +-- | /O(1)/. The minimal (key, element) in the queue, if the queue is nonempty. +getMin :: MinPQueue k a -> Maybe (k, a) +getMin (MinPQ _ k a _) = Just (k, a) +getMin _ = Nothing + +-- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. +adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a +adjustMinWithKey _ Empty = Empty +adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts + +-- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. +-- If the queue is empty, does nothing. +updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> MinPQueue k a -> MinPQueue k a +updateMinWithKey _ Empty = Empty +updateMinWithKey f (MinPQ n k a ts) = case f k a of + Nothing -> extractHeap (<=) n ts + Just a' -> MinPQ n k a' ts + +-- | /O(log n)/. Retrieves the minimal (key, value) pair of the map, and the map stripped of that +-- element, or 'Nothing' if passed an empty map. +minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a) +minViewWithKey Empty = Nothing +minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap (<=) n ts) + +-- | /O(n)/. Map a function over all values in the queue. +mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b +mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f) + +-- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly +-- monotonic. /The precondition is not checked./ This function has better performance than +-- 'mapKeys'. +mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a +mapKeysMonotonic _ Empty = Empty +mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts) + +-- | /O(n)/. Map values and collect the 'Just' results. +mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b +mapMaybeWithKey _ Empty = Empty +mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF (<=) f (const Empty) ts) + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) +mapEitherWithKey _ Empty = (Empty, Empty) +mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a) + (mapEitherF (<=) f (const (Empty, Empty)) ts) + +-- | /O(n log n)/. Fold the keys and values in the map, such that +-- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldrWithKeyU'. +foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MinPQueue k a -> b +foldrWithKey _ z Empty = z +foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where + foldF ts = case extract ts of + Yes (Extract k a _ ts') -> f k a (foldF ts') + _ -> z + +-- | /O(n log n)/. Fold the keys and values in the map, such that +-- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldlWithKeyU'. +foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MinPQueue k a -> b +foldlWithKey _ z Empty = z +foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where + foldF z ts = case extract ts of + Yes (Extract k a _ ts') -> foldF (f z k a) ts' + _ -> z + +-- | Equivalent to 'insert', save the assumption that this key is @<=@ +-- every other key in the map. /The precondition is not checked./ +insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a +insertMin k a Empty = MinPQ 1 k a Nil +insertMin k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin (tip k' a') ts) + +-- | /O(1)/. Returns a binomial tree of rank zero containing this +-- key and value. +tip :: k -> a -> BinomTree Zero k a +tip k a = BinomTree k a Zero + +-- | /O(1)/. Takes the union of two binomial trees of the same rank. +meld :: CompF k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a +meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) + | k1 `le` k2 = BinomTree k1 v1 (Succ t2 ts1) + | otherwise = BinomTree k2 v2 (Succ t1 ts2) + +-- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. +mergeForest :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a +mergeForest le f1 f2 = case (f1, f2) of + (Skip ts1, Skip ts2) -> Skip (mergeForest le ts1 ts2) + (Skip ts1, Cons t2 ts2) -> Cons t2 (mergeForest le ts1 ts2) + (Cons t1 ts1, Skip ts2) -> Cons t1 (mergeForest le ts1 ts2) + (Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest le (meld le t1 t2) ts1 ts2) + (Nil, _) -> f2 + (_, Nil) -> f1 + +-- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. +-- Analogous to binary addition when a digit has been carried. +carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a +carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of + (Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2) + (Cons t1 ts1, Skip ts2) -> Skip (carryMeld t0 t1 ts1 ts2) + (Skip ts1, Cons t2 ts2) -> Skip (carryMeld t0 t2 ts1 ts2) + (Skip ts1, Skip ts2) -> Cons t0 (mergeForest le ts1 ts2) + (Nil, _) -> incr le t0 f2 + (_, Nil) -> incr le t0 f1 + where carryMeld = carryForest le .: meld le + +-- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. +incr :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incr le t ts = t `seq` case ts of + Nil -> Cons t Nil + Skip ts' -> Cons t ts' + Cons t' ts' -> Skip (incr le (meld le t t') ts') + +-- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree +-- is less than all other roots. Analogous to binary incrementation. Equivalent to +-- @'incr' (\_ _ -> True)@. +incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incrMin t@(BinomTree k a ts) tss = case tss of + Nil -> Cons t Nil + Skip tss' -> Cons t tss' + Cons t' tss' -> Skip (incrMin (BinomTree k a (Succ t' ts)) tss') + +extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a +extractHeap le n ts = n `seq` case extractForest le ts of + No -> Empty + Yes (Extract k a _ ts') -> MinPQ (n - 1) k a ts' + +-- | A specialized type intended to organize the return of extract-min queries +-- from a binomial forest. We walk all the way through the forest, and then +-- walk backwards. @Extract rk a@ is the result type of an extract-min +-- operation that has walked as far backwards of rank @rk@ -- that is, it +-- has visited every root of rank @>= rk@. +-- +-- The interpretation of @Extract minKey minVal children forest@ is +-- +-- * @minKey@ is the key of the minimum root visited so far. It may have +-- any rank @>= rk@. We will denote the root corresponding to +-- @minKey@ as @minRoot@. +-- +-- * @minVal@ is the value corresponding to @minKey@. +-- +-- * @children@ is those children of @minRoot@ which have not yet been +-- merged with the rest of the forest. Specifically, these are +-- the children with rank @< rk@. +-- +-- * @forest@ is an accumulating parameter that maintains the partial +-- reconstruction of the binomial forest without @minRoot@. It is +-- the union of all old roots with rank @>= rk@ (except @minRoot@), +-- with the set of all children of @minRoot@ with rank @>= rk@. +-- Note that @forest@ is lazy, so if we discover a smaller key +-- than @minKey@ later, we haven't wasted significant work. + +data Extract rk k a = Extract k a (rk k a) (BinomForest rk k a) +data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) + +incrExtract :: CompF k -> Maybe (BinomTree rk k a) -> Extract (Succ rk) k a -> Extract rk k a +incrExtract _ Nothing (Extract k a (Succ t ts) tss) + = Extract k a ts (Cons t tss) +incrExtract le (Just t) (Extract k a (Succ t' ts) tss) + = Extract k a ts (Skip (incr le (meld le t t') tss)) + +-- | Walks backward from the biggest key in the forest, as far as rank @rk@. +-- Returns its progress. Each successive application of @extractBin@ takes +-- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. +extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a +extractForest _ Nil = No +extractForest le (Skip tss) = case extractForest le tss of + No -> No + Yes ex -> Yes (incrExtract le Nothing ex) +extractForest le (Cons t@(BinomTree k a0 ts) tss) = Yes $ case extractForest le tss of + Yes ex@(Extract k' _ _ _) + | k' incrExtract le (Just t) ex + _ -> Extract k a0 ts (Skip tss) + where + a BinomForest rk k a -> MExtract rk k a +extract = extractForest (<=) + +-- | Utility function for mapping over a forest. +mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b +mapForest f fCh ts0 = case ts0 of + Nil -> Nil + Skip ts' -> Skip (mapForest f fCh' ts') + Cons (BinomTree k a ts) tss + -> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss) + where fCh' (Succ (BinomTree k a ts) tss) + = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss) + +-- | Utility function for mapping a 'Maybe' function over a forest. +mapMaybeF :: CompF k -> (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> + BinomForest rk k a -> MinPQueue k b +mapMaybeF le f fCh ts0 = case ts0 of + Nil -> Empty + Skip ts' -> mapMaybeF le f fCh' ts' + Cons (BinomTree k a ts) ts' + -> insF k a (fCh ts) (mapMaybeF le f fCh' ts') + where insF k a = maybe id (insert' le k) (f k a) .: union' le + fCh' (Succ (BinomTree k a ts) tss) = + insF k a (fCh ts) (fCh tss) + +-- | Utility function for mapping an 'Either' function over a forest. +mapEitherF :: CompF k -> (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) -> + BinomForest rk k a -> (MinPQueue k b, MinPQueue k c) +mapEitherF le f0 fCh ts0 = case ts0 of + Nil -> (Empty, Empty) + Skip ts' -> mapEitherF le f0 fCh' ts' + Cons (BinomTree k a ts) ts' + -> insF k a (fCh ts) (mapEitherF le f0 fCh' ts') + where + insF k a = either (first' . insert' le k) (second' . insert' le k) (f0 k a) .: + (union' le `both` union' le) + fCh' (Succ (BinomTree k a ts) tss) = + insF k a (fCh ts) (fCh tss) + both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) + +-- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. +foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b +foldrWithKeyU _ z Empty = z +foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z) + +-- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. +foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b +foldlWithKeyU _ z Empty = z +foldlWithKeyU f z0 (MinPQ _ k0 a0 ts) = foldlWithKeyF_ (\k a z -> f z k a) (const id) ts (f z0 k0 a0) + +-- | /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) -> MinPQueue k a -> f (MinPQueue k b) +traverseWithKeyU _ Empty = pure Empty +traverseWithKeyU f (MinPQ n k a ts) = MinPQ n k <$> f k a <*> traverseForest f (const (pure Zero)) ts + +{-# SPECIALIZE traverseForest :: (k -> a -> Identity b) -> (rk k a -> Identity (rk k b)) -> BinomForest rk k a -> + Identity (BinomForest rk k b) #-} +traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b) +traverseForest f fCh ts0 = case ts0 of + Nil -> pure Nil + Skip ts' -> Skip <$> traverseForest f fCh' ts' + Cons (BinomTree k a ts) tss + -> Cons <$> (BinomTree k <$> f k a <*> fCh ts) <*> traverseForest f fCh' tss + where + fCh' (Succ (BinomTree k a ts) tss) + = Succ <$> (BinomTree k <$> f k a <*> fCh ts) <*> fCh tss + +-- | Unordered right fold on a binomial forest. +foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b +foldrWithKeyF_ f fCh ts0 z0 = case ts0 of + Nil -> z0 + Skip ts' -> foldrWithKeyF_ f fCh' ts' z0 + Cons (BinomTree k a ts) ts' + -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0)) + where + fCh' (Succ (BinomTree k a ts) tss) z = + f k a (fCh ts (fCh tss z)) + +-- | Unordered left fold on a binomial forest. +foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b +foldlWithKeyF_ f fCh ts0 = case ts0 of + Nil -> id + Skip ts' -> foldlWithKeyF_ f fCh' ts' + Cons (BinomTree k a ts) ts' + -> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a + where + fCh' (Succ (BinomTree k a ts) tss) = + fCh tss . fCh ts . f k a + +-- | Maps a monotonic function over the keys in a binomial forest. +mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a +mapKeysMonoF f fCh ts0 = case ts0 of + Nil -> Nil + Skip ts' -> Skip (mapKeysMonoF f fCh' ts') + Cons (BinomTree k a ts) ts' + -> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts') + where + fCh' (Succ (BinomTree k a ts) tss) = + Succ (BinomTree (f k) a (fCh ts)) (fCh tss) + +-- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. +seqSpine :: MinPQueue k a -> b -> b +seqSpine Empty z0 = z0 +seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where + seqSpineF :: BinomForest rk k a -> b -> b + seqSpineF ts z = case ts of + Nil -> z + Skip ts' -> seqSpineF ts' z + Cons _ ts' -> seqSpineF ts' z + +class NFRank rk where + rnfRk :: (NFData k, NFData a) => rk k a -> () + +instance NFRank Zero where + rnfRk _ = () + +instance NFRank rk => NFRank (Succ rk) where + rnfRk (Succ t ts) = t `deepseq` rnfRk ts + +instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where + rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts + +instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where + rnf Nil = () + rnf (Skip tss) = rnf tss + rnf (Cons t tss) = t `deepseq` rnf tss + +instance (NFData k, NFData a) => NFData (MinPQueue k a) where + rnf Empty = () + rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts diff --git a/src/Data/PQueue/Prio/Max.hs b/src/Data/PQueue/Prio/Max.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Max.hs @@ -0,0 +1,480 @@ +{-# 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 + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup((<>))) +#endif + +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) + +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (MaxPQueue k a) where + (<>) = union +#endif + +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) + +-- | /O(n)/ (an earlier implementation had /O(1)/ but was buggy). +-- Insert an element with the specified key into the priority queue, +-- putting it behind elements whose key compares equal to the +-- inserted one. +insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a +insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) + +-- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union +-- of the two specified queues. +union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a +MaxPQ q1 `union` MaxPQ q2 = MaxPQ (q1 `Q.union` q2) + +-- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). +unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a +unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs]) + +-- | /O(1)/. Checks if this priority queue is empty. +null :: MaxPQueue k a -> Bool +null (MaxPQ q) = Q.null q + +-- | /O(1)/. Returns the size of this priority queue. +size :: MaxPQueue k a -> Int +size (MaxPQ q) = Q.size q + +-- | /O(1)/. The maximal (key, element) in the queue. Calls 'error' if empty. +findMax :: MaxPQueue k a -> (k, a) +findMax = fromMaybe (error "Error: findMax called on an empty queue") . getMax + +-- | /O(1)/. The maximal (key, element) in the queue, if the queue is nonempty. +getMax :: MaxPQueue k a -> Maybe (k, a) +getMax (MaxPQ q) = do + (Down k, a) <- Q.getMin q + return (k, a) + +-- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. +deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a +deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q) + +-- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. +deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) +deleteFindMax = fromMaybe (error "Error: deleteFindMax called on an empty queue") . maxViewWithKey + +-- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. +adjustMax :: (a -> a) -> MaxPQueue k a -> MaxPQueue k a +adjustMax = adjustMaxWithKey . const + +-- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. +adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a +adjustMaxWithKey f (MaxPQ q) = MaxPQ (Q.adjustMinWithKey (f . unDown) q) + +-- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. +-- If the queue is empty, does nothing. +updateMax :: Ord k => (a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a +updateMax = updateMaxWithKey . const + +-- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. +-- If the queue is empty, does nothing. +updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a +updateMaxWithKey f (MaxPQ q) = MaxPQ (Q.updateMinWithKey (f . unDown) q) + +-- | /O(log n)/. Retrieves the value associated with the maximum key of the queue, and the queue +-- stripped of that element, or 'Nothing' if passed an empty queue. +maxView :: Ord k => MaxPQueue k a -> Maybe (a, MaxPQueue k a) +maxView q = do + ((_, a), q') <- maxViewWithKey q + return (a, q') + +-- | /O(log n)/. Retrieves the maximal (key, value) pair of the map, and the map stripped of that +-- element, or 'Nothing' if passed an empty map. +maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a) +maxViewWithKey (MaxPQ q) = do + ((Down k, a), q') <- Q.minViewWithKey q + return ((k, a), MaxPQ q') + +-- | /O(n)/. Map a function over all values in the queue. +map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b +map = mapWithKey . const + +-- | /O(n)/. Map a function over all values in the queue. +mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b +mapWithKey f (MaxPQ q) = MaxPQ (Q.mapWithKey (f . unDown) q) + +-- | /O(n)/. Map a function over all values in the queue. +mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a +mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q) + +-- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly +-- monotonic. /The precondition is not checked./ This function has better performance than +-- 'mapKeys'. +mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a +mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q) + +-- | /O(n log n)/. Fold the keys and values in the map, such that +-- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldrWithKeyU'. +foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b +foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q + +-- | /O(n log n)/. Fold the keys and values in the map, such that +-- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldlWithKeyU'. +foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b +foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\z -> f z . unDown) z0 q + +-- | /O(n log n)/. Traverses the elements of the queue in descending order by key. +-- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) +-- +-- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. +traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (f . unDown) q + +-- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. +-- (@'take' k q == 'List.take' k ('toDescList' q)@) +take :: Ord k => Int -> MaxPQueue k a -> [(k, a)] +take k (MaxPQ q) = fmap (first' unDown) (Q.take k q) + +-- | /O(k log n)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. +drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a +drop k (MaxPQ q) = MaxPQ (Q.drop k q) + +-- | /O(k log n)/. Equivalent to @('take' k q, 'drop' k q)@. +splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +splitAt k (MaxPQ q) = case Q.splitAt k q of + (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') + +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) +takeWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> [(k, a)] +takeWhile = takeWhileWithKey . const + +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) +takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] +takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q) + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +dropWhile = dropWhileWithKey . const + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +dropWhileWithKey p (MaxPQ q) = MaxPQ (Q.dropWhileWithKey (p . unDown) q) + +-- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. +span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +span = spanWithKey . const + +-- | Equivalent to @'span' ('not' . p)@. +break :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +break = breakWithKey . const + +-- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. +spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +spanWithKey p (MaxPQ q) = case Q.spanWithKey (p . unDown) q of + (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') + +-- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. +breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of + (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') + +-- | /O(n)/. Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +filter = filterWithKey . const + +-- | /O(n)/. Filter all values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +filterWithKey p (MaxPQ q) = MaxPQ (Q.filterWithKey (p . unDown) q) + +-- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partition :: Ord k => (a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) +partition = partitionWithKey . const + +-- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) +partitionWithKey p (MaxPQ q) = case Q.partitionWithKey (p . unDown) q of + (q1, q0) -> (MaxPQ q1, MaxPQ q0) + +-- | /O(n)/. Map values and collect the 'Just' results. +mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b +mapMaybe = mapMaybeWithKey . const + +-- | /O(n)/. Map values and collect the 'Just' results. +mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b +mapMaybeWithKey f (MaxPQ q) = MaxPQ (Q.mapMaybeWithKey (f . unDown) q) + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) +mapEither = mapEitherWithKey . const + +-- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) +mapEitherWithKey f (MaxPQ q) = case Q.mapEitherWithKey (f . unDown) q of + (qL, qR) -> (MaxPQ qL, MaxPQ qR) + +-- | /O(n)/. Build a priority queue from the list of (key, value) pairs. +fromList :: Ord k => [(k, a)] -> MaxPQueue k a +fromList = MaxPQ . Q.fromList . fmap (first' Down) + +-- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ +fromAscList :: [(k, a)] -> MaxPQueue k a +fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down) + +-- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ +fromDescList :: [(k, a)] -> MaxPQueue k a +fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down) + +-- | /O(n log n)/. Return all keys of the queue in descending order. +keys :: Ord k => MaxPQueue k a -> [k] +keys = fmap fst . toDescList + +-- | /O(n log n)/. Return all elements of the queue in descending order by key. +elems :: Ord k => MaxPQueue k a -> [a] +elems = fmap snd . toDescList + +-- | /O(n log n)/. Equivalent to 'toDescList'. +assocs :: Ord k => MaxPQueue k a -> [(k, a)] +assocs = toDescList + +-- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. +toAscList :: Ord k => MaxPQueue k a -> [(k, a)] +toAscList (MaxPQ q) = fmap (first' unDown) (Q.toDescList q) + +-- | /O(n log n)/. Return all (key, value) pairs in descending order by key. +toDescList :: Ord k => MaxPQueue k a -> [(k, a)] +toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q) + +-- | /O(n log n)/. Equivalent to 'toDescList'. +-- +-- If the traversal order is irrelevant, consider using 'toListU'. +toList :: Ord k => MaxPQueue k a -> [(k, a)] +toList = toDescList + +-- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. +foldrU :: (a -> b -> b) -> b -> MaxPQueue k a -> b +foldrU = foldrWithKeyU . const + +-- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. +foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b +foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (f . unDown) z q + +-- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. +foldlU :: (b -> a -> b) -> b -> MaxPQueue k a -> b +foldlU f = foldlWithKeyU (const . f) + +-- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. +foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b +foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (\z -> f z . unDown) z0 q + +-- | /O(n)/. An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseU :: (Applicative f) => (a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseU = traverseWithKeyU . const + +-- | /O(n)/. An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseWithKeyU :: (Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (f . unDown) q + +-- | /O(n)/. Return all keys of the queue in no particular order. +keysU :: MaxPQueue k a -> [k] +keysU = fmap fst . toListU + +-- | /O(n)/. Return all elements of the queue in no particular order. +elemsU :: MaxPQueue k a -> [a] +elemsU = fmap snd . toListU + +-- | /O(n)/. Equivalent to 'toListU'. +assocsU :: MaxPQueue k a -> [(k, a)] +assocsU = toListU + +-- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. +toListU :: MaxPQueue k a -> [(k, a)] +toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q) + +-- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. +seqSpine :: MaxPQueue k a -> b -> b +seqSpine (MaxPQ q) = Q.seqSpine q diff --git a/src/Data/PQueue/Prio/Max/Internals.hs b/src/Data/PQueue/Prio/Max/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Max/Internals.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} + +module Data.PQueue.Prio.Max.Internals where + +import Control.DeepSeq (NFData(rnf)) + +import Data.Traversable (Traversable(traverse)) +import Data.Foldable (Foldable(foldr, foldl)) +import Data.Functor ((<$>)) +# if __GLASGOW_HASKELL__ +import Data.Data (Data, Typeable) +# endif + +import Prelude hiding (foldr, foldl) + +import Data.PQueue.Prio.Internals (MinPQueue) + +newtype Down a = Down { unDown :: a } +# if __GLASGOW_HASKELL__ + deriving (Eq, Data, Typeable) +# else + deriving (Eq) +# endif + +-- | A priority queue where values of type @a@ are annotated with keys of type @k@. +-- The queue supports extracting the element with maximum key. +newtype MaxPQueue k a = MaxPQ (MinPQueue (Down k) a) +# if __GLASGOW_HASKELL__ + deriving (Eq, Ord, Data, Typeable) +# else + deriving (Eq, Ord) +# endif + +instance (NFData k, NFData a) => NFData (MaxPQueue k a) where + rnf (MaxPQ q) = rnf q + +instance NFData a => NFData (Down a) where + rnf (Down a) = rnf a + +instance Ord a => Ord (Down a) where + Down a `compare` Down b = b `compare` a + Down a <= Down b = b <= a + +instance Functor Down where + fmap f (Down a) = Down (f a) + +instance Foldable Down where + foldr f z (Down a) = a `f` z + foldl f z (Down a) = z `f` a + +instance Traversable Down where + traverse f (Down a) = Down <$> f a diff --git a/src/Data/PQueue/Prio/Min.hs b/src/Data/PQueue/Prio/Min.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Prio/Min.hs @@ -0,0 +1,422 @@ +{-# 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) + +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup((<>))) +#endif + +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 .: + +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (MinPQueue k a) where + (<>) = union +#endif + +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) +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 the list of (key, value) pairs. +fromList :: Ord k => [(k, a)] -> MinPQueue k a +fromList = foldr (uncurry' insert) empty + +-- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ +fromAscList :: [(k, a)] -> MinPQueue k a +fromAscList = foldr (uncurry' insertMin) empty + +-- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ +fromDescList :: [(k, a)] -> MinPQueue k a +fromDescList = List.foldl' (\q (k, a) -> insertMin k a q) empty + +{-# RULES + "fromList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . + fromList (build g) = g (uncurry' insert) empty; + "fromAscList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . + fromAscList (build g) = g (uncurry' insertMin) empty; + #-} + +{-# INLINE keys #-} +-- | /O(n log n)/. Return all keys of the queue in ascending order. +keys :: Ord k => MinPQueue k a -> [k] +keys = List.map fst . toAscList + +{-# INLINE elems #-} +-- | /O(n log n)/. Return all elements of the queue in ascending order by key. +elems :: Ord k => MinPQueue k a -> [a] +elems = List.map snd . toAscList + +-- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. +toAscList :: Ord k => MinPQueue k a -> [(k, a)] +toAscList = foldrWithKey (curry (:)) [] + +-- | /O(n log n)/. Return all (key, value) pairs in descending order by key. +toDescList :: Ord k => MinPQueue k a -> [(k, a)] +toDescList = foldlWithKey (\z k a -> (k, a) : z) [] + +{-# RULES + "toAscList" toAscList = \q -> build (\c n -> foldrWithKey (curry c) n q); + "toDescList" toDescList = \q -> build (\c n -> foldlWithKey (\z k a -> (k, a) `c` z) n q); + "toListU" toListU = \q -> build (\c n -> foldrWithKeyU (curry c) n q); + #-} + +{-# INLINE toList #-} +-- | /O(n log n)/. Equivalent to 'toAscList'. +-- +-- If the traversal order is irrelevant, consider using 'toListU'. +toList :: Ord k => MinPQueue k a -> [(k, a)] +toList = toAscList + +{-# INLINE assocs #-} +-- | /O(n log n)/. Equivalent to 'toAscList'. +assocs :: Ord k => MinPQueue k a -> [(k, a)] +assocs = toAscList + +{-# INLINE keysU #-} +-- | /O(n)/. Return all keys of the queue in no particular order. +keysU :: MinPQueue k a -> [k] +keysU = List.map fst . toListU + +{-# INLINE elemsU #-} +-- | /O(n)/. Return all elements of the queue in no particular order. +elemsU :: MinPQueue k a -> [a] +elemsU = List.map snd . toListU + +{-# INLINE assocsU #-} +-- | /O(n)/. Equivalent to 'toListU'. +assocsU :: MinPQueue k a -> [(k, a)] +assocsU = toListU + +-- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. +toListU :: MinPQueue k a -> [(k, a)] +toListU = foldrWithKeyU (curry (:)) [] + +-- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. +foldrU :: (a -> b -> b) -> b -> MinPQueue k a -> b +foldrU = foldrWithKeyU . const + +-- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. +foldlU :: (b -> a -> b) -> b -> MinPQueue k a -> b +foldlU f = foldlWithKeyU (const . f) + +-- | /O(n)/. An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseU :: (Applicative f) => (a -> f b) -> MinPQueue k a -> f (MinPQueue k b) +traverseU = traverseWithKeyU . const + +instance Functor (MinPQueue k) where + fmap = map + +instance Ord k => Foldable (MinPQueue k) where + foldr = foldrWithKey . const + foldl f = foldlWithKey (const . f) + +instance Ord k => Traversable (MinPQueue k) where + traverse = traverseWithKey . const diff --git a/tests/PQueueTests.hs b/tests/PQueueTests.hs new file mode 100644 --- /dev/null +++ b/tests/PQueueTests.hs @@ -0,0 +1,145 @@ +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 + putStrLn "all tests passed" + +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