diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,30 @@ # Revision history for pqueue +## 1.4.2.0 + + * 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)) + + * 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)) + + * 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)) + ## 1.4.1.4 -- 2021-12-04 * Maintenance release for ghc-9.0 & ghc-9.2 support @@ -18,7 +43,7 @@ ## 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 @@ -39,7 +64,7 @@ * Fix documentation errors - complexity on `toList`, `toListU` - - PQueue.Prio.Max had "ascending" instead of "descending" in some places + - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places ## 1.3.2 -- 2016-09-28 @@ -53,7 +78,7 @@ ## 1.3.1 -- 2015-10-03 - * Add Monoid instance for MaxPQueue + * Add `Monoid` instance for `MaxPQueue` ## 1.3.0 -- 2015-06-23 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# pqueue + +A fast, reliable priority queue implementation based on a binomial heap. + +For more information, see [`pqueue` on Hackage](https://hackage.haskell.org/package/pqueue). diff --git a/benchmarks/BenchMinPQueue.hs b/benchmarks/BenchMinPQueue.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchMinPQueue.hs @@ -0,0 +1,38 @@ +import System.Random +import Test.Tasty.Bench + +import qualified KWay.PrioMergeAlg as KWay +import qualified PHeapSort as HS + +kWay :: Int -> Int -> Benchmark +kWay i n = bench + ("k-way merge looking " ++ show i ++ " deep into " ++ show n ++ " streams") + (whnf ((!! i) . KWay.merge . KWay.mkStreams n) $ mkStdGen 5466122035931067691) + +hSort :: Int -> Benchmark +hSort n = bench + ("Heap sort with " ++ show n ++ " elements") + (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) + +main :: IO () +main = defaultMain + [ bgroup "heapSort" + [ hSort (10^3) + , hSort (10^4) + , hSort (10^5) + , hSort (10^6) + , hSort (3*10^6) + ] + , bgroup "kWay" + [ kWay (10^3) 1000000 + , kWay (10^5) 1000 + , kWay (10^5) 10000 + , kWay (10^5) 100000 + , kWay (10^6) 1000 + , kWay (10^6) 10000 + , kWay (10^6) 20000 + , kWay (3*10^6) 1000 + , kWay (2*10^6) 2000 + , kWay (4*10^6) 100 + ] + ] diff --git a/benchmarks/BenchMinQueue.hs b/benchmarks/BenchMinQueue.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchMinQueue.hs @@ -0,0 +1,38 @@ +import System.Random +import Test.Tasty.Bench + +import qualified KWay.MergeAlg as KWay +import qualified HeapSort as HS + +kWay :: Int -> Int -> Benchmark +kWay i n = bench + (show i ++ " into " ++ show n ++ " streams") + (whnf ((!! i) . KWay.merge . KWay.mkStreams n) $ mkStdGen 5466122035931067691) + +hSort :: Int -> Benchmark +hSort n = bench + ("Heap sort with " ++ show n ++ " elements") + (nf (HS.heapSortRandoms n) $ mkStdGen (-7750349139967535027)) + +main :: IO () +main = defaultMain + [ bgroup "heapSort" + [ hSort (10^3) + , hSort (10^4) + , hSort (10^5) + , hSort (10^6) + , hSort (3*10^6) + ] + , bgroup "kWay" + [ kWay (10^3) 1000000 + , kWay (10^5) 1000 + , kWay (10^5) 10000 + , kWay (10^5) 100000 + , kWay (10^6) 1000 + , kWay (10^6) 10000 + , kWay (10^6) 20000 + , kWay (3*10^6) 1000 + , kWay (2*10^6) 2000 + , kWay (4*10^6) 100 + ] + ] diff --git a/benchmarks/HeapSort.hs b/benchmarks/HeapSort.hs new file mode 100644 --- /dev/null +++ b/benchmarks/HeapSort.hs @@ -0,0 +1,11 @@ +module HeapSort where + +import Data.PQueue.Min (MinQueue) +import qualified Data.PQueue.Min as P +import System.Random + +heapSortRandoms :: Int -> StdGen -> [Int] +heapSortRandoms n gen = heapSort $ take n (randoms gen) + +heapSort :: Ord a => [a] -> [a] +heapSort = P.toAscList . P.fromList diff --git a/benchmarks/KWay/MergeAlg.hs b/benchmarks/KWay/MergeAlg.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KWay/MergeAlg.hs @@ -0,0 +1,36 @@ +{-# language BangPatterns #-} +{-# language ViewPatterns #-} + +module KWay.MergeAlg where + +import qualified Data.PQueue.Min as P +import System.Random (StdGen) +import Data.Word +import Data.List (unfoldr) +import qualified KWay.RandomIncreasing as RI +import Data.Function (on) +import Data.Coerce + +newtype Stream = Stream { unStream :: RI.Stream } + +viewStream :: Stream -> (Word64, Stream) +viewStream = coerce RI.viewStream + +instance Eq Stream where + (==) = (==) `on` (fst . viewStream) + +instance Ord Stream where + compare = compare `on` (fst . viewStream) + +type PQ = P.MinQueue + +merge :: [Stream] -> [Word64] +merge = unfoldr go . P.fromList + where + go :: PQ Stream -> Maybe (Word64, PQ Stream) + go (P.minView -> Just (viewStream -> (a, s), ss)) + = Just (a, P.insert s ss) + go _ = Nothing + +mkStreams :: Int -> StdGen -> [Stream] +mkStreams = coerce RI.mkStreams diff --git a/benchmarks/KWay/PrioMergeAlg.hs b/benchmarks/KWay/PrioMergeAlg.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KWay/PrioMergeAlg.hs @@ -0,0 +1,23 @@ +{-# language BangPatterns #-} +{-# language ViewPatterns #-} + +module KWay.PrioMergeAlg + ( merge + , mkStreams + ) where + +import qualified Data.PQueue.Prio.Min as P +import System.Random (StdGen) +import Data.Word +import Data.List (unfoldr) +import KWay.RandomIncreasing + +type PQ = P.MinPQueue + +merge :: [Stream] -> [Word64] +merge = unfoldr go . P.fromList . map viewStream + where + go :: PQ Word64 Stream -> Maybe (Word64, PQ Word64 Stream) + go (P.minViewWithKey -> Just ((a, viewStream -> (b, s)), ss)) + = Just (a, P.insert b s ss) + go _ = Nothing diff --git a/benchmarks/KWay/RandomIncreasing.hs b/benchmarks/KWay/RandomIncreasing.hs new file mode 100644 --- /dev/null +++ b/benchmarks/KWay/RandomIncreasing.hs @@ -0,0 +1,25 @@ +{-# language BangPatterns #-} +{-# language ViewPatterns #-} + +module KWay.RandomIncreasing where + +import System.Random +import Data.Word +import Data.List (unfoldr) + +data Stream = Stream !Word64 {-# UNPACK #-} !StdGen + +viewStream :: Stream -> (Word64, Stream) +viewStream (Stream w gen) = (w, case uniform gen of (k, gen') -> Stream (w + fromIntegral (k :: Word16)) gen') + +mkStream :: StdGen -> (Stream, StdGen) +mkStream gen + | (gen1, gen2) <- split gen + , (w16, gen1') <- uniform gen1 + = (Stream (fromIntegral (w16 :: Word16)) gen1', gen2) + +mkStreams :: Int -> StdGen -> [Stream] +mkStreams !n !gen + | n <= 0 = [] + | (s, gen') <- mkStream gen + = s : mkStreams (n - 1) gen' diff --git a/benchmarks/PHeapSort.hs b/benchmarks/PHeapSort.hs new file mode 100644 --- /dev/null +++ b/benchmarks/PHeapSort.hs @@ -0,0 +1,11 @@ +module PHeapSort where + +import Data.PQueue.Prio.Min (MinPQueue) +import qualified Data.PQueue.Prio.Min as P +import System.Random + +heapSortRandoms :: Int -> StdGen -> [Int] +heapSortRandoms n gen = heapSort $ take n (randoms gen) + +heapSort :: Ord a => [a] -> [a] +heapSort xs = [b | (b, ~()) <- P.toAscList . P.fromList . map (\a -> (a, ())) $ xs] diff --git a/include/Typeable.h b/include/Typeable.h deleted file mode 100644 --- a/include/Typeable.h +++ /dev/null @@ -1,69 +0,0 @@ -{- -------------------------------------------------------------------------- -// Macros to help make Typeable instances. -// -// INSTANCE_TYPEABLEn(tc,tcname,"tc") defines -// -// instance Typeable/n/ tc -// instance Typeable a => Typeable/n-1/ (tc a) -// instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) -// ... -// instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) -// -------------------------------------------------------------------------- --} - -#ifndef TYPEABLE_H -#define TYPEABLE_H - -#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } - -#ifdef __GLASGOW_HASKELL__ - --- // For GHC, the extra instances follow from general instance declarations --- // defined in Data.Typeable. - -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } - -#else /* !__GLASGOW_HASKELL__ */ - -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } - -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable1 (tycon a) where { \ - typeOf1 = typeOf1Default }; \ -instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ - typeOf = typeOfDefault } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ -instance Typeable a => Typeable2 (tycon a) where { \ - typeOf2 = typeOf2Default }; \ -instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ - typeOf1 = typeOf1Default }; \ -instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ - typeOf = typeOfDefault } - -#endif /* !__GLASGOW_HASKELL__ */ - -#endif diff --git a/pqueue.cabal b/pqueue.cabal --- a/pqueue.cabal +++ b/pqueue.cabal @@ -1,5 +1,5 @@ name: pqueue -version: 1.4.1.4 +version: 1.4.2.0 category: Data Structures author: Louis Wasserman license: BSD3 @@ -7,19 +7,22 @@ stability: experimental synopsis: Reliable, persistent, fast priority queues. description: A fast, reliable priority queue implementation based on a binomial heap. -maintainer: Lennart Spitzner - Louis Wasserman +maintainer: Lennart Spitzner , + Louis Wasserman , + konsumlamm , + David Feuer +homepage: https://github.com/lspitzner/pqueue bug-reports: https://github.com/lspitzner/pqueue/issues build-type: Simple cabal-version: >= 1.10 -tested-with: GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.1, GHC == 9.2.1 +tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2 extra-source-files: - include/Typeable.h CHANGELOG.md + README.md source-repository head type: git - location: git@github.com:lspitzner/pqueue.git + location: https://github.com/lspitzner/pqueue.git library hs-source-dirs: src @@ -37,40 +40,75 @@ other-modules: Data.PQueue.Prio.Internals Data.PQueue.Internals + BinomialQueue.Internals + BinomialQueue.Min + BinomialQueue.Max + Data.PQueue.Internals.Down + Data.PQueue.Internals.Foldable Data.PQueue.Prio.Max.Internals - Control.Applicative.Identity if impl(ghc) { default-extensions: DeriveDataTypeable } - ghc-options: { + other-extensions: + BangPatterns + , CPP + ghc-options: + -- We currently need -fspec-constr to get GHC to compile conversions + -- from lists well. We could (and probably should) write those a + -- bit differently so we won't need it. + -fspec-constr -fdicts-strict -Wall - -fno-warn-inline-rule-shadowing - } - if impl(ghc >= 8.0) { - ghc-options: { + if impl(ghc >= 8.0) + ghc-options: -fno-warn-unused-imports - } - } -test-Suite test +test-suite test hs-source-dirs: tests - default-language: - Haskell2010 + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: PQueueTests.hs build-depends: { base >= 4.8 && < 4.17 , deepseq >= 1.3 && < 1.5 - , QuickCheck >= 2.5 && < 3 + , tasty + , tasty-quickcheck , pqueue } - ghc-options: { + ghc-options: -Wall - -fno-warn-inline-rule-shadowing - } - if impl(ghc >= 8.0) { - ghc-options: { - -fno-warn-unused-imports - } - } + -fno-warn-type-defaults + +benchmark minqueue-benchmarks + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: BenchMinQueue.hs + other-modules: + KWay.MergeAlg + HeapSort + KWay.RandomIncreasing + ghc-options: -O2 + build-depends: + base >= 4.8 && < 5 + , pqueue + , deepseq >= 1.3 && < 1.5 + , random >= 1.2 && < 1.3 + , tasty-bench >= 0.3 && < 0.4 + +benchmark minpqueue-benchmarks + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: BenchMinPQueue.hs + other-modules: + KWay.PrioMergeAlg + PHeapSort + KWay.RandomIncreasing + ghc-options: -O2 + build-depends: + base >= 4.8 && < 5 + , pqueue + , deepseq >= 1.3 && < 1.5 + , random >= 1.2 && < 1.3 + , tasty-bench >= 0.3 && < 0.4 diff --git a/src/BinomialQueue/Internals.hs b/src/BinomialQueue/Internals.hs new file mode 100644 --- /dev/null +++ b/src/BinomialQueue/Internals.hs @@ -0,0 +1,766 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module BinomialQueue.Internals ( + MinQueue (..), + BinomHeap, + BinomForest(..), + BinomTree(..), + Extract(..), + MExtract(..), + Succ(..), + Zero(..), + LEq, + empty, + extractHeap, + null, + size, + getMin, + minView, + singleton, + insert, + insert', + union, + unionPlusOne, + mapMaybe, + mapEither, + mapMonotonic, + foldrAsc, + foldlAsc, + foldrDesc, + foldrUnfold, + foldlUnfold, + insertMinQ, + insertMinQ', + insertMaxQ', + toAscList, + toDescList, + toListU, + fromList, + mapU, + fromAscList, + foldMapU, + foldrU, + foldlU, + foldlU', + seqSpine, + unions + ) where + +import Control.DeepSeq (NFData(rnf), deepseq) +import Data.Foldable (foldl') +import Data.Function (on) +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..), stimesMonoid) +#endif + +import Data.PQueue.Internals.Foldable +#ifdef __GLASGOW_HASKELL__ +import Data.Data +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +import GHC.Exts (build) +#endif + +import Prelude hiding (null) + +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +-- | A priority queue with elements of type @a@. Getting the +-- size or retrieving the minimum element takes \(O(\log n)\) time. +newtype MinQueue a = MinQueue (BinomHeap a) + +#ifdef __GLASGOW_HASKELL__ +instance (Ord a, Data a) => Data (MinQueue a) where + gfoldl f z q = case minView q of + Nothing -> z empty + Just (x, q') -> z insert `f` x `f` q' + + gunfold k z c = case constrIndex c of + 1 -> z empty + 2 -> k (k (z insertMinQ)) + _ -> error "gunfold" + + dataCast1 x = gcast1 x + + toConstr q + | null q = emptyConstr + | otherwise = consConstr + + dataTypeOf _ = queueDataType + +queueDataType :: DataType +queueDataType = mkDataType "Data.PQueue.Min.MinQueue" [emptyConstr, consConstr] + +emptyConstr, consConstr :: Constr +emptyConstr = mkConstr queueDataType "empty" [] Prefix +consConstr = mkConstr queueDataType "<|" [] Infix + +#endif + +type BinomHeap = BinomForest Zero + +instance Ord a => Eq (MinQueue a) where + (==) = (==) `on` minView + +instance Ord a => Ord (MinQueue a) where + compare = compare `on` minView + -- We compare their first elements, then their other elements up to the smaller queue's length, + -- and then the longer queue wins. + -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. + +-- We implement tree ranks in the type system with a nicely elegant approach, as follows. +-- The goal is to have the type system automatically guarantee that our binomial forest +-- has the correct binomial structure. +-- +-- In the traditional set-theoretic construction of the natural numbers, we define +-- each number to be the set of numbers less than it, and Zero to be the empty set, +-- as follows: +-- +-- 0 = {} 1 = {0} 2 = {0, 1} 3={0, 1, 2} ... +-- +-- Binomial trees have a similar structure: a tree of rank @k@ has one child of each +-- rank less than @k@. Let's define the type @rk@ corresponding to rank @k@ to refer +-- to a collection of binomial trees of ranks @0..k-1@. Then we can say that +-- +-- > data Succ rk a = Succ (BinomTree rk a) (rk a) +-- +-- and this behaves exactly as the successor operator for ranks should behave. Furthermore, +-- we immediately obtain that +-- +-- > data BinomTree rk a = BinomTree a (rk a) +-- +-- which is nice and compact. With this construction, things work out extremely nicely: +-- +-- > BinomTree (Succ (Succ (Succ Zero))) +-- +-- is a type constructor that takes an element type and returns the type of binomial trees +-- of rank @3@. +-- +-- 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. +-- +-- Debit invariant: +-- +-- The next-pointer of a Skip node is allowed 1 debit. No other debits are +-- allowed in the structure. +data BinomForest rk a + = Nil + | Skip (BinomForest (Succ rk) a) + | Cons {-# UNPACK #-} !(BinomTree rk a) (BinomForest (Succ rk) a) + +-- The BinomTree and Succ constructors are entirely strict, primarily because +-- that makes it easier to make sure everything is as strict as it should +-- be. The downside is that this slows down `mapMonotonic`. If that's important, +-- we can do all the forcing manually; it will be a pain. + +data BinomTree rk a = BinomTree !a !(rk a) + +-- | If |rk| corresponds to rank @k@, then |'Succ' rk| corresponds to rank @k+1@. +data Succ rk a = Succ {-# UNPACK #-} !(BinomTree rk a) !(rk a) + +-- | Type corresponding to the Zero rank. +data Zero a = Zero + +-- | Type alias for a comparison function. +type LEq a = a -> a -> Bool + +-- basics + +-- | \(O(1)\). The empty priority queue. +empty :: MinQueue a +empty = MinQueue Nil + +-- | \(O(1)\). Is this the empty priority queue? +null :: MinQueue a -> Bool +null (MinQueue Nil) = True +null _ = False + +-- | \(O(\log n)\). The number of elements in the queue. +size :: MinQueue a -> Int +size (MinQueue hp) = go 0 1 hp + where + go :: Int -> Int -> BinomForest rk 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 + +-- | \(O(\log n)\). Returns the minimum element of the queue, if the queue is nonempty. +getMin :: Ord a => MinQueue a -> Maybe a +-- TODO: Write this directly to avoid rebuilding the heap. +getMin xs = case minView xs of + Just (a, _) -> Just a + Nothing -> Nothing + +-- | Retrieves the minimum element of the queue, and the queue stripped of that element, +-- or 'Nothing' if passed an empty queue. +minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a) +minView (MinQueue ts) = case extractBin (<=) ts of + No -> Nothing + Yes (Extract x ~Zero ts') -> Just (x, MinQueue ts') + +-- | \(O(1)\). Construct a priority queue with a single element. +singleton :: a -> MinQueue a +singleton x = MinQueue (Cons (tip x) Nil) + +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Insert an element into the priority queue. +insert :: Ord a => a -> MinQueue a -> MinQueue a +insert = insert' (<=) + +-- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. +union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a +union = union' (<=) + +-- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. +unions :: Ord a => [MinQueue a] -> MinQueue a +unions = foldl' union empty + +-- | \(O(n)\). 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 + +-- | \(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 + +-- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, +-- as in 'fmap'. If it is not, the result is undefined. +mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b +mapMonotonic = mapU + +{-# INLINABLE [0] foldrAsc #-} +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in +-- ascending order. +foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrAsc f z (MinQueue ts) = foldrUnfold f z extractHeap ts + +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. +-- @foldrDesc f z q == foldlAsc (flip f) z q@. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrDesc = foldlAsc . flip +{-# INLINE [0] foldrDesc #-} + +{-# INLINE foldrUnfold #-} +-- | Equivalent to @foldr f z (unfoldr suc s0)@. +foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c +foldrUnfold f z suc s0 = unf s0 where + unf s = case suc s of + Nothing -> z + Just (x, s') -> x `f` unf s' + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in +-- ascending order. +foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlAsc f z (MinQueue ts) = foldlUnfold f z extractHeap ts + +{-# INLINE foldlUnfold #-} +-- | @foldlUnfold f z suc s0@ is equivalent to @foldl f z (unfoldr suc s0)@. +foldlUnfold :: (c -> a -> c) -> c -> (b -> Maybe (a, b)) -> b -> c +foldlUnfold f z0 suc s0 = unf z0 s0 where + unf z s = case suc s of + Nothing -> z + Just (x, s') -> unf (z `f` x) s' + +{-# INLINABLE [1] toAscList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MinQueue a -> [a] +toAscList queue = foldrAsc (:) [] queue + +{-# INLINABLE toAscListApp #-} +toAscListApp :: Ord a => MinQueue a -> [a] -> [a] +toAscListApp (MinQueue ts) app = foldrUnfold (:) app extractHeap ts + +{-# INLINABLE [1] toDescList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MinQueue a -> [a] +toDescList queue = foldrDesc (:) [] queue + +{-# INLINABLE toDescListApp #-} +toDescListApp :: Ord a => MinQueue a -> [a] -> [a] +toDescListApp (MinQueue ts) app = foldlUnfold (flip (:)) app extractHeap ts + +{-# RULES +"toAscList" [~1] forall q. toAscList q = build (\c nil -> foldrAsc c nil q) +"toDescList" [~1] forall q. toDescList q = build (\c nil -> foldrDesc c nil q) +"ascList" [1] forall q add. foldrAsc (:) add q = toAscListApp q add +"descList" [1] forall q add. foldrDesc (:) add q = toDescListApp q add + #-} + +{-# INLINE fromAscList #-} +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +-- +-- Performance note: Code using this function in a performance-sensitive context +-- with an argument that is a "good producer" for list fusion should be compiled +-- with @-fspec-constr@ or @-O2@. For example, @fromAscList . map f@ needs one +-- of these options for best results. +fromAscList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromAscList xs = foldl' (flip insertMaxQ') empty xs + +insert' :: LEq a -> a -> MinQueue a -> MinQueue a +insert' le x (MinQueue ts) + = MinQueue (incr le (tip x) ts) + +{-# INLINE union' #-} +union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a +union' le (MinQueue f1) (MinQueue f2) = MinQueue (merge le f1 f2) + +-- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. +extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) +extractHeap ts = case extractBin (<=) ts of + No -> Nothing + Yes (Extract x ~Zero ts') -> Just (x, ts') + +-- | A specialized type intended to organize the return of extract-min queries +-- from a binomial forest. We walk all the way through the forest, and then +-- walk backwards. @Extract rk a@ is the result type of an extract-min +-- operation that has walked as far backwards of rank @rk@ -- that is, it +-- has visited every root of rank @>= rk@. +-- +-- The interpretation of @Extract minKey children forest@ is +-- +-- * @minKey@ is the key of the minimum root visited so far. It may have +-- any rank @>= rk@. We will denote the root corresponding to +-- @minKey@ as @minRoot@. +-- +-- * @children@ is those children of @minRoot@ which have not yet been +-- merged with the rest of the forest. Specifically, these are +-- the children with rank @< rk@. +-- +-- * @forest@ is an accumulating parameter that maintains the partial +-- reconstruction of the binomial forest without @minRoot@. It is +-- the union of all old roots with rank @>= rk@ (except @minRoot@), +-- with the set of all children of @minRoot@ with rank @>= rk@. +data Extract rk a = Extract !a !(rk a) !(BinomForest rk a) +data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a) + +incrExtract :: Extract (Succ rk) a -> Extract rk a +incrExtract (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Cons kChild ts) + +incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a +incrExtract' le t (Extract minKey (Succ kChild kChildren) ts) + = Extract minKey kChildren (Skip $ incr le (t `cat` kChild) ts) + where + cat = joinBin le + +-- | Walks backward from the biggest key in the forest, as far as rank @rk@. +-- Returns its progress. Each successive application of @extractBin@ takes +-- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time. +extractBin :: LEq a -> BinomForest rk a -> MExtract rk a +extractBin le0 = start le0 + where + start :: LEq a -> BinomForest rk a -> MExtract rk a + start _le Nil = No + start le (Skip f) = case start le f of + No -> No + Yes ex -> Yes (incrExtract ex) + start le (Cons t@(BinomTree x ts) f) = Yes $ case go le x f of + No -> Extract x ts (Skip f) + Yes ex -> incrExtract' le t ex + + go :: LEq a -> a -> BinomForest rk a -> MExtract rk a + go _le _min_above Nil = _min_above `seq` No + go le min_above (Skip f) = case go le min_above f of + No -> No + Yes ex -> Yes (incrExtract ex) + go le min_above (Cons t@(BinomTree x ts) f) + | min_above `le` x = case go le min_above f of + No -> No + Yes ex -> Yes (incrExtract' le t ex) + | otherwise = case go le x f of + No -> Yes (Extract x ts (Skip f)) + Yes ex -> Yes (incrExtract' le t ex) + +mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b +mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of + Nil -> q0 + Skip forest' -> mapMaybeQueue f le fCh' q0 forest' + Cons t forest' -> mapMaybeQueue f le fCh' (union' le (mapMaybeT t) q0) forest' + where fCh' (Succ t tss) = union' le (mapMaybeT t) (fCh tss) + mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\x -> insert' le x (fCh ts)) (f x0) + +type Partition a b = (MinQueue a, MinQueue b) + +mapEitherQueue :: (a -> Either b c) -> LEq b -> LEq c -> (rk a -> Partition b c) -> Partition b c -> + BinomForest rk a -> Partition b c +mapEitherQueue f0 leB leC fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of + Nil -> (q00, q10) + Skip ts' -> mapEitherQueue f0 leB leC fCh' (q00, q10) ts' + Cons t ts' -> mapEitherQueue f0 leB leC fCh' (both (union' leB) (union' leC) (partitionT t) (q00, q10)) ts' + where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) + fCh' (Succ t tss) = both (union' leB) (union' leC) (partitionT t) (fCh tss) + partitionT (BinomTree x ts) = case fCh ts of + (q0, q1) -> case f0 x of + Left b -> (insert' leB b q0, q1) + Right c -> (q0, insert' leC c q1) + +{-# INLINE tip #-} +-- | Constructs a binomial tree of rank 0. +tip :: a -> BinomTree Zero a +tip x = BinomTree x Zero + +insertMinQ :: a -> MinQueue a -> MinQueue a +insertMinQ x (MinQueue f) = MinQueue (insertMin (tip x) f) + +-- | @insertMin t f@ assumes that the root of @t@ compares as less than +-- or equal to every other root in @f@, and merges accordingly. +insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMin t Nil = Cons t Nil +insertMin t (Skip f) = Cons t f +-- See Note [Force on cascade] +insertMin (BinomTree x ts) (Cons t' f) = f `seq` Skip (insertMin (BinomTree x (Succ t' ts)) f) + +-- | @insertMinQ' x h@ assumes that @x@ compares as less +-- than or equal to every element of @h@. +insertMinQ' :: a -> MinQueue a -> MinQueue a +insertMinQ' x (MinQueue f) = MinQueue (insertMin' (tip x) f) + +-- | @insertMin' t f@ assumes that the root of @t@ compares as less than +-- every other root in @f@, and merges accordingly. It eagerly evaluates +-- the modified portion of the structure. +insertMin' :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMin' t Nil = Cons t Nil +insertMin' t (Skip f) = Cons t f +insertMin' (BinomTree x ts) (Cons t' f) = Skip $! insertMin' (BinomTree x (Succ t' ts)) f + +-- | @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. +-- 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 +insertMaxQ' x (MinQueue f) = MinQueue (insertMax' (tip x) f) + +-- | @insertMax' t f@ assumes that the root of @t@ compares as greater +-- than or equal to every root in @f@, and further assumes that the roots +-- in @f@ occur in descending order. It produces a forest whose roots are +-- again in descending order. Note: the whole modified portion of the spine +-- is forced. +insertMax' :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a +insertMax' t Nil = Cons t Nil +insertMax' t (Skip f) = Cons t f +insertMax' t (Cons (BinomTree x ts) f) = Skip $! insertMax' (BinomTree x (Succ t ts)) f + +{-# INLINABLE fromList #-} +-- | \(O(n)\). Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MinQueue a +fromList xs = MinQueue (fromListHeap (<=) xs) + +{-# INLINE fromListHeap #-} +fromListHeap :: LEq a -> [a] -> BinomHeap a +fromListHeap le xs = foldl' go Nil xs + where + go fr x = incr' le (tip x) fr + +-- | Given two binomial forests starting at rank @rk@, takes their union. +-- Each successive application of this function costs \(O(1)\), so applying it +-- from the beginning costs \(O(\log n)\). +merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a +merge le f1 f2 = case (f1, f2) of + (Skip f1', Skip f2') -> Skip $! merge le f1' f2' + (Skip f1', Cons t2 f2') -> Cons t2 $! merge le f1' f2' + (Cons t1 f1', Skip f2') -> Cons t1 $! merge le f1' f2' + (Cons t1 f1', Cons t2 f2') + -> Skip $! carry le (t1 `cat` t2) f1' f2' + (Nil, _) -> f2 + (_, Nil) -> f1 + where cat = joinBin le + +-- | Take the union of two queues and toss in an extra element. +unionPlusOne :: LEq a -> a -> MinQueue a -> MinQueue a -> MinQueue a +unionPlusOne le a (MinQueue xs) (MinQueue ys) = MinQueue (carry le (tip a) xs ys) + +-- | Merges two binomial forests with another tree. If we are thinking of the trees +-- in the binomial forest as binary digits, this corresponds to a carry operation. +-- Each call to this function takes \(O(1)\) time, so in total, it costs \(O(\log n)\). +carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a +carry le t0 f1 f2 = t0 `seq` case (f1, f2) of + (Skip f1', Skip f2') -> Cons t0 $! merge le f1' f2' + (Skip f1', Cons t2 f2') -> Skip $! mergeCarry t0 t2 f1' f2' + (Cons t1 f1', Skip f2') -> Skip $! mergeCarry t0 t1 f1' f2' + (Cons t1 f1', Cons t2 f2') + -> Cons t0 $! mergeCarry t1 t2 f1' f2' + -- Why do these use incr and not incr'? We want the merge to take amortized + -- O(log(min(|f1|, |f2|))) time. If we performed this final increment + -- eagerly, that would degrade to O(log(max(|f1|, |f2|))) time. + (Nil, _f2) -> incr le t0 f2 + (_f1, Nil) -> incr le t0 f1 + where cat = joinBin le + mergeCarry tA tB = carry le (tA `cat` tB) + +-- | Merges a binomial tree into a binomial forest. If we are thinking +-- of the trees in the binomial forest as binary digits, this corresponds +-- to adding a power of 2. This costs amortized \(O(1)\) time. +incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a +-- See Note [Amortization] +incr le t f0 = t `seq` case f0 of + Nil -> Cons t Nil + Skip f -> Cons t f + Cons t' f' -> f' `seq` Skip (incr le (t `cat` t') f') + -- See Note [Force on cascade] + + -- Question: should we force t `cat` t' here? We're allowed to; + -- it's not obviously good or obviously bad. + where + cat = joinBin le + +-- Note [Amortization] +-- +-- In the Skip case, we perform O(1) unshared work and pay a +-- debit. In the Cons case, there are no debits on f', so we can force it for +-- free. We perform O(1) unshared work, and by induction suspend O(1) amortized +-- work. Another way to look at this: We have a string of Conses followed by +-- a Skip or Nil. We change all the Conses to Skips, and change the Skip to +-- a Cons or the Nil to a Cons Nil. Processing each Cons takes O(1) time, which +-- we account for by placing debits below the new Skips. Note: this increment +-- pattern is exactly the same as the one for Hinze-Paterson 2–3 finger trees, +-- and the amortization argument works just the same. + +-- Note [Force on cascade] +-- +-- As Hinze and Patterson noticed in a similar structure, whenever we cascade +-- past a Cons on insertion, we should force its child. If we don't, then +-- multiple insertions in a row will form a chain of thunks just under the root +-- of the structure, which degrades the worst-case bound for deletion from +-- logarithmic to linear and leads to poor real-world performance. + +-- | A version of 'incr' that constructs the spine eagerly. This is +-- intended for implementing @fromList@. +incr' :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a +incr' le t f0 = t `seq` case f0 of + Nil -> Cons t Nil + Skip f -> Cons t f + Cons t' f' -> Skip $! incr' le (t `cat` t') f' + where + cat = joinBin le + +-- | The carrying operation: takes two binomial heaps of the same rank @k@ +-- and returns one of rank @k+1@. Takes \(O(1)\) time. +joinBin :: LEq a -> BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a +joinBin le t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) + | x1 `le` x2 = BinomTree x1 (Succ t2 ts1) + | otherwise = BinomTree x2 (Succ t1 ts2) + +instance Functor Zero where + fmap _ _ = Zero + +instance Functor rk => Functor (Succ rk) where + fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts) + +instance Functor rk => Functor (BinomTree rk) where + fmap f (BinomTree x ts) = BinomTree (f x) (fmap f ts) + +instance Functor rk => Functor (BinomForest rk) where + fmap _ Nil = Nil + fmap f (Skip ts) = Skip (fmap f ts) + fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts) + +instance Foldr Zero where + foldr_ _ z ~Zero = z + +instance Foldl Zero where + foldl_ _ z ~Zero = z + +instance Foldl' Zero where + foldl'_ _ z ~Zero = z + +instance FoldMap Zero where + foldMap_ _ ~Zero = mempty + +instance Foldr rk => Foldr (Succ rk) where + foldr_ f z (Succ t ts) = foldr_ f (foldr_ f z ts) t + +instance Foldl rk => Foldl (Succ rk) where + foldl_ f z (Succ t ts) = foldl_ f (foldl_ f z t) ts + +instance Foldl' rk => Foldl' (Succ rk) where + foldl'_ f !z (Succ t ts) = foldl'_ f (foldl'_ f z t) ts + +instance FoldMap rk => FoldMap (Succ rk) where + foldMap_ f (Succ t ts) = foldMap_ f t `mappend` foldMap_ f ts + +instance Foldr rk => Foldr (BinomTree rk) where + foldr_ f z (BinomTree x ts) = x `f` foldr_ f z ts + +instance Foldl rk => Foldl (BinomTree rk) where + foldl_ f z (BinomTree x ts) = foldl_ f (z `f` x) ts + +instance Foldl' rk => Foldl' (BinomTree rk) where + foldl'_ f !z (BinomTree x ts) = foldl'_ f (z `f` x) ts + +instance FoldMap rk => FoldMap (BinomTree rk) where + foldMap_ f (BinomTree x ts) = f x `mappend` foldMap_ f ts + +instance Foldr rk => Foldr (BinomForest rk) where + foldr_ _ z Nil = z + foldr_ f z (Skip tss) = foldr_ f z tss + foldr_ f z (Cons t tss) = foldr_ f (foldr_ f z tss) t + +instance Foldl rk => Foldl (BinomForest rk) where + foldl_ _ z Nil = z + foldl_ f z (Skip tss) = foldl_ f z tss + foldl_ f z (Cons t tss) = foldl_ f (foldl_ f z t) tss + +instance Foldl' rk => Foldl' (BinomForest rk) where + foldl'_ _ !z Nil = z + foldl'_ f !z (Skip tss) = foldl'_ f z tss + foldl'_ f !z (Cons t tss) = foldl'_ f (foldl'_ f z t) tss + +instance FoldMap rk => FoldMap (BinomForest rk) where + foldMap_ _ Nil = mempty + foldMap_ f (Skip tss) = foldMap_ f tss + foldMap_ f (Cons t tss) = foldMap_ f t `mappend` foldMap_ f tss + +{- +instance Foldable Zero where + foldr _ z ~Zero = z + foldl _ z ~Zero = z + +instance Foldable rk => Foldable (Succ rk) where + foldr f z (Succ t ts) = foldr f (foldr f z ts) t + foldl f z (Succ t ts) = foldl f (foldl f z t) ts + +instance Foldable rk => Foldable (BinomTree rk) where + foldr f z (BinomTree x ts) = x `f` foldr f z ts + foldl f z (BinomTree x ts) = foldl f (z `f` x) ts + +instance Foldable rk => Foldable (BinomForest rk) where + foldr _ z Nil = z + foldr f z (Skip tss) = foldr f z tss + foldr f z (Cons t tss) = foldr f (foldr f z tss) t + foldl _ z Nil = z + foldl f z (Skip tss) = foldl f z tss + foldl f z (Cons t tss) = foldl f (foldl f z t) tss +-} + +-- instance Traversable Zero where +-- traverse _ _ = pure Zero +-- +-- instance Traversable rk => Traversable (Succ rk) where +-- traverse f (Succ t ts) = Succ <$> traverse f t <*> traverse f ts +-- +-- instance Traversable rk => Traversable (BinomTree rk) where +-- traverse f (BinomTree x ts) = BinomTree <$> f x <*> traverse f ts +-- +-- instance Traversable rk => Traversable (BinomForest rk) where +-- traverse _ Nil = pure Nil +-- traverse f (Skip tss) = Skip <$> traverse f tss +-- traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss + +mapU :: (a -> b) -> MinQueue a -> MinQueue b +mapU 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 +foldrU f z (MinQueue ts) = foldr_ f z ts + +-- | \(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 -> MinQueue a -> b +foldlU f z (MinQueue ts) = foldl_ f z ts + +-- | \(O(n)\). Unordered strict left fold on a priority queue. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU' f z (MinQueue ts) = foldl'_ f z ts + +-- | \(O(n)\). Unordered monoidal fold on a priority queue. +-- +-- @since 1.4.2 +foldMapU :: Monoid m => (a -> m) -> MinQueue a -> m +foldMapU f (MinQueue ts) = foldMap_ f ts + +{-# NOINLINE toListU #-} +-- | \(O(n)\). Returns the elements of the queue, in no particular order. +toListU :: MinQueue a -> [a] +toListU q = foldrU (:) [] q + +{-# NOINLINE toListUApp #-} +toListUApp :: MinQueue a -> [a] -> [a] +toListUApp (MinQueue ts) app = foldr_ (:) app ts + +{-# RULES +"toListU/build" [~1] forall q. toListU q = build (\c n -> foldrU c n q) +"toListU" [1] forall q app. foldrU (:) app q = toListUApp q app + #-} + +-- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) +-- traverseU _ Empty = pure Empty +-- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts + +-- | \(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. +seqSpine :: MinQueue a -> b -> b +seqSpine (MinQueue ts) z = seqSpineF ts z + +seqSpineF :: BinomForest rk a -> b -> b +seqSpineF Nil z = z +seqSpineF (Skip ts') z = seqSpineF ts' z +seqSpineF (Cons _ ts') z = seqSpineF ts' z + +class NFRank rk where + rnfRk :: NFData a => rk a -> () + +instance NFRank Zero where + rnfRk _ = () + +instance NFRank rk => NFRank (Succ rk) where + rnfRk (Succ t ts) = t `deepseq` rnfRk ts + +instance (NFData a, NFRank rk) => NFData (BinomTree rk a) where + rnf (BinomTree x ts) = x `deepseq` rnfRk ts + +instance (NFData a, NFRank rk) => NFData (BinomForest rk a) where + rnf Nil = () + rnf (Skip ts) = rnf ts + rnf (Cons t ts) = t `deepseq` rnf ts + +instance NFData a => NFData (MinQueue a) where + rnf (MinQueue ts) = rnf ts + +instance (Ord a, Show a) => Show (MinQueue a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromAscList " . shows (toAscList xs) + +instance Read a => Read (MinQueue a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromAscList" <- lexP + xs <- readPrec + return (fromAscList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromAscList",s) <- lex r + (xs,t) <- reads s + return (fromAscList xs,t) +#endif + +#if MIN_VERSION_base(4,9,0) +instance Ord a => Semigroup (MinQueue a) where + (<>) = union + stimes = stimesMonoid +#endif + +instance Ord a => Monoid (MinQueue a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions diff --git a/src/BinomialQueue/Max.hs b/src/BinomialQueue/Max.hs new file mode 100644 --- /dev/null +++ b/src/BinomialQueue/Max.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : BinomialQueue.Max +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue. Unlike the queues in "Data.PQueue.Max", +-- these are /not/ augmented with a global root or their size, so 'getMax' +-- and 'size' take logarithmic, rather than constant, time. When those +-- operations are not (often) needed, these queues are generally faster than +-- those in "Data.PQueue.Max". +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /k/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- This implementation is based on a binomial heap. +-- +-- This implementation does not guarantee stable behavior. +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module BinomialQueue.Max ( + MaxQueue, + -- * Basic operations + empty, + null, + size, + -- * Query operations + findMax, + getMax, + deleteMax, + deleteFindMax, + maxView, + -- * Construction operations + singleton, + insert, + union, + unions, + -- * Subsets + -- ** Extracting subsets + (!!), + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + dropWhile, + span, + break, + -- * Filter/Map + filter, + partition, + mapMaybe, + mapEither, + -- * Fold\/Functor\/Traversable variations + map, + foldrAsc, + foldlAsc, + foldrDesc, + foldlDesc, + -- * List operations + toList, + toAscList, + toDescList, + fromList, + fromAscList, + fromDescList, + -- * Unordered operations + foldrU, + foldlU, + foldlU', + foldMapU, + elemsU, + toListU, + -- * Miscellaneous operations +-- keysQueue, -- We want bare Prio queues for this. + seqSpine + ) where + +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 qualified Data.List as List + +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. +findMax :: Ord a => MaxQueue a -> a +findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax + +-- | \(O(1)\). The top (maximum) element of the queue, if there is one. +getMax :: Ord a => MaxQueue a -> Maybe a +getMax (MaxQueue q) = unDown <$> MinQ.getMin q + +-- | \(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 + +-- | \(O(\log n)\). Extracts the maximum element. Throws an error on an empty queue. +deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) +deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView + +-- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. +maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) +maxView (MaxQueue q) = case MinQ.minView q of + Just (Down a, q') -> Just (a, MaxQueue q') + Nothing -> Nothing + +-- | \(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 + +{-# 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 + +-- | '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 + +-- | '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) + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) +break p = span (not . p) + +{-# INLINE take #-} +-- | \(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'@. +drop :: Ord a => Int -> MaxQueue a -> MaxQueue a +drop n (MaxQueue queue) = MaxQueue (MinQ.drop n 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) + +-- | \(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 + +-- | \(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) + +-- | \(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 + +{-# 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 + +toAscList :: Ord a => MaxQueue a -> [a] +toAscList = fmap unDown . MinQ.toDescList . unMaxQueue + +toDescList :: Ord a => MaxQueue a -> [a] +toDescList = fmap unDown . MinQ.toAscList . unMaxQueue + +-- | \(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 + +-- | \(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 + +-- | \(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 + +-- | \(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 + +{-# 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 + +{-# 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 + +fromList :: Ord a => [a] -> MaxQueue a +fromList = MaxQueue . MinQ.fromList . fmap Down + +-- | Equivalent to 'toListU'. +elemsU :: MaxQueue a -> [a] +elemsU = toListU + +-- | Convert to a list in an arbitrary order. +toListU :: MaxQueue a -> [a] +toListU = fmap unDown . MinQ.toListU . unMaxQueue + +-- | Get the number of elements in a 'MaxQueue'. +size :: MaxQueue a -> Int +size = MinQ.size . unMaxQueue + +empty :: MaxQueue a +empty = MaxQueue MinQ.empty + +foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m +foldMapU f = MinQ.foldMapU (f . unDown) . 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' :: (b -> a -> b) -> b -> MaxQueue a -> b +foldlU' f b = MinQ.foldlU' (\acc (Down a) -> f acc a) b . unMaxQueue + +foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b +foldrU c n = MinQ.foldrU (c . unDown) n . unMaxQueue + +null :: MaxQueue a -> Bool +null = MinQ.null . unMaxQueue + +singleton :: a -> MaxQueue a +singleton = MaxQueue . MinQ.singleton . Down + +mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b +mapMaybe f = MaxQueue . MinQ.mapMaybe (fmap Down . f . unDown) . unMaxQueue + +insert :: Ord a => a -> MaxQueue a -> MaxQueue a +insert a (MaxQueue q) = MaxQueue (MinQ.insert (Down a) q) + +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) + +union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a +union (MaxQueue a) (MaxQueue b) = MaxQueue (MinQ.union a b) + +unions :: Ord a => [MaxQueue a] -> MaxQueue a +unions = MaxQueue . MinQ.unions . fmap unMaxQueue diff --git a/src/BinomialQueue/Min.hs b/src/BinomialQueue/Min.hs new file mode 100644 --- /dev/null +++ b/src/BinomialQueue/Min.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : BinomialQueue.Min +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- General purpose priority queue. Unlike the queues in "Data.PQueue.Min", +-- these are /not/ augmented with a global root or their size, so 'getMin' +-- and 'size' take logarithmic, rather than constant, time. When those +-- operations are not (often) needed, these queues are generally faster than +-- those in "Data.PQueue.Min". +-- +-- An amortized running time is given for each operation, with /n/ referring +-- to the length of the sequence and /k/ being the integral index used by +-- some operations. These bounds hold even in a persistent (shared) setting. +-- +-- This implementation is based on a binomial heap. +-- +-- This implementation does not guarantee stable behavior. +-- +-- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for +-- unordered. No guarantees whatsoever are made on the execution or traversal order of +-- these functions. +----------------------------------------------------------------------------- +module BinomialQueue.Min ( + MinQueue, + -- * Basic operations + empty, + null, + size, + -- * Query operations + findMin, + getMin, + deleteMin, + deleteFindMin, + minView, + -- * Construction operations + singleton, + insert, + union, + unions, + -- * Subsets + -- ** Extracting subsets + (!!), + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + dropWhile, + span, + break, + -- * Filter/Map + filter, + partition, + mapMaybe, + mapEither, + -- * Fold\/Functor\/Traversable variations + map, + foldrAsc, + foldlAsc, + foldrDesc, + foldlDesc, + -- * List operations + toList, + toAscList, + toDescList, + fromList, + fromAscList, + fromDescList, + -- * Unordered operations + mapU, + foldrU, + foldlU, + foldlU', + foldMapU, + elemsU, + toListU, + -- * Miscellaneous operations +-- keysQueue, -- We want bare Prio queues for this. + seqSpine + ) where + +import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter, map) + +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 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 + +-- | \(O(\log n)\). Deletes the minimum element. If the queue is empty, does nothing. +deleteMin :: Ord a => MinQueue a -> MinQueue a +deleteMin q = case minView q of + Nothing -> empty + Just (_, q') -> q' + +-- | \(O(\log n)\). Extracts the minimum element. Throws an error on an empty queue. +deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) +deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView + +-- | \(O(k \log n)\)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- element in the queue. Equivalent to @toAscList queue !! k@. +(!!) :: Ord a => MinQueue a -> Int -> a +q !! n | n >= size q + = error "Data.PQueue.Min.!!: index too large" +q !! n = (List.!!) (toAscList q) n + +{-# INLINE takeWhile #-} +-- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the +-- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. +takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] +takeWhile p = foldWhileFB p . toAscList + +{-# INLINE foldWhileFB #-} +-- | Equivalent to Data.List.takeWhile, but is a better producer. +foldWhileFB :: (a -> Bool) -> [a] -> [a] +foldWhileFB p xs0 = build (\c nil -> let + consWhile x xs + | p x = x `c` xs + | otherwise = nil + in foldr consWhile nil xs0) + +-- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. +dropWhile :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +dropWhile p = drop' where + drop' q = case minView q of + Just (x, q') | p x -> drop' q' + _ -> q + +-- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- satisfy @p@ and second element is the remainder of the queue. +span :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +span p queue = case minView queue of + Just (x, q') + | p x -> let (ys, q'') = span p q' in (x : ys, q'') + _ -> ([], queue) + +-- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where +-- first element is longest prefix (possibly empty) of @queue@ of elements that +-- /do not satisfy/ @p@ and second element is the remainder of the queue. +break :: Ord a => (a -> Bool) -> MinQueue a -> ([a], MinQueue a) +break p = span (not . p) + +{-# INLINE take #-} +-- | \(O(k \log n)\)/. 'take' @k@, applied to a queue @queue@, returns a list of the smallest @k@ elements of @queue@, +-- or all elements of @queue@ itself if @k >= 'size' queue@. +take :: Ord a => Int -> MinQueue a -> [a] +take n = List.take n . toAscList + +-- | \(O(k \log n)\)/. 'drop' @k@, applied to a queue @queue@, returns @queue@ with the smallest @k@ elements deleted, +-- or an empty queue if @k >= size 'queue'@. +drop :: Ord a => Int -> MinQueue a -> MinQueue a +drop n queue = n `seq` case minView queue of + Just (_, queue') + | n > 0 -> drop (n - 1) queue' + _ -> queue + +-- | \(O(k \log n)\)/. Equivalent to @('take' k queue, 'drop' k queue)@. +splitAt :: Ord a => Int -> MinQueue a -> ([a], MinQueue a) +splitAt n queue = n `seq` case minView queue of + Just (x, queue') + | n > 0 -> let (xs, queue'') = splitAt (n - 1) queue' in (x : xs, queue'') + _ -> ([], queue) + +-- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. +filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a +filter p = mapMaybe (\x -> if p x then Just x else Nothing) + +-- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue +-- contains all elements not satisfying @p@. +partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) +partition p = mapEither (\x -> if p x then Left x else Right x) + +-- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. +-- Equivalent to @'fromList' . 'Data.List.map' f . toList@. +map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b +map f = foldrU (insert . f) empty + +{-# INLINE toList #-} +-- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. +-- +-- If the order of the elements is irrelevant, consider using 'toListU'. +toList :: Ord a => MinQueue a -> [a] +toList = toAscList + +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. +-- @foldlDesc f z q == foldrAsc (flip f) z q@. +foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b +foldlDesc = foldrAsc . flip + +{-# INLINE fromDescList #-} +-- | \(O(n)\). Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. +fromDescList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromDescList xs = foldl' (flip insertMinQ') empty xs + +-- | Equivalent to 'toListU'. +elemsU :: MinQueue a -> [a] +elemsU = toListU diff --git a/src/Control/Applicative/Identity.hs b/src/Control/Applicative/Identity.hs deleted file mode 100644 --- a/src/Control/Applicative/Identity.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Control.Applicative.Identity where - -import Control.Applicative - -import Prelude - -newtype Identity a = Identity { runIdentity :: a } - -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) diff --git a/src/Data/PQueue/Internals.hs b/src/Data/PQueue/Internals.hs --- a/src/Data/PQueue/Internals.hs +++ b/src/Data/PQueue/Internals.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} module Data.PQueue.Internals ( MinQueue (..), @@ -21,39 +22,70 @@ mapMonotonic, foldrAsc, foldlAsc, + foldrDesc, insertMinQ, --- mapU, + insertMinQ', + insertMaxQ', + toAscList, + toDescList, + toListU, + fromList, + mapU, + fromAscList, + foldMapU, foldrU, foldlU, + foldlU', -- traverseU, - keysQueue, - seqSpine + seqSpine, + unions ) where +import BinomialQueue.Internals + ( BinomHeap + , BinomForest (..) + , BinomTree (..) + , Succ (..) + , Zero (..) + , Extract (..) + , MExtract (..) + ) +import qualified BinomialQueue.Internals as BQ import Control.DeepSeq (NFData(rnf), deepseq) - -import qualified Data.PQueue.Prio.Internals as Prio +import Data.Foldable (foldl') +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..), stimesMonoid) +#endif +import Data.PQueue.Internals.Foldable #ifdef __GLASGOW_HASKELL__ import Data.Data +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +import GHC.Exts (build) #endif import Prelude hiding (null) --- | A priority queue with elements of type @a@. Supports extracting the minimum element. -data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int a !(BinomHeap a) -#if __GLASGOW_HASKELL__>=707 - deriving Typeable -#else -#include "Typeable.h" -INSTANCE_TYPEABLE1(MinQueue,minQTC,"MinQueue") +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] #endif +-- | A priority queue with elements of type @a@. Supports extracting the minimum element. +data MinQueue a = Empty | MinQueue {-# UNPACK #-} !Int !a !(BQ.MinQueue a) + +fromBare :: Ord a => BQ.MinQueue a -> MinQueue a +-- Should we fuse the size calculation with the minimum extraction? +fromBare xs = case BQ.minView xs of + Just (x, xs') -> MinQueue (1 + BQ.size xs') x xs' + Nothing -> Empty + #ifdef __GLASGOW_HASKELL__ instance (Ord a, Data a) => Data (MinQueue a) where gfoldl f z q = case minView q of Nothing -> z Empty - Just (x, q') -> z insertMinQ `f` x `f` q' + Just (x, q') -> z insert `f` x `f` q' gunfold k z c = case constrIndex c of 1 -> z Empty @@ -77,99 +109,42 @@ #endif -type BinomHeap = BinomForest Zero - instance Ord a => Eq (MinQueue a) where Empty == Empty = True MinQueue n1 x1 q1 == MinQueue n2 x2 q2 = - n1 == n2 && eqExtract (x1,q1) (x2,q2) + n1 == n2 && x1 == x2 && q1 == q2 _ == _ = False -eqExtract :: Ord a => (a, BinomHeap a) -> (a, BinomHeap a) -> Bool -eqExtract (x1,q1) (x2,q2) = - x1 == x2 && - case (extractHeap q1, extractHeap q2) of - (Just h1, Just h2) -> eqExtract h1 h2 - (Nothing, Nothing) -> True - _ -> False - instance Ord a => Ord (MinQueue a) where Empty `compare` Empty = EQ Empty `compare` _ = LT _ `compare` Empty = GT - MinQueue _n1 x1 q1 `compare` MinQueue _n2 x2 q2 = cmpExtract (x1,q1) (x2,q2) - -cmpExtract :: Ord a => (a, BinomHeap a) -> (a, BinomHeap a) -> Ordering -cmpExtract (x1,q1) (x2,q2) = - compare x1 x2 `mappend` - case (extractHeap q1, extractHeap q2) of - (Just h1, Just h2) -> cmpExtract h1 h2 - (Nothing, Nothing) -> EQ - (Just _, Nothing) -> GT - (Nothing, Just _) -> LT + MinQueue _n1 x1 q1 `compare` MinQueue _n2 x2 q2 = compare (x1,q1) (x2,q2) -- We compare their first elements, then their other elements up to the smaller queue's length, -- and then the longer queue wins. -- This is equivalent to @comparing toAscList@, except it fuses much more nicely. --- We implement tree ranks in the type system with a nicely elegant approach, as follows. --- The goal is to have the type system automatically guarantee that our binomial forest --- has the correct binomial structure. --- --- In the traditional set-theoretic construction of the natural numbers, we define --- each number to be the set of numbers less than it, and Zero to be the empty set, --- as follows: --- --- 0 = {} 1 = {0} 2 = {0, 1} 3={0, 1, 2} ... --- --- Binomial trees have a similar structure: a tree of rank @k@ has one child of each --- rank less than @k@. Let's define the type @rk@ corresponding to rank @k@ to refer --- to a collection of binomial trees of ranks @0..k-1@. Then we can say that --- --- > data Succ rk a = Succ (BinomTree rk a) (rk a) --- --- and this behaves exactly as the successor operator for ranks should behave. Furthermore, --- we immediately obtain that --- --- > data BinomTree rk a = BinomTree a (rk a) --- --- which is nice and compact. With this construction, things work out extremely nicely: --- --- > BinomTree (Succ (Succ (Succ Zero))) --- --- is a type constructor that takes an element type and returns the type of binomial trees --- of rank @3@. -data BinomForest rk a = Nil | Skip (BinomForest (Succ rk) a) | - Cons {-# UNPACK #-} !(BinomTree rk a) (BinomForest (Succ rk) a) - -data BinomTree rk a = BinomTree a (rk a) - --- | If |rk| corresponds to rank @k@, then |'Succ' rk| corresponds to rank @k+1@. -data Succ rk a = Succ {-# UNPACK #-} !(BinomTree rk a) (rk a) - --- | Type corresponding to the Zero rank. -data Zero a = Zero - -- | Type alias for a comparison function. type LEq a = a -> a -> Bool -- basics --- | /O(1)/. The empty priority queue. +-- | \(O(1)\). The empty priority queue. empty :: MinQueue a empty = Empty --- | /O(1)/. Is this the empty priority queue? +-- | \(O(1)\). Is this the empty priority queue? null :: MinQueue a -> Bool null Empty = True null _ = False --- | /O(1)/. The number of elements in the queue. +-- | \(O(1)\). The number of elements in the queue. size :: MinQueue a -> Int size Empty = 0 size (MinQueue n _ _) = n --- | Returns the minimum element of the queue, if the queue is nonempty. +-- | \(O(1)\). Returns the minimum element of the queue, if the queue is nonempty. getMin :: MinQueue a -> Maybe a getMin (MinQueue _ x _) = Just x getMin _ = Nothing @@ -178,328 +153,240 @@ -- or 'Nothing' if passed an empty queue. minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a) minView Empty = Nothing -minView (MinQueue n x ts) = Just (x, case extractHeap ts of +minView (MinQueue n x ts) = Just (x, case BQ.minView ts of Nothing -> Empty Just (x', ts') -> MinQueue (n - 1) x' ts') --- | /O(1)/. Construct a priority queue with a single element. +-- | \(O(1)\). Construct a priority queue with a single element. singleton :: a -> MinQueue a -singleton x = MinQueue 1 x Nil +singleton x = MinQueue 1 x BQ.empty --- | Amortized /O(1)/, worst-case /O(log n)/. Insert an element into the priority queue. +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Insert an element into the priority queue. insert :: Ord a => a -> MinQueue a -> MinQueue a insert = insert' (<=) --- | Amortized /O(log (min(n,m)))/, worst-case /O(log (max (n,m)))/. Take the union of two priority queues. +-- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a union = union' (<=) --- | /O(n)/. Map elements and collect the 'Just' results. +-- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. +unions :: Ord a => [MinQueue a] -> MinQueue a +unions = foldl' union empty + +-- | \(O(n)\). Map elements and collect the 'Just' results. mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b mapMaybe _ Empty = Empty -mapMaybe f (MinQueue _ x ts) = maybe q' (`insert` q') (f x) +mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insert` q') (f x) where - q' = mapMaybeQueue f (<=) (const Empty) Empty ts + q' = BQ.mapMaybe f ts --- | /O(n)/. Map elements and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) mapEither _ Empty = (Empty, Empty) -mapEither f (MinQueue _ x ts) = case (mapEitherQueue f (<=) (<=) (const (Empty, Empty)) (Empty, Empty) ts, f x) of - ((qL, qR), Left b) -> (insert b qL, qR) - ((qL, qR), Right c) -> (qL, insert c qR) +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)) --- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, +-- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, -- as in 'fmap'. If it is not, the result is undefined. mapMonotonic :: (a -> b) -> MinQueue a -> MinQueue b mapMonotonic = mapU -{-# INLINE foldrAsc #-} --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. +{-# INLINABLE [0] foldrAsc #-} +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in +-- ascending order. foldrAsc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b foldrAsc _ z Empty = z -foldrAsc f z (MinQueue _ x ts) = x `f` foldrUnfold f z extractHeap ts +foldrAsc f z (MinQueue _ x ts) = x `f` BQ.foldrUnfold f z BQ.minView ts -{-# INLINE foldrUnfold #-} --- | Equivalent to @foldr f z (unfoldr suc s0)@. -foldrUnfold :: (a -> c -> c) -> c -> (b -> Maybe (a, b)) -> b -> c -foldrUnfold f z suc s0 = unf s0 where - unf s = case suc s of - Nothing -> z - Just (x, s') -> x `f` unf s' +-- | \(O(n \log n)\). Performs a right fold on the elements of a priority queue in descending order. +-- @foldrDesc f z q == foldlAsc (flip f) z q@. +foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b +foldrDesc = foldlAsc . flip +{-# INLINE [0] foldrDesc #-} --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in ascending order. +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in +-- ascending order. foldlAsc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b foldlAsc _ z Empty = z -foldlAsc f z (MinQueue _ x ts) = foldlUnfold f (z `f` x) extractHeap ts +foldlAsc f z (MinQueue _ x ts) = BQ.foldlUnfold f (z `f` x) BQ.minView ts -{-# INLINE foldlUnfold #-} --- | @foldlUnfold f z suc s0@ is equivalent to @foldl f z (unfoldr suc s0)@. -foldlUnfold :: (c -> a -> c) -> c -> (b -> Maybe (a, b)) -> b -> c -foldlUnfold f z0 suc s0 = unf z0 s0 where - unf z s = case suc s of - Nothing -> z - Just (x, s') -> unf (z `f` x) s' +{-# INLINABLE [1] toAscList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. +toAscList :: Ord a => MinQueue a -> [a] +toAscList queue = foldrAsc (:) [] queue +{-# INLINABLE toAscListApp #-} +toAscListApp :: Ord a => MinQueue a -> [a] -> [a] +toAscListApp Empty app = app +toAscListApp (MinQueue _ x ts) app = x : BQ.foldrUnfold (:) app BQ.minView ts + +{-# INLINABLE [1] toDescList #-} +-- | \(O(n \log n)\). Extracts the elements of the priority queue in descending order. +toDescList :: Ord a => MinQueue a -> [a] +toDescList queue = foldrDesc (:) [] queue + +{-# INLINABLE toDescListApp #-} +toDescListApp :: Ord a => MinQueue a -> [a] -> [a] +toDescListApp Empty app = app +toDescListApp (MinQueue _ x ts) app = BQ.foldlUnfold (flip (:)) (x : app) BQ.minView ts + +{-# RULES +"toAscList" [~1] forall q. toAscList q = build (\c nil -> foldrAsc c nil q) +"toDescList" [~1] forall q. toDescList q = build (\c nil -> foldrDesc c nil q) +"ascList" [1] forall q add. foldrAsc (:) add q = toAscListApp q add +"descList" [1] forall q add. foldrDesc (:) add q = toDescListApp q add + #-} + +{-# INLINE fromAscList #-} +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +-- +-- Performance note: Code using this function in a performance-sensitive context +-- with an argument that is a "good producer" for list fusion should be compiled +-- with @-fspec-constr@ or @-O2@. For example, @fromAscList . map f@ needs one +-- of these options for best results. +fromAscList :: [a] -> MinQueue a +-- We apply an explicit argument to get foldl' to inline. +fromAscList xs = foldl' (flip insertMaxQ') empty xs + insert' :: LEq a -> a -> MinQueue a -> MinQueue a insert' _ x Empty = singleton x insert' le x (MinQueue n x' ts) - | x `le` x' = MinQueue (n + 1) x (incr le (tip x') ts) - | otherwise = MinQueue (n + 1) x' (incr le (tip x) ts) + | x `le` x' = MinQueue (n + 1) x (BQ.insertMinQ x' ts) + | otherwise = MinQueue (n + 1) x' (BQ.insert' le x ts) {-# INLINE union' #-} union' :: LEq a -> MinQueue a -> MinQueue a -> MinQueue a union' _ Empty q = q union' _ q Empty = q union' le (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) - | x1 `le` x2 = MinQueue (n1 + n2) x1 (carry le (tip x2) f1 f2) - | otherwise = MinQueue (n1 + n2) x2 (carry le (tip x1) f1 f2) - --- | Takes a size and a binomial forest and produces a priority queue with a distinguished global root. -extractHeap :: Ord a => BinomHeap a -> Maybe (a, BinomHeap a) -extractHeap ts = case extractBin (<=) ts of - Yes (Extract x _ ts') -> Just (x, ts') - _ -> Nothing - --- | A specialized type intended to organize the return of extract-min queries --- from a binomial forest. We walk all the way through the forest, and then --- walk backwards. @Extract rk a@ is the result type of an extract-min --- operation that has walked as far backwards of rank @rk@ -- that is, it --- has visited every root of rank @>= rk@. --- --- The interpretation of @Extract minKey children forest@ is --- --- * @minKey@ is the key of the minimum root visited so far. It may have --- any rank @>= rk@. We will denote the root corresponding to --- @minKey@ as @minRoot@. --- --- * @children@ is those children of @minRoot@ which have not yet been --- merged with the rest of the forest. Specifically, these are --- the children with rank @< rk@. --- --- * @forest@ is an accumulating parameter that maintains the partial --- reconstruction of the binomial forest without @minRoot@. It is --- the union of all old roots with rank @>= rk@ (except @minRoot@), --- with the set of all children of @minRoot@ with rank @>= rk@. --- Note that @forest@ is lazy, so if we discover a smaller key --- than @minKey@ later, we haven't wasted significant work. -data Extract rk a = Extract a (rk a) (BinomForest rk a) -data MExtract rk a = No | Yes {-# UNPACK #-} !(Extract rk a) - -incrExtract :: Extract (Succ rk) a -> Extract rk a -incrExtract (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Cons kChild ts) - -incrExtract' :: LEq a -> BinomTree rk a -> Extract (Succ rk) a -> Extract rk a -incrExtract' le t (Extract minKey (Succ kChild kChildren) ts) - = Extract minKey kChildren (Skip (incr le (t `cat` kChild) ts)) - where - cat = joinBin le - --- | Walks backward from the biggest key in the forest, as far as rank @rk@. --- Returns its progress. Each successive application of @extractBin@ takes --- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. -extractBin :: LEq a -> BinomForest rk a -> MExtract rk a -extractBin _ Nil = No -extractBin le (Skip f) = case extractBin le f of - Yes ex -> Yes (incrExtract ex) - No -> No -extractBin le (Cons t@(BinomTree x ts) f) = Yes $ case extractBin le f of - Yes ex@(Extract minKey _ _) - | minKey `lt` x -> incrExtract' le t ex - _ -> Extract x ts (Skip f) - where a `lt` b = not (b `le` a) - -mapMaybeQueue :: (a -> Maybe b) -> LEq b -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b -mapMaybeQueue f le fCh q0 forest = q0 `seq` case forest of - Nil -> q0 - Skip forest' -> mapMaybeQueue f le fCh' q0 forest' - Cons t forest' -> mapMaybeQueue f le fCh' (union' le (mapMaybeT t) q0) forest' - where fCh' (Succ t tss) = union' le (mapMaybeT t) (fCh tss) - mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\x -> insert' le x (fCh ts)) (f x0) - -type Partition a b = (MinQueue a, MinQueue b) - -mapEitherQueue :: (a -> Either b c) -> LEq b -> LEq c -> (rk a -> Partition b c) -> Partition b c -> - BinomForest rk a -> Partition b c -mapEitherQueue f0 leB leC fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of - Nil -> (q00, q10) - Skip ts' -> mapEitherQueue f0 leB leC fCh' (q00, q10) ts' - Cons t ts' -> mapEitherQueue f0 leB leC fCh' (both (union' leB) (union' leC) (partitionT t) (q00, q10)) ts' - where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) - fCh' (Succ t tss) = both (union' leB) (union' leC) (partitionT t) (fCh tss) - partitionT (BinomTree x ts) = case fCh ts of - (q0, q1) -> case f0 x of - Left b -> (insert' leB b q0, q1) - Right c -> (q0, insert' leC c q1) - -{-# INLINE tip #-} --- | Constructs a binomial tree of rank 0. -tip :: a -> BinomTree Zero a -tip x = BinomTree x Zero + | x1 `le` x2 = MinQueue (n1 + n2) x1 (BQ.unionPlusOne le x2 f1 f2) + | otherwise = MinQueue (n1 + n2) x2 (BQ.unionPlusOne le x1 f1 f2) +-- | @insertMinQ x h@ assumes that @x@ compares as less +-- than or equal to every element of @h@. insertMinQ :: a -> MinQueue a -> MinQueue a insertMinQ x Empty = singleton x -insertMinQ x (MinQueue n x' f) = MinQueue (n + 1) x (insertMin (tip x') f) - --- | @insertMin t f@ assumes that the root of @t@ compares as less than --- every other root in @f@, and merges accordingly. -insertMin :: BinomTree rk a -> BinomForest rk a -> BinomForest rk a -insertMin t Nil = Cons t Nil -insertMin t (Skip f) = Cons t f -insertMin (BinomTree x ts) (Cons t' f) = Skip (insertMin (BinomTree x (Succ t' ts)) f) - --- | Given two binomial forests starting at rank @rk@, takes their union. --- Each successive application of this function costs /O(1)/, so applying it --- from the beginning costs /O(log n)/. -merge :: LEq a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a -merge le f1 f2 = case (f1, f2) of - (Skip f1', Skip f2') -> Skip (merge le f1' f2') - (Skip f1', Cons t2 f2') -> Cons t2 (merge le f1' f2') - (Cons t1 f1', Skip f2') -> Cons t1 (merge le f1' f2') - (Cons t1 f1', Cons t2 f2') - -> Skip (carry le (t1 `cat` t2) f1' f2') - (Nil, _) -> f2 - (_, Nil) -> f1 - where cat = joinBin le - --- | Merges two binomial forests with another tree. If we are thinking of the trees --- in the binomial forest as binary digits, this corresponds to a carry operation. --- Each call to this function takes /O(1)/ time, so in total, it costs /O(log n)/. -carry :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a -carry le t0 f1 f2 = t0 `seq` case (f1, f2) of - (Skip f1', Skip f2') -> Cons t0 (merge le f1' f2') - (Skip f1', Cons t2 f2') -> Skip (mergeCarry t0 t2 f1' f2') - (Cons t1 f1', Skip f2') -> Skip (mergeCarry t0 t1 f1' f2') - (Cons t1 f1', Cons t2 f2') - -> Cons t0 (mergeCarry t1 t2 f1' f2') - (Nil, _f2) -> incr le t0 f2 - (_f1, Nil) -> incr le t0 f1 - where cat = joinBin le - mergeCarry tA tB = carry le (tA `cat` tB) - --- | Merges a binomial tree into a binomial forest. If we are thinking --- of the trees in the binomial forest as binary digits, this corresponds --- to adding a power of 2. This costs amortized /O(1)/ time. -incr :: LEq a -> BinomTree rk a -> BinomForest rk a -> BinomForest rk a -incr le t f0 = t `seq` case f0 of - Nil -> Cons t Nil - Skip f -> Cons t f - Cons t' f' -> Skip (incr le (t `cat` t') f') - where cat = joinBin le - --- | The carrying operation: takes two binomial heaps of the same rank @k@ --- and returns one of rank @k+1@. Takes /O(1)/ time. -joinBin :: LEq a -> BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a -joinBin le t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) - | x1 `le` x2 = BinomTree x1 (Succ t2 ts1) - | otherwise = BinomTree x2 (Succ t1 ts2) - -instance Functor Zero where - fmap _ _ = Zero - -instance Functor rk => Functor (Succ rk) where - fmap f (Succ t ts) = Succ (fmap f t) (fmap f ts) - -instance Functor rk => Functor (BinomTree rk) where - fmap f (BinomTree x ts) = BinomTree (f x) (fmap f ts) - -instance Functor rk => Functor (BinomForest rk) where - fmap _ Nil = Nil - fmap f (Skip ts) = Skip (fmap f ts) - fmap f (Cons t ts) = Cons (fmap f t) (fmap f ts) - -instance Foldable Zero where - foldr _ z _ = z - foldl _ z _ = z - -instance Foldable rk => Foldable (Succ rk) where - foldr f z (Succ t ts) = foldr f (foldr f z ts) t - foldl f z (Succ t ts) = foldl f (foldl f z t) ts +insertMinQ x (MinQueue n x' f) = MinQueue (n + 1) x (BQ.insertMinQ x' f) -instance Foldable rk => Foldable (BinomTree rk) where - foldr f z (BinomTree x ts) = x `f` foldr f z ts - foldl f z (BinomTree x ts) = foldl f (z `f` x) ts +-- | @insertMinQ' x h@ assumes that @x@ compares as less +-- than or equal to every element of @h@. +insertMinQ' :: a -> MinQueue a -> MinQueue a +insertMinQ' x Empty = singleton x +insertMinQ' x (MinQueue n x' f) = MinQueue (n + 1) x (BQ.insertMinQ' x' f) -instance Foldable rk => Foldable (BinomForest rk) where - foldr _ z Nil = z - foldr f z (Skip tss) = foldr f z tss - foldr f z (Cons t tss) = foldr f (foldr f z tss) t - foldl _ z Nil = z - foldl f z (Skip tss) = foldl f z tss - foldl f z (Cons t tss) = foldl f (foldl f z t) tss +-- | @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. +-- 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 +insertMaxQ' x Empty = singleton x +insertMaxQ' x (MinQueue n x' f) = MinQueue (n + 1) x' (BQ.insertMaxQ' x f) --- instance Traversable Zero where --- traverse _ _ = pure Zero --- --- instance Traversable rk => Traversable (Succ rk) where --- traverse f (Succ t ts) = Succ <$> traverse f t <*> traverse f ts --- --- instance Traversable rk => Traversable (BinomTree rk) where --- traverse f (BinomTree x ts) = BinomTree <$> f x <*> traverse f ts --- --- instance Traversable rk => Traversable (BinomForest rk) where --- traverse _ Nil = pure Nil --- traverse f (Skip tss) = Skip <$> traverse f tss --- traverse f (Cons t tss) = Cons <$> traverse f t <*> traverse f tss +{-# INLINABLE fromList #-} +-- | \(O(n)\). Constructs a priority queue from an unordered list. +fromList :: Ord a => [a] -> MinQueue 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 = fromBare (BQ.fromList xs) mapU :: (a -> b) -> MinQueue a -> MinQueue b mapU _ Empty = Empty -mapU f (MinQueue n x ts) = MinQueue n (f x) (f <$> ts) +mapU f (MinQueue n x ts) = MinQueue n (f x) (BQ.mapU f ts) --- | /O(n)/. Unordered right fold on a priority queue. +{-# NOINLINE [0] foldrU #-} +-- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MinQueue a -> b foldrU _ z Empty = z -foldrU f z (MinQueue _ x ts) = x `f` foldr f z ts +foldrU f z (MinQueue _ x ts) = x `f` BQ.foldrU f z ts --- | /O(n)/. Unordered left fold on a priority queue. +-- | \(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 -> MinQueue a -> b foldlU _ z Empty = z -foldlU f z (MinQueue _ x ts) = foldl f (z `f` x) ts +foldlU f z (MinQueue _ x ts) = BQ.foldlU f (z `f` x) ts +-- | \(O(n)\). Unordered strict left fold on a priority queue. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MinQueue a -> b +foldlU' _ z Empty = z +foldlU' f z (MinQueue _ x ts) = BQ.foldlU' f (z `f` x) ts + +-- | \(O(n)\). Unordered monoidal fold on a priority queue. +-- +-- @since 1.4.2 +foldMapU :: Monoid m => (a -> m) -> MinQueue a -> m +foldMapU _ Empty = mempty +foldMapU f (MinQueue _ x ts) = f x `mappend` BQ.foldMapU f ts + +{-# NOINLINE toListU #-} +-- | \(O(n)\). Returns the elements of the queue, in no particular order. +toListU :: MinQueue a -> [a] +toListU q = foldrU (:) [] q + +{-# NOINLINE toListUApp #-} +toListUApp :: MinQueue a -> [a] -> [a] +toListUApp Empty app = app +toListUApp (MinQueue _ x ts) app = x : BQ.foldrU (:) app ts + +{-# RULES +"toListU/build" [~1] forall q. toListU q = build (\c n -> foldrU c n q) +"toListU" [1] forall q app. foldrU (:) app q = toListUApp q app + #-} + -- traverseU :: Applicative f => (a -> f b) -> MinQueue a -> f (MinQueue b) -- traverseU _ Empty = pure Empty -- traverseU f (MinQueue n x ts) = MinQueue n <$> f x <*> traverse f ts --- | Forces the spine of the priority queue. +-- | \(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. seqSpine :: MinQueue a -> b -> b seqSpine Empty z = z -seqSpine (MinQueue _ _ ts) z = seqSpineF ts z - -seqSpineF :: BinomForest rk a -> b -> b -seqSpineF Nil z = z -seqSpineF (Skip ts') z = seqSpineF ts' z -seqSpineF (Cons _ ts') z = seqSpineF ts' z - --- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. -keysQueue :: Prio.MinPQueue k a -> MinQueue k -keysQueue Prio.Empty = Empty -keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (keysF (const Zero) ts) - -keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k -keysF f ts0 = case ts0 of - Prio.Nil -> Nil - Prio.Skip ts' -> Skip (keysF f' ts') - Prio.Cons (Prio.BinomTree k _ ts) ts' - -> Cons (BinomTree k (f ts)) (keysF f' ts') - where f' (Prio.Succ (Prio.BinomTree k _ ts) tss) = Succ (BinomTree k (f ts)) (f tss) +seqSpine (MinQueue _ _ ts) z = BQ.seqSpine ts z -class NFRank rk where - rnfRk :: NFData a => rk a -> () +instance NFData a => NFData (MinQueue a) where + rnf Empty = () + rnf (MinQueue _ x ts) = x `deepseq` rnf ts -instance NFRank Zero where - rnfRk _ = () +instance (Ord a, Show a) => Show (MinQueue a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromAscList " . shows (toAscList xs) -instance NFRank rk => NFRank (Succ rk) where - rnfRk (Succ t ts) = t `deepseq` rnfRk ts +instance Read a => Read (MinQueue a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromAscList" <- lexP + xs <- readPrec + return (fromAscList xs) -instance (NFData a, NFRank rk) => NFData (BinomTree rk a) where - rnf (BinomTree x ts) = x `deepseq` rnfRk ts + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromAscList",s) <- lex r + (xs,t) <- reads s + return (fromAscList xs,t) +#endif -instance (NFData a, NFRank rk) => NFData (BinomForest rk a) where - rnf Nil = () - rnf (Skip ts) = rnf ts - rnf (Cons t ts) = t `deepseq` rnf ts +#if MIN_VERSION_base(4,9,0) +instance Ord a => Semigroup (MinQueue a) where + (<>) = union + stimes = stimesMonoid +#endif -instance NFData a => NFData (MinQueue a) where - rnf Empty = () - rnf (MinQueue _ x ts) = x `deepseq` rnf ts +instance Ord a => Monoid (MinQueue a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions diff --git a/src/Data/PQueue/Internals/Down.hs b/src/Data/PQueue/Internals/Down.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals/Down.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +module Data.PQueue.Internals.Down where + +import Control.DeepSeq (NFData(rnf)) +import Data.Foldable (Foldable (..)) + +#if __GLASGOW_HASKELL__ +import Data.Data (Data) +#endif + +newtype Down a = Down { unDown :: a } +#if __GLASGOW_HASKELL__ + deriving (Eq, Data) +#else + deriving (Eq) +#endif + + +instance NFData a => NFData (Down a) where + rnf (Down a) = rnf a + +instance Ord a => Ord (Down a) where + Down a `compare` Down b = b `compare` a + Down a <= Down b = b <= a + +instance Functor Down where + fmap f (Down a) = Down (f a) + +instance Foldable Down where + foldr f z (Down a) = a `f` z + foldl f z (Down a) = z `f` a + foldl' f !z (Down a) = z `f` a diff --git a/src/Data/PQueue/Internals/Foldable.hs b/src/Data/PQueue/Internals/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/PQueue/Internals/Foldable.hs @@ -0,0 +1,38 @@ +-- | 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 @@ -16,8 +16,6 @@ -- some operations. These bounds hold even in a persistent (shared) setting. -- -- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. -- -- This implementation does not guarantee stable behavior. -- @@ -76,6 +74,8 @@ mapU, foldrU, foldlU, + foldlU', + foldMapU, elemsU, toListU, -- * Miscellaneous operations @@ -87,14 +87,16 @@ import Data.Maybe (fromMaybe) #if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) +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.Prio.Max.Internals (Down(..)) +import Data.PQueue.Internals.Down (Down(..)) -import Prelude hiding (null, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) +import Prelude hiding (null, map, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) @@ -110,7 +112,7 @@ -- Implemented as a wrapper around 'Min.MinQueue'. newtype MaxQueue a = MaxQ (Min.MinQueue (Down a)) # if __GLASGOW_HASKELL__ - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord, Data) # else deriving (Eq, Ord) # endif @@ -140,60 +142,64 @@ #if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MaxQueue a) where (<>) = union + stimes = stimesMonoid #endif instance Ord a => Monoid (MaxQueue a) where mempty = empty +#if !MIN_VERSION_base(4,11,0) mappend = union +#endif + mconcat = unions --- | /O(1)/. The empty priority queue. +-- | \(O(1)\). The empty priority queue. empty :: MaxQueue a empty = MaxQ Min.empty --- | /O(1)/. Is this the empty priority queue? +-- | \(O(1)\). Is this the empty priority queue? null :: MaxQueue a -> Bool null (MaxQ q) = Min.null q --- | /O(1)/. The number of elements in the queue. +-- | \(O(1)\). The number of elements in the queue. size :: MaxQueue a -> Int size (MaxQ q) = Min.size q --- | /O(1)/. Returns the maximum element of the queue. Throws an error on an empty queue. +-- | \(O(1)\). Returns the maximum element of the queue. Throws an error on an empty queue. findMax :: MaxQueue a -> a findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax --- | /O(1)/. The top (maximum) element of the queue, if there is one. +-- | \(O(1)\). The top (maximum) element of the queue, if there is one. getMax :: MaxQueue a -> Maybe a getMax (MaxQ q) = unDown <$> Min.getMin q --- | /O(log n)/. Deletes the maximum element of the queue. Does nothing on an empty queue. +-- | \(O(\log n)\). Deletes the maximum element of the queue. Does nothing on an empty queue. deleteMax :: Ord a => MaxQueue a -> MaxQueue a deleteMax (MaxQ q) = MaxQ (Min.deleteMin q) --- | /O(log n)/. Extracts the maximum element of the queue. Throws an error on an empty queue. +-- | \(O(\log n)\). Extracts the maximum element of the queue. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView --- | /O(log n)/. Extract the top (maximum) element of the sequence, if there is one. +-- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) maxView (MaxQ q) = case Min.minView q of Nothing -> Nothing Just (Down x, q') -> Just (x, MaxQ q') --- | /O(log n)/. Delete the top (maximum) element of the sequence, if there is one. +-- | \(O(\log n)\). Delete the top (maximum) element of the sequence, if there is one. delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) delete = fmap snd . maxView --- | /O(1)/. Construct a priority queue with a single element. +-- | \(O(1)\). Construct a priority queue with a single element. singleton :: a -> MaxQueue a singleton = MaxQ . Min.singleton . Down --- | /O(1)/. Insert an element into the priority queue. +-- | \(O(1)\). Insert an element into the priority queue. insert :: Ord a => a -> MaxQueue a -> MaxQueue a x `insert` MaxQ q = MaxQ (Down x `Min.insert` q) --- | /O(log (min(n1,n2)))/. Take the union of two priority queues. +-- | \(O(\log min(n_1,n_2))\). Take the union of two priority queues. union :: Ord a => MaxQueue a -> MaxQueue a -> MaxQueue a MaxQ q1 `union` MaxQ q2 = MaxQ (q1 `Min.union` q2) @@ -201,29 +207,29 @@ unions :: Ord a => [MaxQueue a] -> MaxQueue a unions qs = MaxQ (Min.unions [q | MaxQ q <- qs]) --- | /O(k log n)/. Returns the @(k+1)@th largest element of the queue. +-- | \(O(k \log n)\)/. Returns the @(k+1)@th largest element of the queue. (!!) :: Ord a => MaxQueue a -> Int -> a MaxQ q !! n = unDown ((Min.!!) q n) {-# INLINE take #-} --- | /O(k log n)/. Returns the list of the @k@ largest elements of the queue, in descending order, or +-- | \(O(k \log n)\)/. Returns the list of the @k@ largest elements of the queue, in descending order, or -- all elements of the queue, if @k >= n@. take :: Ord a => Int -> MaxQueue a -> [a] take k (MaxQ q) = [a | Down a <- Min.take k q] --- | /O(k log n)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. +-- | \(O(k \log n)\)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. drop :: Ord a => Int -> MaxQueue a -> MaxQueue a drop k (MaxQ q) = MaxQ (Min.drop k q) --- | /O(k log n)/. Equivalent to @(take k queue, drop k queue)@. +-- | \(O(k \log n)\)/. Equivalent to @(take k queue, drop k queue)@. splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) -splitAt k (MaxQ q) = (map unDown xs, MaxQ q') where +splitAt k (MaxQ q) = (fmap unDown xs, MaxQ q') where (xs, q') = Min.splitAt k q -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] -takeWhile p (MaxQ q) = map unDown (Min.takeWhile (p . unDown) q) +takeWhile p (MaxQ q) = fmap unDown (Min.takeWhile (p . unDown) q) -- | 'dropWhile' @p queue@ returns the queue remaining after 'takeWhile' @p queue@. dropWhile :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a @@ -234,7 +240,7 @@ -- satisfy @p@ and second element is the remainder of the queue. -- span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) -span p (MaxQ q) = (map unDown xs, MaxQ q') where +span p (MaxQ q) = (fmap unDown xs, MaxQ q') where (xs, q') = Min.span (p . unDown) q -- | 'break', applied to a predicate @p@ and a queue @queue@, returns a tuple where @@ -243,104 +249,129 @@ break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) break p = span (not . p) --- | /O(n)/. Returns a queue of those elements which satisfy the predicate. +-- | \(O(n)\). Returns a queue of those elements which satisfy the predicate. filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q) --- | /O(n)/. Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, +-- | \(O(n)\). Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, -- and the right queue contains those that do not. partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) partition p (MaxQ q) = (MaxQ q0, MaxQ q1) where (q0, q1) = Min.partition (p . unDown) q --- | /O(n)/. Maps a function over the elements of the queue, and collects the 'Just' values. +-- | \(O(n)\). Maps a function over the elements of the queue, and collects the 'Just' values. mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\(Down x) -> Down <$> f x) q) --- | /O(n)/. Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. +-- | \(O(n)\). Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1) where (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q --- | /O(n)/. Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue. +-- | \(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) + +-- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue. -- /Does not check the precondition/. mapU :: (a -> b) -> MaxQueue a -> MaxQueue b mapU f (MaxQ q) = MaxQ (Min.mapU (\(Down a) -> Down (f a)) q) --- | /O(n)/. Unordered right fold on a priority queue. +-- | \(O(n)\). Unordered right fold on a priority queue. foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q --- | /O(n)/. Unordered left fold on a priority queue. +-- | \(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 + +-- | \(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 +-- | \(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 + {-# INLINE elemsU #-} -- | Equivalent to 'toListU'. elemsU :: MaxQueue a -> [a] elemsU = toListU {-# INLINE toListU #-} --- | /O(n)/. Returns a list of the elements of the priority queue, in no particular order. +-- | \(O(n)\). Returns a list of the elements of the priority queue, in no particular order. toListU :: MaxQueue a -> [a] -toListU (MaxQ q) = map unDown (Min.toListU q) +toListU (MaxQ q) = fmap unDown (Min.toListU q) --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in ascending order. +-- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in ascending order. -- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b foldrAsc = foldlDesc . flip --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. +-- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. -- @'foldlAsc' f z q == 'foldrDesc' (flip f) z q@. foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b foldlAsc = foldrDesc . flip --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. +-- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in descending order. foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. +-- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q {-# INLINE toAscList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. +-- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. toAscList :: Ord a => MaxQueue a -> [a] toAscList q = build (\c nil -> foldrAsc c nil q) -- I can see no particular reason this does not simply forward to Min.toDescList. (lsp, 2016) {-# INLINE toDescList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in descending order. +-- | \(O(n \log n)\). Extracts the elements of the priority queue in descending order. toDescList :: Ord a => MaxQueue a -> [a] toDescList q = build (\c nil -> foldrDesc c nil q) -- I can see no particular reason this does not simply forward to Min.toAscList. (lsp, 2016) {-# INLINE toList #-} --- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'. +-- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toDescList'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MaxQueue a -> [a] -toList (MaxQ q) = map unDown (Min.toList q) +toList (MaxQ q) = fmap unDown (Min.toList q) {-# INLINE fromAscList #-} --- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. +-- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. fromAscList :: [a] -> MaxQueue a -fromAscList = MaxQ . Min.fromDescList . map Down +fromAscList = MaxQ . Min.fromDescList . fmap Down {-# INLINE fromDescList #-} --- | /O(n)/. Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. +-- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MaxQueue a -fromDescList = MaxQ . Min.fromAscList . map Down +fromDescList = MaxQ . Min.fromAscList . fmap Down {-# INLINE fromList #-} --- | /O(n log n)/. Constructs a priority queue from an unordered list. +-- | \(O(n \log n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MaxQueue a -fromList = foldr insert empty +fromList = MaxQ . Min.fromList . fmap Down --- | /O(n)/. Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. +-- | \(O(n)\). Constructs a priority queue from the keys of a 'Prio.MaxPQueue'. keysQueue :: Prio.MaxPQueue k a -> MaxQueue k keysQueue (Prio.MaxPQ q) = MaxQ (Min.keysQueue q) --- | /O(log n)/. Forces the spine of the heap. +-- | \(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. 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,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -17,8 +16,6 @@ -- some operations. These bounds hold even in a persistent (shared) setting. -- -- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. -- -- This implementation does not guarantee stable behavior. -- @@ -76,6 +73,8 @@ mapU, foldrU, foldlU, + foldlU', + foldMapU, elemsU, toListU, -- * Miscellaneous operations @@ -94,66 +93,31 @@ import qualified Data.List as List import Data.PQueue.Internals +import qualified BinomialQueue.Internals as BQ +import qualified Data.PQueue.Prio.Internals as Prio #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif --- instance - -instance (Ord a, Show a) => Show (MinQueue a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) - -instance Read a => Read (MinQueue a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP - xs <- readPrec - return (fromAscList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \r -> do - ("fromAscList",s) <- lex r - (xs,t) <- reads s - return (fromAscList xs,t) -#endif - -#if MIN_VERSION_base(4,9,0) -instance Ord a => Semigroup (MinQueue a) where - (<>) = union -#endif - -instance Ord a => Monoid (MinQueue a) where - mempty = empty - mappend = union - mconcat = unions - --- | /O(1)/. Returns the minimum element. Throws an error on an empty queue. +-- | \(O(1)\). Returns the minimum element. Throws an error on an empty queue. findMin :: MinQueue a -> a findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin --- | /O(log n)/. Deletes the minimum element. If the queue is empty, does nothing. +-- | \(O(\log n)\). Deletes the minimum element. If the queue is empty, does nothing. deleteMin :: Ord a => MinQueue a -> MinQueue a deleteMin q = case minView q of Nothing -> empty Just (_, q') -> q' --- | /O(log n)/. Extracts the minimum element. Throws an error on an empty queue. +-- | \(O(\log n)\). Extracts the minimum element. Throws an error on an empty queue. deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView --- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. -unions :: Ord a => [MinQueue a] -> MinQueue a -unions = foldl union empty - --- | /O(k log n)/. Index (subscript) operator, starting from 0. @queue !! k@ returns the @(k+1)@th smallest +-- | \(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 @@ -198,12 +162,12 @@ 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, +-- | \(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 @@ -211,94 +175,58 @@ | 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') | n > 0 -> let (xs, queue'') = splitAt (n - 1) queue' in (x : xs, queue'') _ -> ([], queue) --- | /O(n)/. Returns the queue with all elements not satisfying @p@ removed. +-- | \(O(n)\). Returns the queue with all elements not satisfying @p@ removed. filter :: Ord a => (a -> Bool) -> MinQueue a -> MinQueue a filter p = mapMaybe (\x -> if p x then Just x else Nothing) --- | /O(n)/. Returns a pair where the first queue contains all elements satisfying @p@, and the second queue +-- | \(O(n)\). Returns a pair where the first queue contains all elements satisfying @p@, and the second queue -- contains all elements not satisfying @p@. partition :: Ord a => (a -> Bool) -> MinQueue a -> (MinQueue a, MinQueue a) partition p = mapEither (\x -> if p x then Left x else Right x) --- | /O(n)/. Creates a new priority queue containing the images of the elements of this queue. +-- | \(O(n)\). Creates a new priority queue containing the images of the elements of this queue. -- Equivalent to @'fromList' . 'Data.List.map' f . toList@. map :: Ord b => (a -> b) -> MinQueue a -> MinQueue b map f = foldrU (insert . f) empty -{-# INLINE toAscList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in ascending order. -toAscList :: Ord a => MinQueue a -> [a] -toAscList queue = build (\c nil -> foldrAsc c nil queue) - -{-# INLINE toDescList #-} --- | /O(n log n)/. Extracts the elements of the priority queue in descending order. -toDescList :: Ord a => MinQueue a -> [a] -toDescList queue = build (\c nil -> foldrDesc c nil queue) - {-# INLINE toList #-} --- | /O(n log n)/. Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. +-- | \(O(n \log n)\). Returns the elements of the priority queue in ascending order. Equivalent to 'toAscList'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MinQueue a -> [a] toList = toAscList -{-# RULES - "toAscList" forall q . toAscList q = build (\c nil -> foldrAsc c nil q); - -- inlining doesn't seem to be working out =/ - "toDescList" forall q . toDescList q = build (\c nil -> foldrDesc c nil q); - #-} - --- | /O(n log n)/. Performs a right-fold on the elements of a priority queue in descending order. --- @foldrDesc f z q == foldlAsc (flip f) z q@. -foldrDesc :: Ord a => (a -> b -> b) -> b -> MinQueue a -> b -foldrDesc = foldlAsc . flip - --- | /O(n log n)/. Performs a left-fold on the elements of a priority queue in descending order. +-- | \(O(n \log n)\). Performs a left fold on the elements of a priority queue in descending order. -- @foldlDesc f z q == foldrAsc (flip f) z q@. foldlDesc :: Ord a => (b -> a -> b) -> b -> MinQueue a -> b foldlDesc = foldrAsc . flip -{-# INLINE fromList #-} --- | /O(n)/. Constructs a priority queue from an unordered list. -fromList :: Ord a => [a] -> MinQueue a -fromList = foldr insert empty - -{-# RULES - "fromList" fromList = foldr insert empty; - "fromAscList" fromAscList = foldr insertMinQ empty; - #-} - -{-# INLINE fromAscList #-} --- | /O(n)/. Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. -fromAscList :: [a] -> MinQueue a -fromAscList = foldr insertMinQ empty - --- | /O(n)/. Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. +{-# INLINE fromDescList #-} +-- | \(O(n)\). Constructs a priority queue from an descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MinQueue a -fromDescList = foldl' (flip insertMinQ) empty - --- | Maps a function over the elements of the queue, ignoring order. This function is only safe if the function is monotonic. --- This function /does not/ check the precondition. -mapU :: (a -> b) -> MinQueue a -> MinQueue b -mapU = mapMonotonic +-- We apply an explicit argument to get foldl' to inline. +fromDescList xs = foldl' (flip insertMinQ') empty xs -{-# INLINE elemsU #-} -- | Equivalent to 'toListU'. elemsU :: MinQueue a -> [a] elemsU = toListU --- | /O(n)/. Returns the elements of the queue, in no particular order. -toListU :: MinQueue a -> [a] -toListU q = build (\c n -> foldrU c n q) +-- | Constructs a priority queue out of the keys of the specified 'Prio.MinPQueue'. +keysQueue :: Prio.MinPQueue k a -> MinQueue k +keysQueue Prio.Empty = Empty +keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (BQ.MinQueue (keysF (const Zero) ts)) -{-# RULES - "foldr/toListU" forall f z q . foldr f z (toListU q) = foldrU f z q; - "foldl/toListU" forall f z q . foldl f z (toListU q) = foldlU f z q; - #-} +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) 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,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} module Data.PQueue.Prio.Internals ( MinPQueue(..), @@ -17,7 +18,9 @@ union, getMin, adjustMinWithKey, + adjustMinWithKeyA', updateMinWithKey, + updateMinWithKeyA', minViewWithKey, mapWithKey, mapKeysMonotonic, @@ -25,34 +28,108 @@ mapEitherWithKey, foldrWithKey, foldlWithKey, + foldrU, + toAscList, + toDescList, + toListU, insertMin, + insertMin', + insertMax', + fromList, + fromAscList, foldrWithKeyU, + foldMapWithKeyU, foldlWithKeyU, + foldlWithKeyU', + traverseWithKey, + mapMWithKey, traverseWithKeyU, seqSpine, - mapForest + mapForest, + unions ) where -import Control.Applicative.Identity (Identity(Identity, runIdentity)) +import Control.Applicative (liftA2, liftA3) import Control.DeepSeq (NFData(rnf), deepseq) +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 ((<>)) - -import Prelude hiding (null) - -#if __GLASGOW_HASKELL__ +#endif +import Prelude hiding (null, map) +#ifdef __GLASGOW_HASKELL__ import Data.Data +import GHC.Exts (build) +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +#endif +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + +#if __GLASGOW_HASKELL__ instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where - gfoldl f z m = z (foldr (uncurry' insertMin) empty) `f` foldrWithKey (curry (:)) [] m - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "Data.PQueue.Prio.Min.MinPQueue" + 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" + 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 + #endif +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (MinPQueue k a) where + (<>) = union + stimes = stimesMonoid +#endif + +instance Ord k => Monoid (MinPQueue k a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions + +instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromAscList " . shows (toAscList xs) + +instance (Read k, Read a) => Read (MinPQueue k a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromAscList" <- lexP + xs <- readPrec + return (fromAscList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromAscList",s) <- lex r + (xs,t) <- reads s + return (fromAscList xs,t) +#endif + +-- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). +unions :: Ord k => [MinPQueue k a] -> MinPQueue k a +unions = List.foldl' union empty + + (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (f .: g) x y = f (g x y) @@ -62,17 +139,11 @@ second' :: (b -> c) -> (a, b) -> (a, c) second' f (a, b) = (a, f b) -uncurry' :: (a -> b -> c) -> (a, b) -> c -uncurry' f (a, b) = f a b - infixr 8 .: -- | A priority queue where values of type @a@ are annotated with keys of type @k@. -- The queue supports extracting the element with minimum key. -data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int k a (BinomHeap k a) -#if __GLASGOW_HASKELL__ - deriving (Typeable) -#endif +data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a) data BinomForest rk k a = Nil | @@ -80,10 +151,44 @@ 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 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) +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 + type CompF a = a -> a -> Bool instance (Ord k, Eq a) => Eq (MinPQueue k a) where @@ -118,30 +223,30 @@ (Yes{}, No) -> GT (No, No) -> EQ --- | /O(1)/. Returns the empty priority queue. +-- | \(O(1)\). Returns the empty priority queue. empty :: MinPQueue k a empty = Empty --- | /O(1)/. Checks if this priority queue is empty. +-- | \(O(1)\). Checks if this priority queue is empty. null :: MinPQueue k a -> Bool null Empty = True null _ = False --- | /O(1)/. Returns the size of this priority queue. +-- | \(O(1)\). Returns the size of this priority queue. size :: MinPQueue k a -> Int size Empty = 0 size (MinPQ n _ _ _) = n --- | /O(1)/. Constructs a singleton priority queue. +-- | \(O(1)\). Constructs a singleton priority queue. singleton :: k -> a -> MinPQueue k a singleton k a = MinPQ 1 k a Nil --- | Amortized /O(1)/, worst-case /O(log n)/. Inserts +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts -- an element with the specified key into the queue. insert :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a insert = insert' (<=) --- | /O(n)/ (an earlier implementation had /O(1)/ but was buggy). +-- | \(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. @@ -160,10 +265,10 @@ insert' :: CompF k -> k -> a -> MinPQueue k a -> MinPQueue k a insert' _ k a Empty = singleton k a insert' le k a (MinPQ n k' a' ts) - | k `le` k' = MinPQ (n + 1) k a (incr le (tip k' a') ts) + | k `le` k' = MinPQ (n + 1) k a (incrMin (tip k' a') ts) | otherwise = MinPQ (n + 1) k' a' (incr le (tip k a ) ts) --- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union +-- | Amortized \(O(\log \min(n_1,n_2))\), worst-case \(O(\log \max(n_1,n_2))\). Returns the union -- of the two specified queues. union :: Ord k => MinPQueue k a -> MinPQueue k a -> MinPQueue k a union = union' (<=) @@ -177,17 +282,23 @@ union' _ Empty q2 = q2 union' _ q1 Empty = q1 --- | /O(1)/. The minimal (key, element) in the queue, if the queue is nonempty. +-- | \(O(1)\). The minimal (key, element) in the queue, if the queue is nonempty. getMin :: MinPQueue k a -> Maybe (k, a) getMin (MinPQ _ k a _) = Just (k, a) getMin _ = Nothing --- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. +-- | \(O(1)\). Alter the value at the minimum key. If the queue is empty, does nothing. adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a adjustMinWithKey _ Empty = Empty adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. +-- | \(O(1)\) per operation. Alter the value at the minimum key in an 'Applicative' context. If the +-- queue is empty, does nothing. +adjustMinWithKeyA' :: Applicative f => (MinPQueue k a -> r) -> (k -> a -> f a) -> MinPQueue k a -> f r +adjustMinWithKeyA' g _ Empty = pure (g Empty) +adjustMinWithKeyA' g f (MinPQ n k a ts) = fmap (\a' -> g (MinPQ n k a' ts)) (f k a) + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the minimum key. -- If the queue is empty, does nothing. updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> MinPQueue k a -> MinPQueue k a updateMinWithKey _ Empty = Empty @@ -195,35 +306,50 @@ Nothing -> extractHeap (<=) n ts Just a' -> MinPQ n k a' ts --- | /O(log n)/. Retrieves the minimal (key, value) pair of the map, and the map stripped of that +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the minimum key in an 'Applicative' context. If the queue is +-- empty, does nothing. +updateMinWithKeyA' + :: (Applicative f, Ord k) + => (MinPQueue k a -> r) + -> (k -> a -> f (Maybe a)) + -> MinPQueue k a + -> f r +updateMinWithKeyA' g _ Empty = pure (g Empty) +updateMinWithKeyA' g f (MinPQ n k a ts) = fmap (g . tweak) (f k a) + where + tweak Nothing = extractHeap (<=) n ts + tweak (Just a') = MinPQ n k a' ts + +-- | \(O(\log n)\). Retrieves the minimal (key, value) pair of the map, and the map stripped of that -- element, or 'Nothing' if passed an empty map. minViewWithKey :: Ord k => MinPQueue k a -> Maybe ((k, a), MinPQueue k a) minViewWithKey Empty = Nothing minViewWithKey (MinPQ n k a ts) = Just ((k, a), extractHeap (<=) n ts) --- | /O(n)/. Map a function over all values in the queue. +-- | \(O(n)\). Map a function over all values in the queue. mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f) --- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly +-- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly -- monotonic. /The precondition is not checked./ This function has better performance than -- 'mapKeys'. mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeysMonotonic _ Empty = Empty mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts) --- | /O(n)/. Map values and collect the 'Just' results. +-- | \(O(n)\). Map values and collect the 'Just' results. mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b mapMaybeWithKey _ Empty = Empty mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF (<=) f (const Empty) ts) --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) mapEitherWithKey _ Empty = (Empty, Empty) mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a) (mapEitherF (<=) f (const (Empty, Empty)) ts) --- | /O(n log n)/. Fold the keys and values in the map, such that +-- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. -- -- If you do not care about the traversal order, consider using 'foldrWithKeyU'. @@ -234,7 +360,7 @@ Yes (Extract k a _ ts') -> f k a (foldF ts') _ -> z --- | /O(n log n)/. Fold the keys and values in the map, such that +-- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. -- -- If you do not care about the traversal order, consider using 'foldlWithKeyU'. @@ -245,18 +371,90 @@ Yes (Extract k a _ ts') -> foldF (f z k a) ts' _ -> z +{-# INLINABLE [1] toAscList #-} +-- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. +toAscList :: Ord k => MinPQueue k a -> [(k, a)] +toAscList = foldrWithKey (curry (:)) [] + +{-# INLINABLE [1] toDescList #-} +-- | \(O(n \log n)\). Return all (key, value) pairs in descending order by key. +toDescList :: Ord k => MinPQueue k a -> [(k, a)] +toDescList = foldlWithKey (\z k a -> (k, a) : z) [] + +-- | \(O(n)\). Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ +fromAscList :: [(k, a)] -> MinPQueue k a +{-# INLINE fromAscList #-} +fromAscList xs = List.foldl' (\q (k, a) -> insertMax' k a q) empty xs + +{-# RULES + "toAscList" toAscList = \q -> build (\c n -> foldrWithKey (curry c) n q); + "toDescList" toDescList = \q -> build (\c n -> foldlWithKey (\z k a -> (k, a) `c` z) n q); + "toListU" toListU = \q -> build (\c n -> foldrWithKeyU (curry c) n q); + #-} + +{-# NOINLINE toListU #-} +-- | \(O(n)\). Returns all (key, value) pairs in the queue in no particular order. +toListU :: MinPQueue k a -> [(k, a)] +toListU = foldrWithKeyU (curry (:)) [] + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrU :: (a -> b -> b) -> b -> MinPQueue k a -> b +foldrU = foldrWithKeyU . const + -- | Equivalent to 'insert', save the assumption that this key is @<=@ -- every other key in the map. /The precondition is not checked./ insertMin :: k -> a -> MinPQueue k a -> MinPQueue k a insertMin k a Empty = MinPQ 1 k a Nil insertMin k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin (tip k' a') ts) --- | /O(1)/. Returns a binomial tree of rank zero containing this +-- | Equivalent to 'insert', save the assumption that this key is @<=@ +-- every other key in the map. /The precondition is not checked./ Additionally, +-- this eagerly constructs the new portion of the spine. +insertMin' :: k -> a -> MinPQueue k a -> MinPQueue k a +insertMin' k a Empty = MinPQ 1 k a Nil +insertMin' k a (MinPQ n k' a' ts) = MinPQ (n + 1) k a (incrMin' (tip k' a') ts) + +-- | Inserts an entry with key @>=@ every key in the map. Assumes and preserves +-- an extra invariant: the roots of the binomial trees are decreasing along +-- the spine. +insertMax' :: k -> a -> MinPQueue k a -> MinPQueue k a +insertMax' k a Empty = MinPQ 1 k a Nil +insertMax' k a (MinPQ n k' a' ts) = MinPQ (n + 1) k' a' (incrMax' (tip k a) ts) + +{-# 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 extractForest (<=) (fromListHeap (<=) xs) of + No -> Empty + -- Should we track the size as we go instead? That saves O(log n) + -- at the end, but it needs an extra register all along the way. + -- 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 + +{-# INLINE fromListHeap #-} +fromListHeap :: CompF k -> [(k, a)] -> BinomHeap k a +fromListHeap le xs = List.foldl' go Nil xs + where + go fr (k, a) = incr' le (tip k a) fr + +sizeHeap :: BinomHeap k a -> Int +sizeHeap = 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 + +-- | \(O(1)\). Returns a binomial tree of rank zero containing this -- key and value. tip :: k -> a -> BinomTree Zero k a tip k a = BinomTree k a Zero --- | /O(1)/. Takes the union of two binomial trees of the same rank. +-- | \(O(1)\). Takes the union of two binomial trees of the same rank. meld :: CompF k -> BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a meld le t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) | k1 `le` k2 = BinomTree k1 v1 (Succ t2 ts1) @@ -265,10 +463,10 @@ -- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. mergeForest :: CompF k -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a mergeForest le f1 f2 = case (f1, f2) of - (Skip ts1, Skip ts2) -> Skip (mergeForest le ts1 ts2) - (Skip ts1, Cons t2 ts2) -> Cons t2 (mergeForest le ts1 ts2) - (Cons t1 ts1, Skip ts2) -> Cons t1 (mergeForest le ts1 ts2) - (Cons t1 ts1, Cons t2 ts2) -> Skip (carryForest le (meld le t1 t2) ts1 ts2) + (Skip ts1, Skip ts2) -> Skip $! mergeForest le ts1 ts2 + (Skip ts1, Cons t2 ts2) -> Cons t2 $! mergeForest le ts1 ts2 + (Cons t1 ts1, Skip ts2) -> Cons t1 $! mergeForest le ts1 ts2 + (Cons t1 ts1, Cons t2 ts2) -> Skip $! carryForest le (meld le t1 t2) ts1 ts2 (Nil, _) -> f2 (_, Nil) -> f1 @@ -276,10 +474,13 @@ -- Analogous to binary addition when a digit has been carried. carryForest :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a carryForest le t0 f1 f2 = t0 `seq` case (f1, f2) of - (Cons t1 ts1, Cons t2 ts2) -> Cons t0 (carryMeld t1 t2 ts1 ts2) - (Cons t1 ts1, Skip ts2) -> Skip (carryMeld t0 t1 ts1 ts2) - (Skip ts1, Cons t2 ts2) -> Skip (carryMeld t0 t2 ts1 ts2) - (Skip ts1, Skip ts2) -> Cons t0 (mergeForest le ts1 ts2) + (Cons t1 ts1, Cons t2 ts2) -> Cons t0 $! carryMeld t1 t2 ts1 ts2 + (Cons t1 ts1, Skip ts2) -> Skip $! carryMeld t0 t1 ts1 ts2 + (Skip ts1, Cons t2 ts2) -> Skip $! carryMeld t0 t2 ts1 ts2 + (Skip ts1, Skip ts2) -> Cons t0 $! mergeForest le ts1 ts2 + -- Why do these use incr and not incr'? We want the merge to take + -- O(log(min(|f1|, |f2|))) amortized time. If we performed this final + -- increment eagerly, that would degrade to O(log(max(|f1|, |f2|))) time. (Nil, _) -> incr le t0 f2 (_, Nil) -> incr le t0 f1 where carryMeld = carryForest le .: meld le @@ -289,8 +490,16 @@ incr le t ts = t `seq` case ts of Nil -> Cons t Nil Skip ts' -> Cons t ts' - Cons t' ts' -> Skip (incr le (meld le t t') ts') + Cons t' ts' -> ts' `seq` Skip (incr le (meld le t t') ts') +-- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. +-- Forces the rebuilt portion of the spine. +incr' :: CompF k -> BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a +incr' le t ts = t `seq` case ts of + Nil -> Cons t Nil + Skip ts' -> Cons t ts' + Cons t' ts' -> Skip $! incr' le (meld le t t') ts' + -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr' (\_ _ -> True)@. @@ -298,8 +507,24 @@ incrMin t@(BinomTree k a ts) tss = case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' - Cons t' tss' -> Skip (incrMin (BinomTree k a (Succ t' ts)) tss') + Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k a (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 + Nil -> Cons t Nil + Skip tss' -> Cons t tss' + Cons t' tss' -> Skip $! incrMin' (BinomTree k a (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' + extractHeap :: CompF k -> Int -> BinomHeap k a -> MinPQueue k a extractHeap le n ts = n `seq` case extractForest le ts of No -> Empty @@ -330,30 +555,52 @@ -- 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 a !(rk k a) !(BinomForest rk k a) data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) -incrExtract :: CompF k -> Maybe (BinomTree rk k a) -> Extract (Succ rk) k a -> Extract rk k a -incrExtract _ Nothing (Extract k a (Succ t ts) tss) - = Extract k a ts (Cons t tss) -incrExtract le (Just t) (Extract k a (Succ t' ts) tss) - = Extract k a ts (Skip (incr le (meld le t t') tss)) +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) +-- 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' :: CompF k -> BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a +incrExtract' le t (Extract minKey minVal (Succ kChild kChildren) ts) + = Extract minKey minVal kChildren (Skip $ incr le (t `cat` kChild) ts) + where + cat = meld le + -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes --- amortized /O(1)/ time, so applying it from the beginning takes /O(log n)/ time. +-- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time. extractForest :: CompF k -> BinomForest rk k a -> MExtract rk k a -extractForest _ Nil = No -extractForest le (Skip tss) = case extractForest le tss of - No -> No - Yes ex -> Yes (incrExtract le Nothing ex) -extractForest le (Cons t@(BinomTree k a0 ts) tss) = Yes $ case extractForest le tss of - Yes ex@(Extract k' _ _ _) - | k' incrExtract le (Just t) ex - _ -> Extract k a0 ts (Skip tss) +extractForest le0 = start le0 where - a BinomForest rk k a -> MExtract rk k a + start _le Nil = No + start le (Skip f) = case start le f of + No -> No + Yes ex -> Yes (incrExtract ex) + start le (Cons t@(BinomTree k v ts) f) = Yes $ case go le k f of + No -> Extract k v ts (Skip f) + Yes ex -> incrExtract' le t ex + go :: CompF k -> k -> BinomForest rk k a -> MExtract rk k a + go _le _min_above Nil = _min_above `seq` No + go le min_above (Skip f) = case go le min_above f of + No -> No + Yes ex -> Yes (incrExtract ex) + go le min_above (Cons t@(BinomTree k v ts) f) + | min_above `le` k = case go le min_above f of + No -> No + Yes ex -> Yes (incrExtract' le t ex) + | otherwise = case go le k f of + No -> Yes (Extract k v ts (Skip f)) + Yes ex -> Yes (incrExtract' le t ex) + extract :: (Ord k) => BinomForest rk k a -> MExtract rk k a extract = extractForest (<=) @@ -394,22 +641,67 @@ insF k a (fCh ts) (fCh tss) both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b foldrWithKeyU _ z Empty = z foldrWithKeyU f z (MinPQ _ k a ts) = f k a (foldrWithKeyF_ f (const id) ts z) --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. +-- | \(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 + +-- | \(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) --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. +-- | \(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 + +-- | \(O(n)\). Map a function over all values in the queue. +map :: (a -> b) -> MinPQueue k a -> MinPQueue k b +map = mapWithKey . const + +-- | \(O(n \log n)\). Traverses the elements of the queue in ascending order by key. +-- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) +-- +-- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. +-- +-- If you are working in a strict monad, consider using 'mapMWithKey'. +traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) +traverseWithKey f q = case minViewWithKey q of + Nothing -> pure empty + Just ((k, a), q') -> liftA2 (insertMin k) (f k a) (traverseWithKey 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) -> MinPQueue k a -> m (MinPQueue k b) +mapMWithKey f = go empty + where + go !acc q = + case minViewWithKey q of + Nothing -> pure acc + Just ((k, a), q') -> do + b <- f k a + let !acc' = insertMax' k b acc + go acc' q' + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. -- While there is no guarantee in which order the elements are traversed, the resulting -- priority queue will be perfectly valid. traverseWithKeyU :: Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) traverseWithKeyU _ Empty = pure Empty -traverseWithKeyU f (MinPQ n k a ts) = MinPQ n k <$> f k a <*> traverseForest f (const (pure Zero)) ts +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) #-} @@ -418,7 +710,7 @@ Nil -> pure Nil Skip ts' -> Skip <$> traverseForest f fCh' ts' Cons (BinomTree k a ts) tss - -> Cons <$> (BinomTree k <$> f k a <*> fCh ts) <*> traverseForest f fCh' tss + -> 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 @@ -456,7 +748,13 @@ fCh' (Succ (BinomTree k a ts) tss) = Succ (BinomTree (f k) a (fCh ts)) (fCh tss) --- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. +-- | \(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. seqSpine :: MinPQueue k a -> b -> b seqSpine Empty z0 = z0 seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where @@ -486,3 +784,19 @@ instance (NFData k, NFData a) => NFData (MinPQueue k a) where rnf Empty = () rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts + +instance Functor (MinPQueue k) where + fmap = map + +instance Ord k => Foldable (MinPQueue k) where + foldr = foldrWithKey . const + foldl f = foldlWithKey (const . f) + length = size + null = null + +-- | Traverses in ascending order. 'mapM' is strictly accumulating like +-- 'mapMWithKey'. +instance Ord k => Traversable (MinPQueue k) where + traverse = traverseWithKey . const + mapM = mapMWithKey . const + sequence = mapM id 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 @@ -1,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Prio.Max @@ -15,11 +12,9 @@ -- viewing and extracting the element with the maximum key. -- -- A worst-case bound is given for each operation. In some cases, an amortized --- bound is also specified; these bounds do not hold in a persistent context. +-- bound is also specified; these bounds hold even in a persistent context. -- -- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. -- -- We do not guarantee stable behavior. -- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there @@ -49,9 +44,13 @@ deleteMax, deleteFindMax, adjustMax, + adjustMaxA, adjustMaxWithKey, + adjustMaxWithKeyA, updateMax, + updateMaxA, updateMaxWithKey, + updateMaxWithKeyA, maxView, maxViewWithKey, -- * Traversal @@ -65,6 +64,7 @@ foldlWithKey, -- ** Traverse traverseWithKey, + mapMWithKey, -- * Subsets -- ** Indexed take, @@ -103,8 +103,11 @@ -- * Unordered operations foldrU, foldrWithKeyU, + foldMapWithKeyU, foldlU, + foldlU', foldlWithKeyU, + foldlWithKeyU', traverseU, traverseWithKeyU, keysU, @@ -116,361 +119,5 @@ ) where -import Data.Maybe (fromMaybe) import Data.PQueue.Prio.Max.Internals - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup((<>))) -#endif - -import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) - -import qualified Data.PQueue.Prio.Min as Q - -#ifdef __GLASGOW_HASKELL__ -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) -#else -build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] -build f = f (:) [] -#endif - -first' :: (a -> b) -> (a, c) -> (b, c) -first' f (a, c) = (f a, c) - -#if MIN_VERSION_base(4,9,0) -instance Ord k => Semigroup (MaxPQueue k a) where - (<>) = union -#endif - -instance Ord k => Monoid (MaxPQueue k a) where - mempty = empty - mappend = union - mconcat = unions - -instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromDescList " . shows (toDescList xs) - -instance (Read k, Read a) => Read (MaxPQueue k a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromDescList" <- lexP - xs <- readPrec - return (fromDescList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \r -> do - ("fromDescList",s) <- lex r - (xs,t) <- reads s - return (fromDescList xs,t) -#endif - -instance Functor (MaxPQueue k) where - fmap f (MaxPQ q) = MaxPQ (fmap f q) - -instance Ord k => Foldable (MaxPQueue k) where - foldr f z (MaxPQ q) = foldr f z q - foldl f z (MaxPQ q) = foldl f z q - -instance Ord k => Traversable (MaxPQueue k) where - traverse f (MaxPQ q) = MaxPQ <$> traverse f q - --- | /O(1)/. Returns the empty priority queue. -empty :: MaxPQueue k a -empty = MaxPQ Q.empty - --- | /O(1)/. Constructs a singleton priority queue. -singleton :: k -> a -> MaxPQueue k a -singleton k a = MaxPQ (Q.singleton (Down k) a) - --- | Amortized /O(1)/, worst-case /O(log n)/. Inserts --- an element with the specified key into the queue. -insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insert k a (MaxPQ q) = MaxPQ (Q.insert (Down k) a q) - --- | /O(n)/ (an earlier implementation had /O(1)/ but was buggy). --- Insert an element with the specified key into the priority queue, --- putting it behind elements whose key compares equal to the --- inserted one. -insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a -insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) - --- | Amortized /O(log(min(n1, n2)))/, worst-case /O(log(max(n1, n2)))/. Returns the union --- of the two specified queues. -union :: Ord k => MaxPQueue k a -> MaxPQueue k a -> MaxPQueue k a -MaxPQ q1 `union` MaxPQ q2 = MaxPQ (q1 `Q.union` q2) - --- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). -unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a -unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs]) - --- | /O(1)/. Checks if this priority queue is empty. -null :: MaxPQueue k a -> Bool -null (MaxPQ q) = Q.null q - --- | /O(1)/. Returns the size of this priority queue. -size :: MaxPQueue k a -> Int -size (MaxPQ q) = Q.size q - --- | /O(1)/. The maximal (key, element) in the queue. Calls 'error' if empty. -findMax :: MaxPQueue k a -> (k, a) -findMax = fromMaybe (error "Error: findMax called on an empty queue") . getMax - --- | /O(1)/. The maximal (key, element) in the queue, if the queue is nonempty. -getMax :: MaxPQueue k a -> Maybe (k, a) -getMax (MaxPQ q) = do - (Down k, a) <- Q.getMin q - return (k, a) - --- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. -deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a -deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q) - --- | /O(log n)/. Delete and find the element with the maximum key. Calls 'error' if empty. -deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) -deleteFindMax = fromMaybe (error "Error: deleteFindMax called on an empty queue") . maxViewWithKey - --- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. -adjustMax :: (a -> a) -> MaxPQueue k a -> MaxPQueue k a -adjustMax = adjustMaxWithKey . const - --- | /O(1)/. Alter the value at the maximum key. If the queue is empty, does nothing. -adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a -adjustMaxWithKey f (MaxPQ q) = MaxPQ (Q.adjustMinWithKey (f . unDown) q) - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. --- If the queue is empty, does nothing. -updateMax :: Ord k => (a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a -updateMax = updateMaxWithKey . const - --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the maximum key. --- If the queue is empty, does nothing. -updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a -updateMaxWithKey f (MaxPQ q) = MaxPQ (Q.updateMinWithKey (f . unDown) q) - --- | /O(log n)/. Retrieves the value associated with the maximum key of the queue, and the queue --- stripped of that element, or 'Nothing' if passed an empty queue. -maxView :: Ord k => MaxPQueue k a -> Maybe (a, MaxPQueue k a) -maxView q = do - ((_, a), q') <- maxViewWithKey q - return (a, q') - --- | /O(log n)/. Retrieves the maximal (key, value) pair of the map, and the map stripped of that --- element, or 'Nothing' if passed an empty map. -maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a) -maxViewWithKey (MaxPQ q) = do - ((Down k, a), q') <- Q.minViewWithKey q - return ((k, a), MaxPQ q') - --- | /O(n)/. Map a function over all values in the queue. -map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b -map = mapWithKey . const - --- | /O(n)/. Map a function over all values in the queue. -mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b -mapWithKey f (MaxPQ q) = MaxPQ (Q.mapWithKey (f . unDown) q) - --- | /O(n)/. Map a function over all values in the queue. -mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q) - --- | /O(n)/. @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly --- monotonic. /The precondition is not checked./ This function has better performance than --- 'mapKeys'. -mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a -mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q) - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. --- --- If you do not care about the traversal order, consider using 'foldrWithKeyU'. -foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q - --- | /O(n log n)/. Fold the keys and values in the map, such that --- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. --- --- If you do not care about the traversal order, consider using 'foldlWithKeyU'. -foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\z -> f z . unDown) z0 q - --- | /O(n log n)/. Traverses the elements of the queue in descending order by key. --- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) --- --- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. -traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKey f (MaxPQ q) = MaxPQ <$> Q.traverseWithKey (f . unDown) q - --- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. --- (@'take' k q == 'List.take' k ('toDescList' q)@) -take :: Ord k => Int -> MaxPQueue k a -> [(k, a)] -take k (MaxPQ q) = fmap (first' unDown) (Q.take k q) - --- | /O(k log n)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. -drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a -drop k (MaxPQ q) = MaxPQ (Q.drop k q) - --- | /O(k log n)/. Equivalent to @('take' k q, 'drop' k q)@. -splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -splitAt k (MaxPQ q) = case Q.splitAt k q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) -takeWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhile = takeWhileWithKey . const - --- | Takes the longest possible prefix of elements satisfying the predicate. --- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) -takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] -takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q) - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -dropWhile = dropWhileWithKey . const - --- | Removes the longest possible prefix of elements satisfying the predicate. -dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -dropWhileWithKey p (MaxPQ q) = MaxPQ (Q.dropWhileWithKey (p . unDown) q) - --- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. -span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -span = spanWithKey . const - --- | Equivalent to @'span' ('not' . p)@. -break :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -break = breakWithKey . const - --- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. -spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -spanWithKey p (MaxPQ q) = case Q.spanWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. -breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) -breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of - (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') - --- | /O(n)/. Filter all values that satisfy the predicate. -filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -filter = filterWithKey . const - --- | /O(n)/. Filter all values that satisfy the predicate. -filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a -filterWithKey p (MaxPQ q) = MaxPQ (Q.filterWithKey (p . unDown) q) - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partition :: Ord k => (a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) -partition = partitionWithKey . const - --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements --- which satisfy the predicate, the second all elements that fail the predicate. -partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) -partitionWithKey p (MaxPQ q) = case Q.partitionWithKey (p . unDown) q of - (q1, q0) -> (MaxPQ q1, MaxPQ q0) - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b -mapMaybe = mapMaybeWithKey . const - --- | /O(n)/. Map values and collect the 'Just' results. -mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b -mapMaybeWithKey f (MaxPQ q) = MaxPQ (Q.mapMaybeWithKey (f . unDown) q) - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) -mapEither = mapEitherWithKey . const - --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. -mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) -mapEitherWithKey f (MaxPQ q) = case Q.mapEitherWithKey (f . unDown) q of - (qL, qR) -> (MaxPQ qL, MaxPQ qR) - --- | /O(n)/. Build a priority queue from the list of (key, value) pairs. -fromList :: Ord k => [(k, a)] -> MaxPQueue k a -fromList = MaxPQ . Q.fromList . fmap (first' Down) - --- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ -fromAscList :: [(k, a)] -> MaxPQueue k a -fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down) - --- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ -fromDescList :: [(k, a)] -> MaxPQueue k a -fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down) - --- | /O(n log n)/. Return all keys of the queue in descending order. -keys :: Ord k => MaxPQueue k a -> [k] -keys = fmap fst . toDescList - --- | /O(n log n)/. Return all elements of the queue in descending order by key. -elems :: Ord k => MaxPQueue k a -> [a] -elems = fmap snd . toDescList - --- | /O(n log n)/. Equivalent to 'toDescList'. -assocs :: Ord k => MaxPQueue k a -> [(k, a)] -assocs = toDescList - --- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. -toAscList :: Ord k => MaxPQueue k a -> [(k, a)] -toAscList (MaxPQ q) = fmap (first' unDown) (Q.toDescList q) - --- | /O(n log n)/. Return all (key, value) pairs in descending order by key. -toDescList :: Ord k => MaxPQueue k a -> [(k, a)] -toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q) - --- | /O(n log n)/. Equivalent to 'toDescList'. --- --- If the traversal order is irrelevant, consider using 'toListU'. -toList :: Ord k => MaxPQueue k a -> [(k, a)] -toList = toDescList - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrU :: (a -> b -> b) -> b -> MaxPQueue k a -> b -foldrU = foldrWithKeyU . const - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b -foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (f . unDown) z q - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlU :: (b -> a -> b) -> b -> MaxPQueue k a -> b -foldlU f = foldlWithKeyU (const . f) - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. -foldlWithKeyU :: (b -> k -> a -> b) -> b -> MaxPQueue k a -> b -foldlWithKeyU f z0 (MaxPQ q) = Q.foldlWithKeyU (\z -> f z . unDown) z0 q - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseU :: (Applicative f) => (a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseU = traverseWithKeyU . const - --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. --- While there is no guarantee in which order the elements are traversed, the resulting --- priority queue will be perfectly valid. -traverseWithKeyU :: (Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) -traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (f . unDown) q - --- | /O(n)/. Return all keys of the queue in no particular order. -keysU :: MaxPQueue k a -> [k] -keysU = fmap fst . toListU - --- | /O(n)/. Return all elements of the queue in no particular order. -elemsU :: MaxPQueue k a -> [a] -elemsU = fmap snd . toListU - --- | /O(n)/. Equivalent to 'toListU'. -assocsU :: MaxPQueue k a -> [(k, a)] -assocsU = toListU - --- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. -toListU :: MaxPQueue k a -> [(k, a)] -toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q) - --- | /O(log n)/. Analogous to @deepseq@ in the @deepseq@ package, but only forces the spine of the binomial heap. -seqSpine :: MaxPQueue k a -> b -> b -seqSpine (MaxPQ q) = Q.seqSpine q +import Prelude () 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 @@ -1,27 +1,140 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -module Data.PQueue.Prio.Max.Internals where +----------------------------------------------------------------------------- +-- | +-- Module : Data.PQueue.Prio.Max +-- Copyright : (c) Louis Wasserman 2010 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Data.PQueue.Prio.Max.Internals ( + MaxPQueue (..), + -- * Construction + empty, + singleton, + insert, + insertBehind, + union, + unions, + -- * Query + null, + size, + -- ** Maximum view + findMax, + getMax, + deleteMax, + deleteFindMax, + adjustMax, + adjustMaxA, + adjustMaxWithKey, + adjustMaxWithKeyA, + updateMax, + updateMaxA, + updateMaxWithKey, + updateMaxWithKeyA, + maxView, + maxViewWithKey, + -- * Traversal + -- ** Map + map, + mapWithKey, + mapKeys, + mapKeysMonotonic, + -- ** Fold + foldrWithKey, + foldlWithKey, + -- ** Traverse + traverseWithKey, + mapMWithKey, + -- * Subsets + -- ** Indexed + take, + drop, + splitAt, + -- ** Predicates + takeWhile, + takeWhileWithKey, + dropWhile, + dropWhileWithKey, + span, + spanWithKey, + break, + breakWithKey, + -- *** Filter + filter, + filterWithKey, + partition, + partitionWithKey, + mapMaybe, + mapMaybeWithKey, + mapEither, + mapEitherWithKey, + -- * List operations + -- ** Conversion from lists + fromList, + fromAscList, + fromDescList, + -- ** Conversion to lists + keys, + elems, + assocs, + toAscList, + toDescList, + toList, + -- * Unordered operations + foldrU, + foldMapWithKeyU, + foldrWithKeyU, + foldlU, + foldlU', + foldlWithKeyU, + foldlWithKeyU', + traverseU, + traverseWithKeyU, + keysU, + elemsU, + assocsU, + toListU, + -- * Helper methods + seqSpine + ) + where +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 __GLASGOW_HASKELL__ -import Data.Data (Data, Typeable) -# endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup(..), stimesMonoid) +#endif -import Data.PQueue.Prio.Internals (MinPQueue) +import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) +import qualified Data.Foldable as F -newtype Down a = Down { unDown :: a } -# if __GLASGOW_HASKELL__ - deriving (Eq, Data, Typeable) -# else - deriving (Eq) -# endif +import qualified Data.PQueue.Prio.Min as Q +#ifdef __GLASGOW_HASKELL__ +import Data.Data (Data) +import Text.Read (Lexeme(Ident), lexP, parens, prec, + readPrec, readListPrec, readListPrecDefault) +#endif + + +#ifndef __GLASGOW_HASKELL__ +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build f = f (:) [] +#endif + -- | A priority queue where values of type @a@ are annotated with keys of type @k@. -- The queue supports extracting the element with maximum key. newtype MaxPQueue k a = MaxPQ (MinPQueue (Down k) a) # if __GLASGOW_HASKELL__ - deriving (Eq, Ord, Data, Typeable) + deriving (Eq, Ord, Data) # else deriving (Eq, Ord) # endif @@ -29,19 +142,430 @@ instance (NFData k, NFData a) => NFData (MaxPQueue k a) where rnf (MaxPQ q) = rnf q -instance NFData a => NFData (Down a) where - rnf (Down a) = rnf a +first' :: (a -> b) -> (a, c) -> (b, c) +first' f (a, c) = (f a, c) -instance Ord a => Ord (Down a) where - Down a `compare` Down b = b `compare` a - Down a <= Down b = b <= a +#if MIN_VERSION_base(4,9,0) +instance Ord k => Semigroup (MaxPQueue k a) where + (<>) = union + stimes = stimesMonoid +#endif -instance Functor Down where - fmap f (Down a) = Down (f a) +instance Ord k => Monoid (MaxPQueue k a) where + mempty = empty +#if !MIN_VERSION_base(4,11,0) + mappend = union +#endif + mconcat = unions -instance Foldable Down where - foldr f z (Down a) = a `f` z - foldl f z (Down a) = z `f` a +instance (Ord k, Show k, Show a) => Show (MaxPQueue k a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromDescList " . shows (toDescList xs) -instance Traversable Down where - traverse f (Down a) = Down <$> f a +instance (Read k, Read a) => Read (MaxPQueue k a) where +#ifdef __GLASGOW_HASKELL__ + readPrec = parens $ prec 10 $ do + Ident "fromDescList" <- lexP + xs <- readPrec + return (fromDescList xs) + + readListPrec = readListPrecDefault +#else + readsPrec p = readParen (p > 10) $ \r -> do + ("fromDescList",s) <- lex r + (xs,t) <- reads s + return (fromDescList xs,t) +#endif + +instance Functor (MaxPQueue k) where + fmap f (MaxPQ q) = MaxPQ (fmap f q) + +instance Ord k => Foldable (MaxPQueue k) where + foldr f z (MaxPQ q) = foldr f z q + foldl f z (MaxPQ q) = foldl f z q + + length = size + null = null + +-- | Traverses in descending order. 'mapM' is strictly accumulating like +-- 'mapMWithKey'. +instance Ord k => Traversable (MaxPQueue k) where + traverse f (MaxPQ q) = MaxPQ <$> traverse f q + mapM = mapMWithKey . const + sequence = mapM id + +-- | \(O(1)\). Returns the empty priority queue. +empty :: MaxPQueue k a +empty = MaxPQ Q.empty + +-- | \(O(1)\). Constructs a singleton priority queue. +singleton :: k -> a -> MaxPQueue k a +singleton k a = MaxPQ (Q.singleton (Down k) a) + +-- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts +-- an element with the specified key into the queue. +insert :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a +insert k a (MaxPQ q) = MaxPQ (Q.insert (Down k) a q) + +-- | \(O(n)\) (an earlier implementation had \(O(1)\) but was buggy). +-- Insert an element with the specified key into the priority queue, +-- putting it behind elements whose key compares equal to the +-- inserted one. +insertBehind :: Ord k => k -> a -> MaxPQueue k a -> MaxPQueue k a +insertBehind k a (MaxPQ q) = MaxPQ (Q.insertBehind (Down k) a q) + +-- | Amortized \(O(\log \min(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) + +-- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). +unions :: Ord k => [MaxPQueue k a] -> MaxPQueue k a +unions qs = MaxPQ (Q.unions [q | MaxPQ q <- qs]) + +-- | \(O(1)\). Checks if this priority queue is empty. +null :: MaxPQueue k a -> Bool +null (MaxPQ q) = Q.null q + +-- | \(O(1)\). Returns the size of this priority queue. +size :: MaxPQueue k a -> Int +size (MaxPQ q) = Q.size q + +-- | \(O(1)\). The maximal (key, element) in the queue. Calls 'error' if empty. +findMax :: MaxPQueue k a -> (k, a) +findMax = fromMaybe (error "Error: findMax called on an empty queue") . getMax + +-- | \(O(1)\). The maximal (key, element) in the queue, if the queue is nonempty. +getMax :: MaxPQueue k a -> Maybe (k, a) +getMax (MaxPQ q) = do + (Down k, a) <- Q.getMin q + return (k, a) + +-- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. +deleteMax :: Ord k => MaxPQueue k a -> MaxPQueue k a +deleteMax (MaxPQ q) = MaxPQ (Q.deleteMin q) + +-- | \(O(\log n)\). Delete and find the element with the maximum key. Calls 'error' if empty. +deleteFindMax :: Ord k => MaxPQueue k a -> ((k, a), MaxPQueue k a) +deleteFindMax = fromMaybe (error "Error: deleteFindMax called on an empty queue") . maxViewWithKey + +-- | \(O(1)\). Alter the value at the maximum key. If the queue is empty, does nothing. +adjustMax :: (a -> a) -> MaxPQueue k a -> MaxPQueue k a +adjustMax = adjustMaxWithKey . const + +-- | \(O(1)\) per operation. Alter the value at the maximum key in an +-- 'Applicative' context. If the queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMaxA :: Applicative f => (a -> f a) -> MaxPQueue k a -> f (MaxPQueue k a) +adjustMaxA = adjustMaxWithKeyA . const + +-- | \(O(1)\). Alter the value at the maximum key. If the queue is empty, does nothing. +adjustMaxWithKey :: (k -> a -> a) -> MaxPQueue k a -> MaxPQueue k a +adjustMaxWithKey f (MaxPQ q) = MaxPQ (Q.adjustMinWithKey (f . unDown) q) + +-- | \(O(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 + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. +-- If the queue is empty, does nothing. +updateMax :: Ord k => (a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a +updateMax = updateMaxWithKey . const + +-- | \(O(\log n)\) 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 +-- empty, does nothing. +-- +-- @since 1.4.2 +updateMaxA :: (Applicative f, Ord k) => (a -> f (Maybe a)) -> MaxPQueue k a -> f (MaxPQueue k a) +updateMaxA = updateMaxWithKeyA . const + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the maximum key. +-- If the queue is empty, does nothing. +updateMaxWithKey :: Ord k => (k -> a -> Maybe a) -> MaxPQueue k a -> MaxPQueue k a +updateMaxWithKey f (MaxPQ q) = MaxPQ (Q.updateMinWithKey (f . unDown) q) + +-- | \(O(\log n)\) 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 +-- empty, does nothing. +-- +-- @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 + +-- | \(O(\log n)\). Retrieves the value associated with the maximum key of the queue, and the queue +-- stripped of that element, or 'Nothing' if passed an empty queue. +maxView :: Ord k => MaxPQueue k a -> Maybe (a, MaxPQueue k a) +maxView q = do + ((_, a), q') <- maxViewWithKey q + return (a, q') + +-- | \(O(\log n)\). Retrieves the maximal (key, value) pair of the map, and the map stripped of that +-- element, or 'Nothing' if passed an empty map. +maxViewWithKey :: Ord k => MaxPQueue k a -> Maybe ((k, a), MaxPQueue k a) +maxViewWithKey (MaxPQ q) = do + ((Down k, a), q') <- Q.minViewWithKey q + return ((k, a), MaxPQ q') + +-- | \(O(n)\). Map a function over all values in the queue. +map :: (a -> b) -> MaxPQueue k a -> MaxPQueue k b +map = mapWithKey . const + +-- | \(O(n)\). Map a function over all values in the queue. +mapWithKey :: (k -> a -> b) -> MaxPQueue k a -> MaxPQueue k b +mapWithKey f (MaxPQ q) = MaxPQ (Q.mapWithKey (f . unDown) q) + +-- | \(O(n)\). Map a function over all values in the queue. +mapKeys :: Ord k' => (k -> k') -> MaxPQueue k a -> MaxPQueue k' a +mapKeys f (MaxPQ q) = MaxPQ (Q.mapKeys (fmap f) q) + +-- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly +-- monotonic. /The precondition is not checked./ This function has better performance than +-- 'mapKeys'. +mapKeysMonotonic :: (k -> k') -> MaxPQueue k a -> MaxPQueue k' a +mapKeysMonotonic f (MaxPQ q) = MaxPQ (Q.mapKeysMonotonic (fmap f) q) + +-- | \(O(n \log n)\). Fold the keys and values in the map, such that +-- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toDescList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldrWithKeyU'. +foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MaxPQueue k a -> b +foldrWithKey f z (MaxPQ q) = Q.foldrWithKey (f . unDown) z q + +-- | \(O(n \log n)\). Fold the keys and values in the map, such that +-- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toDescList' q)@. +-- +-- If you do not care about the traversal order, consider using 'foldlWithKeyU'. +foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MaxPQueue k a -> b +foldlWithKey f z0 (MaxPQ q) = Q.foldlWithKey (\z -> f z . unDown) z0 q + +-- | \(O(n \log n)\). Traverses the elements of the queue in descending order by key. +-- (@'traverseWithKey' f q == 'fromDescList' <$> 'traverse' ('uncurry' f) ('toDescList' q)@) +-- +-- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. +-- +-- 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 + +-- | 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) + +-- | \(O(k \log n)\)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. +-- (@'take' k q == 'List.take' k ('toDescList' q)@) +take :: Ord k => Int -> MaxPQueue k a -> [(k, a)] +take k (MaxPQ q) = fmap (first' unDown) (Q.take k q) + +-- | \(O(k \log n)\)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. +drop :: Ord k => Int -> MaxPQueue k a -> MaxPQueue k a +drop k (MaxPQ q) = MaxPQ (Q.drop k q) + +-- | \(O(k \log n)\)/. Equivalent to @('take' k q, 'drop' k q)@. +splitAt :: Ord k => Int -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +splitAt k (MaxPQ q) = case Q.splitAt k q of + (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') + +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toDescList' q)@) +takeWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> [(k, a)] +takeWhile = takeWhileWithKey . const + +-- | Takes the longest possible prefix of elements satisfying the predicate. +-- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toDescList' q)@) +takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> [(k, a)] +takeWhileWithKey p (MaxPQ q) = fmap (first' unDown) (Q.takeWhileWithKey (p . unDown) q) + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhile :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +dropWhile = dropWhileWithKey . const + +-- | Removes the longest possible prefix of elements satisfying the predicate. +dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +dropWhileWithKey p (MaxPQ q) = MaxPQ (Q.dropWhileWithKey (p . unDown) q) + +-- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. +span :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +span = spanWithKey . const + +-- | Equivalent to @'span' ('not' . p)@. +break :: Ord k => (a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +break = breakWithKey . const + +-- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. +spanWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +spanWithKey p (MaxPQ q) = case Q.spanWithKey (p . unDown) q of + (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') + +-- | Equivalent to @'spanWithKey' (\k a -> 'not' (p k a)) q@. +breakWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> ([(k, a)], MaxPQueue k a) +breakWithKey p (MaxPQ q) = case Q.breakWithKey (p . unDown) q of + (xs, q') -> (fmap (first' unDown) xs, MaxPQ q') + +-- | \(O(n)\). Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +filter = filterWithKey . const + +-- | \(O(n)\). Filter all values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> MaxPQueue k a +filterWithKey p (MaxPQ q) = MaxPQ (Q.filterWithKey (p . unDown) q) + +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partition :: Ord k => (a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) +partition = partitionWithKey . const + +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements +-- which satisfy the predicate, the second all elements that fail the predicate. +partitionWithKey :: Ord k => (k -> a -> Bool) -> MaxPQueue k a -> (MaxPQueue k a, MaxPQueue k a) +partitionWithKey p (MaxPQ q) = case Q.partitionWithKey (p . unDown) q of + (q1, q0) -> (MaxPQ q1, MaxPQ q0) + +-- | \(O(n)\). Map values and collect the 'Just' results. +mapMaybe :: Ord k => (a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b +mapMaybe = mapMaybeWithKey . const + +-- | \(O(n)\). Map values and collect the 'Just' results. +mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MaxPQueue k a -> MaxPQueue k b +mapMaybeWithKey f (MaxPQ q) = MaxPQ (Q.mapMaybeWithKey (f . unDown) q) + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +mapEither :: Ord k => (a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) +mapEither = mapEitherWithKey . const + +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. +mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MaxPQueue k a -> (MaxPQueue k b, MaxPQueue k c) +mapEitherWithKey f (MaxPQ q) = case Q.mapEitherWithKey (f . unDown) q of + (qL, qR) -> (MaxPQ qL, MaxPQ qR) + +-- | \(O(n)\). Build a priority queue from the list of (key, value) pairs. +fromList :: Ord k => [(k, a)] -> MaxPQueue k a +fromList = MaxPQ . Q.fromList . fmap (first' Down) + +-- | \(O(n)\). Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ +fromAscList :: [(k, a)] -> MaxPQueue k a +fromAscList = MaxPQ . Q.fromDescList . fmap (first' Down) + +-- | \(O(n)\). Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ +fromDescList :: [(k, a)] -> MaxPQueue k a +fromDescList = MaxPQ . Q.fromAscList . fmap (first' Down) + +-- | \(O(n \log n)\). Return all keys of the queue in descending order. +keys :: Ord k => MaxPQueue k a -> [k] +keys = fmap fst . toDescList + +-- | \(O(n \log n)\). Return all elements of the queue in descending order by key. +elems :: Ord k => MaxPQueue k a -> [a] +elems = fmap snd . toDescList + +-- | \(O(n \log n)\). Equivalent to 'toDescList'. +assocs :: Ord k => MaxPQueue k a -> [(k, a)] +assocs = toDescList + +-- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. +toAscList :: Ord k => MaxPQueue k a -> [(k, a)] +toAscList (MaxPQ q) = fmap (first' unDown) (Q.toDescList q) + +-- | \(O(n \log n)\). Return all (key, value) pairs in descending order by key. +toDescList :: Ord k => MaxPQueue k a -> [(k, a)] +toDescList (MaxPQ q) = fmap (first' unDown) (Q.toAscList q) + +-- | \(O(n \log n)\). Equivalent to 'toDescList'. +-- +-- If the traversal order is irrelevant, consider using 'toListU'. +toList :: Ord k => MaxPQueue k a -> [(k, a)] +toList = toDescList + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrU :: (a -> b -> b) -> b -> MaxPQueue k a -> b +foldrU = foldrWithKeyU . const + +-- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. +foldrWithKeyU :: (k -> a -> b -> b) -> b -> MaxPQueue k a -> b +foldrWithKeyU f z (MaxPQ q) = Q.foldrWithKeyU (f . unDown) z q + +-- | \(O(n)\). An unordered 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 + +-- | \(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 +-- more likely to perform well. +foldlU :: (b -> a -> b) -> b -> MaxPQueue k a -> b +foldlU f = foldlWithKeyU (const . f) + +-- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no +-- particular order. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MaxPQueue k a -> b +foldlU' f = foldlWithKeyU' (const . f) + +-- | \(O(n)\). An unordered left fold over the elements of the queue, in no +-- particular order. 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 + +-- | \(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 + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseU :: (Applicative f) => (a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseU = traverseWithKeyU . const + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. +-- While there is no guarantee in which order the elements are traversed, the resulting +-- priority queue will be perfectly valid. +traverseWithKeyU :: (Applicative f) => (k -> a -> f b) -> MaxPQueue k a -> f (MaxPQueue k b) +traverseWithKeyU f (MaxPQ q) = MaxPQ <$> Q.traverseWithKeyU (f . unDown) q + +-- | \(O(n)\). Return all keys of the queue in no particular order. +keysU :: MaxPQueue k a -> [k] +keysU = fmap fst . toListU + +-- | \(O(n)\). Return all elements of the queue in no particular order. +elemsU :: MaxPQueue k a -> [a] +elemsU = fmap snd . toListU + +-- | \(O(n)\). Equivalent to 'toListU'. +assocsU :: MaxPQueue k a -> [(k, a)] +assocsU = toListU + +-- | \(O(n)\). Returns all (key, value) pairs in the queue in no particular order. +toListU :: MaxPQueue k a -> [(k, a)] +toListU (MaxPQ q) = fmap (first' unDown) (Q.toListU q) + +-- | \(O(\log n)\). @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. +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,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -15,11 +14,9 @@ -- viewing and extracting the element with the minimum key. -- -- A worst-case bound is given for each operation. In some cases, an amortized --- bound is also specified; these bounds do not hold in a persistent context. +-- bound is also specified; these bounds hold even in a persistent context. -- -- This implementation is based on a binomial heap augmented with a global root. --- The spine of the heap is maintained lazily. To force the spine of the heap, --- use 'seqSpine'. -- -- We do not guarantee stable behavior. -- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there @@ -49,9 +46,13 @@ deleteMin, deleteFindMin, adjustMin, + adjustMinA, adjustMinWithKey, + adjustMinWithKeyA, updateMin, + updateMinA, updateMinWithKey, + updateMinWithKeyA, minView, minViewWithKey, -- * Traversal @@ -65,6 +66,7 @@ foldlWithKey, -- ** Traverse traverseWithKey, + mapMWithKey, -- * Subsets -- ** Indexed take, @@ -102,9 +104,12 @@ toList, -- * Unordered operations foldrU, + foldMapWithKeyU, foldrWithKeyU, foldlU, + foldlU', foldlWithKeyU, + foldlWithKeyU', traverseU, traverseWithKeyU, keysU, @@ -129,8 +134,6 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) -import Text.Read (Lexeme(Ident), lexP, parens, prec, - readPrec, readListPrec, readListPrecDefault) #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] @@ -144,118 +147,104 @@ infixr 8 .: -#if MIN_VERSION_base(4,9,0) -instance Ord k => Semigroup (MinPQueue k a) where - (<>) = union -#endif - -instance Ord k => Monoid (MinPQueue k a) where - mempty = empty - mappend = union - mconcat = unions - -instance (Ord k, Show k, Show a) => Show (MinPQueue k a) where - showsPrec p xs = showParen (p > 10) $ - showString "fromAscList " . shows (toAscList xs) - -instance (Read k, Read a) => Read (MinPQueue k a) where -#ifdef __GLASGOW_HASKELL__ - readPrec = parens $ prec 10 $ do - Ident "fromAscList" <- lexP - xs <- readPrec - return (fromAscList xs) - - readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \r -> do - ("fromAscList",s) <- lex r - (xs,t) <- reads s - return (fromAscList xs,t) -#endif - - --- | The union of a list of queues: (@'unions' == 'List.foldl' 'union' 'empty'@). -unions :: Ord k => [MinPQueue k a] -> MinPQueue k a -unions = List.foldl union empty - --- | /O(1)/. The minimal (key, element) in the queue. Calls 'error' if empty. +-- | \(O(1)\). The minimal (key, element) in the queue. Calls 'error' if empty. findMin :: MinPQueue k a -> (k, a) findMin = fromMaybe (error "Error: findMin called on an empty queue") . getMin --- | /O(log n)/. Deletes the minimal (key, element) in the queue. Returns an empty queue +-- | \(O(\log n)\). Deletes the minimal (key, element) in the queue. Returns an empty queue -- if the queue is empty. deleteMin :: Ord k => MinPQueue k a -> MinPQueue k a deleteMin = updateMin (const Nothing) --- | /O(log n)/. Delete and find the element with the minimum key. Calls 'error' if empty. +-- | \(O(\log n)\). Delete and find the element with the minimum key. Calls 'error' if empty. deleteFindMin :: Ord k => MinPQueue k a -> ((k, a), MinPQueue k a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on an empty queue") . minViewWithKey --- | /O(1)/. Alter the value at the minimum key. If the queue is empty, does nothing. +-- | \(O(1)\). Alter the value at the minimum key. If the queue is empty, does nothing. adjustMin :: (a -> a) -> MinPQueue k a -> MinPQueue k a adjustMin = adjustMinWithKey . const --- | /O(log n)/. (Actually /O(1)/ if there's no deletion.) Update the value at the minimum key. +-- | \(O(1)\). Alter the value at the minimum key in an 'Applicative' context. If +-- the queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMinA :: Applicative f => (a -> f a) -> MinPQueue k a -> f (MinPQueue k a) +adjustMinA = adjustMinWithKeyA . const + +-- | \(O(1)\) per operation. Alter the value at the minimum key in an 'Applicative' context. If the +-- queue is empty, does nothing. +-- +-- @since 1.4.2 +adjustMinWithKeyA :: Applicative f => (k -> a -> f a) -> MinPQueue k a -> f (MinPQueue k a) +adjustMinWithKeyA = adjustMinWithKeyA' id + +-- | \(O(\log n)\). (Actually \(O(1)\) if there's no deletion.) Update the value at the minimum key. -- If the queue is empty, does nothing. updateMin :: Ord k => (a -> Maybe a) -> MinPQueue k a -> MinPQueue k a updateMin = updateMinWithKey . const --- | /O(log n)/. Retrieves the value associated with the minimal key of the queue, and the queue +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the minimum key. If the queue is empty, does nothing. +-- +-- @since 1.4.2 +updateMinA :: (Applicative f, Ord k) => (a -> f (Maybe a)) -> MinPQueue k a -> f (MinPQueue k a) +updateMinA = updateMinWithKeyA . const + +-- | \(O(\log n)\) per operation. (Actually \(O(1)\) if there's no deletion.) Update +-- the value at the minimum key in an 'Applicative' context. If the queue is +-- empty, does nothing. +-- +-- @since 1.4.2 +updateMinWithKeyA :: (Applicative f, Ord k) => (k -> a -> f (Maybe a)) -> MinPQueue k a -> f (MinPQueue k a) +updateMinWithKeyA = updateMinWithKeyA' id + +-- | \(O(\log n)\). Retrieves the value associated with the minimal key of the queue, and the queue -- stripped of that element, or 'Nothing' if passed an empty queue. minView :: Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a) minView q = do ((_, a), q') <- minViewWithKey q return (a, q') --- | /O(n)/. Map a function over all values in the queue. +-- | \(O(n)\). Map a function over all values in the queue. map :: (a -> b) -> MinPQueue k a -> MinPQueue k b map = mapWithKey . const --- | /O(n)/. @'mapKeys' f q@ is the queue obtained by applying @f@ to each key of @q@. +-- | \(O(n)\). @'mapKeys' f q@ is the queue obtained by applying @f@ to each key of @q@. mapKeys :: Ord k' => (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeys f q = fromList [(f k, a) | (k, a) <- toListU q] --- | /O(n log n)/. Traverses the elements of the queue in ascending order by key. --- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) --- --- If you do not care about the /order/ of the traversal, consider using 'traverseWithKeyU'. -traverseWithKey :: (Ord k, Applicative f) => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) -traverseWithKey f q = case minViewWithKey q of - Nothing -> pure empty - Just ((k, a), q') -> insertMin k <$> f k a <*> traverseWithKey f q' - --- | /O(n)/. Map values and collect the 'Just' results. +-- | \(O(n)\). Map values and collect the 'Just' results. mapMaybe :: Ord k => (a -> Maybe b) -> MinPQueue k a -> MinPQueue k b mapMaybe = mapMaybeWithKey . const --- | /O(n)/. Map values and separate the 'Left' and 'Right' results. +-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEither :: Ord k => (a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) mapEither = mapEitherWithKey . const --- | /O(n)/. Filter all values that satisfy the predicate. +-- | \(O(n)\). Filter all values that satisfy the predicate. filter :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a filter = filterWithKey . const --- | /O(n)/. Filter all values that satisfy the predicate. +-- | \(O(n)\). Filter all values that satisfy the predicate. filterWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a filterWithKey p = mapMaybeWithKey (\k a -> if p k a then Just a else Nothing) --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partition :: Ord k => (a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) partition = partitionWithKey . const --- | /O(n)/. Partition the queue according to a predicate. The first queue contains all elements +-- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partitionWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) partitionWithKey p = mapEitherWithKey (\k a -> if p k a then Left a else Right a) {-# INLINE take #-} --- | /O(k log n)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. +-- | \(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 @@ -266,7 +255,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) @@ -317,100 +306,63 @@ breakWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) breakWithKey p = spanWithKey (not .: p) --- | /O(n)/. Build a priority queue from the list of (key, value) pairs. -fromList :: Ord k => [(k, a)] -> MinPQueue k a -fromList = foldr (uncurry' insert) empty - --- | /O(n)/. Build a priority queue from an ascending list of (key, value) pairs. /The precondition is not checked./ -fromAscList :: [(k, a)] -> MinPQueue k a -fromAscList = foldr (uncurry' insertMin) empty - --- | /O(n)/. Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ +-- | \(O(n)\). Build a priority queue from a descending list of (key, value) pairs. /The precondition is not checked./ fromDescList :: [(k, a)] -> MinPQueue k a -fromDescList = List.foldl' (\q (k, a) -> insertMin k a q) empty - -{-# RULES - "fromList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . - fromList (build g) = g (uncurry' insert) empty; - "fromAscList/build" forall (g :: forall b . ((k, a) -> b -> b) -> b -> b) . - fromAscList (build g) = g (uncurry' insertMin) empty; - #-} +{-# INLINE fromDescList #-} +fromDescList xs = List.foldl' (\q (k, a) -> insertMin' k a q) empty xs {-# INLINE keys #-} --- | /O(n log n)/. Return all keys of the queue in ascending order. +-- | \(O(n \log n)\). Return all keys of the queue in ascending order. keys :: Ord k => MinPQueue k a -> [k] keys = List.map fst . toAscList {-# INLINE elems #-} --- | /O(n log n)/. Return all elements of the queue in ascending order by key. +-- | \(O(n \log n)\). Return all elements of the queue in ascending order by key. elems :: Ord k => MinPQueue k a -> [a] elems = List.map snd . toAscList --- | /O(n log n)/. Return all (key, value) pairs in ascending order by key. -toAscList :: Ord k => MinPQueue k a -> [(k, a)] -toAscList = foldrWithKey (curry (:)) [] - --- | /O(n log n)/. Return all (key, value) pairs in descending order by key. -toDescList :: Ord k => MinPQueue k a -> [(k, a)] -toDescList = foldlWithKey (\z k a -> (k, a) : z) [] - -{-# RULES - "toAscList" toAscList = \q -> build (\c n -> foldrWithKey (curry c) n q); - "toDescList" toDescList = \q -> build (\c n -> foldlWithKey (\z k a -> (k, a) `c` z) n q); - "toListU" toListU = \q -> build (\c n -> foldrWithKeyU (curry c) n q); - #-} - {-# INLINE toList #-} --- | /O(n log n)/. Equivalent to 'toAscList'. +-- | \(O(n \log n)\). Equivalent to 'toAscList'. -- -- If the traversal order is irrelevant, consider using 'toListU'. toList :: Ord k => MinPQueue k a -> [(k, a)] toList = toAscList {-# INLINE assocs #-} --- | /O(n log n)/. Equivalent to 'toAscList'. +-- | \(O(n \log n)\). Equivalent to 'toAscList'. assocs :: Ord k => MinPQueue k a -> [(k, a)] assocs = toAscList {-# INLINE keysU #-} --- | /O(n)/. Return all keys of the queue in no particular order. +-- | \(O(n)\). Return all keys of the queue in no particular order. keysU :: MinPQueue k a -> [k] keysU = List.map fst . toListU {-# INLINE elemsU #-} --- | /O(n)/. Return all elements of the queue in no particular order. +-- | \(O(n)\). Return all elements of the queue in no particular order. elemsU :: MinPQueue k a -> [a] elemsU = List.map snd . toListU {-# INLINE assocsU #-} --- | /O(n)/. Equivalent to 'toListU'. +-- | \(O(n)\). Equivalent to 'toListU'. assocsU :: MinPQueue k a -> [(k, a)] assocsU = toListU --- | /O(n)/. Returns all (key, value) pairs in the queue in no particular order. -toListU :: MinPQueue k a -> [(k, a)] -toListU = foldrWithKeyU (curry (:)) [] - --- | /O(n)/. An unordered right fold over the elements of the queue, in no particular order. -foldrU :: (a -> b -> b) -> b -> MinPQueue k a -> b -foldrU = foldrWithKeyU . const - --- | /O(n)/. An unordered left fold over the elements of the queue, in no particular order. +-- | \(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 +-- more likely to perform well. foldlU :: (b -> a -> b) -> b -> MinPQueue k a -> b foldlU f = foldlWithKeyU (const . f) --- | /O(n)/. An unordered traversal over a priority queue, in no particular order. +-- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no +-- particular order. +-- +-- @since 1.4.2 +foldlU' :: (b -> a -> b) -> b -> MinPQueue k a -> b +foldlU' f = foldlWithKeyU' (const . f) + +-- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. -- While there is no guarantee in which order the elements are traversed, the resulting -- priority queue will be perfectly valid. traverseU :: (Applicative f) => (a -> f b) -> MinPQueue k a -> f (MinPQueue k b) traverseU = traverseWithKeyU . const - -instance Functor (MinPQueue k) where - fmap = map - -instance Ord k => Foldable (MinPQueue k) where - foldr = foldrWithKey . const - foldl f = foldlWithKey (const . f) - -instance Ord k => Traversable (MinPQueue k) where - traverse = traverseWithKey . const diff --git a/tests/PQueueTests.hs b/tests/PQueueTests.hs --- a/tests/PQueueTests.hs +++ b/tests/PQueueTests.hs @@ -1,145 +1,193 @@ -module Main (main) where - -import qualified Data.PQueue.Prio.Max as PMax () -import qualified Data.PQueue.Prio.Min as PMin () -import qualified Data.PQueue.Max as Max () -import qualified Data.PQueue.Min as Min - -import Test.QuickCheck +{-# language ExtendedDefaultRules #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} -import System.Exit +module Main (main) where +import Data.Bifunctor (bimap, first, second) +import Data.Function (on) +import Data.Functor.Identity import qualified Data.List as List -import Control.Arrow (second) - - -validMinToAscList :: [Int] -> Bool -validMinToAscList xs = Min.toAscList (Min.fromList xs) == List.sort xs - -validMinToDescList :: [Int] -> Bool -validMinToDescList xs = Min.toDescList (Min.fromList xs) == List.sortBy (flip compare) xs - -validMinUnfoldr :: [Int] -> Bool -validMinUnfoldr xs = List.unfoldr Min.minView (Min.fromList xs) == List.sort xs - -validMinToList :: [Int] -> Bool -validMinToList xs = List.sort (Min.toList (Min.fromList xs)) == List.sort xs - -validMinFromAscList :: [Int] -> Bool -validMinFromAscList xs = Min.fromAscList (List.sort xs) == Min.fromList xs - -validMinFromDescList :: [Int] -> Bool -validMinFromDescList xs = Min.fromDescList (List.sortBy (flip compare) xs) == Min.fromList xs - -validMinUnion :: [Int] -> [Int] -> Bool -validMinUnion xs1 xs2 = Min.union (Min.fromList xs1) (Min.fromList xs2) == Min.fromList (xs1 ++ xs2) - -validMinMapMonotonic :: [Int] -> Bool -validMinMapMonotonic xs = Min.mapU (+1) (Min.fromList xs) == Min.fromList (map (+1) xs) - -validMinFilter :: [Int] -> Bool -validMinFilter xs = Min.filter even (Min.fromList xs) == Min.fromList (List.filter even xs) - -validMinPartition :: [Int] -> Bool -validMinPartition xs = Min.partition even (Min.fromList xs) == (let (xs1, xs2) = List.partition even xs in (Min.fromList xs1, Min.fromList xs2)) - -validMinCmp :: [Int] -> [Int] -> Bool -validMinCmp xs1 xs2 = compare (Min.fromList xs1) (Min.fromList xs2) == compare (List.sort xs1) (List.sort xs2) - -validMinCmp2 :: [Int] -> Bool -validMinCmp2 xs = compare (Min.fromList ys) (Min.fromList (take 30 ys)) == compare ys (take 30 ys) - where ys = List.sort xs - -validSpan :: [Int] -> Bool -validSpan xs = (Min.takeWhile even q, Min.dropWhile even q) == Min.span even q - where q = Min.fromList xs - -validSpan2 :: [Int] -> Bool -validSpan2 xs = - second Min.toAscList (Min.span even (Min.fromList xs)) - == - List.span even (List.sort xs) - -validSplit :: Int -> [Int] -> Bool -validSplit n xs = Min.splitAt n q == (Min.take n q, Min.drop n q) - where q = Min.fromList xs - -validSplit2 :: Int -> [Int] -> Bool -validSplit2 n xs = case Min.splitAt n (Min.fromList xs) of - (ys, q') -> (ys, Min.toAscList q') == List.splitAt n (List.sort xs) - -validMapEither :: [Int] -> Bool -validMapEither xs = - Min.mapEither collatz q == - (Min.mapMaybe (either Just (const Nothing) . collatz) q, - Min.mapMaybe (either (const Nothing) Just . collatz) q) - where q = Min.fromList xs - -validMap :: [Int] -> Bool -validMap xs = Min.map f (Min.fromList xs) == Min.fromList (List.map f xs) - where f = either id id . collatz - -collatz :: Int -> Either Int Int -collatz x = - if even x - then Left $ x `quot` 2 - else Right $ 3 * x + 1 - -validSize :: [Int] -> Bool -validSize xs = Min.size q == List.length xs' - where - q = Min.drop 10 (Min.fromList xs) - xs' = List.drop 10 (List.sort xs) - -validNull :: Int -> [Int] -> Bool -validNull n xs = Min.null q == List.null xs' - where - q = Min.drop n (Min.fromList xs) - xs' = List.drop n (List.sort xs) +import Data.Ord (Down(..)) -validFoldl :: [Int] -> Bool -validFoldl xs = Min.foldlAsc (flip (:)) [] (Min.fromList xs) == List.foldl (flip (:)) [] (List.sort xs) +import Test.Tasty +import Test.Tasty.QuickCheck -validFoldlU :: [Int] -> Bool -validFoldlU xs = Min.foldlU (flip (:)) [] q == List.reverse (Min.foldrU (:) [] q) - where q = Min.fromList xs +import qualified Data.PQueue.Max as Max +import qualified Data.PQueue.Min as Min +import qualified Data.PQueue.Prio.Max as PMax +import qualified Data.PQueue.Prio.Min as PMin -validFoldrU :: [Int] -> Bool -validFoldrU xs = Min.foldrU (+) 0 q == List.sum xs - where q = Min.fromList xs +default (Int) main :: IO () -main = do - check validMinToAscList - check validMinToDescList - check validMinUnfoldr - check validMinToList - check validMinFromAscList - check validMinFromDescList - check validMinUnion - check validMinMapMonotonic - check validMinPartition - check validMinCmp - check validMinCmp2 - check validSpan - check validSpan2 - check validSplit - check validSplit2 - check validMinFilter - check validMapEither - check validMap - check validSize - check validNull - check validFoldl - check validFoldlU - check validFoldrU - putStrLn "all tests passed" - -isPass :: Result -> Bool -isPass Success{} = True -isPass _ = False - -check :: Testable prop => prop -> IO () -check p = do - r <- quickCheckResult p - if isPass r then return () else exitFailure +main = defaultMain $ testGroup "pqueue" + [ testGroup "Data.PQueue.Min" + [ testProperty "size" $ \xs -> Min.size (Min.fromList xs) === length xs + , testGroup "getMin" + [ 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 "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 "map" $ \xs -> Min.map negate (Min.fromList xs) === Min.fromList (List.map negate 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)) + , testProperty "takeWhile" $ \(Fn f) xs -> Min.takeWhile f (Min.fromList xs) === List.takeWhile f (List.sort xs) + , testProperty "dropWhile" $ \(Fn f) xs -> Min.dropWhile f (Min.fromList xs) === Min.fromList (List.dropWhile f (List.sort xs)) + , testProperty "span" $ \(Fn f) xs -> Min.span f (Min.fromList xs) === second Min.fromList (List.span f (List.sort xs)) + , testProperty "foldrAsc" $ \xs -> Min.foldrAsc (:) [] (Min.fromList xs) === List.sort xs + , testProperty "foldlAsc" $ \xs -> Min.foldlAsc (flip (:)) [] (Min.fromList xs) === List.sortOn Down xs + , testProperty "foldrDesc" $ \xs -> Min.foldrDesc (:) [] (Min.fromList xs) === List.sortOn Down xs + , testProperty "foldlDesc" $ \xs -> Min.foldlDesc (flip (:)) [] (Min.fromList xs) === List.sort xs + , testProperty "toAscList" $ \xs -> Min.toAscList (Min.fromList xs) === List.sort xs + , 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 + , testProperty "toListU" $ \xs -> List.sort (Min.toListU (Min.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` Min.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` Min.fromList) xs ys === (compare `on` List.sort) xs ys + ] + , testGroup "Data.PQueue.Max" + [ testProperty "size" $ \xs -> Max.size (Max.fromList xs) === length xs + , testGroup "getMax" + [ testProperty "empty" $ Max.getMax Max.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> Max.getMax (Max.fromList xs) === Just (maximum xs) + ] + , testProperty "minView" $ \xs -> Max.maxView (Max.fromList xs) === fmap (second Max.fromList) (List.uncons (List.sortOn Down xs)) + , testProperty "insert" $ \x xs -> Max.insert x (Max.fromList xs) === Max.fromList (x : xs) + , testProperty "union" $ \xs ys -> Max.union (Max.fromList xs) (Max.fromList ys) === Max.fromList (xs ++ ys) + , 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 "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)) + , testProperty "takeWhile" $ \(Fn f) xs -> Max.takeWhile f (Max.fromList xs) === List.takeWhile f (List.sortOn Down xs) + , testProperty "dropWhile" $ \(Fn f) xs -> Max.dropWhile f (Max.fromList xs) === Max.fromList (List.dropWhile f (List.sortOn Down xs)) + , testProperty "span" $ \(Fn f) xs -> Max.span f (Max.fromList xs) === second Max.fromList (List.span f (List.sortOn Down xs)) + , testProperty "foldrAsc" $ \xs -> Max.foldrAsc (:) [] (Max.fromList xs) === List.sort xs + , testProperty "foldlAsc" $ \xs -> Max.foldlAsc (flip (:)) [] (Max.fromList xs) === List.sortOn Down xs + , testProperty "foldrDesc" $ \xs -> Max.foldrDesc (:) [] (Max.fromList xs) === List.sortOn Down xs + , testProperty "foldlDesc" $ \xs -> Max.foldlDesc (flip (:)) [] (Max.fromList xs) === List.sort xs + , testProperty "toAscList" $ \xs -> Max.toAscList (Max.fromList xs) === List.sort xs + , 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 + , testProperty "toListU" $ \xs -> List.sort (Max.toListU (Max.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` Max.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` Max.fromList) xs ys === (compare `on` (List.sort . List.map Down)) xs ys + ] + , testGroup "Data.PQueue.Prio.Min" + [ testProperty "size" $ \xs -> PMin.size (PMin.fromList xs) === length xs + , testGroup "getMin" + [ testProperty "empty" $ PMin.getMin PMin.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> fmap fst (PMin.getMin (PMin.fromList xs)) === Just (fst (minimum xs)) + ] + , testProperty "adjustMin" $ \xs -> PMin.adjustMin id (PMin.fromList xs) === PMin.fromList xs + , testProperty "adjustMinA" $ \xs -> PMin.adjustMinA Identity (PMin.fromList xs) === Identity (PMin.fromList xs) + , testGroup "updateMin" + [ testProperty "Just" $ \xs -> PMin.updateMin Just (PMin.fromList xs) === PMin.fromList xs + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMin.updateMin (const Nothing) (PMin.fromList xs) === PMin.fromList (tail (List.sort xs)) + ] + , testGroup "updateMinA" + [ 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 "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 "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)) + , testProperty "takeWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMin.takeWhileWithKey f (PMin.fromList xs) === List.takeWhile (uncurry f) (List.sort xs) + , testProperty "dropWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMin.dropWhileWithKey f (PMin.fromList xs) === PMin.fromList (List.dropWhile (uncurry f) (List.sort xs)) + , testProperty "span" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMin.spanWithKey f (PMin.fromList xs) === second PMin.fromList (List.span (uncurry f) (List.sort xs)) + , testProperty "foldrWithKey" $ \(xs :: [(Int, ())]) -> PMin.foldrWithKey (\k x acc -> (k, x) : acc) [] (PMin.fromList xs) === List.sort xs + , testProperty "foldlWithKey" $ \(xs :: [(Int, ())]) -> PMin.foldlWithKey (\acc k x -> (k, x) : acc) [] (PMin.fromList xs) === List.sortOn Down xs + , testProperty "traverseWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.traverseWithKey f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "mapMWithKey" $ + \(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 "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 + , testProperty "fromDescList" $ \(xs :: [(Int, ())]) -> PMin.fromDescList (List.sortOn Down xs) === PMin.fromList xs + , testProperty "foldrU" $ \xs -> PMin.foldrU (+) 0 (PMin.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU" $ \xs -> PMin.foldlU (+) 0 (PMin.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU'" $ \xs -> PMin.foldlU' (+) 0 (PMin.fromList xs) === sum (List.map snd xs) + , testProperty "traverseU" $ + \(Fn (f :: () -> Maybe ())) (xs :: [(Int, ())]) -> PMin.traverseU f (PMin.fromList xs) === fmap PMin.fromList (traverse (\(k, x) -> fmap (k,) (f x)) xs) + , testProperty "toListU" $ \xs -> List.sort (PMin.toListU (PMin.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` PMin.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` PMin.fromList) xs ys === (compare `on` List.sort) xs ys + ] + , testGroup "Data.PQueue.Prio.Max" + [ testProperty "size" $ \xs -> PMax.size (PMax.fromList xs) === length xs + , testGroup "getMax" + [ testProperty "empty" $ PMax.getMax PMax.empty === Nothing + , testProperty "non-empty" $ \(NonEmpty xs) -> fmap fst (PMax.getMax (PMax.fromList xs)) === Just (fst (maximum xs)) + ] + , testProperty "adjustMin" $ \xs -> PMax.adjustMax id (PMax.fromList xs) === PMax.fromList xs + , testProperty "adjustMinA" $ \xs -> PMax.adjustMaxA Identity (PMax.fromList xs) === Identity (PMax.fromList xs) + , testGroup "updateMin" + [ testProperty "Just" $ \xs -> PMax.updateMax Just (PMax.fromList xs) === PMax.fromList xs + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMax.updateMax (const Nothing) (PMax.fromList xs) === PMax.fromList (tail (List.sortOn Down xs)) + ] + , testGroup "updateMinA" + [ testProperty "Just" $ \xs -> PMax.updateMaxA (Identity . Just) (PMax.fromList xs) === Identity (PMax.fromList xs) + , testProperty "Nothing" $ \(NonEmpty (xs :: [(Int, ())])) -> PMax.updateMaxA (Identity . const Nothing) (PMax.fromList xs) === Identity (PMax.fromList (tail (List.sortOn Down xs))) + ] + , 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 "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)) + , testProperty "takeWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMax.takeWhileWithKey f (PMax.fromList xs) === List.takeWhile (uncurry f) (List.sortOn Down xs) + , testProperty "dropWhile" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMax.dropWhileWithKey f (PMax.fromList xs) === PMax.fromList (List.dropWhile (uncurry f) (List.sortOn Down xs)) + , testProperty "span" $ \(Fn2 f) (xs :: [(Int, ())]) -> PMax.spanWithKey f (PMax.fromList xs) === second PMax.fromList (List.span (uncurry f) (List.sortOn Down xs)) + , testProperty "foldrWithKey" $ \(xs :: [(Int, ())]) -> PMax.foldrWithKey (\k x acc -> (k, x) : acc) [] (PMax.fromList xs) === List.sortOn Down xs + , testProperty "foldlWithKey" $ \(xs :: [(Int, ())]) -> PMax.foldlWithKey (\acc k x -> (k, x) : acc) [] (PMax.fromList xs) === List.sort xs + , testProperty "traverseWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMax.traverseWithKey f (PMax.fromList xs) === fmap PMax.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "mapMWithKey" $ + \(Fn2 (f :: Int -> () -> Maybe ())) (xs :: [(Int, ())]) -> PMax.mapMWithKey f (PMax.fromList xs) === fmap PMax.fromList (traverse (\(k, x) -> fmap (k,) (f k x)) xs) + , testProperty "insert" $ \k xs -> PMax.insert k () (PMax.fromList xs) === PMax.fromList ((k, ()) : xs) + , testProperty "union" $ \(xs :: [(Int, ())]) ys -> PMax.union (PMax.fromList xs) (PMax.fromList ys) === PMax.fromList (xs ++ ys) + , testProperty "filter" $ + \(xs :: [(Int, ())]) -> PMax.filterWithKey (\k _ -> even k) (PMax.fromList xs) === PMax.fromList (List.filter (even . fst) xs) + , testProperty "partition" $ + \(xs :: [(Int, ())]) -> PMax.partitionWithKey (\k _ -> even k) (PMax.fromList xs) === bimap PMax.fromList PMax.fromList (List.partition (even . fst) xs) + , testProperty "toAscList" $ \(xs :: [(Int, ())]) -> PMax.toAscList (PMax.fromList xs) === List.sort xs + , testProperty "toDescList" $ \(xs :: [(Int, ())]) -> PMax.toDescList (PMax.fromList xs) === List.sortOn Down xs + , testProperty "fromAscList" $ \(xs :: [(Int, ())]) -> PMax.fromAscList (List.sort xs) === PMax.fromList xs + , testProperty "fromDescList" $ \(xs :: [(Int, ())]) -> PMax.fromDescList (List.sortOn Down xs) === PMax.fromList xs + , testProperty "foldrU" $ \xs -> PMax.foldrU (+) 0 (PMax.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU" $ \xs -> PMax.foldlU (+) 0 (PMax.fromList xs) === sum (List.map snd xs) + , testProperty "foldlU'" $ \xs -> PMax.foldlU' (+) 0 (PMax.fromList xs) === sum (List.map snd xs) + , testProperty "traverseU" $ + \(Fn (f :: () -> Maybe ())) (xs :: [(Int, ())]) -> PMax.traverseU f (PMax.fromList xs) === fmap PMax.fromList (traverse (\(k, x) -> fmap (k,) (f x)) xs) + , testProperty "toListU" $ \xs -> List.sort (PMax.toListU (PMax.fromList xs)) === List.sort xs + , testProperty "==" $ \(xs :: [(Int, ())]) ys -> ((==) `on` PMax.fromList) xs ys === ((==) `on` List.sort) xs ys + , testProperty "compare" $ \(xs :: [(Int, ())]) ys -> (compare `on` PMax.fromList) xs ys === (compare `on` (List.sort . List.map Down)) xs ys + ] + ]