pqueue-1.3.1.1/0000755000000000000000000000000012720103341011336 5ustar0000000000000000pqueue-1.3.1.1/Setup.lhs0000644000000000000000000000011612720103341013144 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain pqueue-1.3.1.1/LICENSE0000644000000000000000000000005312720103341012341 0ustar0000000000000000Copyright Louis Wasserman 2010 BSD license pqueue-1.3.1.1/pqueue.cabal0000644000000000000000000000262212720103341013630 0ustar0000000000000000Name: pqueue Version: 1.3.1.1 Category: Data Structures Author: Louis Wasserman License: BSD3 License-file: LICENSE Stability: experimental Synopsis: Reliable, persistent, fast priority queues. Description: A fast, reliable priority queue implementation based on a binomial heap. Maintainer: Lennart Spitzner Louis Wasserman Bug-reports: https://github.com/lspitzner/pqueue/issues Build-type: Simple cabal-version: >= 1.6 extra-source-files: include/Typeable.h tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1, GHC == 8.0.1 source-repository head type: git location: git@github.com:lspitzner/pqueue.git Library { build-depends: { base >= 4 && < 4.10 , deepseq >= 1.3 && < 1.5 } exposed-modules: Data.PQueue.Prio.Min Data.PQueue.Prio.Max Data.PQueue.Min Data.PQueue.Max other-modules: Data.PQueue.Prio.Internals Data.PQueue.Internals Data.PQueue.Prio.Max.Internals Control.Applicative.Identity if impl(ghc) { extensions: DeriveDataTypeable } ghc-options: { -fdicts-strict -Wall -fno-warn-name-shadowing -fno-warn-unused-imports } if impl(ghc>=7.8) { ghc-options: { -fno-warn-inline-rule-shadowing } } } pqueue-1.3.1.1/Data/0000755000000000000000000000000012720103341012207 5ustar0000000000000000pqueue-1.3.1.1/Data/PQueue/0000755000000000000000000000000012720103341013413 5ustar0000000000000000pqueue-1.3.1.1/Data/PQueue/Min.hs0000644000000000000000000002402712720103341014477 0ustar0000000000000000{-# 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 Control.Applicative (Applicative(..), (<$>)) import Control.Applicative.Identity import Data.Monoid import Data.Maybe hiding (mapMaybe) import Data.Foldable (foldl, foldr, foldl') import Data.Traversable 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) import Data.Data #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif -- instance instance (Ord a, Show a) => Show (MinQueue a) where showsPrec p xs = showParen (p > 10) $ showString "fromAscList " . shows (toAscList xs) instance Read a => Read (MinQueue a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromAscList" <- lexP xs <- readPrec return (fromAscList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \ r -> do ("fromAscList",s) <- lex r (xs,t) <- reads s return (fromAscList xs,t) #endif instance Ord a => Monoid (MinQueue a) where mempty = empty mappend = union mconcat = unions -- | /O(1)/. Returns the minimum element. Throws an error on an empty queue. findMin :: MinQueue a -> a findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin -- | /O(log n)/. Deletes the minimum element. If the queue is empty, does nothing. deleteMin :: Ord a => MinQueue a -> MinQueue a deleteMin q = case minView q of Nothing -> empty Just (_, q') -> q' -- | /O(log n)/. Extracts the minimum element. Throws an error on an empty queue. deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView -- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. unions :: Ord a => [MinQueue a] -> MinQueue a unions = foldl union empty -- | /O(k log n)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest -- element in the queue. Equivalent to @toAscList queue !! k@. (!!) :: Ord a => MinQueue a -> Int -> a q !! n | n >= size q = error "Data.PQueue.Min.!!: index too large" q !! n = (List.!!) (toAscList q) n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] takeWhile p = foldWhileFB p . toAscList {-# INLINE foldWhileFB #-} -- | Equivalent to Data.List.takeWhile, but is a better producer. foldWhileFB :: (a -> Bool) -> [a] -> [a] foldWhileFB p xs = build (\ c nil -> let consWhile x xs | p x = x `c` xs | otherwise = nil in foldr consWhile nil xs) -- | '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)/. 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 -- | 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; #-} pqueue-1.3.1.1/Data/PQueue/Internals.hs0000644000000000000000000004464412720103341015722 0ustar0000000000000000{-# 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 import Data.Functor import Data.Foldable (Foldable (foldr, foldl)) import Data.Monoid (Monoid (..)) 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 && x1 == x2 && eq' q1 q2 where eq' q1 q2 = case (extractHeap q1, extractHeap q2) of (Just (x1, q1'), Just (x2, q2')) -> x1 == x2 && eq' q1' q2' (Nothing, Nothing) -> True _ -> False _ == _ = False instance Ord a => Ord (MinQueue a) where Empty `compare` Empty = EQ Empty `compare` _ = LT _ `compare` Empty = GT MinQueue _n1 x1 q1 `compare` MinQueue _n2 x2 q2 = compare x1 x2 `mappend` cmp' q1 q2 where cmp' q1 q2 = case (extractHeap q1, extractHeap q2) of (Just (x1, q1'), Just (x2, q2')) -> compare x1 x2 `mappend` cmp' q1' q2' (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 z suc s0 = unf z 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' (<=) x (MinQueue n x' ts) | x <= x' = MinQueue (n+1) x (incr (<=) (tip x') ts) | otherwise = MinQueue (n+1) x' (incr (<=) (tip x) ts) {-# INLINE union' #-} union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a union' _ Empty q = q union' _ q Empty = q union' (<=) (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) | x1 <= x2 = MinQueue (n1 + n2) x1 (carry (<=) (tip x2) f1 f2) | otherwise = MinQueue (n1 + n2) x2 (carry (<=) (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' (<=) t (Extract minKey (Succ kChild kChildren) ts) = Extract minKey kChildren (Skip (incr (<=) (t `cat` kChild) ts)) where cat = joinBin (<=) -- | 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 (<=) (Skip f) = case extractBin (<=) f of Yes ex -> Yes (incrExtract ex) No -> No extractBin (<=) (Cons t@(BinomTree x ts) f) = Yes $ case extractBin (<=) f of Yes ex@(Extract minKey _ _) | minKey < x -> incrExtract' (<=) t ex _ -> Extract x ts (Skip f) where a < b = not (b <= a) mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b mapMaybeQueue f (<=) fCh q0 forest = q0 `seq` case forest of Nil -> q0 Skip forest' -> mapMaybeQueue f (<=) fCh' q0 forest' Cons t forest' -> mapMaybeQueue f (<=) fCh' (union' (<=) (mapMaybeT t) q0) forest' where fCh' (Succ t tss) = union' (<=) (mapMaybeT t) (fCh tss) mapMaybeT (BinomTree x ts) = maybe (fCh ts) (\ x -> insert' (<=) x (fCh ts)) (f x) 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 f (<=) (<=.) fCh (q0, q1) ts = q0 `seq` q1 `seq` case ts of Nil -> (q0, q1) Skip ts' -> mapEitherQueue f (<=) (<=.) fCh' (q0, q1) ts' Cons t ts' -> mapEitherQueue f (<=) (<=.) fCh' (both (union' (<=)) (union' (<=.)) (partitionT t) (q0, q1)) ts' where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) fCh' (Succ t tss) = both (union' (<=)) (union' (<=.)) (partitionT t) (fCh tss) partitionT (BinomTree x ts) = case fCh ts of (q0, q1) -> case f x of Left b -> (insert' (<=) b q0, q1) Right c -> (q0, insert' (<=.) 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 (<=) f1 f2 = case (f1, f2) of (Skip f1', Skip f2') -> Skip (merge (<=) f1' f2') (Skip f1', Cons t2 f2') -> Cons t2 (merge (<=) f1' f2') (Cons t1 f1', Skip f2') -> Cons t1 (merge (<=) f1' f2') (Cons t1 f1', Cons t2 f2') -> Skip (carry (<=) (t1 `cat` t2) f1' f2') (Nil, _) -> f2 (_, Nil) -> f1 where cat = joinBin (<=) -- | 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 (<=) t0 f1 f2 = t0 `seq` case (f1, f2) of (Skip f1', Skip f2') -> Cons t0 (merge (<=) f1' f2') (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2') (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2') (Cons t1 f1', Cons t2 f2') -> Cons t0 (mergeCarry t1 t2 f1' f2') (Nil, _f2) -> incr (<=) t0 f2 (_f1, Nil) -> incr (<=) t0 f1 where cat = joinBin (<=) mergeCarry tA tB = carry (<=) (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 (<=) t f = t `seq` case f of Nil -> Cons t Nil Skip f -> Cons t f Cons t' f' -> Skip (incr (<=) (t `cat` t') f') where cat = joinBin (<=) -- | 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 (<=) t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) | x1 <= 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 ts = case ts 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 pqueue-1.3.1.1/Data/PQueue/Max.hs0000644000000000000000000002753312720103341014506 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- 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 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.Applicative (Applicative(..), (<$>)) import Control.DeepSeq import Data.Monoid import Data.Maybe hiding (mapMaybe) import Data.Foldable (foldl, foldr) import Data.Traversable import qualified Data.PQueue.Min as Min import qualified Data.PQueue.Prio.Max.Internals as Prio import Data.PQueue.Prio.Max.Internals (Down(..)) import Prelude hiding (null, foldr, foldl, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, readListPrecDefault) import Data.Data #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif -- | A priority queue with elements of type @a@. Supports extracting the maximum element. -- Implemented as a wrapper around 'Min.MinQueue'. newtype MaxQueue a = MaxQ (Min.MinQueue (Down a)) # if __GLASGOW_HASKELL__ deriving (Eq, Ord, Data, Typeable) # else deriving (Eq, Ord) # endif instance NFData a => NFData (MaxQueue a) where rnf (MaxQ q) = rnf q instance (Ord a, Show a) => Show (MaxQueue a) where showsPrec p xs = showParen (p > 10) $ showString "fromDescList " . shows (toDescList xs) instance Read a => Read (MaxQueue a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromDescList" <- lexP xs <- readPrec return (fromDescList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \ r -> do ("fromDescList",s) <- lex r (xs,t) <- reads s return (fromDescList xs,t) #endif instance Ord a => Monoid (MaxQueue a) where mempty = empty mappend = union -- | /O(1)/. The empty priority queue. empty :: MaxQueue a empty = MaxQ Min.empty -- | /O(1)/. Is this the empty priority queue? null :: MaxQueue a -> Bool null (MaxQ q) = Min.null q -- | /O(1)/. The number of elements in the queue. size :: MaxQueue a -> Int size (MaxQ q) = Min.size q -- | /O(1)/. Returns the maximum element of the queue. Throws an error on an empty queue. findMax :: MaxQueue a -> a findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax -- | /O(1)/. The top (maximum) element of the queue, if there is one. getMax :: MaxQueue a -> Maybe a getMax (MaxQ q) = unDown <$> Min.getMin q -- | /O(log n)/. Deletes the maximum element of the queue. Does nothing on an empty queue. deleteMax :: Ord a => MaxQueue a -> MaxQueue a deleteMax (MaxQ q) = MaxQ (Min.deleteMin q) -- | /O(log n)/. Extracts the maximum element of the queue. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView -- | /O(log n)/. Extract the top (maximum) element of the sequence, if there is one. maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) maxView (MaxQ q) = case Min.minView q of Nothing -> Nothing Just (Down x, q') -> Just (x, MaxQ q') -- | /O(log n)/. Delete the top (maximum) element of the sequence, if there is one. delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) delete = fmap snd . maxView -- | /O(1)/. Construct a priority queue with a single element. singleton :: a -> MaxQueue a singleton = MaxQ . Min.singleton . Down -- | /O(1)/. Insert an element into the priority queue. insert :: Ord a => a -> MaxQueue a -> MaxQueue a x `insert` MaxQ q = MaxQ (Down x `Min.insert` q) -- | /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) {-# 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) {-# INLINE toList #-} -- | /O(n)/. Returns the elements of the priority queue in no particular order. 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 pqueue-1.3.1.1/Data/PQueue/Prio/0000755000000000000000000000000012720103341014324 5ustar0000000000000000pqueue-1.3.1.1/Data/PQueue/Prio/Min.hs0000644000000000000000000003420612720103341015410 0ustar0000000000000000{-# 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, 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 (..), (<$>)) import Data.Monoid import qualified Data.List as List import Data.Foldable (Foldable, foldl, foldr, foldl') import Data.Traversable import Data.Maybe (fromMaybe) import Data.PQueue.Prio.Internals import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null, foldr) #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 (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (f .: g) x y = f (g x y) uncurry' :: (a -> b -> c) -> (a, b) -> c uncurry' f (a, b) = f a b infixr 8 .: instance Ord k => Monoid (MinPQueue k a) where mempty = empty mappend = union mconcat = unions instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where showsPrec p xs = showParen (p > 10) $ showString "fromAscList " . shows (toAscList xs) instance (Read k, Read a) => Read (MinPQueue k a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromAscList" <- lexP xs <- readPrec return (fromAscList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \ r -> do ("fromAscList",s) <- lex r (xs,t) <- reads s return (fromAscList xs,t) #endif -- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). unions :: Ord k => [MinPQueue k a] -> MinPQueue k a unions = List.foldl union empty -- | /O(1)/. The minimal (key, element) in the queue. Calls 'error' if empty. findMin :: MinPQueue k a -> (k, a) findMin = fromMaybe (error "Error: findMin called on an empty queue") . getMin -- | /O(log n)/. Deletes the minimal (key, element) in the queue. Returns an empty queue -- if the queue is empty. deleteMin :: Ord k => MinPQueue k a -> MinPQueue k a deleteMin = updateMin (const Nothing) -- | /O(log n)/. Delete and find the element with the minimum key. Calls 'error' if empty. deleteFindMin :: Ord k => MinPQueue k a -> ((k, a), MinPQueue k a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on an empty queue") . minViewWithKey -- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. adjustMin :: (a -> a) -> MinPQueue k a -> MinPQueue k a adjustMin = adjustMinWithKey . const -- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. -- If the queue is empty, does nothing. updateMin :: Ord k => (a -> Maybe a) -> MinPQueue k a -> MinPQueue k a updateMin = updateMinWithKey . const -- | /O(log n)/. Retrieves the value associated with the minimal key of the queue, and the queue -- stripped of that element, or 'Nothing' if passed an empty queue. minView :: Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a) minView q = do ((_, a), q') <- minViewWithKey q return (a, q') -- | /O(n)/. Map a function over all values in the queue. map :: (a -> b) -> MinPQueue k a -> MinPQueue k b map = mapWithKey . const -- | /O(n)/. @'mapKeys' f q@ is the queue obtained by applying @f@ to each key of @q@. mapKeys :: Ord k' => (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeys f q = fromList [(f k, a) | (k, a) <- toListU q] -- | /O(n log n)/. Traverses the elements of the queue in ascending order by key. -- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) -- -- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) traverseWithKey f q = case minViewWithKey q of Nothing -> pure empty Just ((k, a), q') -> insertMin k <$> f k a <*> traverseWithKey f q' -- | /O(n)/. Map values and collect the 'Just' results. mapMaybe :: Ord k => (a -> Maybe b) -> MinPQueue k a -> MinPQueue k b mapMaybe = mapMaybeWithKey . const -- | /O(n)/. Map values and separate the 'Left' and 'Right' results. mapEither :: Ord k => (a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) mapEither = mapEitherWithKey . const -- | /O(n)/. Filter all values that satisfy the predicate. filter :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a filter = filterWithKey . const -- | /O(n)/. Filter all values that satisfy the predicate. filterWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a filterWithKey p = mapMaybeWithKey (\ k a -> if p k a then Just a else Nothing) -- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partition :: Ord k => (a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) partition = partitionWithKey . const -- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partitionWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) partitionWithKey p = mapEitherWithKey (\ k a -> if p k a then Left a else Right a) {-# INLINE take #-} -- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. -- (@'take' k q == 'List.take' k ('toAscList' q)@) take :: Ord k => Int -> MinPQueue k a -> [(k, a)] take n = List.take n . toAscList -- | /O(k log n)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. drop :: Ord k => Int -> MinPQueue k a -> MinPQueue k a drop n q | n <= 0 = q | n >= size q = empty | otherwise = drop' n q 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 p = takeWhileFB (uncurry' p) . toAscList where takeWhileFB p xs = build (\ c n -> foldr (\ x z -> if p x then x `c` z else n) n xs) -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a dropWhile = dropWhileWithKey . const -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a dropWhileWithKey p q = case minViewWithKey q of Just ((k, a), q') | p k a -> dropWhileWithKey p q' _ -> q -- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. span :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -- | Equivalent to @'span' ('not' . p)@. break :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) span = spanWithKey . const break p = span (not . p) -- | Equivalent to @('takeWhileWithKey' p q, 'dropWhileWithKey' p q)@. spanWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. breakWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) spanWithKey p q = case minViewWithKey q of Just ((k, a), q') | p k a -> let (kas, q'') = spanWithKey p q' in ((k, a):kas, q'') _ -> ([], q) breakWithKey p = spanWithKey (not .: p) -- | /O(n)/. Build a priority queue from the list of (key, value) pairs. fromList :: Ord k => [(k, a)] -> MinPQueue k a fromList = foldr (uncurry' insert) empty -- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ fromAscList :: [(k, a)] -> MinPQueue k a fromAscList = foldr (uncurry' insertMin) empty -- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ fromDescList :: [(k, a)] -> MinPQueue k a fromDescList = 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 pqueue-1.3.1.1/Data/PQueue/Prio/Internals.hs0000644000000000000000000004465412720103341016634 0ustar0000000000000000{-# LANGUAGE CPP #-} module Data.PQueue.Prio.Internals ( MinPQueue(..), BinomForest(..), BinomHeap, BinomTree(..), Zero(..), Succ(..), LEq, empty, null, size, singleton, insert, 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 import Control.DeepSeq import Data.Monoid (Monoid (..)) import Prelude hiding (null) #if __GLASGOW_HASKELL__ import Data.Data instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where gfoldl f z m = z (foldr (uncurry' insertMin) empty) `f` foldrWithKey (curry (:)) [] m toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.PQueue.Prio.Min.MinPQueue" dataCast2 f = gcast2 f #endif (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (f .: g) x y = f (g x y) first' :: (a -> b) -> (a, c) -> (b, c) first' f (a, c) = (f a, c) second' :: (b -> c) -> (a, b) -> (a, c) second' f (a, b) = (a, f b) uncurry' :: (a -> b -> c) -> (a, b) -> c uncurry' f (a, b) = f a b infixr 8 .: -- | A priority queue where values of type @a@ are annotated with keys of type @k@. -- The queue supports extracting the element with minimum key. data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int k a (BinomHeap k a) #if __GLASGOW_HASKELL__ deriving (Typeable) #endif data BinomForest rk k a = Nil | Skip (BinomForest (Succ rk) k a) | Cons {-# UNPACK #-} !(BinomTree rk k a) (BinomForest (Succ rk) k a) type BinomHeap = BinomForest Zero data BinomTree rk k a = BinomTree k a (rk k a) data Zero k a = Zero data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a) type LEq 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 && k1 == k2 && a1 == a2 && equHeap ts1 ts2 where equHeap ts1 ts2 = case (extract ts1, extract ts2) of (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) -> k1 == k2 && a1 == a2 && equHeap ts1' ts2' (No, No) -> True _ -> False extract = extractForest (<=) Empty == Empty = True _ == _ = False (<>) :: Monoid m => m -> m -> m (<>) = mappend infixr 6 <> instance (Ord k, Ord a) => Ord (MinPQueue k a) where MinPQ _n1 k1 a1 ts1 `compare` MinPQ _n2 k2 a2 ts2 = k1 `compare` k2 <> a1 `compare` a2 <> ts1 `cmpHeap` ts2 where ts1 `cmpHeap` ts2 = case (extract ts1, extract ts2) of (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) -> k1 `compare` k2 <> a1 `compare` a2 <> ts1' `cmpHeap` ts2' (No, Yes{}) -> LT (Yes{}, No) -> GT (No, No) -> EQ extract = extractForest (<=) Empty `compare` Empty = EQ Empty `compare` MinPQ{} = LT MinPQ{} `compare` Empty = GT -- | /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' (<=) -- | Internal helper method, using a specific comparator function. insert' :: LEq k -> k -> a -> MinPQueue k a -> MinPQueue k a insert' _ k a Empty = singleton k a insert' (<=) k a (MinPQ n k' a' ts) | k <= k' = MinPQ (n+1) k a (incr (<=) (tip k' a') ts) | otherwise = MinPQ (n+1) k' a' (incr (<=) (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' :: LEq k -> MinPQueue k a -> MinPQueue k a -> MinPQueue k a union' (<=) (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2) | k1 <= k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2) | otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1) where insMerge k a = carryForest (<=) (tip k a) ts1 ts2 union' _ Empty q2 = q2 union' _ q1 Empty = q1 -- | /O(1)/. The minimal (key, element) in the queue, if the queue is nonempty. getMin :: MinPQueue k a -> Maybe (k, a) getMin (MinPQ _ k a _) = Just (k, a) getMin _ = Nothing -- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a adjustMinWithKey _ Empty = Empty adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts -- | /O(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 _ k a ts) = f k a (foldF ts) where extract = extractForest (<=) 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 z (MinPQ _ k a ts) = foldF (f z k a) ts where extract = extractForest (<=) 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 :: LEq k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a meld (<=) t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) | k1 <= 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 :: LEq k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a mergeForest (<=) f1 f2 = case (f1, f2) of (Skip ts1, Skip ts2) -> Skip (mergeForest (<=) ts1 ts2) (Skip ts1, Cons t2 ts2) -> Cons t2 (mergeForest (<=) ts1 ts2) (Cons t1 ts1, Skip ts2) -> Cons t1 (mergeForest (<=) ts1 ts2) (Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest (<=) (meld (<=) t1 t2) ts1 ts2) (Nil, _) -> f2 (_, Nil) -> f1 -- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. -- Analogous to binary addition when a digit has been carried. carryForest :: LEq k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a carryForest (<=) t0 f1 f2 = t0 `seq` case (f1, f2) of (Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2) (Cons t1 ts1, Skip ts2) -> Skip (carryMeld t0 t1 ts1 ts2) (Skip ts1, Cons t2 ts2) -> Skip (carryMeld t0 t2 ts1 ts2) (Skip ts1, Skip ts2) -> Cons t0 (mergeForest (<=) ts1 ts2) (Nil, _) -> incr (<=) t0 f2 (_, Nil) -> incr (<=) t0 f1 where carryMeld = carryForest (<=) .: meld (<=) -- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. incr :: LEq k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incr (<=) t ts = t `seq` case ts of Nil -> Cons t Nil Skip ts' -> Cons t ts' Cons t' ts' -> Skip (incr (<=) (meld (<=) t t') ts') -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr' (\ _ _ -> True)@. incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incrMin t@(BinomTree k 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 :: LEq k -> Int -> BinomHeap k a -> MinPQueue k a extractHeap (<=) n ts = n `seq` case extractForest (<=) 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 :: LEq 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 (<=) (Just t) (Extract k a (Succ t' ts) tss) = Extract k a ts (Skip (incr (<=) (meld (<=) 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 :: LEq k -> BinomForest rk k a -> MExtract rk k a extractForest _ Nil = No extractForest (<=) (Skip tss) = case extractForest (<=) tss of No -> No Yes ex -> Yes (incrExtract (<=) Nothing ex) extractForest (<=) (Cons t@(BinomTree k a ts) tss) = Yes $ case extractForest (<=) tss of Yes ex@(Extract k' _ _ _) | k' incrExtract (<=) (Just t) ex _ -> Extract k a ts (Skip tss) where a a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b mapForest f fCh ts = case ts 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 :: LEq k -> (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> BinomForest rk k a -> MinPQueue k b mapMaybeF (<=) f fCh ts = case ts of Nil -> Empty Skip ts' -> mapMaybeF (<=) f fCh' ts' Cons (BinomTree k a ts) ts' -> insF k a (fCh ts) (mapMaybeF (<=) f fCh' ts') where insF k a = maybe id (insert' (<=) k) (f k a) .: union' (<=) 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 :: LEq 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 (<=) f fCh ts = case ts of Nil -> (Empty, Empty) Skip ts' -> mapEitherF (<=) f fCh' ts' Cons (BinomTree k a ts) ts' -> insF k a (fCh ts) (mapEitherF (<=) f fCh' ts') where insF k a = either (first' . insert' (<=) k) (second' . insert' (<=) k) (f k a) .: (union' (<=) `both` union' (<=)) 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 z (MinPQ _ k a ts) = foldlWithKeyF_ (\ k a z -> f z k a) (const id) ts (f z k a) 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 ts = case ts 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 ts z = case ts of Nil -> z Skip ts' -> foldrWithKeyF_ f fCh' ts' z Cons (BinomTree k a ts) ts' -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z)) 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 ts = case ts 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 ts = case ts 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 z = z seqSpine (MinPQ _ _ _ ts) z = ts `seqSpineF` z 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 pqueue-1.3.1.1/Data/PQueue/Prio/Max.hs0000644000000000000000000004324412720103341015414 0ustar0000000000000000{-# 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, 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 hiding (empty) import Control.Arrow import Data.Monoid import qualified Data.List as List import Data.Foldable (Foldable, foldr, foldl) import Data.Traversable import Data.Maybe hiding (mapMaybe) import Data.PQueue.Prio.Max.Internals import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null, foldr, foldl) import qualified Data.PQueue.Prio.Min as Q #ifdef __GLASGOW_HASKELL__ import 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 first' :: (a -> b) -> (a, c) -> (b, c) first' f (a, c) = (f a, c) instance Ord k => Monoid (MaxPQueue k a) where mempty = empty mappend = union mconcat = unions instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where showsPrec p xs = showParen (p > 10) $ showString "fromDescList " . shows (toDescList xs) instance (Read k, Read a) => Read (MaxPQueue k a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromDescList" <- lexP xs <- readPrec return (fromDescList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \ r -> do ("fromDescList",s) <- lex r (xs,t) <- reads s return (fromDescList xs,t) #endif instance Functor (MaxPQueue k) where fmap f (MaxPQ q) = MaxPQ (fmap f q) instance Ord k => Foldable (MaxPQueue k) where foldr f z (MaxPQ q) = foldr f z q foldl f z (MaxPQ q) = foldl f z q instance Ord k => Traversable (MaxPQueue k) where traverse f (MaxPQ q) = MaxPQ <$> traverse f q -- | /O(1)/. Returns the empty priority queue. empty :: MaxPQueue k a empty = MaxPQ Q.empty -- | /O(1)/. Constructs a singleton priority queue. singleton :: k -> a -> MaxPQueue k a singleton k a = MaxPQ (Q.singleton (Down k) a) -- | Amortized /O(1)/, worst-case /O(log n)/. Inserts -- an element with the specified key into the queue. insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a insert k a (MaxPQ q) = MaxPQ (Q.insert (Down k) a q) -- | Amortized /O(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 ('toAscList' 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 ('toAscList' 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 z (MaxPQ q) = Q.foldlWithKey (\ z -> f z . unDown) z 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') ('toAscList' 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) ('toAscList' 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 ascending order. keys :: Ord k => MaxPQueue k a -> [k] keys = fmap fst . toDescList -- | /O(n log n)/. Return all elements of the queue in ascending 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 'toAscList'. -- -- 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 z (MaxPQ q) = Q.foldlWithKeyU (\ z -> f z . unDown) z 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 pqueue-1.3.1.1/Data/PQueue/Prio/Max/0000755000000000000000000000000012720103341015051 5ustar0000000000000000pqueue-1.3.1.1/Data/PQueue/Prio/Max/Internals.hs0000644000000000000000000000226712720103341017353 0ustar0000000000000000{-# LANGUAGE CPP #-} module Data.PQueue.Prio.Max.Internals where import Control.Applicative import Control.DeepSeq import Data.Foldable import Data.Traversable # if __GLASGOW_HASKELL__ import Data.Data # 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 pqueue-1.3.1.1/include/0000755000000000000000000000000012720103341012761 5ustar0000000000000000pqueue-1.3.1.1/include/Typeable.h0000644000000000000000000000444212720103341014703 0ustar0000000000000000{- -------------------------------------------------------------------------- // Macros to help make Typeable instances. // // INSTANCE_TYPEABLEn(tc,tcname,"tc") defines // // instance Typeable/n/ tc // instance Typeable a => Typeable/n-1/ (tc a) // instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) // ... // instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) // -------------------------------------------------------------------------- -} #ifndef TYPEABLE_H #define TYPEABLE_H #define INSTANCE_TYPEABLE0(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \ instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } #ifdef __GLASGOW_HASKELL__ -- // For GHC, the extra instances follow from general instance declarations -- // defined in Data.Typeable. #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \ instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE2(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \ instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE3(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \ instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } #else /* !__GLASGOW_HASKELL__ */ #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname = mkTyCon str; \ instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } #define INSTANCE_TYPEABLE2(tycon,tcname,str) \ tcname = mkTyCon str; \ instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ instance Typeable a => Typeable1 (tycon a) where { \ typeOf1 = typeOf1Default }; \ instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ typeOf = typeOfDefault } #define INSTANCE_TYPEABLE3(tycon,tcname,str) \ tcname = mkTyCon str; \ instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ instance Typeable a => Typeable2 (tycon a) where { \ typeOf2 = typeOf2Default }; \ instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ typeOf1 = typeOf1Default }; \ instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ typeOf = typeOfDefault } #endif /* !__GLASGOW_HASKELL__ */ #endif pqueue-1.3.1.1/Control/0000755000000000000000000000000012720103341012756 5ustar0000000000000000pqueue-1.3.1.1/Control/Applicative/0000755000000000000000000000000012720103341015217 5ustar0000000000000000pqueue-1.3.1.1/Control/Applicative/Identity.hs0000644000000000000000000000044312720103341017345 0ustar0000000000000000module Control.Applicative.Identity where import Control.Applicative 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)