pqueue 1.4.2.0 → 1.4.3.0
raw patch · 8 files changed
+208/−212 lines, 8 filesdep +indexed-traversabledep ~base
Dependencies added: indexed-traversable
Dependency ranges changed: base
Files
- CHANGELOG.md +18/−12
- pqueue.cabal +5/−4
- src/BinomialQueue/Internals.hs +65/−87
- src/Data/PQueue/Internals.hs +11/−20
- src/Data/PQueue/Internals/Down.hs +4/−1
- src/Data/PQueue/Max.hs +1/−0
- src/Data/PQueue/Prio/Internals.hs +88/−87
- src/Data/PQueue/Prio/Max/Internals.hs +16/−1
CHANGELOG.md view
@@ -1,7 +1,13 @@ # Revision history for pqueue -## 1.4.2.0+## 1.4.3.0 -- 2022-10-30 + * Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable).+ ([#85](https://github.com/lspitzner/pqueue/pull/85))+ * Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86))++## 1.4.2.0 -- 2022-06-19+ * Overall performance has improved greatly, especially when there are many insertions and/or merges in a row. Insertion, deletion, and merge are now *worst case* logarithmic, while maintaining their previous amortized@@ -25,23 +31,23 @@ * Fixed `Data.PQueue.Max.map` to work on `MaxQueue`s. ([#76](https://github.com/lspitzner/pqueue/pull/76)) -## 1.4.1.4 -- 2021-12-04+## 1.4.1.4 -- 2021-12-04 * Maintenance release for ghc-9.0 & ghc-9.2 support * Change nix-setup to use the seaaye tool -## 1.4.1.3 -- 2020-06-06+## 1.4.1.3 -- 2020-06-06 * Maintenance release * Add missing documentation * Add nix-expressions for testing against different compilers/package sets -## 1.4.1.2 -- 2018-09-26+## 1.4.1.2 -- 2018-09-26 * Maintenance release for ghc-8.6 * Drop support for ghc<7.10 -## 1.4.1.1 -- 2018-02-11+## 1.4.1.1 -- 2018-02-11 * Remove/replace buggy `insertBehind` implementation. @@ -52,35 +58,35 @@ * Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release * Drop support for ghc<7.4 -## 1.3.2.3 -- 2017-08-01+## 1.3.2.3 -- 2017-08-01 * Maintenance release for ghc-8.2 -## 1.3.2.2 -- 2017-03-12+## 1.3.2.2 -- 2017-03-12 * Add test-suite from darcs repository for pqueue-1.0.1. -## 1.3.2.1 -- 2017-03-11+## 1.3.2.1 -- 2017-03-11 * Fix documentation errors - complexity on `toList`, `toListU` - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places -## 1.3.2 -- 2016-09-28+## 1.3.2 -- 2016-09-28 * Add function `insertBehind` as a slight variation of `insert` which differs in behaviour for elements the compare equal. -## 1.3.1.1 -- 2016-05-21+## 1.3.1.1 -- 2016-05-21 * Ensure compatibility with ghc-8 * Minor internal refactors -## 1.3.1 -- 2015-10-03+## 1.3.1 -- 2015-10-03 * Add `Monoid` instance for `MaxPQueue` -## 1.3.0 -- 2015-06-23+## 1.3.0 -- 2015-06-23 * Lennart Spitzner starts co-maintaining * new git repository at github.com:lspitzner/pqueue
pqueue.cabal view
@@ -1,5 +1,5 @@ name: pqueue-version: 1.4.2.0+version: 1.4.3.0 category: Data Structures author: Louis Wasserman license: BSD3@@ -15,7 +15,7 @@ bug-reports: https://github.com/lspitzner/pqueue/issues build-type: Simple cabal-version: >= 1.10-tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2+tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.4.2 extra-source-files: CHANGELOG.md README.md@@ -29,8 +29,9 @@ default-language: Haskell2010 build-depends:- { base >= 4.8 && < 4.17+ { base >= 4.8 && < 4.18 , deepseq >= 1.3 && < 1.5+ , indexed-traversable >= 0.1 && < 0.2 } exposed-modules: Data.PQueue.Prio.Min@@ -69,7 +70,7 @@ type: exitcode-stdio-1.0 main-is: PQueueTests.hs build-depends:- { base >= 4.8 && < 4.17+ { base >= 4.8 && < 4.18 , deepseq >= 1.3 && < 1.5 , tasty , tasty-quickcheck
src/BinomialQueue/Internals.hs view
@@ -11,7 +11,6 @@ MExtract(..), Succ(..), Zero(..),- LEq, empty, extractHeap, null,@@ -20,7 +19,6 @@ minView, singleton, insert,- insert', union, unionPlusOne, mapMaybe,@@ -168,9 +166,6 @@ -- | 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.@@ -201,7 +196,7 @@ -- | Retrieves the minimum element of the queue, and the queue stripped of that element, -- or 'Nothing' if passed an empty queue. minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a)-minView (MinQueue ts) = case extractBin (<=) ts of+minView (MinQueue ts) = case extractBin ts of No -> Nothing Yes (Extract x ~Zero ts') -> Just (x, MinQueue ts') @@ -211,11 +206,11 @@ -- | 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' (<=)+insert x (MinQueue ts) = MinQueue (incr (tip x) ts) -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a-union = union' (<=)+union (MinQueue f1) (MinQueue f2) = MinQueue (merge f1 f2) -- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. unions :: Ord a => [MinQueue a] -> MinQueue a@@ -223,11 +218,11 @@ -- | \(O(n)\). Map elements and collect the 'Just' results. mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b-mapMaybe f (MinQueue ts) = mapMaybeQueue f (<=) (const empty) empty ts+mapMaybe f (MinQueue ts) = 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 f (MinQueue ts) = mapEitherQueue f (<=) (<=) (const (empty, empty)) (empty, empty) ts+mapEither f (MinQueue ts) = mapEitherQueue f (const (empty, empty)) (empty, empty) ts -- | \(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.@@ -303,17 +298,9 @@ -- We apply an explicit argument to get foldl' to inline. fromAscList xs = foldl' (flip insertMaxQ') empty xs -insert' :: LEq a -> a -> MinQueue a -> MinQueue a-insert' le x (MinQueue ts)- = MinQueue (incr le (tip x) ts)--{-# INLINE union' #-}-union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a-union' le (MinQueue f1) (MinQueue f2) = MinQueue (merge le 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+extractHeap ts = case extractBin ts of No -> Nothing Yes (Extract x ~Zero ts') -> Just (x, ts') @@ -344,62 +331,60 @@ incrExtract (Extract minKey (Succ kChild kChildren) ts) = Extract minKey kChildren (Cons kChild ts) -incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a-incrExtract' le t (Extract minKey (Succ kChild kChildren) ts)- = Extract minKey kChildren (Skip $ incr le (t `cat` kChild) ts)- where- cat = joinBin le+incrExtract' :: Ord a => BinomTree rk a -> Extract (Succ rk) a -> Extract rk a+incrExtract' t (Extract minKey (Succ kChild kChildren) ts)+ = Extract minKey kChildren (Skip $ incr (t `joinBin` kChild) ts) -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes -- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time.-extractBin :: LEq a -> BinomForest rk a -> MExtract rk a-extractBin le0 = start le0+extractBin :: Ord a => BinomForest rk a -> MExtract rk a+extractBin = start where- start :: LEq a -> BinomForest rk a -> MExtract rk a- start _le Nil = No- start le (Skip f) = case start le f of+ start :: Ord a => BinomForest rk a -> MExtract rk a+ start Nil = No+ start (Skip f) = case start f of No -> No Yes ex -> Yes (incrExtract ex)- start le (Cons t@(BinomTree x ts) f) = Yes $ case go le x f of+ start (Cons t@(BinomTree x ts) f) = Yes $ case go x f of No -> Extract x ts (Skip f)- Yes ex -> incrExtract' le t ex+ Yes ex -> incrExtract' t ex - go :: LEq a -> a -> BinomForest rk a -> MExtract rk a- go _le _min_above Nil = _min_above `seq` No- go le min_above (Skip f) = case go le min_above f of+ go :: Ord a => a -> BinomForest rk a -> MExtract rk a+ go _min_above Nil = _min_above `seq` No+ go min_above (Skip f) = case go min_above f of No -> No Yes ex -> Yes (incrExtract ex)- go le min_above (Cons t@(BinomTree x ts) f)- | min_above `le` x = case go le min_above f of+ go min_above (Cons t@(BinomTree x ts) f)+ | min_above <= x = case go min_above f of No -> No- Yes ex -> Yes (incrExtract' le t ex)- | otherwise = case go le x f of+ Yes ex -> Yes (incrExtract' t ex)+ | otherwise = case go x f of No -> Yes (Extract x ts (Skip f))- Yes ex -> Yes (incrExtract' le t ex)+ Yes ex -> Yes (incrExtract' t ex) -mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b-mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of+mapMaybeQueue :: Ord b => (a -> Maybe 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 le fCh' q0 forest'- Cons t forest' -> mapMaybeQueue f le fCh' (union' le (mapMaybeT t) q0) forest'- where fCh' (Succ t tss) = union' le (mapMaybeT t) (fCh tss)- mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\x -> insert' le x (fCh ts)) (f x0)+ 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 x0 ts) = maybe (fCh ts) (\x -> insert x (fCh ts)) (f x0) type Partition a b = (MinQueue a, MinQueue b) -mapEitherQueue :: (a -> Either b c) -> LEq b -> LEq c -> (rk a -> Partition b c) -> Partition b c ->+mapEitherQueue :: (Ord b, Ord c) => (a -> Either b c) -> (rk a -> Partition b c) -> Partition b c -> BinomForest rk a -> Partition b c-mapEitherQueue f0 leB leC fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of+mapEitherQueue f0 fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of Nil -> (q00, q10)- Skip ts' -> mapEitherQueue f0 leB leC fCh' (q00, q10) ts'- Cons t ts' -> mapEitherQueue f0 leB leC fCh' (both (union' leB) (union' leC) (partitionT t) (q00, q10)) ts'+ Skip ts' -> mapEitherQueue f0 fCh' (q00, q10) ts'+ Cons t ts' -> mapEitherQueue f0 fCh' (both union union (partitionT t) (q00, q10)) ts' where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2)- fCh' (Succ t tss) = both (union' leB) (union' leC) (partitionT t) (fCh tss)+ fCh' (Succ t tss) = both union union (partitionT t) (fCh tss) partitionT (BinomTree x ts) = case fCh ts of (q0, q1) -> case f0 x of- Left b -> (insert' leB b q0, q1)- Right c -> (q0, insert' leC c q1)+ Left b -> (insert b q0, q1)+ Right c -> (q0, insert c q1) {-# INLINE tip #-} -- | Constructs a binomial tree of rank 0.@@ -451,38 +436,33 @@ {-# INLINABLE fromList #-} -- | \(O(n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MinQueue a-fromList xs = MinQueue (fromListHeap (<=) xs)--{-# INLINE fromListHeap #-}-fromListHeap :: LEq a -> [a] -> BinomHeap a-fromListHeap le xs = foldl' go Nil xs+fromList xs = MinQueue (foldl' go Nil xs) where- go fr x = incr' le (tip x) fr+ go fr x = incr' (tip x) fr -- | Given two binomial forests starting at rank @rk@, takes their union. -- Each successive application of this function costs \(O(1)\), so applying it -- from the beginning costs \(O(\log n)\).-merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a-merge le f1 f2 = case (f1, f2) of- (Skip f1', Skip f2') -> Skip $! merge le f1' f2'- (Skip f1', Cons t2 f2') -> Cons t2 $! merge le f1' f2'- (Cons t1 f1', Skip f2') -> Cons t1 $! merge le f1' f2'+merge :: Ord a => BinomForest rk a -> BinomForest rk a -> BinomForest rk a+merge f1 f2 = case (f1, f2) of+ (Skip f1', Skip f2') -> Skip $! merge f1' f2'+ (Skip f1', Cons t2 f2') -> Cons t2 $! merge f1' f2'+ (Cons t1 f1', Skip f2') -> Cons t1 $! merge f1' f2' (Cons t1 f1', Cons t2 f2')- -> Skip $! carry le (t1 `cat` t2) f1' f2'+ -> Skip $! carry (t1 `joinBin` t2) f1' f2' (Nil, _) -> f2 (_, Nil) -> f1- where cat = joinBin le -- | Take the union of two queues and toss in an extra element.-unionPlusOne :: LEq a -> a -> MinQueue a -> MinQueue a -> MinQueue a-unionPlusOne le a (MinQueue xs) (MinQueue ys) = MinQueue (carry le (tip a) xs ys)+unionPlusOne :: Ord a => a -> MinQueue a -> MinQueue a -> MinQueue a+unionPlusOne a (MinQueue xs) (MinQueue ys) = MinQueue (carry (tip a) xs ys) -- | Merges two binomial forests with another tree. If we are thinking of the trees -- in the binomial forest as binary digits, this corresponds to a carry operation. -- Each call to this function takes \(O(1)\) time, so in total, it costs \(O(\log n)\).-carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a-carry le t0 f1 f2 = t0 `seq` case (f1, f2) of- (Skip f1', Skip f2') -> Cons t0 $! merge le f1' f2'+carry :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a+carry t0 f1 f2 = t0 `seq` case (f1, f2) of+ (Skip f1', Skip f2') -> Cons t0 $! merge f1' f2' (Skip f1', Cons t2 f2') -> Skip $! mergeCarry t0 t2 f1' f2' (Cons t1 f1', Skip f2') -> Skip $! mergeCarry t0 t1 f1' f2' (Cons t1 f1', Cons t2 f2')@@ -490,26 +470,24 @@ -- Why do these use incr and not incr'? We want the merge to take amortized -- O(log(min(|f1|, |f2|))) time. If we performed this final increment -- eagerly, that would degrade to O(log(max(|f1|, |f2|))) time.- (Nil, _f2) -> incr le t0 f2- (_f1, Nil) -> incr le t0 f1- where cat = joinBin le- mergeCarry tA tB = carry le (tA `cat` tB)+ (Nil, _f2) -> incr t0 f2+ (_f1, Nil) -> incr t0 f1+ where+ mergeCarry tA tB = carry (tA `joinBin` tB) -- | Merges a binomial tree into a binomial forest. If we are thinking -- of the trees in the binomial forest as binary digits, this corresponds -- to adding a power of 2. This costs amortized \(O(1)\) time.-incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a+incr :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a -- See Note [Amortization]-incr le t f0 = t `seq` case f0 of+incr t f0 = t `seq` case f0 of Nil -> Cons t Nil Skip f -> Cons t f- Cons t' f' -> f' `seq` Skip (incr le (t `cat` t') f')+ Cons t' f' -> f' `seq` Skip (incr (t `joinBin` t') f') -- See Note [Force on cascade] -- Question: should we force t `cat` t' here? We're allowed to; -- it's not obviously good or obviously bad.- where- cat = joinBin le -- Note [Amortization] --@@ -533,21 +511,20 @@ -- | A version of 'incr' that constructs the spine eagerly. This is -- intended for implementing @fromList@.-incr' :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a-incr' le t f0 = t `seq` case f0 of+incr' :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a+incr' t f0 = t `seq` case f0 of Nil -> Cons t Nil Skip f -> Cons t f- Cons t' f' -> Skip $! incr' le (t `cat` t') f'- where- cat = joinBin le+ Cons t' f' -> Skip $! incr' (t `joinBin` t') f' -- | The carrying operation: takes two binomial heaps of the same rank @k@ -- and returns one of rank @k+1@. Takes \(O(1)\) time.-joinBin :: LEq a -> BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a-joinBin le t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2)- | x1 `le` x2 = BinomTree x1 (Succ t2 ts1)+joinBin :: Ord a => BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a+joinBin t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2)+ | x1 <= x2 = BinomTree x1 (Succ t2 ts1) | otherwise = BinomTree x2 (Succ t1 ts2) + instance Functor Zero where fmap _ _ = Zero @@ -756,6 +733,7 @@ instance Ord a => Semigroup (MinQueue a) where (<>) = union stimes = stimesMonoid+ {-# INLINABLE stimes #-} #endif instance Ord a => Monoid (MinQueue a) where
src/Data/PQueue/Internals.hs view
@@ -8,7 +8,6 @@ BinomTree(..), Succ(..), Zero(..),- LEq, empty, null, size,@@ -125,9 +124,6 @@ -- and then the longer queue wins. -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. --- | Type alias for a comparison function.-type LEq a = a -> a -> Bool- -- basics -- | \(O(1)\). The empty priority queue.@@ -163,12 +159,20 @@ -- | 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' (<=)+insert x Empty = singleton x+insert x (MinQueue n x' ts)+ | x <= x' = MinQueue (n + 1) x (BQ.insertMinQ x' ts)+ | otherwise = MinQueue (n + 1) x' (BQ.insert x ts) -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a-union = union' (<=)+union Empty q = q+union q Empty = q+union (MinQueue n1 x1 f1) (MinQueue n2 x2 f2)+ | x1 <= x2 = MinQueue (n1 + n2) x1 (BQ.unionPlusOne x2 f1 f2)+ | otherwise = MinQueue (n1 + n2) x2 (BQ.unionPlusOne x1 f1 f2) + -- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. unions :: Ord a => [MinQueue a] -> MinQueue a unions = foldl' union empty@@ -251,20 +255,6 @@ -- We apply an explicit argument to get foldl' to inline. fromAscList xs = foldl' (flip insertMaxQ') empty xs -insert' :: LEq a -> a -> MinQueue a -> MinQueue a-insert' _ x Empty = singleton x-insert' le x (MinQueue n x' ts)- | x `le` x' = MinQueue (n + 1) x (BQ.insertMinQ x' ts)- | otherwise = MinQueue (n + 1) x' (BQ.insert' le x ts)--{-# INLINE union' #-}-union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a-union' _ Empty q = q-union' _ q Empty = q-union' le (MinQueue n1 x1 f1) (MinQueue n2 x2 f2)- | x1 `le` x2 = MinQueue (n1 + n2) x1 (BQ.unionPlusOne le x2 f1 f2)- | otherwise = MinQueue (n1 + n2) x2 (BQ.unionPlusOne le x1 f1 f2)- -- | @insertMinQ x h@ assumes that @x@ compares as less -- than or equal to every element of @h@. insertMinQ :: a -> MinQueue a -> MinQueue a@@ -382,6 +372,7 @@ instance Ord a => Semigroup (MinQueue a) where (<>) = union stimes = stimesMonoid+ {-# INLINABLE stimes #-} #endif instance Ord a => Monoid (MinQueue a) where
src/Data/PQueue/Internals/Down.hs view
@@ -17,13 +17,15 @@ deriving (Eq) #endif - instance NFData a => NFData (Down a) where rnf (Down a) = rnf a instance Ord a => Ord (Down a) where Down a `compare` Down b = b `compare` a Down a <= Down b = b <= a+ Down a >= Down b = b >= a+ Down a < Down b = b < a+ Down a > Down b = b > a instance Functor Down where fmap f (Down a) = Down (f a)@@ -31,4 +33,5 @@ instance Foldable Down where foldr f z (Down a) = a `f` z foldl f z (Down a) = z `f` a+ foldr' f !z (Down a) = a `f` z foldl' f !z (Down a) = z `f` a
src/Data/PQueue/Max.hs view
@@ -143,6 +143,7 @@ instance Ord a => Semigroup (MaxQueue a) where (<>) = union stimes = stimesMonoid+ {-# INLINABLE stimes #-} #endif instance Ord a => Monoid (MaxQueue a) where
src/Data/PQueue/Prio/Internals.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} module Data.PQueue.Prio.Internals ( MinPQueue(..),@@ -8,7 +10,6 @@ BinomTree(..), Zero(..), Succ(..),- CompF, empty, null, size,@@ -69,6 +70,10 @@ readPrec, readListPrec, readListPrecDefault) #endif +import Data.Functor.WithIndex+import Data.Foldable.WithIndex+import Data.Traversable.WithIndex+ #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) []@@ -97,6 +102,7 @@ instance Ord k => Semigroup (MinPQueue k a) where (<>) = union stimes = stimesMonoid+ {-# INLINABLE stimes #-} #endif instance Ord k => Monoid (MinPQueue k a) where@@ -189,8 +195,6 @@ foldMapWithKey_ f (Skip ts) = foldMapWithKey_ f ts foldMapWithKey_ f (Cons t ts) = foldMapWithKey_ f t `mappend` foldMapWithKey_ f ts -type CompF a = a -> a -> Bool- instance (Ord k, Eq a) => Eq (MinPQueue k a) where MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 = n1 == n2 && eqExtract k1 a1 ts1 k2 a2 ts2@@ -244,7 +248,10 @@ -- | 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' (<=)+insert k a Empty = singleton k a+insert k a (MinPQ n k' a' ts)+ | k <= k' = MinPQ (n + 1) k a (incrMin (tip k' a') ts)+ | otherwise = MinPQ (n + 1) k' a' (incr (tip k a ) ts) -- | \(O(n)\) (an earlier implementation had \(O(1)\) but was buggy). -- Insert an element with the specified key into the priority queue,@@ -261,26 +268,15 @@ let (kas, q'') = spanKey p q' in (t : kas, q'') _ -> ([], q) --- | Internal helper method, using a specific comparator function.-insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a-insert' _ k a Empty = singleton k a-insert' le k a (MinPQ n k' a' ts)- | k `le` k' = MinPQ (n + 1) k a (incrMin (tip k' a') ts)- | otherwise = MinPQ (n + 1) k' a' (incr le (tip k a ) ts)- -- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union -- of the two specified queues. union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a-union = union' (<=)---- | Takes the union of the two specified queues, using the given comparison function.-union' :: CompF k -> MinPQueue k a -> MinPQueue k a -> MinPQueue k a-union' le (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2)- | k1 `le` k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2)+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 le (tip k a) ts1 ts2-union' _ Empty q2 = q2-union' _ q1 Empty = q1+ 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)@@ -303,7 +299,7 @@ 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+ Nothing -> extractHeap n ts Just a' -> MinPQ n k a' ts -- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update@@ -318,14 +314,14 @@ updateMinWithKeyA' g _ Empty = pure (g Empty) updateMinWithKeyA' g f (MinPQ n k a ts) = fmap (g . tweak) (f k a) where- tweak Nothing = extractHeap (<=) n ts+ tweak Nothing = extractHeap n ts tweak (Just a') = MinPQ n k a' ts -- | \(O(\log n)\). Retrieves the minimal (key, value) pair of the map, and the map stripped of that -- element, or 'Nothing' if passed an empty map. minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a) minViewWithKey Empty = Nothing-minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap (<=) n ts)+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@@ -341,13 +337,13 @@ -- | \(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)+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)+ (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)@.@@ -427,7 +423,7 @@ -- We build a forest first and then extract its minimum at the end. -- Why not just build the 'MinQueue' directly? This way saves us one -- comparison per element.-fromList xs = case extractForest (<=) (fromListHeap (<=) xs) of+fromList xs = case extract (fromListHeap xs) of No -> Empty -- Should we track the size as we go instead? That saves O(log n) -- at the end, but it needs an extra register all along the way.@@ -436,10 +432,10 @@ Yes (Extract k v ~Zero f) -> MinPQ (sizeHeap f + 1) k v f {-# INLINE fromListHeap #-}-fromListHeap :: CompF k -> [(k, a)] -> BinomHeap k a-fromListHeap le xs = List.foldl' go Nil xs+fromListHeap :: Ord k => [(k, a)] -> BinomHeap k a+fromListHeap xs = List.foldl' go Nil xs where- go fr (k, a) = incr' le (tip k a) fr+ go fr (k, a) = incr' (tip k a) fr sizeHeap :: BinomHeap k a -> Int sizeHeap = go 0 1@@ -455,50 +451,50 @@ tip k a = BinomTree k a Zero -- | \(O(1)\). Takes the union of two binomial trees of the same rank.-meld :: CompF k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a-meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2)- | k1 `le` k2 = BinomTree k1 v1 (Succ t2 ts1)+meld :: Ord 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 :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a-mergeForest le f1 f2 = case (f1, f2) of- (Skip ts1, Skip ts2) -> Skip $! mergeForest le ts1 ts2- (Skip ts1, Cons t2 ts2) -> Cons t2 $! mergeForest le ts1 ts2- (Cons t1 ts1, Skip ts2) -> Cons t1 $! mergeForest le ts1 ts2- (Cons t1 ts1, Cons t2 ts2) -> Skip $! carryForest le (meld le t1 t2) ts1 ts2+mergeForest :: Ord k => BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a+mergeForest f1 f2 = case (f1, f2) of+ (Skip ts1, Skip ts2) -> Skip $! mergeForest ts1 ts2+ (Skip ts1, Cons t2 ts2) -> Cons t2 $! mergeForest ts1 ts2+ (Cons t1 ts1, Skip ts2) -> Cons t1 $! mergeForest ts1 ts2+ (Cons t1 ts1, Cons t2 ts2) -> Skip $! carryForest (meld t1 t2) ts1 ts2 (Nil, _) -> f2 (_, Nil) -> f1 -- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. -- Analogous to binary addition when a digit has been carried.-carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a-carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of+carryForest :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a+carryForest t0 f1 f2 = t0 `seq` case (f1, f2) of (Cons t1 ts1, Cons t2 ts2) -> Cons t0 $! carryMeld t1 t2 ts1 ts2 (Cons t1 ts1, Skip ts2) -> Skip $! carryMeld t0 t1 ts1 ts2 (Skip ts1, Cons t2 ts2) -> Skip $! carryMeld t0 t2 ts1 ts2- (Skip ts1, Skip ts2) -> Cons t0 $! mergeForest le ts1 ts2+ (Skip ts1, Skip ts2) -> Cons t0 $! mergeForest ts1 ts2 -- Why do these use incr and not incr'? We want the merge to take -- O(log(min(|f1|, |f2|))) amortized time. If we performed this final -- increment eagerly, that would degrade to O(log(max(|f1|, |f2|))) time.- (Nil, _) -> incr le t0 f2- (_, Nil) -> incr le t0 f1- where carryMeld = carryForest le .: meld le+ (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 :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a-incr le t ts = t `seq` case ts of+incr :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a+incr t ts = t `seq` case ts of Nil -> Cons t Nil Skip ts' -> Cons t ts'- Cons t' ts' -> ts' `seq` Skip (incr le (meld le t t') ts')+ Cons t' ts' -> ts' `seq` Skip (incr (meld t t') ts') -- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. -- Forces the rebuilt portion of the spine.-incr' :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a-incr' le t ts = t `seq` case ts of+incr' :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a+incr' t ts = t `seq` case ts of Nil -> Cons t Nil Skip ts' -> Cons t ts'- Cons t' ts' -> Skip $! incr' le (meld le t 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@@ -525,8 +521,8 @@ Skip tss' -> Cons t tss' Cons (BinomTree k a ts) tss' -> Skip $! incrMax' (BinomTree k a (Succ t ts)) tss' -extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a-extractHeap le n ts = n `seq` case extractForest le ts of+extractHeap :: Ord k => Int -> BinomHeap k a -> MinPQueue k a+extractHeap n ts = n `seq` case extract ts of No -> Empty Yes (Extract k a _ ts') -> MinPQ (n - 1) k a ts' @@ -567,42 +563,37 @@ -- fused (operationally) with successive operations. If the next operation is -- union or minView, this doesn't save anything, but if some insertions follow, -- it might be faster this way.-incrExtract' :: CompF k -> BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a-incrExtract' le t (Extract minKey minVal (Succ kChild kChildren) ts)- = Extract minKey minVal kChildren (Skip $ incr le (t `cat` kChild) ts)- where- cat = meld le+incrExtract' :: Ord k => BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a+incrExtract' t (Extract minKey minVal (Succ kChild kChildren) ts)+ = Extract minKey minVal kChildren (Skip $ incr (t `meld` kChild) ts) -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes -- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time.-extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a-extractForest le0 = start le0+extract :: Ord k => BinomForest rk k a -> MExtract rk k a+extract = start where- start :: CompF k -> BinomForest rk k a -> MExtract rk k a- start _le Nil = No- start le (Skip f) = case start le f of+ start :: Ord k => BinomForest rk k a -> MExtract rk k a+ start Nil = No+ start (Skip f) = case start f of No -> No Yes ex -> Yes (incrExtract ex)- start le (Cons t@(BinomTree k v ts) f) = Yes $ case go le k f of+ start (Cons t@(BinomTree k v ts) f) = Yes $ case go k f of No -> Extract k v ts (Skip f)- Yes ex -> incrExtract' le t ex+ Yes ex -> incrExtract' t ex - go :: CompF k -> k -> BinomForest rk k a -> MExtract rk k a- go _le _min_above Nil = _min_above `seq` No- go le min_above (Skip f) = case go le min_above f of+ go :: Ord k => k -> BinomForest rk k a -> MExtract rk k a+ go _min_above Nil = _min_above `seq` No+ go min_above (Skip f) = case go min_above f of No -> No Yes ex -> Yes (incrExtract ex)- go le min_above (Cons t@(BinomTree k v ts) f)- | min_above `le` k = case go le min_above f of+ go min_above (Cons t@(BinomTree k v ts) f)+ | min_above <= k = case go min_above f of No -> No- Yes ex -> Yes (incrExtract' le t ex)- | otherwise = case go le k f of+ Yes ex -> Yes (incrExtract' t ex)+ | otherwise = case go k f of No -> Yes (Extract k v ts (Skip f))- Yes ex -> Yes (incrExtract' le t ex)--extract :: (Ord k) => BinomForest rk k a -> MExtract rk k a-extract = extractForest (<=)+ Yes ex -> Yes (incrExtract' t ex) -- | Utility function for mapping over a forest. mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b@@ -615,28 +606,28 @@ = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss) -- | Utility function for mapping a 'Maybe' function over a forest.-mapMaybeF :: CompF k -> (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) ->+mapMaybeF :: Ord k => (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> BinomForest rk k a -> MinPQueue k b-mapMaybeF le f fCh ts0 = case ts0 of+mapMaybeF f fCh ts0 = case ts0 of Nil -> Empty- Skip ts' -> mapMaybeF le f fCh' ts'+ Skip ts' -> mapMaybeF f fCh' ts' Cons (BinomTree k a ts) ts'- -> insF k a (fCh ts) (mapMaybeF le f fCh' ts')- where insF k a = maybe id (insert' le k) (f k a) .: union' le+ -> 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 :: CompF k -> (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) ->+mapEitherF :: Ord k => (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) -> BinomForest rk k a -> (MinPQueue k b, MinPQueue k c)-mapEitherF le f0 fCh ts0 = case ts0 of+mapEitherF f0 fCh ts0 = case ts0 of Nil -> (Empty, Empty)- Skip ts' -> mapEitherF le f0 fCh' ts'+ Skip ts' -> mapEitherF f0 fCh' ts' Cons (BinomTree k a ts) ts'- -> insF k a (fCh ts) (mapEitherF le f0 fCh' ts')+ -> insF k a (fCh ts) (mapEitherF f0 fCh' ts') where- insF k a = either (first' . insert' le k) (second' . insert' le k) (f0 k a) .:- (union' le `both` union' le)+ insF k a = either (first' . insert k) (second' . insert k) (f0 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)@@ -788,15 +779,25 @@ instance Functor (MinPQueue k) where fmap = map +instance FunctorWithIndex k (MinPQueue k) where+ imap = mapWithKey+ instance Ord k => Foldable (MinPQueue k) where foldr = foldrWithKey . const foldl f = foldlWithKey (const . f) length = size null = null +instance Ord k => FoldableWithIndex k (MinPQueue k) where+ ifoldr = foldrWithKey+ ifoldl f = foldlWithKey (flip f)+ -- | Traverses in ascending order. 'mapM' is strictly accumulating like -- 'mapMWithKey'. instance Ord k => Traversable (MinPQueue k) where traverse = traverseWithKey . const mapM = mapMWithKey . const sequence = mapM id++instance Ord k => TraversableWithIndex k (MinPQueue k) where+ itraverse = traverseWithKey
src/Data/PQueue/Prio/Max/Internals.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- |@@ -124,6 +126,9 @@ readPrec, readListPrec, readListPrecDefault) #endif +import Data.Functor.WithIndex+import Data.Foldable.WithIndex+import Data.Traversable.WithIndex #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]@@ -149,6 +154,7 @@ instance Ord k => Semigroup (MaxPQueue k a) where (<>) = union stimes = stimesMonoid+ {-# INLINABLE stimes #-} #endif instance Ord k => Monoid (MaxPQueue k a) where@@ -180,19 +186,28 @@ instance Functor (MaxPQueue k) where fmap f (MaxPQ q) = MaxPQ (fmap f q) +instance FunctorWithIndex k (MaxPQueue k) where+ imap = mapWithKey+ instance Ord k => Foldable (MaxPQueue k) where foldr f z (MaxPQ q) = foldr f z q foldl f z (MaxPQ q) = foldl f z q- length = size null = null +instance Ord k => FoldableWithIndex k (MaxPQueue k) where+ ifoldr = foldrWithKey+ ifoldl f = foldlWithKey (flip f)+ -- | Traverses in descending order. 'mapM' is strictly accumulating like -- 'mapMWithKey'. instance Ord k => Traversable (MaxPQueue k) where traverse f (MaxPQ q) = MaxPQ <$> traverse f q mapM = mapMWithKey . const sequence = mapM id++instance Ord k => TraversableWithIndex k (MaxPQueue k) where+ itraverse = traverseWithKey -- | \(O(1)\). Returns the empty priority queue. empty :: MaxPQueue k a