Thu Mar 4 11:22:34 CST 2010 wasserman.louis@gmail.com
* Data.PQueue with binomial heaps
New patches:
[Data.PQueue with binomial heaps
wasserman.louis@gmail.com**20100304172234
Ignore-this: ff30638168b7add7d1fd1e5473289500
] {
adddir ./Data/PQueue
addfile ./Data/PQueue.hs
hunk ./Data/PQueue.hs 1
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.MinQueue
+-- Copyright : (c) Louis Wasserman 2010
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- General purpose priority queue, supporting extract-maximum operations.
+--
+-- This module reexports "Data.PQueue.Min". If you need to use a max-queue,
+-- you should import "Data.PQueue.Max".
+---------------------------------------------------------------------------
+module Data.PQueue (
+ PQueue,
+ module Data.PQueue.Min) where
hunk ./Data/PQueue.hs 20
+import Data.PQueue.Min
+
+type PQueue = MinQueue
addfile ./Data/PQueue/Max.hs
hunk ./Data/PQueue/Max.hs 1
+{-# LANGUAGE CPP #-}
hunk ./Data/PQueue/Max.hs 3
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.MinQueue.Max
+-- Copyright : (c) Louis Wasserman 2010
+-- License : BSD-style
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- General purpose priority queue, supporting extract-maximum operations.
+--
+-- An amortized running time is given for each operation, with /n/ referring
+-- to the length of the sequence and /i/ 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 strictly, ensuring that computations happen
+-- as they are performed. Note that this module is a small wrapper around
+-- "Data.PQueue.Min".
+--
+-- /WARNING:/ 'toList' and 'toAscList' are /not/ equivalent, unlike for example
+-- "Data.Map".
+-----------------------------------------------------------------------------
+module Data.PQueue.Max(
+ MaxQueue,
+ -- * Basic operations
+ empty,
+ null,
+ size,
+ -- * Query operations
+ ViewQ(..),
+ top,
+ delete,
+ extract,
+ -- * Construction operations
+ singleton,
+ insert,
+ union,
+ unions,
+ intersection,
+ difference,
+ -- * Fold\/Functor\/Traversable variations
+ mapMonotonic,
+ foldrQueue,
+ foldlQueue,
+ traverseMonotonic,
+ -- * List operations
+ toList,
+ toDescList,
+ fromList,
+ fromDescList) where
+
+import Control.Applicative (Applicative(..), (<$>))
+
+import Data.Monoid
+import Data.Foldable hiding (toList)
+import Data.Traversable
+
+import qualified Data.PQueue.Min as Min
+
+import Prelude hiding (foldr, foldl, null)
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (build)
+import Text.Read (Lexeme(Ident), lexP, parens, prec,
+ readPrec, readListPrec, readListPrecDefault)
+#endif
+
+-- | A priority queue implementation. Implemented as a wrapper around "Data.PQueue.Min".
+-- /Warning/: the 'Functor', 'Foldable', and 'Traversable' instances of this type /ignore ordering/.
+-- For 'Functor', it is guaranteed that if @f@ is a monotonic function, then @'fmap' f@ on a valid
+-- 'MaxQueue' will return a valid 'MaxQueue'. An analogous guarantee holds for 'traverse'. (Note:
+-- if passed constant-time operations, every function in 'Functor', 'Foldable', and 'Traversable'
+-- will run in /O(n)/.)
+--
+-- If you wish to perform folds on a priority queue that respect order, use 'foldrQueue' or
+-- 'foldlQueue'.
+newtype MaxQueue a = MaxQ {unMaxQ :: Min.MinQueue (Down a)}
+newtype Down a = Down a deriving (Eq)
+
+instance Ord a => Ord (Down a) where
+ Down x `compare` Down y = compare y x
+ Down x <= Down y = y <= x
+ Down x < Down y = y < x
+ Down x >= Down y = y >= x
+ Down x > Down y = y > x
+
+instance Ord a => Eq (MaxQueue a) where
+ q1 == q2 = toDescList q1 == toDescList q2
+
+instance Ord a => Ord (MaxQueue a) where
+ q1 `compare` q2 = toDescList q1 `compare` toDescList q2
+
+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
+
+data ViewQ a = EmptyQ -- ^ empty queue
+ | a :^ MaxQueue a -- ^ the top (maximum) of the queue and the rest of the queue
+ deriving (Eq, Ord, Read, Show)
+
+instance Functor ViewQ where
+ fmap f (a :^ q) = f a :^ fmap f q
+ fmap _ _ = EmptyQ
+
+instance Foldable ViewQ where
+ foldr _ z EmptyQ = z
+ foldr f z (a :^ q) = a `f` foldr f z q
+ foldl _ z EmptyQ = z
+ foldl f z (a :^ q) = foldl f (z `f` a) q
+
+instance Traversable ViewQ where
+ traverse _ EmptyQ = pure EmptyQ
+ traverse f (a :^ q) = (:^) <$> f a <*> traverse f q
+
+-- | /O(log n)/. The top (maximum) element of the queue, if there is one.
+top :: Ord a => MaxQueue a -> Maybe a
+top q = case extract q of
+ EmptyQ -> Nothing
+ x :^ _ -> Just x
+
+-- | /O(log n)/. Extract the top (maximum) element of the sequence, if there is one.
+extract :: Ord a => MaxQueue a -> ViewQ a
+extract (MaxQ q) = case Min.extract q of
+ Min.EmptyQ -> EmptyQ
+ (Min.:^) (Down a) q'
+ -> a :^ 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 (MaxQ q) = MaxQ <$> Min.delete q
+
+-- | /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
+insert x (MaxQ q) = MaxQ (Min.insert (Down x) q)
+
+-- | /O(log (min(n,m)))/. Take the union of two priority queues.
+union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a
+MaxQ q1 `union` MaxQ q2 = MaxQ (Min.union q1 q2)
+
+-- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@.
+unions :: Ord a => [MaxQueue a] -> MaxQueue a
+unions = foldl union empty
+
+-- | /O(n log n + m log m)/. Take the intersection of two priority queues.
+intersection :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a
+MaxQ q1 `intersection` MaxQ q2 = MaxQ (Min.intersection q1 q2)
+
+-- | /O(n log n + m log m)/. Takes the difference of two priority queues.
+difference :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a
+MaxQ q1 `difference` MaxQ q2 = MaxQ (Min.difference q1 q2)
+
+-- | /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) -> MaxQueue a -> MaxQueue b
+mapMonotonic = fmap
+
+-- | /O(n)/. Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation.
+-- If the function is not monotonic, the result is undefined.
+traverseMonotonic :: Applicative f => (a -> f b) -> MaxQueue a -> f (MaxQueue b)
+traverseMonotonic = traverse
+
+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
+
+instance Functor MaxQueue where
+ fmap f (MaxQ q) = MaxQ (fmap (fmap f) q)
+
+instance Foldable MaxQueue where
+ foldr f z (MaxQ q) = foldr (flip (foldr f)) z q
+ foldl f z (MaxQ q) = foldl (foldl f) z q
+
+instance Traversable MaxQueue where
+ traverse f (MaxQ q) = MaxQ <$> traverse (traverse f) q
+
+foldrQueue :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b
+foldrQueue f z (MaxQ q) = Min.foldrQueue (flip (foldr f)) z q
+
+foldlQueue :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b
+foldlQueue f z (MaxQ q) = Min.foldlQueue (foldl f) z q
+
+{-# INLINE toDescList #-}
+-- | /O(n log n)/. Extracts the elements of the priority queue in descending order.
+toDescList :: Ord a => MaxQueue a -> [a]
+#ifdef __GLASGOW_HASKELL__
+toDescList q = build (\ c nil -> foldrQueue c nil q)
+#else
+toDescList = foldrQueue (:) []
+#endif
+
+{-# INLINE toList #-}
+-- | /O(n)/. Returns the elements of the priority queue in no particular order.
+toList :: MaxQueue a -> [a]
+#ifdef __GLASGOW_HASKELL__
+toList q = build (\ c nil -> foldr c nil q)
+#else
+toList = foldr (:) []
+#endif
+
+{-# INLINE fromDescList #-}
+-- | /O(n)/. Constructs a priority queue from an 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
addfile ./Data/PQueue/Min.hs
hunk ./Data/PQueue/Min.hs 1
+{-# LANGUAGE CPP #-}
hunk ./Data/PQueue/Min.hs 3
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.MinQueue.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 /i/ 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 strictly, ensuring that computations happen
+-- as they are performed.
+--
+-- /WARNING:/ 'toList' and 'toAscList' are /not/ equivalent, unlike for example
+-- "Data.Map".
+-----------------------------------------------------------------------------
+module Data.PQueue.Min (
+ MinQueue,
+ -- * Basic operations
+ empty,
+ null,
+ size,
+ -- * Query operations
+ ViewQ(..),
+ top,
+ delete,
+ extract,
+ -- * Construction operations
+ singleton,
+ insert,
+ union,
+ unions,
+ intersection,
+ difference,
+ -- * Fold\/Functor\/Traversable variations
+ mapMonotonic,
+ foldrQueue,
+ foldlQueue,
+ traverseMonotonic,
+ -- * List operations
+ toList,
+ toAscList,
+ fromList,
+ fromAscList) where
+
+import Prelude hiding (null, foldr, foldl)
+
+import Control.Applicative (Applicative(..), (<$>))
+
+import Data.Monoid
+import Data.Foldable hiding (toList)
+import Data.Traversable
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (build)
+import Text.Read (Lexeme(Ident), lexP, parens, prec,
+ readPrec, readListPrec, readListPrecDefault)
+#endif
+
+-- | A priority queue implementation. Implemented as a find-min wrapper around a binomial heap.
+-- /Warning/: the 'Functor', 'Foldable', and 'Traversable' instances of this type /ignore ordering/.
+-- For 'Functor', it is guaranteed that if @f@ is a monotonic function, then @'fmap' f@ on a valid
+-- 'MinQueue' will return a valid 'MinQueue'. An analogous guarantee holds for 'traverse'. (Note:
+-- if passed constant-time operations, every function in 'Functor', 'Foldable', and 'Traversable'
+-- will run in /O(n)/.)
+--
+-- If you wish to perform folds on a priority queue that respect order, use 'foldrQueue' or
+-- 'foldlQueue'.
+data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int a !(BinomHeap a)
+type BinomHeap a = BinomForest a Zero
+
+instance Ord a => Eq (MinQueue a) where
+ q1 == q2 = toAscList q1 == toAscList q2
+
+instance Ord a => Ord (MinQueue a) where
+ compare q1 q2 = compare (toAscList q1) (toAscList q2)
+
+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
+
+-- We implement tree ranks in the type system with a nicely elegant approach, as follows.
+--
+-- A binomial tree of rank @0@ with elements of type @e@ has type @'BinomTree' e 'Zero'@.
+-- If a binomial tree of rank @k@ has type @BinomTree e k@, then a binomial tree of rank
+-- @k+1@ has type @'BinomTree' e ('Succ' e k)@. Therefore, we may justifiably label the
+-- second type argument as the /rank/ of the node.
+--
+-- Consider the set-theoretic definition of the natural numbers, in which a number is specified
+-- to be the set of all numbers less than it, and 0 is the empty set. The ranks of binomial
+-- trees are similar: the children of a binomial tree of rank @k@ are a collection of a binomial
+-- tree of every rank less than @k@. We can then /define/ the type representing rank @k@
+-- to be a sequence of a binomial tree of every rank less than @k@. In particular,
+-- @'Succ' e k@ is equivalent to @(BinomTree e k, k)@, since @k@ is a type representing a
+-- sequence of binomial trees of rank less than @k@. We may reasonably define the type
+-- corresponding to @0@ to be @()@, since it should be an unambiguous ``unit.'' This is
+-- nicely analogous to the construction of the natural numbers, where @succ(a) = {a} `union` a@.
+--
+-- Now that we've defined rank types, we note that a binomial tree with a given rank @rk@,
+-- written as @'BinomTree' e rk@, has a root of type @e@ and a set of children of type @rk@.
+-- We may justifiably say, then,
+--
+-- > data BinomTree e rk = BinomTree e rk
+--
+-- Cute!
+--
+-- To implement binomial heaps, in which we may have at most one root of each rank, we define
+-- @'BinomForest' e rk@ to be a binomial forest of roots of rank at least @rk@. Since there is only
+-- one root of each rank, we may either have a binomial forest of rank @rk@ or not, and then
+-- a @BinomForest e (Succ e rk)@ contains the rest of the forest. We also have a 'Nil' constructor,
+-- for when we have no more roots. We maintain the invariant that @Nil@ always follows a @Cons@, but
+-- don't implement that in the type system.
+data BinomForest e rk = Nil | Skip !(BinomForest' e rk) | Cons {-# UNPACK #-} !(BinomTree e rk) !(BinomForest' e rk)
+type BinomForest' e rk = BinomForest e (Succ e rk)
+
+instance Ord e => Monoid (BinomForest e rk) where
+ mempty = Nil
+ mappend = merge (<=)
+
+data BinomTree e rk = BinomTree e rk
+type BinomTree' e rk = BinomTree e (Succ e rk)
+data Succ e rk = Succ {-# UNPACK #-} !(BinomTree e rk) rk
+type Zero = ()
+
+-- 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
+
+-- queries
+
+-- | View of the top of a sequence. Note: the 'Functor', 'Foldable', and 'Traversable' instances
+-- have the same caveats as the instances for 'MinQueue'.
+data ViewQ a = EmptyQ -- ^ empty queue
+ | a :^ MinQueue a -- ^ the top (minimum) of the queue and the rest of the queue
+ deriving (Eq, Ord, Read, Show)
+
+instance Functor ViewQ where
+ fmap f (a :^ q) = f a :^ fmap f q
+ fmap _ _ = EmptyQ
+
+instance Foldable ViewQ where
+ foldr _ z EmptyQ = z
+ foldr f z (a :^ q) = a `f` foldr f z q
+ foldl _ z EmptyQ = z
+ foldl f z (a :^ q) = foldl f (z `f` a) q
+
+instance Traversable ViewQ where
+ traverse _ EmptyQ = pure EmptyQ
+ traverse f (a :^ q) = (:^) <$> f a <*> traverse f q
+
+-- | /O(1)/. View the top (minimum) element of the queue, if there is one.
+top :: Ord a => MinQueue a -> Maybe a
+top q = case extract q of
+ EmptyQ -> Nothing
+ x :^ _ -> Just x
+
+-- | /O(log n)/. Extract the top (minimum) element of the sequence, if there is one.
+extract :: Ord a => MinQueue a -> ViewQ a
+extract Empty = EmptyQ
+extract (MinQueue n x f) = x :^ delete' n f
+
+-- | /O(log n)/. Delete the top element of the sequence, if there is one.
+delete :: Ord a => MinQueue a -> Maybe (MinQueue a)
+delete q = case extract q of
+ EmptyQ -> Nothing
+ _ :^ q' -> Just q'
+
+-- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root.
+delete' :: Ord a => Int -> BinomHeap a -> MinQueue a
+delete' n f = n `seq` case extractBin (<=) f of
+ NoExtract -> Empty
+ YesExtract x' _ f'
+ -> MinQueue (n-1) x' f'
+
+-- | 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 e rk@ 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 @YesExtract 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 a 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 e rk = NoExtract | YesExtract e rk (BinomForest e rk)
+
+-- | 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 :: (e -> e -> Bool) -> BinomForest e rk -> Extract e rk
+extractBin _ Nil = NoExtract
+extractBin (<=) (Skip f) = case extractBin (<=) f of
+ NoExtract -> NoExtract
+ YesExtract minKey (Succ kChild kChildren) f' ->
+ YesExtract minKey kChildren (Cons kChild f')
+extractBin (<=) (Cons t@(BinomTree x ts) f) = case extractBin (<=) f of
+ YesExtract minKey (Succ kChild kChildren) f'
+ | minKey <= x -> YesExtract minKey kChildren (Skip (carry1 (<=) (t `cat` kChild) f'))
+ _ -> YesExtract x ts (Skip f)
+ where cat = joinBin (<=)
+
+-- | /O(1)/. Construct a priority queue with a single element.
+singleton :: a -> MinQueue a
+singleton x = MinQueue 1 x Nil
+
+-- | /O(1)/. Insert an element into the priority queue.
+insert :: Ord a => a -> MinQueue a -> MinQueue a
+insert x' (MinQueue n x f)
+ | x' <= x = MinQueue (n+1) x' (insertBin x f)
+ | otherwise = MinQueue (n+1) x (insertBin x' f)
+ where insertBin = carry1 (<=) . tip
+insert x Empty = singleton x
+
+-- | /O(log (min(n,m)))/. Take the union of two priority queues.
+union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a
+Empty `union` q = q
+q `union` Empty = q
+MinQueue n1 x1 f1 `union` 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 the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@.
+unions :: Ord a => [MinQueue a] -> MinQueue a
+unions = foldl union Empty
+
+-- | /O(n log n + m log m)/. Take the intersection of two priority queues.
+intersection :: Ord a => MinQueue a -> MinQueue a -> MinQueue a
+Empty `intersection` _ = Empty
+_ `intersection` Empty = Empty
+MinQueue _ x1 f1 `intersection` MinQueue _ x2 f2 = intersectBin (<=) compare x1 f1 x2 f2
+
+-- Takes the intersection of two binomial heaps. Essentially, this is just the algorithm
+-- for intersecting two sorted lists, except unconsing is replaced by dequeueing.
+-- Not particularly necessary, but interesting to have just for grins.
+intersectBin :: (a -> a -> Bool) -> (a -> a -> Ordering) -> a -> BinomHeap a -> a -> BinomHeap a -> MinQueue a
+intersectBin (<=) cmp = intersect where
+ intersect x1 f1 x2 f2 = case (cmp x1 x2, extractBin (<=) f1, extractBin (<=) f2) of
+ (LT, YesExtract x1' _ f1', _)
+ -> intersect x1' f1' x2 f2
+ (EQ, YesExtract x1' _ f1', YesExtract x2' _ f2')
+ -> x1 `insertMinQ` intersect x1' f1' x2' f2'
+ (EQ, _, _)
+ -> singleton x1
+ (GT, _, YesExtract x2' _ f2')
+ -> intersect x1 f1 x2' f2'
+ _ -> Empty
+
+-- | /O(n log n + m log m)/. Takes the difference of two priority queues.
+difference :: Ord a => MinQueue a -> MinQueue a -> MinQueue a
+queue `difference` Empty
+ = queue
+Empty `difference` _
+ = Empty
+MinQueue n1 x1 f1 `difference` MinQueue _ x2 f2
+ = differenceBin (<=) compare n1 x1 f1 x2 f2
+
+-- Takes the difference of two binomial heaps. Essentially, this is just the algorithm
+-- for the difference of two sorted lists, except unconsing is replaced by dequeueing.
+-- Not particularly necessary, but interesting to have just for grins.
+differenceBin :: (a -> a -> Bool) -> (a -> a -> Ordering) -> Int -> a -> BinomHeap a -> a -> BinomHeap a -> MinQueue a
+differenceBin (<=) cmp = diffBin where
+ diffBin n x1 f1 x2 f2 = n `seq` case (cmp x1 x2, extractBin (<=) f1, extractBin (<=) f2) of
+ (LT, YesExtract x1' _ f1', _)
+ -> x1 `insertMinQ` diffBin (n-1) x1' f1' x2 f2
+ (LT, _, _)
+ -> singleton x1
+ (EQ, YesExtract x1' _ f1', YesExtract x2' _ f2')
+ -> diffBin (n-1) x1' f1' x2' f2'
+ (EQ, YesExtract x1' _ f1', _)
+ -> MinQueue n x1' f1'
+ (EQ, _, _)
+ -> Empty
+ (GT, _, YesExtract x2' _ f2')
+ -> diffBin n x1 f1 x2' f2'
+ (GT, _, _)
+ -> MinQueue n x1 f1
+
+{-# INLINE tip #-}
+-- | Constructs a binomial tree of rank 0.
+tip :: e -> BinomTree e ()
+tip x = BinomTree x ()
+
+-- | 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 :: (e -> e -> Bool) -> BinomForest e rk -> BinomForest e rk -> BinomForest e rk
+merge (<=) f1 f2 = case (f1, f2) of
+ (Nil, _) -> f2
+ (_, Nil) -> f1
+ (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')
+ 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 :: (e -> e -> Bool) -> BinomTree e rk -> BinomForest e rk -> BinomForest e rk -> BinomForest e rk
+carry (<=) t0 f1 f2 = t0 `seq` case (f1, f2) of
+ (Nil, Nil) -> Cons t0 Nil
+ (Nil, Skip f2') -> Cons t0 f2'
+ (Skip f1', Nil) -> Cons t0 f1'
+ (Nil, Cons t2 f2') -> Skip (carry1 (<=) (t0 `cat` t2) f2')
+ (Cons t1 f1', Nil) -> Skip (carry1 (<=) (t0 `cat` t1) f1')
+ (Skip f1', Skip f2') -> Cons t0 (merge (<=) f1' f2')
+ (Skip f1', Cons t2 f2') -> Skip (carry (<=) (t0 `cat` t2) f1' f2')
+ (Cons t1 f1', Skip f2') -> Skip (carry (<=) (t0 `cat` t1) f1' f2')
+ (Cons t1 f1', Cons t2 f2')
+ -> Cons t0 (carry (<=) (t1 `cat` t2) f1' f2')
+ where cat = joinBin (<=)
+
+-- | 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.
+carry1 :: (e -> e -> Bool) -> BinomTree e rk -> BinomForest e rk -> BinomForest e rk
+carry1 (<=) t f = t `seq` case f of
+ Nil -> Cons t Nil
+ Skip f -> Cons t f
+ Cons t' f' -> Skip (carry1 (<=) (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 :: (e -> e -> Bool) -> BinomTree e rk -> BinomTree e rk -> BinomTree' e rk
+joinBin (<=) t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2)
+ | x1 <= x2 = BinomTree x1 (Succ t2 ts1)
+ | otherwise = BinomTree x2 (Succ t1 ts2)
+
+-- folding
+
+-- | /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 = fmap
+
+-- | /O(n)/. Assumes that the function it is given is monotonic, in some sense, and performs the 'traverse' operation.
+-- If the function is not monotonic, the result is undefined.
+traverseMonotonic :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b)
+traverseMonotonic = traverse
+
+instance Functor MinQueue where
+ fmap _ Empty = Empty
+ fmap f (MinQueue n x forest) = MinQueue n (f x) (mapForest f (const ()) forest)
+
+mapForest :: (a -> b) -> (rk -> rk') -> BinomForest a rk -> BinomForest b rk'
+mapForest f fCh forest = case forest of
+ Nil -> Nil
+ Skip forest'
+ -> Skip (fF' forest')
+ Cons t forest'
+ -> Cons (fT t) (fF' forest')
+ where fT (BinomTree x ts) = BinomTree (f x) (fCh ts)
+ fCh' (Succ t ts) = Succ (fT t) (fCh ts)
+ fF' = mapForest f fCh'
+
+instance Foldable MinQueue where
+ foldr _ n Empty = n
+ foldr c n (MinQueue _ x f) = x `c` foldrUnord c n (const id) f
+ foldMap _ Empty = mempty
+ foldMap f (MinQueue _ x forest) = f x `mappend` foldMap0 mappend mempty f forest
+
+-- | The initial level of 'foldMap'. Avoids unnecessary @'mappend' 'mempty'@ computations.
+foldMap0 :: (m -> m -> m) -> m -> (a -> m) -> BinomHeap a -> m
+foldMap0 (><) zero f forest = case forest of
+ Nil -> zero
+ Skip forest'
+ -> fF' forest'
+ Cons (BinomTree x _) forest'
+ -> f x >< fF' forest'
+ where fF' = foldMapUnord (><) zero f (\ (Succ (BinomTree x _) _) -> f x)
+
+-- | A recursive implementation of 'foldMap' capable of working up to trees of arbitrary rank.
+-- Does not respect ordering of the elements.
+foldMapUnord :: (m -> m -> m) -> m -> (a -> m) -> (rk -> m) -> BinomForest a rk -> m
+foldMapUnord (><) zero f fCh forest = case forest of
+ Nil -> zero
+ Skip forest' -> fF' forest'
+ Cons t forest' -> fT t >< fF' forest'
+ where fT (BinomTree x ts) = f x >< fCh ts
+ fCh' (Succ t tss) = fT t >< fCh tss
+ fF' = foldMapUnord (><) zero f fCh'
+
+-- | 'foldr' implementation on the binomial forest. Does not respect ordering of the elements.
+foldrUnord :: (a -> b -> b) -> b -> (rk -> b -> b) -> BinomForest a rk -> b
+foldrUnord c n cCh forest = case forest of
+ Nil -> n
+ Skip f' -> cF' f'
+ Cons t f' -> t `cT` cF' f'
+ where cT (BinomTree x ts) = c x . cCh ts
+ cCh' (Succ t tss) = cT t . cCh tss
+ cF' = foldrUnord c n cCh'
+
+instance Traversable MinQueue where
+ traverse _ Empty = pure Empty
+ traverse f (MinQueue n x forest)
+ = MinQueue n <$> f x <*> traverseBin f (const (pure ())) forest
+
+traverseBin :: Applicative f => (a -> f b) -> (rk -> f rk') -> BinomForest a rk -> f (BinomForest b rk')
+traverseBin f fCh forest = case forest of
+ Nil -> pure Nil
+ Skip forest'
+ -> Skip <$> fF' forest'
+ Cons t forest'
+ -> Cons <$> fT t <*> fF' forest'
+ where fF' = traverseBin f fCh'
+ fT (BinomTree x ts) = BinomTree <$> f x <*> fCh ts
+ fCh' (Succ t tss) = Succ <$> fT t <*> fCh tss
+
+{-# INLINE toAscList #-}
+-- | /O(n log n)/. Extracts the elements of the priority queue in ascending order.
+toAscList :: Ord a => MinQueue a -> [a]
+#ifdef __GLASGOW_HASKELL__
+toAscList q = build (\ c nil -> foldrQueue c nil q)
+#else
+toAscList = foldrQueue (:) []
+#endif
+
+{-# INLINE toList #-}
+-- | /O(n)/. Returns the elements of the priority queue in no particular order.
+toList :: MinQueue a -> [a]
+#ifdef __GLASGOW_HASKELL__
+toList q = build (\ c nil -> foldr c nil q)
+#else
+toList = foldr (:) []
+#endif
+
+-- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order.
+foldrQueue :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b
+foldrQueue c n (MinQueue _ x f) = x `c` foldrOrd (<=) c n f
+foldrQueue _ n _ = n
+
+-- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order.
+foldlQueue :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b
+foldlQueue f z (MinQueue _ x forest) = foldlOrd (<=) f (z `f` x) forest
+foldlQueue _ z _ = z
+
+-- | Right fold on a binomial forest. Respects order.
+foldrOrd :: (a -> a -> Bool) -> (a -> b -> b) -> b -> BinomHeap a -> b
+foldrOrd (<=) c n = foldQ0 where
+ foldQ0 = foldQ1 . extractBin (<=)
+ foldQ1 NoExtract = n
+ foldQ1 (YesExtract x _ f)
+ = x `c` foldQ0 f
+
+-- | Left fold on a binomial forest. Respects order.
+foldlOrd :: (a -> a -> Bool) -> (b -> a -> b) -> b -> BinomHeap a -> b
+foldlOrd (<=) f z = foldlQ0 z where
+ foldlQ0 z = foldlQ1 z . extractBin (<=)
+ foldlQ1 z NoExtract = z
+ foldlQ1 z (YesExtract x _ f')
+ = foldlQ0 (z `f` x) f'
+
+
+{-# 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
+
+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 e rk -> BinomForest e rk -> BinomForest e rk
+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)
+
+{-# INLINE fromList #-}
+-- | /O(n log n)/. Constructs a priority queue from an unordered list.
+fromList :: Ord a => [a] -> MinQueue a
+fromList = foldr insert Empty
hunk ./containers.cabal 36
Data.Graph
Data.Sequence
Data.Tree
+ Data.PQueue
+ Data.PQueue.Min
+ Data.PQueue.Max
}
if impl(ghc) {
extensions: DeriveDataTypeable, MagicHash, Rank2Types
}
Context:
[Tweak layout to work with the alternative layout rule
Ian Lynagh **20091129154519]
[Disable building Data.Sequence (and dependents) for nhc98.
Malcolm.Wallace@cs.york.ac.uk**20091124025653
There is some subtlety of polymorphically recursive datatypes and
type-class defaulting that nhc98's type system barfs over.
]
[Fix another instance of non-ghc breakage.
Malcolm.Wallace@cs.york.ac.uk**20091123092637]
[Add #ifdef around ghc-only (<$) as member of Functor class.
Malcolm.Wallace@cs.york.ac.uk**20091123085155]
[Fix broken code in non-GHC branch of an ifdef.
Malcolm.Wallace@cs.york.ac.uk**20091123084824]
[doc bugfix: correct description of index argument
Ross Paterson **20091028105532
Ignore-this: 9790e7bf422c4cb528722c03cfa4fed9
As noted by iaefai on the libraries list.
Please merge to STABLE.
]
[Bump version to 0.3.0.0
Ian Lynagh **20090920141847]
[update base dependency
Ross Paterson **20090916073125
Ignore-this: ad382ffc6c6a18c15364e6c072f19edb
The package uses mkNoRepType and Data.Functor, which were not in the
stable branch of base-4.
]
[add fast version of <$ for Seq
Ross Paterson **20090916072812
Ignore-this: 5a39a7d31d39760ed589790b1118d240
]
[new methods for Data.Sequence (proposal #3271)
Ross Paterson **20090915173324
Ignore-this: cf17bedd709a6ab3448fd718dcdf62e7
Adds a lot of new methods to Data.Sequence, mostly paralleling those
in Data.List. Several of these are significantly faster than versions
implemented with the previous public interface. In particular, replicate
takes O(log n) time and space instead of O(n).
(by Louis Wasserman)
]
[Fix "Cabal check" warnings
Ian Lynagh **20090811215900]
[TAG 2009-06-25
Ian Lynagh **20090625160202]
Patch bundle hash:
7b157605a4dbb34b789009b9de1873b5ae0a190f