diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,93 +1,144 @@ # Revision history for pqueue +## 1.7.0.0 -- 2026-04-16 + +* Remove `insertBehind` ([#145](https://github.com/lspitzner/pqueue/pull/145)) + +* Change `Read` and `Show` instances to use `fromList` + ([#144](https://github.com/lspitzner/pqueue/issues/144)) + +## 1.6.0.0 -- 2025-10-11 + +* Deprecate `mapU` and replace it by `mapMonotonic` in `Data.PQeueu.Min` and `Data.PQueue.Max` + ([#129](https://github.com/lspitzner/pqueue/pull/129)) + +* Add ghc-9.8, ghc-9.10 & ghc-9.12 support + ([#133](https://github.com/lspitzner/pqueue/pull/133), [#135](https://github.com/lspitzner/pqueue/pull/135), [#139](https://github.com/lspitzner/pqueue/pull/139)) + +* Drop ghc-7.10 support ([#142](https://github.com/lspitzner/pqueue/pull/142)) + +* Fix typo in `Data.PQueue.Max.toList` documentation + ([#131](https://github.com/lspitzner/pqueue/pull/131)) + +## 1.5.0.0 -- 2023-08-08 + +* Fix incorrect behavior of `mapMaybe` and `mapEither` for `MinQueue`. These + previously worked only for monotonic functions. + +* Fix a performance bug that caused queue performance not to improve + when the queue shrinks. + ([#109](https://github.com/lspitzner/pqueue/pull/109)) + +* Make `minView` more eager, improving performance in typical cases. + ([#107](https://github.com/lspitzner/pqueue/pull/107)) + +* Make mapping and traversal functions force the full data structure spine. + This should make performance more predictable, and removes the last + remaining reasons to use the `seqSpine` functions. As these are no longer + useful, deprecate them. + ([#103](https://github.com/lspitzner/pqueue/pull/103)) + +* Deprecate `insertBehind`. This function does not play nicely with merges, + we lack tests to verify it works properly without merges, it imposes a + substantial maintenance burden on the rest of the package, and it is quite + slow. ([#35](https://github.com/lspitzner/pqueue/issues/35)) + +* Add pattern synonyms to work with `MinQueue` and `MinPQueue`. + ([#92](https://github.com/lspitzner/pqueue/pull/92)) + +* Make the `Data` instances respect the queue invariants. Make the + `Constr`s match the pattern synonyms. Make the `Data` instance for + `MinPQueue` work "incrementally", like the one for `MinQueue`. + ([#92](https://github.com/lspitzner/pqueue/pull/92)) + ## 1.4.3.0 -- 2022-10-30 - * Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable). - ([#85](https://github.com/lspitzner/pqueue/pull/85)) - * Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86)) +* Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable). + ([#85](https://github.com/lspitzner/pqueue/pull/85)) +* Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86)) ## 1.4.2.0 -- 2022-06-19 - * Overall performance has improved greatly, especially when there are many - insertions and/or merges in a row. Insertion, deletion, and merge are now - *worst case* logarithmic, while maintaining their previous amortized - bounds. ([#26](https://github.com/lspitzner/pqueue/pull/26)) +* Overall performance has improved greatly, especially when there are many + insertions and/or merges in a row. Insertion, deletion, and merge are now + *worst case* logarithmic, while maintaining their previous amortized + bounds. ([#26](https://github.com/lspitzner/pqueue/pull/26)) - * New `mapMWithKey` functions optimized for working in strict monads. These - are used to implement the `mapM` and `sequence` methods of `Traversable`. - ([#46](https://github.com/lspitzner/pqueue/pull/46)) +* New `mapMWithKey` functions optimized for working in strict monads. These + are used to implement the `mapM` and `sequence` methods of `Traversable`. + ([#46](https://github.com/lspitzner/pqueue/pull/46)) - * Define `stimes` in the `Semigroup` instances. - ([#57](https://github.com/lspitzner/pqueue/pull/57)) +* Define `stimes` in the `Semigroup` instances. + ([#57](https://github.com/lspitzner/pqueue/pull/57)) - * Add strict left unordered folds (`foldlU'`, `foldlWithKeyU'`) - and monoidal unordered folds (`foldMapU`, `foldMapWithKeyU`). - ([#59](https://github.com/lspitzner/pqueue/pull/59)) +* Add strict left unordered folds (`foldlU'`, `foldlWithKeyU'`) + and monoidal unordered folds (`foldMapU`, `foldMapWithKeyU`). + ([#59](https://github.com/lspitzner/pqueue/pull/59)) - * New functions for adjusting and updating the min/max of a key-value - priority queue in an `Applicative` context. - ([#66](https://github.com/lspitzner/pqueue/pull/66)) +* New functions for adjusting and updating the min/max of a key-value + priority queue in an `Applicative` context. + ([#66](https://github.com/lspitzner/pqueue/pull/66)) - * Fixed `Data.PQueue.Max.map` to work on `MaxQueue`s. - ([#76](https://github.com/lspitzner/pqueue/pull/76)) +* Fixed `Data.PQueue.Max.map` to work on `MaxQueue`s. + ([#76](https://github.com/lspitzner/pqueue/pull/76)) ## 1.4.1.4 -- 2021-12-04 - * Maintenance release for ghc-9.0 & ghc-9.2 support - * Change nix-setup to use the seaaye tool +* Maintenance release for ghc-9.0 & ghc-9.2 support +* Change nix-setup to use the seaaye tool ## 1.4.1.3 -- 2020-06-06 - * Maintenance release - * Add missing documentation - * Add nix-expressions for testing against different compilers/package sets +* Maintenance release +* Add missing documentation +* Add nix-expressions for testing against different compilers/package sets ## 1.4.1.2 -- 2018-09-26 - * Maintenance release for ghc-8.6 - * Drop support for ghc<7.10 +* Maintenance release for ghc-8.6 +* Drop support for ghc<7.10 ## 1.4.1.1 -- 2018-02-11 - * Remove/replace buggy `insertBehind` implementation. +* Remove/replace buggy `insertBehind` implementation. - The existing implementation did not always insert behind. As a fix, - the function was removed from Data.PQueue.Max/Min and was rewritten - with a O(n) complexity (!) for Data.PQueue.Prio.Max/Min. + The existing implementation did not always insert behind. As a fix, + the function was removed from Data.PQueue.Max/Min and was rewritten + with a O(n) complexity (!) for Data.PQueue.Prio.Max/Min. - * Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release - * Drop support for ghc<7.4 +* Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release +* Drop support for ghc<7.4 ## 1.3.2.3 -- 2017-08-01 - * Maintenance release for ghc-8.2 +* Maintenance release for ghc-8.2 ## 1.3.2.2 -- 2017-03-12 - * Add test-suite from darcs repository for pqueue-1.0.1. +* Add test-suite from darcs repository for pqueue-1.0.1. ## 1.3.2.1 -- 2017-03-11 - * Fix documentation errors - - complexity on `toList`, `toListU` - - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places +* Fix documentation errors + - complexity on `toList`, `toListU` + - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places ## 1.3.2 -- 2016-09-28 - * Add function `insertBehind` as a slight variation of `insert` which differs - in behaviour for elements the compare equal. +* Add function `insertBehind` as a slight variation of `insert` which differs + in behaviour for elements the compare equal. ## 1.3.1.1 -- 2016-05-21 - * Ensure compatibility with ghc-8 - * Minor internal refactors +* Ensure compatibility with ghc-8 +* Minor internal refactors ## 1.3.1 -- 2015-10-03 - * Add `Monoid` instance for `MaxPQueue` +* Add `Monoid` instance for `MaxPQueue` ## 1.3.0 -- 2015-06-23 - * Lennart Spitzner starts co-maintaining - * new git repository at github.com:lspitzner/pqueue - * Ensure compatibility with ghc-7.10 +* Lennart Spitzner starts co-maintaining +* new git repository at github.com:lspitzner/pqueue +* Ensure compatibility with ghc-7.10 diff --git a/benchmarks/BenchMinPQueue.hs b/benchmarks/BenchMinPQueue.hs --- a/benchmarks/BenchMinPQueue.hs +++ b/benchmarks/BenchMinPQueue.hs @@ -3,6 +3,7 @@ import qualified KWay.PrioMergeAlg as KWay import qualified PHeapSort as HS +import qualified Data.PQueue.Prio.Min as P kWay :: Int -> Int -> Benchmark kWay i n = bench @@ -14,6 +15,17 @@ ("Heap sort with " ++ show n ++ " elements") (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) +filterQ :: Int -> Benchmark +filterQ n = bench + ("filter with " ++ show n ++ " elements") + (whnf (P.drop 1 . P.filterWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 977209486631198655) + +partitionQ :: Int -> Benchmark +partitionQ n = bench + ("partition with " ++ show n ++ " elements") + (whnf (P.drop 1 . snd . P.partitionWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 781928047937198) + + main :: IO () main = defaultMain [ bgroup "heapSort" @@ -34,5 +46,19 @@ , kWay (3*10^6) 1000 , kWay (2*10^6) 2000 , kWay (4*10^6) 100 + ] + , bgroup "filter" + [ filterQ (10^3) + , filterQ (10^4) + , filterQ (10^5) + , filterQ (10^6) + , filterQ (3*10^6) + ] + , bgroup "partition" + [ partitionQ (10^3) + , partitionQ (10^4) + , partitionQ (10^5) + , partitionQ (10^6) + , partitionQ (3*10^6) ] ] diff --git a/benchmarks/BenchMinQueue.hs b/benchmarks/BenchMinQueue.hs --- a/benchmarks/BenchMinQueue.hs +++ b/benchmarks/BenchMinQueue.hs @@ -3,6 +3,7 @@ import qualified KWay.MergeAlg as KWay import qualified HeapSort as HS +import qualified Data.PQueue.Min as P kWay :: Int -> Int -> Benchmark kWay i n = bench @@ -14,9 +15,19 @@ ("Heap sort with " ++ show n ++ " elements") (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) +filterQ :: Int -> Benchmark +filterQ n = bench + ("filter with " ++ show n ++ " elements") + (whnf (P.drop 1 . P.filter (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 977209486631198655) + +partitionQ :: Int -> Benchmark +partitionQ n = bench + ("partition with " ++ show n ++ " elements") + (whnf (P.drop 1 . snd . P.partition (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 781928047937198) + main :: IO () -main = defaultMain - [ bgroup "heapSort" +main = defaultMain [ + bgroup "heapSort" [ hSort (10^3) , hSort (10^4) , hSort (10^5) @@ -34,5 +45,19 @@ , kWay (3*10^6) 1000 , kWay (2*10^6) 2000 , kWay (4*10^6) 100 + ] + , bgroup "filter" + [ filterQ (10^3) + , filterQ (10^4) + , filterQ (10^5) + , filterQ (10^6) + , filterQ (3*10^6) + ] + , bgroup "partition" + [ partitionQ (10^3) + , partitionQ (10^4) + , partitionQ (10^5) + , partitionQ (10^6) + , partitionQ (3*10^6) ] ] diff --git a/benchmarks/HeapSort.hs b/benchmarks/HeapSort.hs --- a/benchmarks/HeapSort.hs +++ b/benchmarks/HeapSort.hs @@ -1,6 +1,5 @@ module HeapSort where -import Data.PQueue.Min (MinQueue) import qualified Data.PQueue.Min as P import System.Random diff --git a/benchmarks/KWay/PrioMergeAlg.hs b/benchmarks/KWay/PrioMergeAlg.hs --- a/benchmarks/KWay/PrioMergeAlg.hs +++ b/benchmarks/KWay/PrioMergeAlg.hs @@ -7,7 +7,6 @@ ) where import qualified Data.PQueue.Prio.Min as P -import System.Random (StdGen) import Data.Word import Data.List (unfoldr) import KWay.RandomIncreasing diff --git a/benchmarks/KWay/RandomIncreasing.hs b/benchmarks/KWay/RandomIncreasing.hs --- a/benchmarks/KWay/RandomIncreasing.hs +++ b/benchmarks/KWay/RandomIncreasing.hs @@ -5,7 +5,6 @@ import System.Random import Data.Word -import Data.List (unfoldr) data Stream = Stream !Word64 {-# UNPACK #-} !StdGen diff --git a/benchmarks/PHeapSort.hs b/benchmarks/PHeapSort.hs --- a/benchmarks/PHeapSort.hs +++ b/benchmarks/PHeapSort.hs @@ -1,6 +1,5 @@ module PHeapSort where -import Data.PQueue.Prio.Min (MinPQueue) import qualified Data.PQueue.Prio.Min as P import System.Random diff --git a/pqueue.cabal b/pqueue.cabal --- a/pqueue.cabal +++ b/pqueue.cabal @@ -1,8 +1,9 @@ +cabal-version: 2.2 name: pqueue -version: 1.4.3.0 +version: 1.7.0.0 category: Data Structures author: Louis Wasserman -license: BSD3 +license: BSD-3-Clause license-file: LICENSE stability: experimental synopsis: Reliable, persistent, fast priority queues. @@ -14,9 +15,23 @@ homepage: https://github.com/lspitzner/pqueue 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.4, GHC == 9.4.2 -extra-source-files: +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.3 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + +extra-doc-files: CHANGELOG.md README.md @@ -29,10 +44,9 @@ default-language: Haskell2010 build-depends: - { base >= 4.8 && < 4.18 - , deepseq >= 1.3 && < 1.5 - , indexed-traversable >= 0.1 && < 0.2 - } + , base >= 4.9 && < 4.23 + , deepseq >= 1.3 && < 1.6 + , indexed-traversable >= 0.1 && < 0.2 exposed-modules: Data.PQueue.Prio.Min Data.PQueue.Prio.Max @@ -44,12 +58,12 @@ BinomialQueue.Internals BinomialQueue.Min BinomialQueue.Max + Data.PQueue.Internals.Classes Data.PQueue.Internals.Down - Data.PQueue.Internals.Foldable Data.PQueue.Prio.Max.Internals - if impl(ghc) { + Nattish + if impl(ghc) default-extensions: DeriveDataTypeable - } other-extensions: BangPatterns , CPP @@ -60,22 +74,40 @@ -fspec-constr -fdicts-strict -Wall - if impl(ghc >= 8.0) - ghc-options: - -fno-warn-unused-imports test-suite test - hs-source-dirs: tests + hs-source-dirs: src, tests default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: PQueueTests.hs build-depends: - { base >= 4.8 && < 4.18 - , deepseq >= 1.3 && < 1.5 - , tasty - , tasty-quickcheck - , pqueue - } + , base >= 4.9 && < 4.23 + , deepseq >= 1.3 && < 1.6 + , indexed-traversable >= 0.1 && < 0.2 + , tasty + , tasty-quickcheck + other-modules: + Data.PQueue.Prio.Min + Data.PQueue.Prio.Max + Data.PQueue.Min + Data.PQueue.Max + Data.PQueue.Prio.Internals + Data.PQueue.Internals + BinomialQueue.Internals + BinomialQueue.Min + BinomialQueue.Max + Data.PQueue.Internals.Classes + Data.PQueue.Internals.Down + Data.PQueue.Prio.Max.Internals + Nattish + + Validity.BinomialQueue + Validity.PQueue.Min + Validity.PQueue.Prio.BinomialQueue + Validity.PQueue.Prio.Min + Validity.PQueue.Prio.Max + if impl(ghc) + default-extensions: DeriveDataTypeable ghc-options: -Wall -fno-warn-type-defaults @@ -91,11 +123,11 @@ KWay.RandomIncreasing ghc-options: -O2 build-depends: - base >= 4.8 && < 5 + , base >= 4.9 && < 5 , pqueue - , deepseq >= 1.3 && < 1.5 - , random >= 1.2 && < 1.3 - , tasty-bench >= 0.3 && < 0.4 + , deepseq >= 1.3 && < 1.6 + , random >= 1.2 && < 1.4 + , tasty-bench >= 0.3 && < 0.6 benchmark minpqueue-benchmarks default-language: Haskell2010 @@ -108,8 +140,8 @@ KWay.RandomIncreasing ghc-options: -O2 build-depends: - base >= 4.8 && < 5 + , base >= 4.9 && < 5 , pqueue - , deepseq >= 1.3 && < 1.5 - , random >= 1.2 && < 1.3 - , tasty-bench >= 0.3 && < 0.4 + , deepseq >= 1.3 && < 1.6 + , random >= 1.2 && < 1.4 + , tasty-bench >= 0.3 && < 0.6 diff --git a/src/BinomialQueue/Internals.hs b/src/BinomialQueue/Internals.hs --- a/src/BinomialQueue/Internals.hs +++ b/src/BinomialQueue/Internals.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} module BinomialQueue.Internals ( MinQueue (..), @@ -19,6 +18,7 @@ minView, singleton, insert, + insertEager, union, unionPlusOne, mapMaybe, @@ -36,7 +36,6 @@ toDescList, toListU, fromList, - mapU, fromAscList, foldMapU, foldrU, @@ -47,13 +46,13 @@ ) where import Control.DeepSeq (NFData(rnf), deepseq) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import Data.Function (on) -#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid) -#endif -import Data.PQueue.Internals.Foldable +import Data.PQueue.Internals.Classes #ifdef __GLASGOW_HASKELL__ import Data.Data import Text.Read (Lexeme(Ident), lexP, parens, prec, @@ -141,8 +140,9 @@ -- -- The Skip constructor must be lazy to obtain the desired amortized bounds. -- The forest field of the Cons constructor /could/ be made strict, but that --- would be worse for heavily persistent use and not obviously better --- otherwise. +-- would be worse for heavily persistent use. According to our benchmarks, it +-- doesn't make a significant or consistent difference even in non-persistent +-- code (heap sort and k-way merge). -- -- Debit invariant: -- @@ -208,6 +208,14 @@ insert :: Ord a => a -> MinQueue a -> MinQueue a insert x (MinQueue ts) = MinQueue (incr (tip x) ts) +-- | \(O(\log n)\), but a fast \(O(1)\) average when inserting repeatedly in +-- an empty queue or at least around \(O(\log n)\) times into a nonempty one. +-- Insert an element into the priority queue. This is good for 'fromList'-like +-- operations. +insertEager :: Ord a => a -> MinQueue a -> MinQueue a +insertEager x (MinQueue ts) = MinQueue (incr' (tip x) ts) +{-# INLINE insertEager #-} + -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a union (MinQueue f1) (MinQueue f2) = MinQueue (merge f1 f2) @@ -218,16 +226,31 @@ -- | \(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 = flip foldlU' empty $ \q a -> + case f a of + Nothing -> q + Just b -> insertEager b q +-- This seems to be needed for specialization. +{-# INLINABLE mapMaybe #-} -- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) -mapEither f (MinQueue ts) = mapEitherQueue f (const (empty, empty)) (empty, empty) ts +mapEither f = fromPartition . + foldlU' + (\(Partition ls rs) a -> + case f a of + Left b -> Partition (insertEager b ls) rs + Right b -> Partition ls (insertEager b rs)) + (Partition empty empty) +-- This seems to be needed for specialization. +{-# INLINABLE mapEither #-} --- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, --- as in 'fmap'. If it is not, the result is undefined. +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic +-- (meaning that @x <= y@ implies @f x <= f y@), and +-- applies this function to every element of the priority queue, as in 'fmap'. +-- If the function is not monotonic, the result is undefined. mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b -mapMonotonic = mapU +mapMonotonic f (MinQueue ts) = MinQueue (fmap_ f ts) {-# INLINABLE [0] foldrAsc #-} -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in @@ -331,9 +354,17 @@ incrExtract (Extract minKey (Succ kChild kChildren) ts) = Extract minKey kChildren (Cons kChild ts) +-- Note: We used to apply Skip lazily here, and to use the lazy incr, for fear +-- that the potential cascade of carries would be more expensive than leaving +-- those carries suspended and letting subsequent operations force them. +-- However, our benchmarks indicated that doing these strictly was +-- faster. Note that even if we chose to go back to incr (rather than incr'), +-- it's even more clearly worse to apply Skip lazily— forcing the result of +-- incr in this context doesn't cause a cascade, because the child of any Cons +-- will come from an Extract, and therefore be in WHNF already. incrExtract' :: Ord a => BinomTree rk a -> Extract (Succ rk) a -> Extract rk a incrExtract' t (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Skip $ incr (t `joinBin` kChild) ts) + = 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 @@ -347,7 +378,7 @@ No -> No Yes ex -> Yes (incrExtract ex) start (Cons t@(BinomTree x ts) f) = Yes $ case go x f of - No -> Extract x ts (Skip f) + No -> Extract x ts (skip f) Yes ex -> incrExtract' t ex go :: Ord a => a -> BinomForest rk a -> MExtract rk a @@ -360,31 +391,19 @@ No -> No Yes ex -> Yes (incrExtract' t ex) | otherwise = case go x f of - No -> Yes (Extract x ts (Skip f)) + No -> Yes (Extract x ts (skip f)) Yes ex -> Yes (incrExtract' t ex) -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 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) +-- | When the heap size is a power of two and we extract from it, we have +-- to shrink the spine by one. This function takes care of that. +skip :: BinomForest (Succ rk) a -> BinomForest rk a +skip Nil = Nil +skip f = Skip f +{-# INLINE skip #-} -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 fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of - Nil -> (q00, q10) - 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 union (partitionT t) (fCh tss) - partitionT (BinomTree x ts) = case fCh ts of - (q0, q1) -> case f0 x of - Left b -> (insert b q0, q1) - Right c -> (q0, insert c q1) +data Partition a b = Partition !(MinQueue a) !(MinQueue b) +fromPartition :: Partition a b -> (MinQueue a, MinQueue b) +fromPartition (Partition p q) = (p, q) {-# INLINE tip #-} -- | Constructs a binomial tree of rank 0. @@ -436,9 +455,7 @@ {-# INLINABLE fromList #-} -- | \(O(n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MinQueue a -fromList xs = MinQueue (foldl' go Nil xs) - where - go fr x = incr' (tip x) fr +fromList xs = foldl' (flip insertEager) empty xs -- | Given two binomial forests starting at rank @rk@, takes their union. -- Each successive application of this function costs \(O(1)\), so applying it @@ -525,19 +542,19 @@ | otherwise = BinomTree x2 (Succ t1 ts2) -instance Functor Zero where - fmap _ _ = Zero +instance Fmap Zero where + fmap_ _ _ = Zero -instance Functor rk => Functor (Succ rk) where - fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts) +instance Fmap rk => Fmap (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 Fmap rk => Fmap (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 Fmap rk => Fmap (BinomForest rk) where + fmap_ _ Nil = Nil + fmap_ f (Skip ts) = Skip $! fmap_ f ts + fmap_ f (Cons t ts) = Cons (fmap_ f t) $! fmap_ f ts instance Foldr Zero where foldr_ _ z ~Zero = z @@ -631,9 +648,6 @@ -- 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 f (MinQueue ts) = MinQueue (f <$> ts) - {-# NOINLINE [0] foldrU #-} -- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MinQueue a -> b @@ -679,7 +693,7 @@ -- -- Note: The spine of a 'MinQueue' is stored somewhat lazily. Most operations -- take great care to prevent chains of thunks from accumulating along the --- spine to the detriment of performance. However, @mapU@ can leave expensive +-- spine to the detriment of performance. However, @mapMonotonic@ can leave expensive -- thunks in the structure and repeated applications of that function can -- create thunk chains. seqSpine :: MinQueue a -> b -> b @@ -712,29 +726,27 @@ instance (Ord a, Show a) => Show (MinQueue a) where showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) + showString "fromList " . shows (toAscList xs) -instance Read a => Read (MinQueue a) where +instance (Ord a, Read a) => Read (MinQueue a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP + Ident "fromList" <- lexP xs <- readPrec - return (fromAscList xs) + return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \r -> do - ("fromAscList",s) <- lex r + ("fromList",s) <- lex r (xs,t) <- reads s - return (fromAscList xs,t) + return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MinQueue a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} -#endif instance Ord a => Monoid (MinQueue a) where mempty = empty diff --git a/src/BinomialQueue/Max.hs b/src/BinomialQueue/Max.hs --- a/src/BinomialQueue/Max.hs +++ b/src/BinomialQueue/Max.hs @@ -87,26 +87,13 @@ import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) -import Data.Foldable (foldl') -import Data.Maybe (fromMaybe) -import Data.Bifunctor (bimap) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - +import Data.Coerce (coerce) import qualified Data.List as List +import Data.Maybe (fromMaybe) import qualified BinomialQueue.Min as MinQ import Data.PQueue.Internals.Down -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - newtype MaxQueue a = MaxQueue { unMaxQueue :: MinQ.MinQueue (Down a) } -- | \(O(\log n)\). Returns the minimum element. Throws an error on an empty queue. @@ -115,11 +102,11 @@ -- | \(O(1)\). The top (maximum) element of the queue, if there is one. getMax :: Ord a => MaxQueue a -> Maybe a -getMax (MaxQueue q) = unDown <$> MinQ.getMin q +getMax = coerce MinQ.getMin -- | \(O(\log n)\). Deletes the maximum element. If the queue is empty, does nothing. deleteMax :: Ord a => MaxQueue a -> MaxQueue a -deleteMax = MaxQueue . MinQ.deleteMin . unMaxQueue +deleteMax = coerce MinQ.deleteMin -- | \(O(\log n)\). Extracts the maximum element. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) @@ -127,34 +114,30 @@ -- | \(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 (MaxQueue q) = case MinQ.minView q of - Just (Down a, q') -> Just (a, MaxQueue q') - Nothing -> Nothing +maxView = coerce MinQ.minView --- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th largest +-- | \(O(k \log n)\). Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th largest -- element in the queue. Equivalent to @toDescList queue !! k@. (!!) :: Ord a => MaxQueue a -> Int -> a q !! n | n >= size q = error "BinomialQueue.Max.!!: index too large" -q !! n = (List.!!) (toDescList q) n +q !! n = toDescList q List.!! n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] -takeWhile p = fmap unDown . MinQ.takeWhile (p . unDown) . unMaxQueue +takeWhile = coerce MinQ.takeWhile -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -dropWhile p = MaxQueue . MinQ.dropWhile (p . unDown) . unMaxQueue +dropWhile = coerce MinQ.dropWhile -- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that -- satisfy @p@ and second element is the remainder of the queue. span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -span p (MaxQueue queue) - | (front, rear) <- MinQ.span (p . unDown) queue - = (fmap unDown front, MaxQueue rear) +span = coerce MinQ.span -- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that @@ -163,81 +146,75 @@ break p = span (not . p) {-# INLINE take #-} --- | \(O(k \log n)\)/. 'take' @k@, applied to a queue @queue@, returns a list of the greatest @k@ elements of @queue@, +-- | \(O(k \log n)\). 'take' @k@, applied to a queue @queue@, returns a list of the greatest @k@ elements of @queue@, -- or all elements of @queue@ itself if @k >= 'size' queue@. take :: Ord a => Int -> MaxQueue a -> [a] take n = List.take n . toDescList --- | \(O(k \log n)\)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the greatest @k@ elements deleted, --- or an empty queue if @k >= size 'queue'@. +-- | \(O(k \log n)\). 'drop' @k@, applied to a queue @queue@, returns @queue@ with the greatest @k@ elements deleted, +-- or an empty queue if @k >= 'size' queue@. drop :: Ord a => Int -> MaxQueue a -> MaxQueue a -drop n (MaxQueue queue) = MaxQueue (MinQ.drop n queue) +drop = coerce MinQ.drop --- | \(O(k \log n)\)/. Equivalent to @('take' k queue, 'drop' k queue)@. +-- | \(O(k \log n)\). Equivalent to @('take' k queue, 'drop' k queue)@. splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) -splitAt n (MaxQueue queue) - | (l, r) <- MinQ.splitAt n queue - = (fmap unDown l, MaxQueue r) +splitAt = coerce MinQ.splitAt -- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -filter p = MaxQueue . MinQ.filter (p . unDown) . unMaxQueue +filter = coerce MinQ.filter -- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue -- contains all elements not satisfying @p@. partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) -partition p = go . unMaxQueue - where - go queue - | (l, r) <- MinQ.partition (p . unDown) queue - = (MaxQueue l, MaxQueue r) +partition = coerce MinQ.partition -- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. -- Equivalent to @'fromList' . 'Data.List.map' f . toList@. map :: Ord b => (a -> b) -> MaxQueue a -> MaxQueue b -map f = MaxQueue . MinQ.map (fmap f) . unMaxQueue +map = coerce MinQ.map {-# INLINE toList #-} -- | \(O(n \log n)\). Returns the elements of the priority queue in descending order. Equivalent to 'toDescList'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MaxQueue a -> [a] -toList = fmap unDown . MinQ.toAscList . unMaxQueue +toList = coerce MinQ.toAscList toAscList :: Ord a => MaxQueue a -> [a] -toAscList = fmap unDown . MinQ.toDescList . unMaxQueue +toAscList = coerce MinQ.toDescList toDescList :: Ord a => MaxQueue a -> [a] -toDescList = fmap unDown . MinQ.toAscList . unMaxQueue +toDescList = coerce MinQ.toAscList -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b -foldrDesc f z (MaxQueue q) = MinQ.foldrAsc (flip (foldr f)) z q +foldrDesc f z (MaxQueue q) = MinQ.foldrAsc (coerce f) z q -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in ascending order. foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b -foldrAsc f z (MaxQueue q) = MinQ.foldrDesc (flip (foldr f)) z q +foldrAsc f z (MaxQueue q) = MinQ.foldrDesc (coerce f) z q -- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in ascending order. foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlAsc f z (MaxQueue q) = MinQ.foldlDesc (foldl f) z q +foldlAsc f z (MaxQueue q) = MinQ.foldlDesc (coerce f) z q -- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlDesc f z (MaxQueue q) = MinQ.foldlAsc (foldl f) z q +foldlDesc f z (MaxQueue q) = MinQ.foldlAsc (coerce f) z q {-# INLINE fromAscList #-} -- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. fromAscList :: [a] -> MaxQueue a -fromAscList = MaxQueue . MinQ.fromDescList . fmap Down +fromAscList = coerce MinQ.fromDescList {-# INLINE fromDescList #-} -- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MaxQueue a -fromDescList = MaxQueue . MinQ.fromAscList . fmap Down +fromDescList = coerce MinQ.fromAscList fromList :: Ord a => [a] -> MaxQueue a -fromList = MaxQueue . MinQ.fromList . fmap Down +fromList = coerce MinQ.fromList -- | Equivalent to 'toListU'. elemsU :: MaxQueue a -> [a] @@ -245,7 +222,7 @@ -- | Convert to a list in an arbitrary order. toListU :: MaxQueue a -> [a] -toListU = fmap unDown . MinQ.toListU . unMaxQueue +toListU = coerce MinQ.toListU -- | Get the number of elements in a 'MaxQueue'. size :: MaxQueue a -> Int @@ -255,35 +232,34 @@ empty = MaxQueue MinQ.empty foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m -foldMapU f = MinQ.foldMapU (f . unDown) . unMaxQueue +foldMapU f = MinQ.foldMapU (coerce f) . unMaxQueue seqSpine :: MaxQueue a -> b -> b seqSpine = MinQ.seqSpine . unMaxQueue foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b -foldlU f b = MinQ.foldlU (\acc (Down a) -> f acc a) b . unMaxQueue +foldlU f b = MinQ.foldlU (coerce f) b . unMaxQueue foldlU' :: (b -> a -> b) -> b -> MaxQueue a -> b -foldlU' f b = MinQ.foldlU' (\acc (Down a) -> f acc a) b . unMaxQueue +foldlU' f b = MinQ.foldlU' (coerce f) b . unMaxQueue foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b -foldrU c n = MinQ.foldrU (c . unDown) n . unMaxQueue +foldrU c n = MinQ.foldrU (coerce c) n . unMaxQueue null :: MaxQueue a -> Bool null = MinQ.null . unMaxQueue singleton :: a -> MaxQueue a -singleton = MaxQueue . MinQ.singleton . Down +singleton = coerce MinQ.singleton mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b -mapMaybe f = MaxQueue . MinQ.mapMaybe (fmap Down . f . unDown) . unMaxQueue +mapMaybe = coerce MinQ.mapMaybe insert :: Ord a => a -> MaxQueue a -> MaxQueue a -insert a (MaxQueue q) = MaxQueue (MinQ.insert (Down a) q) +insert = coerce MinQ.insert mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) -mapEither f (MaxQueue q) = case MinQ.mapEither (bimap Down Down . f . unDown) q of - (l, r) -> (MaxQueue l, MaxQueue r) +mapEither = coerce MinQ.mapEither union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a union (MaxQueue a) (MaxQueue b) = MaxQueue (MinQ.union a b) diff --git a/src/BinomialQueue/Min.hs b/src/BinomialQueue/Min.hs --- a/src/BinomialQueue/Min.hs +++ b/src/BinomialQueue/Min.hs @@ -62,6 +62,7 @@ mapEither, -- * Fold\/Functor\/Traversable variations map, + mapMonotonic, foldrAsc, foldlAsc, foldrDesc, @@ -74,7 +75,6 @@ fromAscList, fromDescList, -- * Unordered operations - mapU, foldrU, foldlU, foldlU', @@ -88,24 +88,14 @@ import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') -import Data.Maybe (fromMaybe) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) #endif - import qualified Data.List as List +import Data.Maybe (fromMaybe) import BinomialQueue.Internals -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - -- | \(O(\log n)\). Returns the minimum element. Throws an error on an empty queue. findMin :: Ord a => MinQueue a -> a findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin @@ -120,27 +110,18 @@ deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView --- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- | \(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 +q !! n = toAscList q List.!! n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] -takeWhile p = foldWhileFB p . toAscList - -{-# INLINE foldWhileFB #-} --- | Equivalent to Data.List.takeWhile, but is a better producer. -foldWhileFB :: (a -> Bool) -> [a] -> [a] -foldWhileFB p xs0 = build (\c nil -> let - consWhile x xs - | p x = x `c` xs - | otherwise = nil - in foldr consWhile nil xs0) +takeWhile p = List.takeWhile p . toAscList -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a @@ -165,20 +146,20 @@ 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@, +-- | \(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'@. +-- | \(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)@. +-- | \(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') diff --git a/src/Data/PQueue/Internals.hs b/src/Data/PQueue/Internals.hs --- a/src/Data/PQueue/Internals.hs +++ b/src/Data/PQueue/Internals.hs @@ -29,7 +29,6 @@ toDescList, toListU, fromList, - mapU, fromAscList, foldMapU, foldrU, @@ -37,7 +36,7 @@ foldlU', -- traverseU, seqSpine, - unions + unions, ) where import BinomialQueue.Internals @@ -46,17 +45,14 @@ , BinomTree (..) , Succ (..) , Zero (..) - , Extract (..) - , MExtract (..) ) import qualified BinomialQueue.Internals as BQ import Control.DeepSeq (NFData(rnf), deepseq) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup(..), stimesMonoid) #endif +import Data.Semigroup (Semigroup(..), stimesMonoid) -import Data.PQueue.Internals.Foldable #ifdef __GLASGOW_HASKELL__ import Data.Data import Text.Read (Lexeme(Ident), lexP, parens, prec, @@ -81,6 +77,11 @@ Nothing -> Empty #ifdef __GLASGOW_HASKELL__ + +-- | Treats the priority queue as an empty queue or a minimal element and a +-- priority queue. The constructors, conceptually, are 'Data.PQueue.Min.Empty' +-- and '(Data.PQueue.Min.:<)'. All constructed queues maintain the queue +-- invariants. instance (Ord a, Data a) => Data (MinQueue a) where gfoldl f z q = case minView q of Nothing -> z Empty @@ -88,8 +89,8 @@ gunfold k z c = case constrIndex c of 1 -> z Empty - 2 -> k (k (z insertMinQ)) - _ -> error "gunfold" + 2 -> k (k (z insert)) + _ -> error "gunfold: invalid constructor for MinQueue" dataCast1 x = gcast1 x @@ -103,8 +104,8 @@ queueDataType = mkDataType "Data.PQueue.Min.MinQueue" [emptyConstr, consConstr] emptyConstr, consConstr :: Constr -emptyConstr = mkConstr queueDataType "empty" [] Prefix -consConstr = mkConstr queueDataType "<|" [] Infix +emptyConstr = mkConstr queueDataType "Empty" [] Prefix +consConstr = mkConstr queueDataType ":<" [] Infix #endif @@ -180,7 +181,7 @@ -- | \(O(n)\). Map elements and collect the 'Just' results. mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b mapMaybe _ Empty = Empty -mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insert` q') (f x) +mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insertEager` q') (f x) where q' = BQ.mapMaybe f ts @@ -190,13 +191,22 @@ mapEither f (MinQueue _ x ts) | (l, r) <- BQ.mapEither f ts = case f x of - Left y -> (fromBare (BQ.insert y l), fromBare r) - Right z -> (fromBare l, fromBare (BQ.insert z r)) + Left y -> + let !l' = fromBare (BQ.insertEager y l) + !r' = fromBare r + in (l', r') + Right z -> + let !l' = fromBare l + !r' = fromBare (BQ.insertEager z r) + in (l', r') --- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, --- as in 'fmap'. If it is not, the result is undefined. +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic +-- (meaning that @x <= y@ implies @f x <= f y@), and +-- applies this function to every element of the priority queue, as in 'fmap'. +-- If the function is not monotonic, the result is undefined. mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b -mapMonotonic = mapU +mapMonotonic _ Empty = Empty +mapMonotonic f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapMonotonic f ts) {-# INLINABLE [0] foldrAsc #-} -- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in @@ -269,7 +279,7 @@ -- | @insertMaxQ' x h@ assumes that @x@ compares as greater -- than or equal to every element of @h@. It also assumes, --- and preserves, an extra invariant. See 'insertMax'' for details. +-- and preserves, an extra invariant. See 'BQ.insertMax'' for details. -- tldr: this function can be used safely to build a queue from an -- ascending list/array/whatever, but that's about it. insertMaxQ' :: a -> MinQueue a -> MinQueue a @@ -284,10 +294,6 @@ -- comparison per element. fromList xs = fromBare (BQ.fromList xs) -mapU :: (a -> b) -> MinQueue a -> MinQueue b -mapU _ Empty = Empty -mapU f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapU f ts) - {-# NOINLINE [0] foldrU #-} -- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MinQueue a -> b @@ -336,11 +342,11 @@ -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. -- --- Note: The spine of a 'MinQueue' is stored somewhat lazily. Most operations --- take great care to prevent chains of thunks from accumulating along the --- spine to the detriment of performance. However, @mapU@ can leave expensive --- thunks in the structure and repeated applications of that function can --- create thunk chains. +-- Note: The spine of a 'MinQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MinQueue a -> b -> b seqSpine Empty z = z seqSpine (MinQueue _ _ ts) z = BQ.seqSpine ts z @@ -351,29 +357,27 @@ instance (Ord a, Show a) => Show (MinQueue a) where showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) + showString "fromList " . shows (toAscList xs) -instance Read a => Read (MinQueue a) where +instance (Ord a, Read a) => Read (MinQueue a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP + Ident "fromList" <- lexP xs <- readPrec - return (fromAscList xs) + return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \r -> do - ("fromAscList",s) <- lex r + ("fromList",s) <- lex r (xs,t) <- reads s - return (fromAscList xs,t) + return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MinQueue a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} -#endif instance Ord a => Monoid (MinQueue a) where mempty = empty diff --git a/src/Data/PQueue/Internals/Classes.hs b/src/Data/PQueue/Internals/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals/Classes.hs @@ -0,0 +1,26 @@ +-- | Writing `Foldable`/`Functor` instances for non-regular (AKA, nested) types in the +-- natural manner leads to full dictionaries being constructed on +-- each recursive call. This is pretty inefficient. It's better to construct +-- exactly what we need instead. +module Data.PQueue.Internals.Classes + ( Foldr(..) + , Foldl(..) + , FoldMap(..) + , Foldl'(..) + , Fmap(..) + ) where + +class Foldr t where + foldr_ :: (a -> b -> b) -> b -> t a -> b + +class Foldl t where + foldl_ :: (b -> a -> b) -> b -> t a -> b + +class FoldMap t where + foldMap_ :: Monoid m => (a -> m) -> t a -> m + +class Foldl' t where + foldl'_ :: (b -> a -> b) -> b -> t a -> b + +class Fmap f where + fmap_ :: (a -> b) -> f a -> f b diff --git a/src/Data/PQueue/Internals/Foldable.hs b/src/Data/PQueue/Internals/Foldable.hs deleted file mode 100644 --- a/src/Data/PQueue/Internals/Foldable.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | Writing 'Foldable' instances for non-regular (AKA, nested) types in the --- natural manner leads to full `Foldable` dictionaries being constructed on --- each recursive call. This is pretty inefficient. It's better to construct --- exactly what we need instead. -module Data.PQueue.Internals.Foldable - ( Foldr (..) - , Foldl (..) - , FoldMap (..) - , Foldl' (..) - , IFoldr (..) - , IFoldl (..) - , IFoldMap (..) - , IFoldl' (..) - ) where - -class Foldr t where - foldr_ :: (a -> b -> b) -> b -> t a -> b - -class IFoldr t where - foldrWithKey_ :: (k -> a -> b -> b) -> b -> t k a -> b - -class Foldl t where - foldl_ :: (b -> a -> b) -> b -> t a -> b - -class IFoldl t where - foldlWithKey_ :: (b -> k -> a -> b) -> b -> t k a -> b - -class FoldMap t where - foldMap_ :: Monoid m => (a -> m) -> t a -> m - -class IFoldMap t where - foldMapWithKey_ :: Monoid m => (k -> a -> m) -> t k a -> m - -class Foldl' t where - foldl'_ :: (b -> a -> b) -> b -> t a -> b - -class IFoldl' t where - foldlWithKey'_ :: (b -> k -> a -> b) -> b -> t k a -> b diff --git a/src/Data/PQueue/Max.hs b/src/Data/PQueue/Max.hs --- a/src/Data/PQueue/Max.hs +++ b/src/Data/PQueue/Max.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Max @@ -59,6 +61,7 @@ mapEither, -- * Fold\/Functor\/Traversable variations map, + mapMonotonic, foldrAsc, foldlAsc, foldrDesc, @@ -84,14 +87,13 @@ import Control.DeepSeq (NFData(rnf)) +import Data.Coerce (coerce) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable (foldl') +#endif import Data.Maybe (fromMaybe) - -#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid) -#endif -import Data.Foldable (foldl') - import qualified Data.PQueue.Min as Min import qualified Data.PQueue.Prio.Max.Internals as Prio import Data.PQueue.Internals.Down (Down(..)) @@ -122,29 +124,27 @@ instance (Ord a, Show a) => Show (MaxQueue a) where showsPrec p xs = showParen (p > 10) $ - showString "fromDescList " . shows (toDescList xs) + showString "fromList " . shows (toDescList xs) -instance Read a => Read (MaxQueue a) where +instance (Ord a, Read a) => Read (MaxQueue a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do - Ident "fromDescList" <- lexP + Ident "fromList" <- lexP xs <- readPrec - return (fromDescList xs) + return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \r -> do - ("fromDescList",s) <- lex r + ("fromList",s) <- lex r (xs,t) <- reads s - return (fromDescList xs,t) + return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MaxQueue a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} -#endif instance Ord a => Monoid (MaxQueue a) where mempty = empty @@ -171,11 +171,11 @@ -- | \(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 +getMax = coerce Min.getMin -- | \(O(\log n)\). Deletes the maximum element of the queue. Does nothing on an empty queue. deleteMax :: Ord a => MaxQueue a -> MaxQueue a -deleteMax (MaxQ q) = MaxQ (Min.deleteMin q) +deleteMax = coerce Min.deleteMin -- | \(O(\log n)\). Extracts the maximum element of the queue. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) @@ -183,10 +183,7 @@ -- | \(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') +maxView = coerce Min.minView -- | \(O(\log n)\). Delete the top (maximum) element of the sequence, if there is one. delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) @@ -194,11 +191,11 @@ -- | \(O(1)\). Construct a priority queue with a single element. singleton :: a -> MaxQueue a -singleton = MaxQ . Min.singleton . Down +singleton = coerce Min.singleton -- | \(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) +insert = coerce Min.insert -- | \(O(\log min(n_1,n_2))\). Take the union of two priority queues. union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a @@ -206,43 +203,41 @@ -- | 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]) +unions = coerce Min.unions --- | \(O(k \log n)\)/. Returns the @(k+1)@th largest element of the queue. +-- | \(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) +(!!) = coerce (Min.!!) {-# INLINE take #-} --- | \(O(k \log n)\)/. Returns the list of the @k@ largest elements of the queue, in descending order, or +-- | \(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] +take = coerce Min.take --- | \(O(k \log n)\)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. +-- | \(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) +drop = coerce Min.drop --- | \(O(k \log n)\)/. Equivalent to @(take k queue, drop k queue)@. +-- | \(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) = (fmap unDown xs, MaxQ q') where - (xs, q') = Min.splitAt k q +splitAt = coerce Min.splitAt -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] -takeWhile p (MaxQ q) = fmap unDown (Min.takeWhile (p . unDown) q) +takeWhile = coerce Min.takeWhile -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a -dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q) +dropWhile = coerce Min.dropWhile -- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that -- satisfy @p@ and second element is the remainder of the queue. -- span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -span p (MaxQ q) = (fmap unDown xs, MaxQ q') where - (xs, q') = Min.span (p . unDown) q +span = coerce Min.span -- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that @@ -252,54 +247,58 @@ -- | \(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) +filter = coerce Min.filter -- | \(O(n)\). Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, -- and the right queue contains those that do not. partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) -partition p (MaxQ q) = (MaxQ q0, MaxQ q1) - where (q0, q1) = Min.partition (p . unDown) q +partition = coerce Min.partition -- | \(O(n)\). Maps a function over the elements of the queue, and collects the 'Just' values. mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b -mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\(Down x) -> Down <$> f x) q) +mapMaybe = coerce Min.mapMaybe -- | \(O(n)\). Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) -mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1) - where (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q +mapEither = coerce Min.mapEither -- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. -- Equivalent to @'fromList' . 'Data.List.map' f . toList@. map :: Ord b => (a -> b) -> MaxQueue a -> MaxQueue b -map f (MaxQ q) = MaxQ (Min.map (\(Down x) -> Down (f x)) q) +map = coerce Min.map --- | \(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/. +-- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic +-- (meaning that @x <= y@ implies @f x <= f y@), and +-- applies this function to every element of the priority queue, as in 'fmap'. +-- If the function is not monotonic, the result is undefined. +mapMonotonic :: (a -> b) -> MaxQueue a -> MaxQueue b +mapMonotonic f (MaxQ q) = MaxQ (Min.mapMonotonic (\(Down a) -> Down (f a)) q) + +{-# DEPRECATED mapU "use mapMonotonic instead" #-} mapU :: (a -> b) -> MaxQueue a -> MaxQueue b -mapU f (MaxQ q) = MaxQ (Min.mapU (\(Down a) -> Down (f a)) q) +mapU = mapMonotonic -- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b -foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q +foldrU f z (MaxQ q) = Min.foldrU (coerce f) z q -- | \(O(n)\). Unordered monoidal fold on a priority queue. -- -- @since 1.4.2 foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m -foldMapU f (MaxQ q) = Min.foldMapU (f . unDown) q +foldMapU f (MaxQ q) = Min.foldMapU (coerce f) q -- | \(O(n)\). Unordered left fold on a priority queue. This is rarely -- what you want; 'foldrU' and 'foldlU'' are more likely to perform -- well. foldlU :: (b -> a -> b) -> b -> MaxQueue a -> b -foldlU f z (MaxQ q) = Min.foldlU (foldl f) z q +foldlU f z (MaxQ q) = Min.foldlU (coerce f) z q -- | \(O(n)\). Unordered strict left fold on a priority queue. -- -- @since 1.4.2 foldlU' :: (b -> a -> b) -> b -> MaxQueue a -> b -foldlU' f z (MaxQ q) = Min.foldlU' (foldl' f) z q +foldlU' f z (MaxQ q) = Min.foldlU' (coerce f) z q {-# INLINE elemsU #-} -- | Equivalent to 'toListU'. @@ -309,7 +308,7 @@ {-# 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) = fmap unDown (Min.toListU q) +toListU = coerce Min.toListU -- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in ascending order. -- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. @@ -323,11 +322,11 @@ -- | \(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 +foldrDesc f z (MaxQ q) = Min.foldrAsc (coerce f) z q -- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b -foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q +foldlDesc f z (MaxQ q) = Min.foldlAsc (coerce f) z q {-# INLINE toAscList #-} -- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. @@ -342,37 +341,37 @@ -- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016) {-# INLINE toList #-} --- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'. +-- | \(O(n \log n)\). Returns the elements of the priority queue in descending order. Equivalent to 'toDescList'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MaxQueue a -> [a] -toList (MaxQ q) = fmap unDown (Min.toList q) +toList = coerce Min.toList {-# INLINE fromAscList #-} -- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. fromAscList :: [a] -> MaxQueue a -fromAscList = MaxQ . Min.fromDescList . fmap Down +fromAscList = coerce Min.fromDescList {-# INLINE fromDescList #-} -- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MaxQueue a -fromDescList = MaxQ . Min.fromAscList . fmap Down +fromDescList = coerce Min.fromAscList {-# INLINE fromList #-} -- | \(O(n \log n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MaxQueue a -fromList = MaxQ . Min.fromList . fmap Down +fromList = coerce Min.fromList -- | \(O(n)\). Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. keysQueue :: Prio.MaxPQueue k a -> MaxQueue k -keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q) +keysQueue = coerce Min.keysQueue -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. -- --- Note: The spine of a 'MaxQueue' is stored somewhat lazily. Most operations --- take great care to prevent chains of thunks from accumulating along the --- spine to the detriment of performance. However, 'mapU' can leave expensive --- thunks in the structure and repeated applications of that function can --- create thunk chains. +-- Note: The spine of a 'MaxQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MaxQueue a -> b -> b seqSpine (MaxQ q) = Min.seqSpine q diff --git a/src/Data/PQueue/Min.hs b/src/Data/PQueue/Min.hs --- a/src/Data/PQueue/Min.hs +++ b/src/Data/PQueue/Min.hs @@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +#endif ----------------------------------------------------------------------------- -- | @@ -24,7 +28,13 @@ -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Min ( +#if __GLASGOW_HASKELL__ >= 802 + MinQueue (Data.PQueue.Min.Empty, (:<)), +#elif defined (__GLASGOW_HASKELL__) MinQueue, + pattern Data.PQueue.Min.Empty, + pattern (:<), +#endif -- * Basic operations empty, null, @@ -58,6 +68,7 @@ mapEither, -- * Fold\/Functor\/Traversable variations map, + mapMonotonic, foldrAsc, foldlAsc, foldrDesc, @@ -83,24 +94,51 @@ import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') -import Data.Maybe (fromMaybe) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) #endif - import qualified Data.List as List +import Data.Maybe (fromMaybe) -import Data.PQueue.Internals +import Data.PQueue.Internals hiding (MinQueue (..)) +import Data.PQueue.Internals (MinQueue (MinQueue)) +import qualified Data.PQueue.Internals as Internals import qualified BinomialQueue.Internals as BQ import qualified Data.PQueue.Prio.Internals as Prio #ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] +-- | A bidirectional pattern synonym for an empty priority queue. +-- +-- @since 1.5.0 +pattern Empty :: MinQueue a +pattern Empty = Internals.Empty +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE CONLIKE Empty #-} +# endif + +infixr 5 :< + +-- | A bidirectional pattern synonym for working with the minimum view of a +-- 'MinQueue'. Using @:<@ to construct a queue performs an insertion in +-- \(O(1)\) amortized time. When matching on @a :< q@, forcing @q@ takes +-- \(O(\log n)\) time. +-- +-- @since 1.5.0 +# if __GLASGOW_HASKELL__ >= 800 +pattern (:<) :: Ord a => a -> MinQueue a -> MinQueue a +# else +pattern (:<) :: () => Ord a => a -> MinQueue a -> MinQueue a +# endif +pattern a :< q <- (minView -> Just (a, q)) + where + a :< q = insert a q +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE (:<) #-} +# endif + +# if __GLASGOW_HASKELL__ >= 820 +{-# COMPLETE Empty, (:<) #-} +# endif #endif -- | \(O(1)\). Returns the minimum element. Throws an error on an empty queue. @@ -117,27 +155,18 @@ deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView --- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- | \(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 +q !! n = toAscList q List.!! n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] -takeWhile p = foldWhileFB p . toAscList - -{-# INLINE foldWhileFB #-} --- | Equivalent to Data.List.takeWhile, but is a better producer. -foldWhileFB :: (a -> Bool) -> [a] -> [a] -foldWhileFB p xs0 = build (\c nil -> let - consWhile x xs - | p x = x `c` xs - | otherwise = nil - in foldr consWhile nil xs0) +takeWhile p = List.takeWhile p . toAscList -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a @@ -162,20 +191,20 @@ 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@, +-- | \(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'@. +-- | \(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)@. +-- | \(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') @@ -196,6 +225,10 @@ map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b map f = foldrU (insert . f) empty +{-# DEPRECATED mapU "use mapMonotonic instead" #-} +mapU :: (a -> b) -> MinQueue a -> MinQueue b +mapU = mapMonotonic + {-# INLINE toList #-} -- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. -- @@ -220,13 +253,13 @@ -- | 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.Empty = Internals.Empty keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (BQ.MinQueue (keysF (const Zero) ts)) keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k keysF f ts0 = case ts0 of Prio.Nil -> Nil - Prio.Skip ts' -> Skip (keysF f' ts') - Prio.Cons (Prio.BinomTree k _ ts) ts' - -> Cons (BinomTree k (f ts)) (keysF f' ts') - where f' (Prio.Succ (Prio.BinomTree k _ ts) tss) = Succ (BinomTree k (f ts)) (f tss) + 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) diff --git a/src/Data/PQueue/Prio/Internals.hs b/src/Data/PQueue/Prio/Internals.hs --- a/src/Data/PQueue/Prio/Internals.hs +++ b/src/Data/PQueue/Prio/Internals.hs @@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.PQueue.Prio.Internals ( MinPQueue(..), @@ -15,7 +17,7 @@ size, singleton, insert, - insertBehind, + insertEager, union, getMin, adjustMinWithKey, @@ -46,26 +48,25 @@ mapMWithKey, traverseWithKeyU, seqSpine, - mapForest, unions ) where -import Control.Applicative (liftA2, liftA3) +#if MIN_VERSION_base(4,18,0) +import Control.Applicative (Const (..)) +#else +import Control.Applicative (liftA2, Const (..)) +#endif import Control.DeepSeq (NFData(rnf), deepseq) +import Data.Coerce (coerce) import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Data.List as List -import Data.PQueue.Internals.Foldable -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup(..), stimesMonoid) -#else -import Data.Monoid ((<>)) -#endif +import Data.Semigroup (Semigroup(..), stimesMonoid, Endo (..), Dual (..)) import Prelude hiding (null, map) #ifdef __GLASGOW_HASKELL__ import Data.Data -import GHC.Exts (build) +import GHC.Exts (build, inline) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, readListPrecDefault) #endif @@ -73,6 +74,7 @@ import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex +import Nattish (Nattish (..)) #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] @@ -80,30 +82,43 @@ #endif #if __GLASGOW_HASKELL__ -instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where - gfoldl f z m = z fromList `f` foldrWithKey (curry (:)) [] m - toConstr _ = fromListConstr - gunfold k z c = case constrIndex c of - 1 -> k (z fromList) - _ -> error "gunfold" + +-- | Treats the priority queue as an empty queue or a minimal +-- key-value pair and a priority queue. The constructors, conceptually, +-- are 'Data.PQueue.Prio.Min.Empty' and '(Data.PQueue.Prio.Min.:<)'. +-- +-- 'gfoldl' is nondeterministic; any minimal pair may be chosen as +-- the first. All constructed queues maintain the queue invariants. +instance (Ord k, Data k, Data a) => Data (MinPQueue k a) where + gfoldl f z q = case minViewWithKey q of + Nothing -> z Empty + Just (x, q') -> z (\(k, a) -> insert k a) `f` x `f` q' + + gunfold k z c = case constrIndex c of + 1 -> z Empty + 2 -> k (k (z (\(key, val) -> insert key val))) + _ -> error "gunfold: invalid constructor for MinPQueue" + + toConstr q + | null q = emptyConstr + | otherwise = consConstr + dataTypeOf _ = queueDataType dataCast1 f = gcast1 f dataCast2 f = gcast2 f queueDataType :: DataType -queueDataType = mkDataType "Data.PQueue.Prio.Min.MinPQueue" [fromListConstr] - -fromListConstr :: Constr -fromListConstr = mkConstr queueDataType "fromList" [] Prefix +queueDataType = mkDataType "Data.PQueue.Prio.Min.MinPQueue" [emptyConstr, consConstr] +emptyConstr, consConstr :: Constr +emptyConstr = mkConstr queueDataType "Empty" [] Prefix +consConstr = mkConstr queueDataType ":<" [] Infix #endif -#if MIN_VERSION_base(4,9,0) instance Ord k => Semigroup (MinPQueue k a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} -#endif instance Ord k => Monoid (MinPQueue k a) where mempty = empty @@ -114,21 +129,21 @@ instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) + showString "fromList " . shows (toAscList xs) -instance (Read k, Read a) => Read (MinPQueue k a) where +instance (Ord k, Read k, Read a) => Read (MinPQueue k a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP + Ident "fromList" <- lexP xs <- readPrec - return (fromAscList xs) + return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \r -> do - ("fromAscList",s) <- lex r + ("fromList",s) <- lex r (xs,t) <- reads s - return (fromAscList xs,t) + return (fromList xs,t) #endif -- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). @@ -139,16 +154,10 @@ (.:) :: (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) - 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. +-- | A priority queue where keys of type @k@ are annotated with values of type +-- @a@. The queue supports extracting the key-value pair with minimum key. data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a) data BinomForest rk k a = @@ -157,43 +166,9 @@ 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) - -instance IFoldl' Zero where - foldlWithKey'_ _ z ~Zero = z - -instance IFoldMap Zero where - foldMapWithKey_ _ ~Zero = mempty - -instance IFoldl' t => IFoldl' (Succ t) where - foldlWithKey'_ f z (Succ t rk) = foldlWithKey'_ f z' rk - where - !z' = foldlWithKey'_ f z t - -instance IFoldMap t => IFoldMap (Succ t) where - foldMapWithKey_ f (Succ t rk) = foldMapWithKey_ f t `mappend` foldMapWithKey_ f rk - -instance IFoldl' rk => IFoldl' (BinomTree rk) where - foldlWithKey'_ f !z (BinomTree k a rk) = foldlWithKey'_ f ft rk - where - !ft = f z k a - -instance IFoldMap rk => IFoldMap (BinomTree rk) where - foldMapWithKey_ f (BinomTree k a rk) = f k a `mappend` foldMapWithKey_ f rk - -instance IFoldl' t => IFoldl' (BinomForest t) where - foldlWithKey'_ _f z Nil = z - foldlWithKey'_ f !z (Skip ts) = foldlWithKey'_ f z ts - foldlWithKey'_ f !z (Cons t ts) = foldlWithKey'_ f ft ts - where - !ft = foldlWithKey'_ f z t - -instance IFoldMap t => IFoldMap (BinomForest t) where - foldMapWithKey_ _f Nil = mempty - foldMapWithKey_ f (Skip ts) = foldMapWithKey_ f ts - foldMapWithKey_ f (Cons t ts) = foldMapWithKey_ f t `mappend` foldMapWithKey_ f ts +data BinomTree rk k a = BinomTree !k (rk k a) +newtype Zero k a = Zero a +data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a) instance (Ord k, Eq a) => Eq (MinPQueue k a) where MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 = @@ -201,11 +176,11 @@ Empty == Empty = True _ == _ = False -eqExtract :: (Ord k, Eq a) => k -> a -> BinomForest rk k a -> k -> a -> BinomForest rk k a -> Bool +eqExtract :: (Ord k, Eq a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Bool eqExtract k10 a10 ts10 k20 a20 ts20 = k10 == k20 && a10 == a20 && case (extract ts10, extract ts20) of - (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) + (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero a2) ts2')) -> eqExtract k1 a1 ts1' k2 a2 ts2' (No, No) -> True _ -> False @@ -217,11 +192,11 @@ Empty `compare` MinPQ{} = LT MinPQ{} `compare` Empty = GT -cmpExtract :: (Ord k, Ord a) => k -> a -> BinomForest rk k a -> k -> a -> BinomForest rk k a -> Ordering +cmpExtract :: (Ord k, Ord a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Ordering cmpExtract k10 a10 ts10 k20 a20 ts20 = k10 `compare` k20 <> a10 `compare` a20 <> case (extract ts10, extract ts20) of - (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) + (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero a2) ts2')) -> cmpExtract k1 a1 ts1' k2 a2 ts2' (No, Yes{}) -> LT (Yes{}, No) -> GT @@ -253,20 +228,11 @@ | 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, --- putting it behind elements whose key compares equal to the --- inserted one. -insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a -insertBehind k v q = - let (smaller, larger) = spanKey (<= k) q - in foldr (uncurry insert) (insert k v larger) smaller - -spanKey :: Ord k => (k -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) -spanKey p q = case minViewWithKey q of - Just (t@(k, _), q') | p k -> - let (kas, q'') = spanKey p q' in (t : kas, q'') - _ -> ([], q) +insertEager :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a +insertEager k a Empty = singleton k a +insertEager k a (MinPQ n k' a' ts) + | k <= k' = MinPQ (n + 1) k a (insertEagerHeap k' a' ts) + | otherwise = MinPQ (n + 1) k' a' (insertEagerHeap k a ts) -- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union -- of the two specified queues. @@ -325,26 +291,81 @@ -- | \(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) +mapWithKey f = runIdentity . traverseWithKeyU (coerce 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'. +-- | \(O(n)\). @'mapKeysMonotonic' f q == 'Data.PQueue.Prio.Min.mapKeys' f q@, +-- but only works when @f@ is (weakly) monotonic (meaning that @x <= y@ implies +-- @f x <= f y@). /The precondition is not checked./ This function has better +-- performance than 'Data.PQueue.Prio.Min.mapKeys'. +-- +-- Note: if the given function returns bottom for any of the keys in the queue, then the +-- portion of the queue which is bottom is /unspecified/. mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeysMonotonic _ Empty = Empty -mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts) +mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a $! mapKeysMonoHeap f ts +mapKeysMonoHeap :: forall k k' a. (k -> k') -> BinomHeap k a -> BinomHeap k' a +mapKeysMonoHeap f = mapKeysMonoForest Zeroy + where + mapKeysMonoForest :: Ranky rk -> BinomForest rk k a -> BinomForest rk k' a + mapKeysMonoForest !_rky Nil = Nil + mapKeysMonoForest !rky (Skip rest) = Skip $! mapKeysMonoForest (Succy rky) rest + mapKeysMonoForest !rky (Cons t rest) = Cons (mapKeysMonoTree rky t) $! mapKeysMonoForest (Succy rky) rest + + {-# INLINE mapKeysMonoTree #-} + mapKeysMonoTree :: Ranky rk -> BinomTree rk k a -> BinomTree rk k' a + mapKeysMonoTree Zeroy (BinomTree k (Zero a)) = + -- We've reached a value, which we must not force. + BinomTree (f k) (Zero a) + -- We're not at a value; we force the result. + mapKeysMonoTree (Succy rky) (BinomTree k ts) = BinomTree (f k) $! mapKeysMonoTrees rky ts + + mapKeysMonoTrees :: Ranky rk -> Succ rk k a -> Succ rk k' a + mapKeysMonoTrees Zeroy (Succ t (Zero a)) = + -- Don't force the value! + Succ (mapKeysMonoTree Zeroy t) (Zero a) + mapKeysMonoTrees (Succy rky) (Succ t ts) = + -- Whew, no values; force the trees. + Succ (mapKeysMonoTree (Succy rky) t) $! mapKeysMonoTrees rky ts + -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b -mapMaybeWithKey _ Empty = Empty -mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF f (const Empty) ts) +mapMaybeWithKey f = fromBare . + foldlWithKeyU' + (\q k a -> case f k a of + Nothing -> q + Just b -> insertEagerHeap k b q) + Nil +{-# INLINABLE mapMaybeWithKey #-} -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) -mapEitherWithKey _ 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) +mapEitherWithKey f q + | (l, r) <- mapEitherHeap f q + , let + !l' = fromBare l + !r' = fromBare r + = (l', r') +{-# INLINABLE mapEitherWithKey #-} +data Partition k a b = Partition !(BinomHeap k a) !(BinomHeap k b) + +fromPartition :: Partition k a b -> (BinomHeap k a, BinomHeap k b) +fromPartition (Partition p q) = (p, q) + +mapEitherHeap :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (BinomHeap k b, BinomHeap k c) +mapEitherHeap f = fromPartition . + foldlWithKeyU' + (\(Partition ls rs) k a -> + case f k a of + Left b -> Partition (insertEagerHeap k b ls) rs + Right b -> Partition ls (insertEagerHeap k b rs)) + (Partition Nil Nil) + +insertEagerHeap :: Ord k => k -> a -> BinomHeap k a -> BinomHeap k a +insertEagerHeap k a h = incr' (tip k a) h +{-# INLINE insertEagerHeap #-} + -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. -- @@ -353,8 +374,8 @@ foldrWithKey _ z Empty = z foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where foldF ts = case extract ts of - Yes (Extract k a _ ts') -> f k a (foldF ts') - _ -> z + Yes (Extract k (Zero a) ts') -> f k a (foldF ts') + No -> z -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. @@ -364,8 +385,8 @@ foldlWithKey _ z Empty = z foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where foldF z ts = case extract ts of - Yes (Extract k a _ ts') -> foldF (f z k a) ts' - _ -> z + Yes (Extract k (Zero a) ts') -> foldF (f z k a) ts' + No -> z {-# INLINABLE [1] toAscList #-} -- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. @@ -420,22 +441,25 @@ {-# INLINE fromList #-} -- | \(O(n)\). Constructs a priority queue from an unordered list. fromList :: Ord k => [(k, a)] -> MinPQueue k a --- We build a forest first and then extract its minimum at the end. --- Why not just build the 'MinQueue' directly? This way saves us one --- comparison per element. -fromList xs = case extract (fromListHeap xs) of +-- We build a forest first and then extract its minimum at the end. Why not +-- just build the 'MinQueue' directly? This way typically saves us one +-- comparison per element, which roughly halves comparisons. +fromList xs = fromBare (fromListHeap xs) + +fromBare :: Ord k => BinomHeap k a -> MinPQueue k a +fromBare xs = case extract xs of No -> Empty -- Should we track the size as we go instead? That saves O(log n) -- at the end, but it needs an extra register all along the way. -- The nodes should probably all be in L1 cache already thanks to the -- extractHeap. - Yes (Extract k v ~Zero f) -> MinPQ (sizeHeap f + 1) k v f + Yes (Extract k (Zero v) f) -> MinPQ (sizeHeap f + 1) k v f {-# INLINE fromListHeap #-} fromListHeap :: Ord k => [(k, a)] -> BinomHeap k a fromListHeap xs = List.foldl' go Nil xs where - go fr (k, a) = incr' (tip k a) fr + go fr (k, a) = insertEagerHeap k a fr sizeHeap :: BinomHeap k a -> Int sizeHeap = go 0 1 @@ -448,13 +472,13 @@ -- | \(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 +tip k a = BinomTree k (Zero a) -- | \(O(1)\). Takes the union of two binomial trees of the same rank. meld :: Ord k => BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a -meld t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) - | k1 <= k2 = BinomTree k1 v1 (Succ t2 ts1) - | otherwise = BinomTree k2 v2 (Succ t1 ts2) +meld t1@(BinomTree k1 ts1) t2@(BinomTree k2 ts2) + | k1 <= k2 = BinomTree k1 (Succ t2 ts1) + | otherwise = BinomTree k2 (Succ t1 ts2) -- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. mergeForest :: Ord k => BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a @@ -500,31 +524,31 @@ -- 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 +incrMin t@(BinomTree k ts) tss = case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' - Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k a (Succ t' ts)) tss') + Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k (Succ t' ts)) tss') -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr'' (\_ _ -> True)@. Forces the rebuilt portion of the spine. incrMin' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -incrMin' t@(BinomTree k a ts) tss = case tss of +incrMin' t@(BinomTree k ts) tss = case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' - Cons t' tss' -> Skip $! incrMin' (BinomTree k a (Succ t' ts)) tss' + Cons t' tss' -> Skip $! incrMin' (BinomTree k (Succ t' ts)) tss' -- | See 'insertMax'' for invariant info. incrMax' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incrMax' t tss = t `seq` case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' - Cons (BinomTree k a ts) tss' -> Skip $! incrMax' (BinomTree k a (Succ t ts)) tss' + Cons (BinomTree k ts) tss' -> Skip $! incrMax' (BinomTree k (Succ t ts)) tss' extractHeap :: Ord k => Int -> BinomHeap k a -> MinPQueue k a extractHeap n ts = n `seq` case extract ts of No -> Empty - Yes (Extract k a _ ts') -> MinPQ (n - 1) k a ts' + Yes (Extract k (Zero a) ts') -> MinPQ (n - 1) k a ts' -- | A specialized type intended to organize the return of extract-min queries -- from a binomial forest. We walk all the way through the forest, and then @@ -551,21 +575,16 @@ -- 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 Extract rk k a = Extract !k (rk k a) !(BinomForest rk k a) data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) incrExtract :: Extract (Succ rk) k a -> Extract rk k a -incrExtract (Extract minKey minVal (Succ kChild kChildren) ts) - = Extract minKey minVal kChildren (Cons kChild ts) +incrExtract (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Cons kChild ts) --- Why are we so lazy here? The idea, right or not, is to avoid a potentially --- expensive second pass to propagate carries. Instead, carry propagation gets --- 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' :: 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) +incrExtract' t (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Skip $! incr' (t `meld` kChild) ts) -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes @@ -578,8 +597,8 @@ start (Skip f) = case start f of No -> No Yes ex -> Yes (incrExtract ex) - start (Cons t@(BinomTree k v ts) f) = Yes $ case go k f of - No -> Extract k v ts (Skip f) + start (Cons t@(BinomTree k ts) f) = Yes $ case go k f of + No -> Extract k ts (skip f) Yes ex -> incrExtract' t ex go :: Ord k => k -> BinomForest rk k a -> MExtract rk k a @@ -587,81 +606,64 @@ go min_above (Skip f) = case go min_above f of No -> No Yes ex -> Yes (incrExtract ex) - go min_above (Cons t@(BinomTree k v ts) f) + go min_above (Cons t@(BinomTree k ts) f) | min_above <= k = case go min_above f of No -> No Yes ex -> Yes (incrExtract' t ex) | otherwise = case go k f of - No -> Yes (Extract k v ts (Skip f)) + No -> Yes (Extract k ts (skip f)) 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 -mapForest f fCh ts0 = case ts0 of - Nil -> Nil - Skip ts' -> Skip (mapForest f fCh' ts') - Cons (BinomTree k a ts) tss - -> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss) - where fCh' (Succ (BinomTree k a ts) tss) - = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss) - --- | Utility function for mapping a 'Maybe' function over a forest. -mapMaybeF :: Ord k => (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> - BinomForest rk k a -> MinPQueue k b -mapMaybeF f fCh ts0 = case ts0 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 :: 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 f0 fCh ts0 = case ts0 of - Nil -> (Empty, Empty) - Skip ts' -> mapEitherF f0 fCh' ts' - Cons (BinomTree k a ts) ts' - -> insF k a (fCh ts) (mapEitherF f0 fCh' ts') - where - 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) +skip :: BinomForest (Succ rk) k a -> BinomForest rk k a +skip Nil = Nil +skip f = Skip f +{-# INLINE skip #-} -- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b -foldrWithKeyU _ z Empty = z -foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z) +foldrWithKeyU c n = flip appEndo n . inline foldMapWithKeyU (coerce c) -- | \(O(n)\). An unordered monoidal fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 -foldMapWithKeyU :: Monoid m => (k -> a -> m) -> MinPQueue k a -> m -foldMapWithKeyU _ Empty = mempty -foldMapWithKeyU f (MinPQ _ k a ts) = f k a `mappend` foldMapWithKey_ f ts +foldMapWithKeyU :: forall m k a. Monoid m => (k -> a -> m) -> MinPQueue k a -> m +foldMapWithKeyU = coerce + (inline traverseWithKeyU :: (k -> a -> Const m ()) -> MinPQueue k a -> Const m (MinPQueue k ())) -- | \(O(n)\). An unordered left fold over the elements of the queue, in no -- particular order. This is rarely what you want; 'foldrWithKeyU' and -- 'foldlWithKeyU'' are more likely to perform well. foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b -foldlWithKeyU _ z Empty = z -foldlWithKeyU f z0 (MinPQ _ k0 a0 ts) = foldlWithKeyF_ (\k a z -> f z k a) (const id) ts (f z0 k0 a0) +foldlWithKeyU f b = flip appEndo b . getDual . + foldMapWithKeyU (\k a -> Dual $ Endo $ \r -> f r k a) -- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b -foldlWithKeyU' _ z Empty = z -foldlWithKeyU' f !z0 (MinPQ _ k0 a0 ts) = foldlWithKey'_ f (f z0 k0 a0) ts +foldlWithKeyU' f !b q = + case q of + Empty -> b + MinPQ _n k a ts -> foldlHeapU' f (f b k a) ts --- | \(O(n)\). Map a function over all values in the queue. -map :: (a -> b) -> MinPQueue k a -> MinPQueue k b -map = mapWithKey . const +foldlHeapU' :: forall k a b. (b -> k -> a -> b) -> b -> BinomHeap k a -> b +foldlHeapU' f = \b -> foldlForest' Zeroy b + where + foldlForest' :: Ranky rk -> b -> BinomForest rk k a -> b + foldlForest' !_rky !acc Nil = acc + foldlForest' !rky !acc (Skip rest) = foldlForest' (Succy rky) acc rest + foldlForest' !rky !acc (Cons t rest) = + foldlForest' (Succy rky) (foldlTree' rky acc t) rest + {-# INLINE foldlTree' #-} + foldlTree' :: Ranky rk -> b -> BinomTree rk k a -> b + foldlTree' !rky !acc (BinomTree k ts) = foldlTrees' rky acc k ts + + foldlTrees' :: Ranky rk -> b -> k -> rk k a -> b + foldlTrees' Zeroy !acc !k (Zero a) = f acc k a + foldlTrees' (Succy rky) !acc !k (Succ t ts) = + foldlTrees' rky (foldlTree' rky acc t) k ts + -- | \(O(n \log n)\). Traverses the elements of the queue in ascending order by key. -- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) -- @@ -687,65 +689,51 @@ let !acc' = insertMax' k b acc go acc' q' +-- | Natural numbers revealing whether something is 'Zero' or 'Succ'. +type Ranky = Nattish Zero Succ + -- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. -- While there is no guarantee in which order the elements are traversed, the resulting -- priority queue will be perfectly valid. -traverseWithKeyU :: Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) +{-# INLINABLE traverseWithKeyU #-} +traverseWithKeyU :: forall f k a b. Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) traverseWithKeyU _ Empty = pure Empty -traverseWithKeyU f (MinPQ n k a ts) = liftA2 (MinPQ n k) (f k a) (traverseForest f (const (pure Zero)) ts) - -{-# SPECIALIZE traverseForest :: (k -> a -> Identity b) -> (rk k a -> Identity (rk k b)) -> BinomForest rk k a -> - Identity (BinomForest rk k b) #-} -traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b) -traverseForest f fCh ts0 = case ts0 of - Nil -> pure Nil - Skip ts' -> Skip <$> traverseForest f fCh' ts' - Cons (BinomTree k a ts) tss - -> liftA3 (\p q -> Cons (BinomTree k p q)) (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 +traverseWithKeyU f (MinPQ n k a ts) = liftA2 (\a' !ts' -> MinPQ n k a' ts') (f k a) (traverseHeapU f ts) --- | Unordered right fold on a binomial forest. -foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b -foldrWithKeyF_ f fCh ts0 z0 = case ts0 of - Nil -> z0 - Skip ts' -> foldrWithKeyF_ f fCh' ts' z0 - Cons (BinomTree k a ts) ts' - -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0)) +{-# INLINABLE traverseHeapU #-} +traverseHeapU :: forall f k a b. Applicative f => (k -> a -> f b) -> BinomHeap k a -> f (BinomHeap k b) +traverseHeapU f = traverseForest Zeroy where - fCh' (Succ (BinomTree k a ts) tss) z = - f k a (fCh ts (fCh tss z)) + traverseForest :: Ranky rk -> BinomForest rk k a -> f (BinomForest rk k b) + traverseForest !_rky Nil = pure Nil + traverseForest !rky (Skip rest) = (Skip $!) <$> traverseForest (Succy rky) rest + traverseForest !rky (Cons t rest) = + liftA2 (\ !t' !rest' -> Cons t' rest') (traverseTree rky t) (traverseForest (Succy rky) rest) --- | Unordered left fold on a binomial forest. -foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b -foldlWithKeyF_ f fCh ts0 = case ts0 of - Nil -> id - Skip ts' -> foldlWithKeyF_ f fCh' ts' - Cons (BinomTree k a ts) ts' - -> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a - where - fCh' (Succ (BinomTree k a ts) tss) = - fCh tss . fCh ts . f k a + {-# INLINE traverseTree #-} + traverseTree :: Ranky rk -> BinomTree rk k a -> f (BinomTree rk k b) + traverseTree Zeroy (BinomTree k (Zero a)) = + -- We've reached a value, so we don't force the result. + BinomTree k . Zero <$> f k a + traverseTree (Succy rky) (BinomTree k ts) = + -- We're not at a value, so we force the tree list. + (BinomTree k $!) <$> traverseTrees rky k ts --- | Maps a monotonic function over the keys in a binomial forest. -mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a -mapKeysMonoF f fCh ts0 = case ts0 of - Nil -> Nil - Skip ts' -> Skip (mapKeysMonoF f fCh' ts') - Cons (BinomTree k a ts) ts' - -> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts') - where - fCh' (Succ (BinomTree k a ts) tss) = - Succ (BinomTree (f k) a (fCh ts)) (fCh tss) + traverseTrees :: Ranky rk -> k -> Succ rk k a -> f (Succ rk k b) + traverseTrees Zeroy !k2 (Succ (BinomTree k1 (Zero a1)) (Zero a2)) = + -- The right subtree is a value, so we don't force it. + liftA2 (\b1 b2 -> Succ (BinomTree k1 (Zero b1)) (Zero b2)) (f k1 a1) (f k2 a2) + traverseTrees (Succy rky) !k (Succ t ts) = + -- Whew; no values. We're safe to force. + liftA2 (\ !t' !ts' -> Succ t' ts') (traverseTree (Succy rky) t) (traverseTrees rky k ts) -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. -- --- Note: The spine of a 'MinPQueue' is stored somewhat lazily. Most operations --- take great care to prevent chains of thunks from accumulating along the --- spine to the detriment of performance. However, 'mapKeysMonotonic' can leave --- expensive thunks in the structure and repeated applications of that function --- can create thunk chains. +-- Note: The spine of a 'MinPQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MinPQueue k a -> b -> b seqSpine Empty z0 = z0 seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where @@ -759,13 +747,13 @@ rnfRk :: (NFData k, NFData a) => rk k a -> () instance NFRank Zero where - rnfRk _ = () + rnfRk (Zero a) = rnf a instance NFRank rk => NFRank (Succ rk) where rnfRk (Succ t ts) = t `deepseq` rnfRk ts instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where - rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts + rnf (BinomTree k ts) = k `deepseq` rnfRk ts instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where rnf Nil = () @@ -777,10 +765,11 @@ rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts instance Functor (MinPQueue k) where - fmap = map + fmap = imap . const instance FunctorWithIndex k (MinPQueue k) where - imap = mapWithKey + imap = coerce + (traverseWithKeyU :: (k -> a -> Identity b) -> MinPQueue k a -> Identity (MinPQueue k b)) instance Ord k => Foldable (MinPQueue k) where foldr = foldrWithKey . const diff --git a/src/Data/PQueue/Prio/Max.hs b/src/Data/PQueue/Prio/Max.hs --- a/src/Data/PQueue/Prio/Max.hs +++ b/src/Data/PQueue/Prio/Max.hs @@ -32,7 +32,6 @@ empty, singleton, insert, - insertBehind, union, unions, -- * Query diff --git a/src/Data/PQueue/Prio/Max/Internals.hs b/src/Data/PQueue/Prio/Max/Internals.hs --- a/src/Data/PQueue/Prio/Max/Internals.hs +++ b/src/Data/PQueue/Prio/Max/Internals.hs @@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Prio.Max @@ -18,7 +20,6 @@ empty, singleton, insert, - insertBehind, union, unions, -- * Query @@ -105,15 +106,14 @@ ) where +import Data.Coerce import Data.Maybe (fromMaybe) import Data.PQueue.Internals.Down import Data.PQueue.Prio.Internals (MinPQueue) import qualified Data.PQueue.Prio.Internals as PrioInternals import Control.DeepSeq (NFData(rnf)) -#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid) -#endif import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) import qualified Data.Foldable as F @@ -147,15 +147,10 @@ instance (NFData k, NFData a) => NFData (MaxPQueue k a) where rnf (MaxPQ q) = rnf q -first' :: (a -> b) -> (a, c) -> (b, c) -first' f (a, c) = (f a, c) - -#if MIN_VERSION_base(4,9,0) instance Ord k => Semigroup (MaxPQueue k a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} -#endif instance Ord k => Monoid (MaxPQueue k a) where mempty = empty @@ -166,21 +161,21 @@ instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where showsPrec p xs = showParen (p > 10) $ - showString "fromDescList " . shows (toDescList xs) + showString "fromList " . shows (toDescList xs) -instance (Read k, Read a) => Read (MaxPQueue k a) where +instance (Ord k, Read k, Read a) => Read (MaxPQueue k a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do - Ident "fromDescList" <- lexP + Ident "fromList" <- lexP xs <- readPrec - return (fromDescList xs) + return (fromList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \r -> do - ("fromDescList",s) <- lex r + ("fromList",s) <- lex r (xs,t) <- reads s - return (fromDescList xs,t) + return (fromList xs,t) #endif instance Functor (MaxPQueue k) where @@ -215,28 +210,21 @@ -- | \(O(1)\). Constructs a singleton priority queue. singleton :: k -> a -> MaxPQueue k a -singleton k a = MaxPQ (Q.singleton (Down k) a) +singleton = coerce Q.singleton -- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts -- an element with the specified key into the queue. insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insert k a (MaxPQ q) = MaxPQ (Q.insert (Down k) a q) - --- | \(O(n)\) (an earlier implementation had \(O(1)\) but was buggy). --- Insert an element with the specified key into the priority queue, --- putting it behind elements whose key compares equal to the --- inserted one. -insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) +insert = coerce Q.insert -- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union -- of the two specified queues. union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a -MaxPQ q1 `union` MaxPQ q2 = MaxPQ (q1 `Q.union` q2) +union = coerce Q.union -- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a -unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs]) +unions = coerce Q.unions -- | \(O(1)\). Checks if this priority queue is empty. null :: MaxPQueue k a -> Bool @@ -252,13 +240,11 @@ -- | \(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) +getMax = coerce Q.getMin -- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a -deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q) +deleteMax = coerce Q.deleteMin -- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) @@ -277,14 +263,14 @@ -- | \(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) +adjustMaxWithKey = coerce Q.adjustMinWithKey -- | \(O(1)\) per operation. Alter the value at the maximum key in an -- 'Applicative' context. If the queue is empty, does nothing. -- -- @since 1.4.2 adjustMaxWithKeyA :: Applicative f => (k -> a -> f a) -> MaxPQueue k a -> f (MaxPQueue k a) -adjustMaxWithKeyA f (MaxPQ q) = PrioInternals.adjustMinWithKeyA' MaxPQ (f . unDown) q +adjustMaxWithKeyA f (MaxPQ q) = PrioInternals.adjustMinWithKeyA' MaxPQ (coerce f) q -- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. -- If the queue is empty, does nothing. @@ -302,7 +288,7 @@ -- | \(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) +updateMaxWithKey = coerce Q.updateMinWithKey -- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update -- the value at the maximum key in an 'Applicative' context. If the queue is @@ -310,7 +296,7 @@ -- -- @since 1.4.2 updateMaxWithKeyA :: (Applicative f, Ord k) => (k -> a -> f (Maybe a)) -> MaxPQueue k a -> f (MaxPQueue k a) -updateMaxWithKeyA f (MaxPQ q) = PrioInternals.updateMinWithKeyA' MaxPQ (f . unDown) q +updateMaxWithKeyA f (MaxPQ q) = PrioInternals.updateMinWithKeyA' MaxPQ (coerce f) q -- | \(O(\log n)\). Retrieves the value associated with the maximum key of the queue, and the queue -- stripped of that element, or 'Nothing' if passed an empty queue. @@ -322,9 +308,7 @@ -- | \(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') +maxViewWithKey = coerce Q.minViewWithKey -- | \(O(n)\). Map a function over all values in the queue. map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b @@ -332,31 +316,34 @@ -- | \(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) +mapWithKey = coerce Q.mapWithKey -- | \(O(n)\). Map a function over all values in the queue. mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q) +mapKeys = coerce Q.mapKeys --- | \(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'. +-- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when +-- @f@ is (weakly) monotonic (meaning that @x <= y@ implies @f x <= f y@). +-- /The precondition is not checked./ This function has better performance than 'mapKeys'. +-- +-- Note: if the given function returns bottom for any of the keys in the queue, then the +-- portion of the queue which is bottom is /unspecified/. mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q) +mapKeysMonotonic = coerce Q.mapKeysMonotonic -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. -- -- If you do not care about the traversal order, consider using 'foldrWithKeyU'. foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q +foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (coerce f) z q -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. -- -- If you do not care about the traversal order, consider using 'foldlWithKeyU'. foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\z -> f z . unDown) z0 q +foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (coerce f) z0 q -- | \(O(n \log n)\). Traverses the elements of the queue in descending order by key. -- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) @@ -365,38 +352,26 @@ -- -- If you are working in a strict monad, consider using 'mapMWithKey'. traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (f . unDown) q +traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (coerce f) q -- | A strictly accumulating version of 'traverseWithKey'. This works well in -- 'IO' and strict @State@, and is likely what you want for other "strict" monads, -- where @⊥ >>= pure () = ⊥@. mapMWithKey :: (Ord k, Monad m) => (k -> a -> m b) -> MaxPQueue k a -> m (MaxPQueue k b) -mapMWithKey f = go empty - where - go !acc q = - case maxViewWithKey q of - Nothing -> pure acc - Just ((k, a), q') -> do - b <- f k a - let !acc' = insertMin' k b acc - go acc' q' - -insertMin' :: k -> a -> MaxPQueue k a -> MaxPQueue k a -insertMin' k a (MaxPQ q) = MaxPQ (PrioInternals.insertMax' (Down k) a q) +mapMWithKey f (MaxPQ q) = MaxPQ <$> Q.mapMWithKey (coerce f) q --- | \(O(k \log n)\)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. +-- | \(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) +take = coerce Q.take --- | \(O(k \log n)\)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. +-- | \(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) +drop = coerce Q.drop --- | \(O(k \log n)\)/. Equivalent to @('take' k 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') +splitAt = coerce Q.splitAt -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) @@ -406,7 +381,7 @@ -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q) +takeWhileWithKey = coerce Q.takeWhileWithKey -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a @@ -414,7 +389,7 @@ -- | 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) +dropWhileWithKey = coerce Q.dropWhileWithKey -- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) @@ -426,13 +401,11 @@ -- | 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') +spanWithKey = coerce Q.spanWithKey -- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') +breakWithKey = coerce Q.breakWithKey -- | \(O(n)\). Filter all values that satisfy the predicate. filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a @@ -440,7 +413,7 @@ -- | \(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) +filterWithKey = coerce Q.filterWithKey -- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. @@ -450,8 +423,7 @@ -- | \(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) +partitionWithKey = coerce Q.partitionWithKey -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b @@ -459,7 +431,7 @@ -- | \(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) +mapMaybeWithKey = coerce Q.mapMaybeWithKey -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) @@ -467,20 +439,19 @@ -- | \(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) +mapEitherWithKey = coerce Q.mapEitherWithKey -- | \(O(n)\). Build a priority queue from the list of (key, value) pairs. fromList :: Ord k => [(k, a)] -> MaxPQueue k a -fromList = MaxPQ . Q.fromList . fmap (first' Down) +fromList = coerce Q.fromList -- | \(O(n)\). Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ fromAscList :: [(k, a)] -> MaxPQueue k a -fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down) +fromAscList = coerce Q.fromDescList -- | \(O(n)\). Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ fromDescList :: [(k, a)] -> MaxPQueue k a -fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down) +fromDescList = coerce Q.fromAscList -- | \(O(n \log n)\). Return all keys of the queue in descending order. keys :: Ord k => MaxPQueue k a -> [k] @@ -496,11 +467,11 @@ -- | \(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) +toAscList = coerce Q.toDescList -- | \(O(n \log n)\). Return all (key, value) pairs in descending order by key. toDescList :: Ord k => MaxPQueue k a -> [(k, a)] -toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q) +toDescList = coerce Q.toAscList -- | \(O(n \log n)\). Equivalent to 'toDescList'. -- @@ -514,13 +485,13 @@ -- | \(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 +foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (coerce f) z q -- | \(O(n)\). An unordered monoidal fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldMapWithKeyU :: Monoid m => (k -> a -> m) -> MaxPQueue k a -> m -foldMapWithKeyU f (MaxPQ q) = Q.foldMapWithKeyU (f . unDown) q +foldMapWithKeyU f (MaxPQ q) = Q.foldMapWithKeyU (coerce f) q -- | \(O(n)\). An unordered left fold over the elements of the queue, in no -- particular order. This is rarely what you want; 'foldrU' and 'foldlU'' are @@ -539,13 +510,13 @@ -- particular order. This is rarely what you want; 'foldrWithKeyU' and -- 'foldlWithKeyU'' are more likely to perform well. foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (\z -> f z . unDown) z0 q +foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (coerce f) z0 q -- | \(O(n)\). An unordered left fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKeyU' f z0 (MaxPQ q) = Q.foldlWithKeyU' (\z -> f z . unDown) z0 q +foldlWithKeyU' f z0 (MaxPQ q) = Q.foldlWithKeyU' (coerce f) z0 q -- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. -- While there is no guarantee in which order the elements are traversed, the resulting @@ -557,7 +528,7 @@ -- 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 +traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (coerce f) q -- | \(O(n)\). Return all keys of the queue in no particular order. keysU :: MaxPQueue k a -> [k] @@ -573,14 +544,14 @@ -- | \(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) +toListU = coerce Q.toListU -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. -- --- Note: The spine of a 'MaxPQueue' is stored somewhat lazily. Most operations --- take great care to prevent chains of thunks from accumulating along the --- spine to the detriment of performance. However, 'mapKeysMonotonic' can leave --- expensive thunks in the structure and repeated applications of that function --- can create thunk chains. +-- Note: The spine of a 'MaxPQueue' is stored somewhat lazily. In earlier +-- versions of this package, some operations could produce chains of thunks +-- along the spine, occasionally necessitating manual forcing. Now, all +-- operations are careful to force enough to avoid this problem. +{-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MaxPQueue k a -> b -> b seqSpine (MaxPQ q) = Q.seqSpine q diff --git a/src/Data/PQueue/Prio/Min.hs b/src/Data/PQueue/Prio/Min.hs --- a/src/Data/PQueue/Prio/Min.hs +++ b/src/Data/PQueue/Prio/Min.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -29,12 +31,17 @@ -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Prio.Min ( +#if __GLASGOW_HASKELL__ >= 802 + MinPQueue (Data.PQueue.Prio.Min.Empty, (:<)), +#elif defined (__GLASGOW_HASKELL__) MinPQueue, + pattern Data.PQueue.Prio.Min.Empty, + pattern (:<), +#endif -- * Construction empty, singleton, insert, - insertBehind, union, unions, -- * Query @@ -124,19 +131,45 @@ import qualified Data.List as List import Data.Maybe (fromMaybe) -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - -import Data.PQueue.Prio.Internals +import Data.PQueue.Prio.Internals hiding (MinPQueue (..)) +import Data.PQueue.Prio.Internals (MinPQueue) +import qualified Data.PQueue.Prio.Internals as Internals import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) #ifdef __GLASGOW_HASKELL__ -import GHC.Exts (build) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] +-- | A bidirectional pattern synonym for an empty priority queue. +-- +-- @since 1.5.0 +pattern Empty :: MinPQueue k a +pattern Empty = Internals.Empty +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE CONLIKE Empty #-} +# endif + +infixr 5 :< + +-- | A bidirectional pattern synonym for working with the minimum view of a +-- 'MinPQueue'. Using @:<@ to construct a queue performs an insertion in +-- \(O(1)\) amortized time. When matching on @(k, a) :< q@, forcing @q@ takes +-- \(O(\log n)\) time. +-- +-- @since 1.5.0 +# if __GLASGOW_HASKELL__ >= 800 +pattern (:<) :: Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a +# else +pattern (:<) :: () => Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a +# endif +pattern ka :< q <- (minViewWithKey -> Just (ka, q)) + where + (k, a) :< q = insert k a q +# if __GLASGOW_HASKELL__ >= 902 +{-# INLINE (:<) #-} +# endif + +# if __GLASGOW_HASKELL__ >= 820 +{-# COMPLETE Empty, (:<) #-} +# endif #endif (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d @@ -239,12 +272,12 @@ 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@. +-- | \(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@. +-- | \(O(k \log n)\). Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. drop :: Ord k => Int -> MinPQueue k a -> MinPQueue k a drop n0 q0 | n0 <= 0 = q0 @@ -255,7 +288,7 @@ | n == 0 = q | otherwise = drop' (n - 1) (deleteMin q) --- | \(O(k \log n)\)/. Equivalent to @('take' k q, 'drop' k 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) @@ -273,8 +306,7 @@ -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toAscList' q)@) takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> [(k, a)] -takeWhileWithKey p0 = takeWhileFB (uncurry' p0) . toAscList where - takeWhileFB p xs = build (\c n -> foldr (\x z -> if p x then x `c` z else n) n xs) +takeWhileWithKey p0 = List.takeWhile (uncurry' p0) . toAscList -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a diff --git a/src/Nattish.hs b/src/Nattish.hs new file mode 100644 --- /dev/null +++ b/src/Nattish.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 904 +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE ViewPatterns #-} +#endif + +-- | A facility for faking GADTs that work sufficiently similarly +-- to unary natural numbers. +module Nattish + ( Nattish (Zeroy, Succy) + ) + where +#if __GLASGOW_HASKELL__ >= 904 +import Unsafe.Coerce (unsafeCoerce) +#endif +import Data.Kind (Type) + +-- | Conceptually, +-- +-- @ +-- data Nattish :: forall k. k -> (k -> k) -> k -> Type where +-- Zeroy :: Nattish zero succ zero +-- Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n) +-- @ +-- +-- This abstracts over the zero and successor constructors, so it can be used +-- in any sufficiently Nat-like context. In our case, we can use it for the @Zero@ +-- and @Succ@ constructors of both @MinQueue@ and @MinPQueue@. With recent +-- versions of GHC, @Nattish@ is actually represented as a machine integer, so +-- it is very fast to work with. + +#if __GLASGOW_HASKELL__ < 904 +data Nattish :: k -> (k -> k) -> k -> Type where + Zeroy :: Nattish zero succ zero + Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n) + +toWord :: Nattish zero succ n -> Word +toWord = go 0 + where + go :: Word -> Nattish zero succ n -> Word + go !acc Zeroy = acc + go !acc (Succy n) = go (acc + 1) n + +instance Show (Nattish zero succ n) where + showsPrec p n = showParen (p > 10) $ + showString "Nattish " . showsPrec 11 (toWord n) +#else + +type Nattish :: forall k. k -> (k -> k) -> k -> Type +newtype Nattish zero succ n = Nattish Word + deriving (Show) +type role Nattish nominal nominal nominal + +data Res zero succ n where + ResZero :: Res zero succ zero + ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n) + +check :: Nattish zero succ n -> Res zero succ n +check (Nattish 0) = unsafeCoerce ResZero +check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1)) + +pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n +pattern Zeroy <- (check -> ResZero) + where + Zeroy = Nattish 0 +{-# INLINE Zeroy #-} + +pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n +pattern Succy n <- (check -> ResSucc n) + where + Succy (Nattish n) = Nattish (n + 1) +{-# INLINE Succy #-} + +{-# COMPLETE Zeroy, Succy #-} + +#endif diff --git a/tests/PQueueTests.hs b/tests/PQueueTests.hs --- a/tests/PQueueTests.hs +++ b/tests/PQueueTests.hs @@ -1,13 +1,21 @@ +{-# language CPP #-} + +{-# language BangPatterns #-} {-# language ExtendedDefaultRules #-} {-# language ScopedTypeVariables #-} {-# language TupleSections #-} +{-# language ViewPatterns #-} +{-# options_ghc -Wno-x-partial #-} + module Main (main) where import Data.Bifunctor (bimap, first, second) +import qualified Data.Either as Either import Data.Function (on) import Data.Functor.Identity import qualified Data.List as List +import qualified Data.Maybe as Maybe import Data.Ord (Down(..)) import Test.Tasty @@ -17,9 +25,21 @@ import qualified Data.PQueue.Min as Min import qualified Data.PQueue.Prio.Max as PMax import qualified Data.PQueue.Prio.Min as PMin +import qualified Validity.PQueue.Min as VMin +import qualified Validity.PQueue.Prio.Min as VPMin +import qualified Validity.PQueue.Prio.Max as VPMax default (Int) +validMinQueue :: Ord a => Min.MinQueue a -> Property +validMinQueue q = VMin.validShape q .&&. VMin.validSize q .&&. VMin.validOrder q + +validPMinQueue :: Ord k => PMin.MinPQueue k a -> Property +validPMinQueue q = VPMin.validShape q .&&. VPMin.validSize q .&&. VPMin.validOrder q + +validPMaxQueue :: Ord k => PMax.MaxPQueue k a -> Property +validPMaxQueue q = VPMax.validShape q .&&. VPMax.validSize q .&&. VPMax.validOrder q + main :: IO () main = defaultMain $ testGroup "pqueue" [ testGroup "Data.PQueue.Min" @@ -28,12 +48,42 @@ [ testProperty "empty" $ Min.getMin Min.empty === Nothing , testProperty "non-empty" $ \(NonEmpty xs) -> Min.getMin (Min.fromList xs) === Just (minimum xs) ] - , testProperty "minView" $ \xs -> Min.minView (Min.fromList xs) === fmap (second Min.fromList) (List.uncons (List.sort xs)) + , testProperty "minView" $ \xs -> case Min.minView (Min.fromList xs) of + Nothing -> xs === [] + Just (the_min, xs') -> + validMinQueue xs' .&&. + the_min : Min.toList xs' === List.sort xs , testProperty "insert" $ \x xs -> Min.insert x (Min.fromList xs) === Min.fromList (x : xs) , testProperty "union" $ \xs ys -> Min.union (Min.fromList xs) (Min.fromList ys) === Min.fromList (xs ++ ys) - , testProperty "filter" $ \xs -> Min.filter even (Min.fromList xs) === Min.fromList (List.filter even xs) - , testProperty "partition" $ \xs -> Min.partition even (Min.fromList xs) === bimap Min.fromList Min.fromList (List.partition even xs) + , testProperty "filter" $ \xs -> + let xs' = Min.filter even (Min.fromList xs) + in validMinQueue xs' .&&. + Min.toList xs' === List.sort (List.filter even xs) + , testProperty "partition" $ \xs -> + let xs' = Min.fromList xs + (ys, zs) = Min.partition even xs' + in validMinQueue ys .&&. + validMinQueue zs .&&. + (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (List.partition even xs) + , testProperty "mapMaybe" $ \(Fn f) xs -> + let xs' :: Min.MinQueue Char + xs' = Min.mapMaybe f (Min.fromList xs) + in validMinQueue xs' .&&. + Min.toList xs' === List.sort (Maybe.mapMaybe f xs) + , testProperty "mapEither" $ \(Fn f) xs -> + let (ys, zs) = Min.mapEither f (Min.fromList xs) + in validMinQueue ys .&&. + validMinQueue zs .&&. + (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (Either.partitionEithers . List.map f $ xs) , testProperty "map" $ \xs -> Min.map negate (Min.fromList xs) === Min.fromList (List.map negate xs) + , testProperty "mapMonotonic" $ \xs -> + let + -- Monotonic, but not strictly so + fun x + | even x = x + | otherwise = x + 1 + res = Min.mapMonotonic fun (Min.fromList xs) + in validMinQueue res .&&. Min.toList res === List.map fun (List.sort xs) , testProperty "take" $ \n xs -> Min.take n (Min.fromList xs) === List.take n (List.sort xs) , testProperty "drop" $ \n xs -> Min.drop n (Min.fromList xs) === Min.fromList (List.drop n (List.sort xs)) , testProperty "splitAt" $ \n xs -> Min.splitAt n (Min.fromList xs) === second Min.fromList (List.splitAt n (List.sort xs)) @@ -48,7 +98,6 @@ , testProperty "toDescList" $ \xs -> Min.toDescList (Min.fromList xs) === List.sortOn Down xs , testProperty "fromAscList" $ \xs -> Min.fromAscList (List.sort xs) === Min.fromList xs , testProperty "fromDescList" $ \xs -> Min.fromDescList (List.sortOn Down xs) === Min.fromList xs - , testProperty "mapU" $ \xs -> Min.mapU (+ 1) (Min.fromList xs) === Min.fromList (List.map (+ 1) xs) , testProperty "foldrU" $ \xs -> Min.foldrU (+) 0 (Min.fromList xs) === sum xs , testProperty "foldlU" $ \xs -> Min.foldlU (+) 0 (Min.fromList xs) === sum xs , testProperty "foldlU'" $ \xs -> Min.foldlU' (+) 0 (Min.fromList xs) === sum xs @@ -68,6 +117,7 @@ , testProperty "filter" $ \xs -> Max.filter even (Max.fromList xs) === Max.fromList (List.filter even xs) , testProperty "partition" $ \xs -> Max.partition even (Max.fromList xs) === bimap Max.fromList Max.fromList (List.partition even xs) , testProperty "map" $ \xs -> Max.map negate (Max.fromList xs) === Max.fromList (List.map negate xs) + , testProperty "mapMonotonic" $ \xs -> Max.mapMonotonic (+ 1) (Max.fromList xs) === Max.fromList (List.map (+ 1) xs) , testProperty "take" $ \n xs -> Max.take n (Max.fromList xs) === List.take n (List.sortOn Down xs) , testProperty "drop" $ \n xs -> Max.drop n (Max.fromList xs) === Max.fromList (List.drop n (List.sortOn Down xs)) , testProperty "splitAt" $ \n xs -> Max.splitAt n (Max.fromList xs) === second Max.fromList (List.splitAt n (List.sortOn Down xs)) @@ -82,7 +132,6 @@ , testProperty "toDescList" $ \xs -> Max.toDescList (Max.fromList xs) === List.sortOn Down xs , testProperty "fromAscList" $ \xs -> Max.fromAscList (List.sort xs) === Max.fromList xs , testProperty "fromDescList" $ \xs -> Max.fromDescList (List.sortOn Down xs) === Max.fromList xs - , testProperty "mapU" $ \xs -> Max.mapU (+ 1) (Max.fromList xs) === Max.fromList (List.map (+ 1) xs) , testProperty "foldrU" $ \xs -> Max.foldrU (+) 0 (Max.fromList xs) === sum xs , testProperty "foldlU" $ \xs -> Max.foldlU (+) 0 (Max.fromList xs) === sum xs , testProperty "foldlU'" $ \xs -> Max.foldlU' (+) 0 (Max.fromList xs) === sum xs @@ -106,9 +155,20 @@ [ testProperty "Just" $ \xs -> PMin.updateMinA (Identity . Just) (PMin.fromList xs) === Identity (PMin.fromList xs) , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMin.updateMinA (Identity . const Nothing) (PMin.fromList xs) === Identity (PMin.fromList (tail (List.sort xs))) ] - , testProperty "minViewWithKey" $ \(xs :: [(Int, ())]) -> PMin.minViewWithKey (PMin.fromList xs) === fmap (second PMin.fromList) (List.uncons (List.sort xs)) + , testProperty "minViewWithKey" $ \(xs :: [(Int, Int)]) -> case PMin.minViewWithKey (PMin.fromList xs) of + Nothing -> xs === [] + Just ((the_min, the_min_val), xs') -> + validPMinQueue xs' .&&. + List.sort ((the_min, the_min_val) : PMin.toList xs') === List.sort xs , testProperty "map" $ \(xs :: [(Int, ())]) -> PMin.map id (PMin.fromList xs) === PMin.fromList xs - , testProperty "mapKeysMonotonic" $ \xs -> PMin.mapKeysMonotonic (+ 1) (PMin.fromList xs) === PMin.fromList (List.map (first (+ 1)) xs) + , testProperty "mapKeysMonotonic" $ \xs -> + let + -- Monotonic, but not strictly so + fun x + | even x = x + | otherwise = x + 1 + res = PMin.mapKeysMonotonic fun (PMin.fromList xs) + in validPMinQueue res .&&. List.sort (PMin.toList res) === List.sort (List.map (first fun) xs) , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMin.take n (PMin.fromList xs) === List.take n (List.sort xs) , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMin.drop n (PMin.fromList xs) === PMin.fromList (List.drop n (List.sort xs)) , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMin.splitAt n (PMin.fromList xs) === second PMin.fromList (List.splitAt n (List.sort xs)) @@ -123,10 +183,35 @@ \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.mapMWithKey f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) , testProperty "insert" $ \k xs -> PMin.insert k () (PMin.fromList xs) === PMin.fromList ((k, ()) : xs) , testProperty "union" $ \(xs :: [(Int, ())]) ys -> PMin.union (PMin.fromList xs) (PMin.fromList ys) === PMin.fromList (xs ++ ys) - , testProperty "filter" $ - \(xs :: [(Int, ())]) -> PMin.filterWithKey (\k _ -> even k) (PMin.fromList xs) === PMin.fromList (List.filter (even . fst) xs) - , testProperty "partition" $ - \(xs :: [(Int, ())]) -> PMin.partitionWithKey (\k _ -> even k) (PMin.fromList xs) === bimap PMin.fromList PMin.fromList (List.partition (even . fst) xs) + , testProperty "filter" $ \(xs :: [(Int, Int)]) -> + let + -- The probability of a number not being divisible by 3 is 2/3. + -- The probability of a number not being divisible by 4 is 3/4. + -- So the probability of a number being divisible by neither is + -- 1/2. + f x y = x `rem` 3 == 0 || y `rem` 4 == 0 + xs' = PMin.filterWithKey f (PMin.fromList xs) + in validPMinQueue xs' .&&. + List.sort (PMin.toList xs') === List.sort (List.filter (uncurry f) xs) + , testProperty "partition" $ \(xs :: [(Int, Int)]) -> + let + f x y = x `rem` 3 == 0 || y `rem` 4 == 0 + (ys, zs) = PMin.partitionWithKey f (PMin.fromList xs) + in validPMinQueue ys .&&. + validPMinQueue zs .&&. + (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) === + bimap List.sort List.sort (List.partition (uncurry f) xs) + , testProperty "mapMaybe" $ \(Fn2 f) (xs :: [(Int, Int)]) -> + let + xs' = PMin.mapMaybeWithKey f (PMin.fromList xs) + in validPMinQueue xs' .&&. + List.sort (PMin.toList xs') === List.sort (Maybe.mapMaybe (\(k,v) -> fmap (k,) (f k v)) xs) + , testProperty "mapEither" $ \(Fn2 f) (xs :: [(Int, Int)]) -> + let (ys, zs) = PMin.mapEitherWithKey f (PMin.fromList xs) + in validPMinQueue ys .&&. + validPMinQueue zs .&&. + (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) === + bimap List.sort List.sort (Either.partitionEithers . List.map (\(k,v) -> bimap (k,) (k,) (f k v)) $ xs) , testProperty "toAscList" $ \(xs :: [(Int, ())]) -> PMin.toAscList (PMin.fromList xs) === List.sort xs , testProperty "toDescList" $ \(xs :: [(Int, ())]) -> PMin.toDescList (PMin.fromList xs) === List.sortOn Down xs , testProperty "fromAscList" $ \(xs :: [(Int, ())]) -> PMin.fromAscList (List.sort xs) === PMin.fromList xs @@ -158,7 +243,14 @@ ] , testProperty "minViewWithKey" $ \(xs :: [(Int, ())]) -> PMax.maxViewWithKey (PMax.fromList xs) === fmap (second PMax.fromList) (List.uncons (List.sortOn Down xs)) , testProperty "map" $ \(xs :: [(Int, ())]) -> PMax.map id (PMax.fromList xs) === PMax.fromList xs - , testProperty "mapKeysMonotonic" $ \xs -> PMax.mapKeysMonotonic (+ 1) (PMax.fromList xs) === PMax.fromList (List.map (first (+ 1)) xs) + , testProperty "mapKeysMonotonic" $ \xs -> + let + -- Monotonic, but not strictly so + fun x + | even x = x + | otherwise = x + 1 + res = PMax.mapKeysMonotonic fun (PMax.fromList xs) + in validPMaxQueue res .&&. List.sort (PMax.toList res) === List.sort (List.map (first fun) xs) , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMax.take n (PMax.fromList xs) === List.take n (List.sortOn Down xs) , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMax.drop n (PMax.fromList xs) === PMax.fromList (List.drop n (List.sortOn Down xs)) , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMax.splitAt n (PMax.fromList xs) === second PMax.fromList (List.splitAt n (List.sortOn Down xs)) diff --git a/tests/Validity/BinomialQueue.hs b/tests/Validity/BinomialQueue.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/BinomialQueue.hs @@ -0,0 +1,49 @@ +-- | Validity testing +module Validity.BinomialQueue + ( validShape + , precedesProperly + ) where + +import BinomialQueue.Internals + +-- | Does the heap have a valid shape? +validShape :: MinQueue a -> Bool +validShape (MinQueue f) = validShapeF f + +validShapeF :: BinomForest rk a -> Bool +validShapeF (Cons _ f) = validShapeF f +validShapeF (Skip Nil) = False +validShapeF (Skip _f) = True +validShapeF Nil = True + +-- | Takes an element and a priority queue. Checks that the queue is in heap +-- order and that the element is less than or equal to all elements of the +-- queue. +precedesProperly :: Ord a => a -> MinQueue a -> Bool +precedesProperly a (MinQueue q) = precedesProperlyF a q + +-- | Takes an element and a forest. Checks that the forest is in heap order +-- and that the element is less than or equal to all elements of the forest. +precedesProperlyF :: (Ord a, TreeValidity rk) => a -> BinomForest rk a -> Bool +precedesProperlyF _ Nil = True +precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f +precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t + && precedesProperlyF the_min ts + +-- | Takes an element and a tree. Checks that the tree is in heap order +-- and that the element is less than or equal to all elements of the tree. +precedesProperlyTree :: (Ord a, TreeValidity rk) => a -> BinomTree rk a -> Bool +precedesProperlyTree the_min (BinomTree a ts) = the_min <= a && precedesProperlyRk a ts + +-- | A helper class for order validity checking +class TreeValidity rk where + -- | Takes an element and a collection of trees. Checks that the collection + -- is in heap order and that the element is less than or equal to all + -- elements of the collection. + precedesProperlyRk :: Ord a => a -> rk a -> Bool +instance TreeValidity Zero where + precedesProperlyRk _ ~Zero = True +instance TreeValidity rk => TreeValidity (Succ rk) where + precedesProperlyRk the_min (Succ t q) = + precedesProperlyTree the_min t && + precedesProperlyRk the_min q diff --git a/tests/Validity/PQueue/Min.hs b/tests/Validity/PQueue/Min.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Min.hs @@ -0,0 +1,21 @@ +module Validity.PQueue.Min + ( validShape + , validSize + , validOrder + ) where + +import Data.PQueue.Internals +import qualified BinomialQueue.Internals as BQ +import qualified Validity.BinomialQueue as VBQ + +validShape :: MinQueue a -> Bool +validShape Empty = True +validShape (MinQueue _ _ f) = VBQ.validShape f + +validSize :: MinQueue a -> Bool +validSize Empty = True +validSize (MinQueue sz _ f) = sz == BQ.size f + 1 + +validOrder :: Ord a => MinQueue a -> Bool +validOrder Empty = True +validOrder (MinQueue _sz a f) = VBQ.precedesProperly a f diff --git a/tests/Validity/PQueue/Prio/BinomialQueue.hs b/tests/Validity/PQueue/Prio/BinomialQueue.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Prio/BinomialQueue.hs @@ -0,0 +1,40 @@ +-- | Validity testing +module Validity.PQueue.Prio.BinomialQueue + ( validShapeF + , precedesProperlyF + ) where + +import Data.PQueue.Prio.Internals + +-- | Does the heap have a valid shape? +validShapeF :: BinomForest rk k a -> Bool +validShapeF (Cons _ f) = validShapeF f +validShapeF (Skip Nil) = False +validShapeF (Skip _f) = True +validShapeF Nil = True + +-- | Takes an element and a forest. Checks that the forest is in heap order +-- and that the element is less than or equal to all elements of the forest. +precedesProperlyF :: (Ord k, TreeValidity rk) => k -> BinomForest rk k a -> Bool +precedesProperlyF _ Nil = True +precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f +precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t + && precedesProperlyF the_min ts + +-- | Takes an element and a tree. Checks that the tree is in heap order +-- and that the element is less than or equal to all elements of the tree. +precedesProperlyTree :: (Ord k, TreeValidity rk) => k -> BinomTree rk k a -> Bool +precedesProperlyTree the_min (BinomTree k ts) = the_min <= k && precedesProperlyRk k ts + +-- | A helper class for order validity checking +class TreeValidity rk where + -- | Takes an element and a collection of trees. Checks that the collection + -- is in heap order and that the element is less than or equal to all + -- elements of the collection. + precedesProperlyRk :: Ord k => k -> rk k a -> Bool +instance TreeValidity Zero where + precedesProperlyRk _ (Zero _) = True +instance TreeValidity rk => TreeValidity (Succ rk) where + precedesProperlyRk the_min (Succ t q) = + precedesProperlyTree the_min t && + precedesProperlyRk the_min q diff --git a/tests/Validity/PQueue/Prio/Max.hs b/tests/Validity/PQueue/Prio/Max.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Prio/Max.hs @@ -0,0 +1,17 @@ +module Validity.PQueue.Prio.Max + ( validShape + , validSize + , validOrder + ) where + +import Data.PQueue.Prio.Max.Internals as PQM +import qualified Validity.PQueue.Prio.Min as VMin + +validShape :: MaxPQueue k a -> Bool +validShape (MaxPQ q) = VMin.validShape q + +validSize :: MaxPQueue k a -> Bool +validSize (MaxPQ q) = VMin.validSize q + +validOrder :: Ord k => MaxPQueue k a -> Bool +validOrder (MaxPQ q) = VMin.validOrder q diff --git a/tests/Validity/PQueue/Prio/Min.hs b/tests/Validity/PQueue/Prio/Min.hs new file mode 100644 --- /dev/null +++ b/tests/Validity/PQueue/Prio/Min.hs @@ -0,0 +1,28 @@ +module Validity.PQueue.Prio.Min + ( validShape + , validSize + , validOrder + ) where + +import Data.PQueue.Prio.Internals as BQ +import qualified Validity.PQueue.Prio.BinomialQueue as VBQ + +validShape :: MinPQueue k a -> Bool +validShape Empty = True +validShape (MinPQ _ _ _ f) = VBQ.validShapeF f + +validSize :: MinPQueue k a -> Bool +validSize Empty = True +validSize (MinPQ sz _ _ f) = sz == sizeH f + 1 + +validOrder :: Ord k => MinPQueue k a -> Bool +validOrder Empty = True +validOrder (MinPQ _sz k _ f) = VBQ.precedesProperlyF k f + +sizeH :: BinomHeap k a -> Int +sizeH = go 0 1 + where + go :: Int -> Int -> BinomForest rk k a -> Int + go acc rk Nil = rk `seq` acc + go acc rk (Skip f) = go acc (2 * rk) f + go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f