pqueue-1.4.3.0/0000755000000000000000000000000007346545000011352 5ustar0000000000000000pqueue-1.4.3.0/CHANGELOG.md0000644000000000000000000000564207346545000013172 0ustar0000000000000000# Revision history for pqueue ## 1.4.3.0 -- 2022-10-30 * Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable). ([#85](https://github.com/lspitzner/pqueue/pull/85)) * Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86)) ## 1.4.2.0 -- 2022-06-19 * Overall performance has improved greatly, especially when there are many insertions and/or merges in a row. Insertion, deletion, and merge are now *worst case* logarithmic, while maintaining their previous amortized 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 * Change nix-setup to use the seaaye tool ## 1.4.1.3 -- 2020-06-06 * Maintenance release * Add missing documentation * Add nix-expressions for testing against different compilers/package sets ## 1.4.1.2 -- 2018-09-26 * Maintenance release for ghc-8.6 * Drop support for ghc<7.10 ## 1.4.1.1 -- 2018-02-11 * Remove/replace buggy `insertBehind` implementation. The existing implementation did not always insert behind. As a fix, the function was removed from Data.PQueue.Max/Min and was rewritten with a O(n) complexity (!) for Data.PQueue.Prio.Max/Min. * Adapt for ghc-8.4, based on the ghc-8.4.1-alpha1 release * Drop support for ghc<7.4 ## 1.3.2.3 -- 2017-08-01 * Maintenance release for ghc-8.2 ## 1.3.2.2 -- 2017-03-12 * Add test-suite from darcs repository for pqueue-1.0.1. ## 1.3.2.1 -- 2017-03-11 * Fix documentation errors - complexity on `toList`, `toListU` - `PQueue.Prio.Max` had "ascending" instead of "descending" in some places ## 1.3.2 -- 2016-09-28 * Add function `insertBehind` as a slight variation of `insert` which differs in behaviour for elements the compare equal. ## 1.3.1.1 -- 2016-05-21 * Ensure compatibility with ghc-8 * Minor internal refactors ## 1.3.1 -- 2015-10-03 * Add `Monoid` instance for `MaxPQueue` ## 1.3.0 -- 2015-06-23 * Lennart Spitzner starts co-maintaining * new git repository at github.com:lspitzner/pqueue * Ensure compatibility with ghc-7.10 pqueue-1.4.3.0/LICENSE0000644000000000000000000000005307346545000012355 0ustar0000000000000000Copyright Louis Wasserman 2010 BSD license pqueue-1.4.3.0/README.md0000644000000000000000000000026107346545000012630 0ustar0000000000000000# 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). pqueue-1.4.3.0/Setup.lhs0000644000000000000000000000011607346545000013160 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain pqueue-1.4.3.0/benchmarks/0000755000000000000000000000000007346545000013467 5ustar0000000000000000pqueue-1.4.3.0/benchmarks/BenchMinPQueue.hs0000644000000000000000000000166507346545000016643 0ustar0000000000000000import 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 ] ] pqueue-1.4.3.0/benchmarks/BenchMinQueue.hs0000644000000000000000000000162107346545000016513 0ustar0000000000000000import 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 ] ] pqueue-1.4.3.0/benchmarks/HeapSort.hs0000644000000000000000000000043407346545000015551 0ustar0000000000000000module 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 pqueue-1.4.3.0/benchmarks/KWay/0000755000000000000000000000000007346545000014342 5ustar0000000000000000pqueue-1.4.3.0/benchmarks/KWay/MergeAlg.hs0000644000000000000000000000155007346545000016362 0ustar0000000000000000{-# 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 pqueue-1.4.3.0/benchmarks/KWay/PrioMergeAlg.hs0000644000000000000000000000106007346545000017210 0ustar0000000000000000{-# 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 pqueue-1.4.3.0/benchmarks/KWay/RandomIncreasing.hs0000644000000000000000000000124307346545000020121 0ustar0000000000000000{-# 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' pqueue-1.4.3.0/benchmarks/PHeapSort.hs0000644000000000000000000000053007346545000015666 0ustar0000000000000000module 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] pqueue-1.4.3.0/pqueue.cabal0000644000000000000000000000623707346545000013652 0ustar0000000000000000name: pqueue version: 1.4.3.0 category: Data Structures author: Louis Wasserman license: BSD3 license-file: LICENSE stability: experimental synopsis: Reliable, persistent, fast priority queues. description: A fast, reliable priority queue implementation based on a binomial heap. maintainer: Lennart Spitzner , Louis Wasserman , 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 == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.4.2 extra-source-files: CHANGELOG.md README.md source-repository head type: git location: https://github.com/lspitzner/pqueue.git library hs-source-dirs: src default-language: Haskell2010 build-depends: { base >= 4.8 && < 4.18 , deepseq >= 1.3 && < 1.5 , indexed-traversable >= 0.1 && < 0.2 } exposed-modules: Data.PQueue.Prio.Min Data.PQueue.Prio.Max Data.PQueue.Min Data.PQueue.Max other-modules: Data.PQueue.Prio.Internals Data.PQueue.Internals BinomialQueue.Internals BinomialQueue.Min BinomialQueue.Max Data.PQueue.Internals.Down Data.PQueue.Internals.Foldable Data.PQueue.Prio.Max.Internals if impl(ghc) { default-extensions: DeriveDataTypeable } 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 if impl(ghc >= 8.0) ghc-options: -fno-warn-unused-imports test-suite test hs-source-dirs: tests default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: PQueueTests.hs build-depends: { base >= 4.8 && < 4.18 , deepseq >= 1.3 && < 1.5 , tasty , tasty-quickcheck , pqueue } ghc-options: -Wall -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 pqueue-1.4.3.0/src/BinomialQueue/0000755000000000000000000000000007346545000014700 5ustar0000000000000000pqueue-1.4.3.0/src/BinomialQueue/Internals.hs0000644000000000000000000006576407346545000017215 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} module BinomialQueue.Internals ( MinQueue (..), BinomHeap, BinomForest(..), BinomTree(..), Extract(..), MExtract(..), Succ(..), Zero(..), empty, extractHeap, null, size, getMin, minView, singleton, 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 -- 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 x (MinQueue ts) = MinQueue (incr (tip x) ts) -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a union (MinQueue f1) (MinQueue f2) = MinQueue (merge f1 f2) -- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. unions :: Ord a => [MinQueue a] -> MinQueue a 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 -- | 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' :: Ord a => BinomTree rk a -> Extract (Succ rk) a -> Extract rk a incrExtract' t (Extract minKey (Succ kChild kChildren) ts) = Extract minKey kChildren (Skip $ incr (t `joinBin` kChild) ts) -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes -- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time. extractBin :: Ord a => BinomForest rk a -> MExtract rk a extractBin = start where start :: Ord a => BinomForest rk a -> MExtract rk a start Nil = No start (Skip f) = case start f of No -> No Yes ex -> Yes (incrExtract ex) start (Cons t@(BinomTree x ts) f) = Yes $ case go x f of No -> Extract x ts (Skip f) Yes ex -> incrExtract' t ex go :: Ord a => a -> BinomForest rk a -> MExtract rk a go _min_above Nil = _min_above `seq` No go min_above (Skip f) = case go min_above f of No -> No Yes ex -> Yes (incrExtract ex) go min_above (Cons t@(BinomTree x ts) f) | min_above <= x = case go min_above f of No -> No Yes ex -> Yes (incrExtract' t ex) | otherwise = case go x f of No -> Yes (Extract x ts (Skip f)) Yes ex -> Yes (incrExtract' t ex) mapMaybeQueue :: Ord b => (a -> Maybe b) -> (rk a -> MinQueue b) -> MinQueue b -> BinomForest rk a -> MinQueue b mapMaybeQueue f fCh q0 forest = q0 `seq` case forest of Nil -> q0 Skip forest' -> mapMaybeQueue f fCh' q0 forest' Cons t forest' -> mapMaybeQueue f fCh' (union (mapMaybeT t) q0) forest' where fCh' (Succ t tss) = union (mapMaybeT t) (fCh tss) mapMaybeT (BinomTree x0 ts) = maybe (fCh ts) (\x -> insert x (fCh ts)) (f x0) type Partition a b = (MinQueue a, MinQueue b) mapEitherQueue :: (Ord b, Ord c) => (a -> Either b c) -> (rk a -> Partition b c) -> Partition b c -> BinomForest rk a -> Partition b c mapEitherQueue f0 fCh (q00, q10) ts0 = q00 `seq` q10 `seq` case ts0 of Nil -> (q00, q10) Skip ts' -> mapEitherQueue f0 fCh' (q00, q10) ts' Cons t ts' -> mapEitherQueue f0 fCh' (both union union (partitionT t) (q00, q10)) ts' where both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) fCh' (Succ t tss) = both union union (partitionT t) (fCh tss) partitionT (BinomTree x ts) = case fCh ts of (q0, q1) -> case f0 x of Left b -> (insert b q0, q1) Right c -> (q0, insert c q1) {-# 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 (foldl' go Nil xs) where go fr x = incr' (tip x) fr -- | Given two binomial forests starting at rank @rk@, takes their union. -- Each successive application of this function costs \(O(1)\), so applying it -- from the beginning costs \(O(\log n)\). merge :: Ord a => BinomForest rk a -> BinomForest rk a -> BinomForest rk a merge f1 f2 = case (f1, f2) of (Skip f1', Skip f2') -> Skip $! merge f1' f2' (Skip f1', Cons t2 f2') -> Cons t2 $! merge f1' f2' (Cons t1 f1', Skip f2') -> Cons t1 $! merge f1' f2' (Cons t1 f1', Cons t2 f2') -> Skip $! carry (t1 `joinBin` t2) f1' f2' (Nil, _) -> f2 (_, Nil) -> f1 -- | Take the union of two queues and toss in an extra element. unionPlusOne :: Ord a => a -> MinQueue a -> MinQueue a -> MinQueue a unionPlusOne a (MinQueue xs) (MinQueue ys) = MinQueue (carry (tip a) xs ys) -- | Merges two binomial forests with another tree. If we are thinking of the trees -- in the binomial forest as binary digits, this corresponds to a carry operation. -- Each call to this function takes \(O(1)\) time, so in total, it costs \(O(\log n)\). carry :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a -> BinomForest rk a carry t0 f1 f2 = t0 `seq` case (f1, f2) of (Skip f1', Skip f2') -> Cons t0 $! merge f1' f2' (Skip f1', Cons t2 f2') -> Skip $! mergeCarry t0 t2 f1' f2' (Cons t1 f1', Skip f2') -> Skip $! mergeCarry t0 t1 f1' f2' (Cons t1 f1', Cons t2 f2') -> 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 t0 f2 (_f1, Nil) -> incr t0 f1 where mergeCarry tA tB = carry (tA `joinBin` tB) -- | Merges a binomial tree into a binomial forest. If we are thinking -- of the trees in the binomial forest as binary digits, this corresponds -- to adding a power of 2. This costs amortized \(O(1)\) time. incr :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a -- See Note [Amortization] incr t f0 = t `seq` case f0 of Nil -> Cons t Nil Skip f -> Cons t f Cons t' f' -> f' `seq` Skip (incr (t `joinBin` t') f') -- See Note [Force on cascade] -- Question: should we force t `cat` t' here? We're allowed to; -- it's not obviously good or obviously bad. -- 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' :: Ord a => BinomTree rk a -> BinomForest rk a -> BinomForest rk a incr' t f0 = t `seq` case f0 of Nil -> Cons t Nil Skip f -> Cons t f Cons t' f' -> Skip $! incr' (t `joinBin` t') f' -- | The carrying operation: takes two binomial heaps of the same rank @k@ -- and returns one of rank @k+1@. Takes \(O(1)\) time. joinBin :: Ord a => BinomTree rk a -> BinomTree rk a -> BinomTree (Succ rk) a joinBin t1@(BinomTree x1 ts1) t2@(BinomTree x2 ts2) | x1 <= x2 = BinomTree x1 (Succ t2 ts1) | otherwise = BinomTree x2 (Succ t1 ts2) instance Functor Zero where fmap _ _ = Zero 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 {-# INLINABLE stimes #-} #endif instance Ord a => Monoid (MinQueue a) where mempty = empty #if !MIN_VERSION_base(4,11,0) mappend = union #endif mconcat = unions pqueue-1.4.3.0/src/BinomialQueue/Max.hs0000644000000000000000000002444307346545000015770 0ustar0000000000000000{-# 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 pqueue-1.4.3.0/src/BinomialQueue/Min.hs0000644000000000000000000001672107346545000015766 0ustar0000000000000000{-# 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 pqueue-1.4.3.0/src/Data/PQueue/0000755000000000000000000000000007346545000014216 5ustar0000000000000000pqueue-1.4.3.0/src/Data/PQueue/Internals.hs0000644000000000000000000003044407346545000016516 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Data.PQueue.Internals ( MinQueue (..), BinomHeap, BinomForest(..), BinomTree(..), Succ(..), Zero(..), empty, null, size, getMin, minView, singleton, insert, union, mapMaybe, mapEither, mapMonotonic, foldrAsc, foldlAsc, foldrDesc, insertMinQ, insertMinQ', insertMaxQ', toAscList, toDescList, toListU, fromList, mapU, fromAscList, foldMapU, foldrU, foldlU, foldlU', -- traverseU, 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 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) #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 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 instance Ord a => Eq (MinQueue a) where Empty == Empty = True MinQueue n1 x1 q1 == MinQueue n2 x2 q2 = n1 == n2 && x1 == x2 && q1 == q2 _ == _ = False instance Ord a => Ord (MinQueue a) where Empty `compare` Empty = EQ Empty `compare` _ = LT _ `compare` Empty = GT MinQueue _n1 x1 q1 `compare` MinQueue _n2 x2 q2 = compare (x1,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. -- basics -- | \(O(1)\). The empty priority queue. empty :: MinQueue a empty = Empty -- | \(O(1)\). Is this the empty priority queue? null :: MinQueue a -> Bool null Empty = True null _ = False -- | \(O(1)\). The number of elements in the queue. size :: MinQueue a -> Int size Empty = 0 size (MinQueue n _ _) = n -- | \(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 -- | Retrieves the minimum element of the queue, and the queue stripped of that element, -- or 'Nothing' if passed an empty queue. minView :: Ord a => MinQueue a -> Maybe (a, MinQueue a) minView Empty = Nothing minView (MinQueue n x ts) = Just (x, case BQ.minView ts of Nothing -> Empty Just (x', ts') -> MinQueue (n - 1) x' ts') -- | \(O(1)\). Construct a priority queue with a single element. singleton :: a -> MinQueue a singleton x = MinQueue 1 x BQ.empty -- | Amortized \(O(1)\), worst-case \(O(\log n)\). Insert an element into the priority queue. insert :: Ord a => a -> MinQueue a -> MinQueue a insert x Empty = singleton x insert x (MinQueue n x' ts) | x <= x' = MinQueue (n + 1) x (BQ.insertMinQ x' ts) | otherwise = MinQueue (n + 1) x' (BQ.insert x ts) -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a union Empty q = q union q Empty = q union (MinQueue n1 x1 f1) (MinQueue n2 x2 f2) | x1 <= x2 = MinQueue (n1 + n2) x1 (BQ.unionPlusOne x2 f1 f2) | otherwise = MinQueue (n1 + n2) x2 (BQ.unionPlusOne x1 f1 f2) -- | Takes the union of a list of priority queues. Equivalent to @'foldl'' 'union' 'empty'@. unions :: Ord a => [MinQueue a] -> MinQueue a unions = foldl' union empty -- | \(O(n)\). Map elements and collect the 'Just' results. mapMaybe :: Ord b => (a -> Maybe b) -> MinQueue a -> MinQueue b mapMaybe _ Empty = Empty mapMaybe f (MinQueue _ x ts) = fromBare $ maybe q' (`BQ.insert` q') (f x) where q' = BQ.mapMaybe f ts -- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) mapEither _ Empty = (Empty, Empty) mapEither f (MinQueue _ x ts) | (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, -- 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 _ z Empty = z foldrAsc f z (MinQueue _ x ts) = x `f` BQ.foldrUnfold f z BQ.minView 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 #-} -- | \(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) = BQ.foldlUnfold f (z `f` x) BQ.minView ts {-# 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 -- | @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) -- | @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) -- | @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) {-# 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) (BQ.mapU f ts) {-# 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` BQ.foldrU 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 _ z Empty = z 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 -- | \(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 = BQ.seqSpine ts z instance NFData a => NFData (MinQueue a) where rnf Empty = () rnf (MinQueue _ x ts) = x `deepseq` 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 {-# INLINABLE stimes #-} #endif instance Ord a => Monoid (MinQueue a) where mempty = empty #if !MIN_VERSION_base(4,11,0) mappend = union #endif mconcat = unions pqueue-1.4.3.0/src/Data/PQueue/Internals/0000755000000000000000000000000007346545000016155 5ustar0000000000000000pqueue-1.4.3.0/src/Data/PQueue/Internals/Down.hs0000644000000000000000000000145207346545000017422 0ustar0000000000000000{-# 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 Down a >= Down b = b >= a Down a < Down b = b < a Down a > Down b = b > a instance Functor Down where fmap f (Down a) = Down (f a) instance Foldable Down where foldr f z (Down a) = a `f` z foldl f z (Down a) = z `f` a foldr' f !z (Down a) = a `f` z foldl' f !z (Down a) = z `f` a pqueue-1.4.3.0/src/Data/PQueue/Internals/Foldable.hs0000644000000000000000000000200607346545000020217 0ustar0000000000000000-- | 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 pqueue-1.4.3.0/src/Data/PQueue/Max.hs0000644000000000000000000003252107346545000015302 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Max -- Copyright : (c) Louis Wasserman 2010 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- General purpose priority queue, supporting view-maximum operations. -- -- An amortized running time is given for each operation, with /n/ referring -- to the length of the sequence and /k/ being the integral index used by -- some operations. These bounds hold even in a persistent (shared) setting. -- -- This implementation is based on a binomial heap augmented with a global root. -- -- This implementation does not guarantee stable behavior. -- -- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for -- unordered. No guarantees whatsoever are made on the execution or traversal order of -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Max ( MaxQueue, -- * Basic operations empty, null, size, -- * Query operations findMax, getMax, deleteMax, deleteFindMax, delete, maxView, -- * Construction operations singleton, insert, union, unions, -- * Subsets -- ** Extracting subsets (!!), take, drop, splitAt, -- ** Predicates takeWhile, dropWhile, span, break, -- * Filter/Map filter, partition, mapMaybe, mapEither, -- * Fold\/Functor\/Traversable variations map, foldrAsc, foldlAsc, foldrDesc, foldlDesc, -- * List operations toList, toAscList, toDescList, fromList, fromAscList, fromDescList, -- * Unordered operations mapU, foldrU, foldlU, foldlU', foldMapU, elemsU, toListU, -- * Miscellaneous operations keysQueue, seqSpine) where import Control.DeepSeq (NFData(rnf)) import Data.Maybe (fromMaybe) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid) #endif import Data.Foldable (foldl') import qualified Data.PQueue.Min as Min import qualified Data.PQueue.Prio.Max.Internals as Prio import Data.PQueue.Internals.Down (Down(..)) import Prelude hiding (null, map, take, drop, takeWhile, dropWhile, splitAt, span, break, (!!), filter) #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, readListPrecDefault) import Data.Data #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif -- | A priority queue with elements of type @a@. Supports extracting the maximum element. -- Implemented as a wrapper around 'Min.MinQueue'. newtype MaxQueue a = MaxQ (Min.MinQueue (Down a)) # if __GLASGOW_HASKELL__ deriving (Eq, Ord, Data) # else deriving (Eq, Ord) # endif instance NFData a => NFData (MaxQueue a) where rnf (MaxQ q) = rnf q instance (Ord a, Show a) => Show (MaxQueue a) where showsPrec p xs = showParen (p > 10) $ showString "fromDescList " . shows (toDescList xs) instance Read a => Read (MaxQueue a) where #ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromDescList" <- lexP xs <- readPrec return (fromDescList xs) readListPrec = readListPrecDefault #else readsPrec p = readParen (p > 10) $ \r -> do ("fromDescList",s) <- lex r (xs,t) <- reads s return (fromDescList xs,t) #endif #if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (MaxQueue a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} #endif instance Ord a => Monoid (MaxQueue a) where mempty = empty #if !MIN_VERSION_base(4,11,0) mappend = union #endif mconcat = unions -- | \(O(1)\). The empty priority queue. empty :: MaxQueue a empty = MaxQ Min.empty -- | \(O(1)\). Is this the empty priority queue? null :: MaxQueue a -> Bool null (MaxQ q) = Min.null q -- | \(O(1)\). The number of elements in the queue. size :: MaxQueue a -> Int size (MaxQ q) = Min.size q -- | \(O(1)\). Returns the maximum element of the queue. Throws an error on an empty queue. findMax :: MaxQueue a -> a findMax = fromMaybe (error "Error: findMax called on empty queue") . getMax -- | \(O(1)\). The top (maximum) element of the queue, if there is one. getMax :: MaxQueue a -> Maybe a getMax (MaxQ q) = unDown <$> Min.getMin q -- | \(O(\log n)\). Deletes the maximum element of the queue. Does nothing on an empty queue. deleteMax :: Ord a => MaxQueue a -> MaxQueue a deleteMax (MaxQ q) = MaxQ (Min.deleteMin q) -- | \(O(\log n)\). Extracts the maximum element of the queue. Throws an error on an empty queue. deleteFindMax :: Ord a => MaxQueue a -> (a, MaxQueue a) deleteFindMax = fromMaybe (error "Error: deleteFindMax called on empty queue") . maxView -- | \(O(\log n)\). Extract the top (maximum) element of the sequence, if there is one. maxView :: Ord a => MaxQueue a -> Maybe (a, MaxQueue a) maxView (MaxQ q) = case Min.minView q of Nothing -> Nothing Just (Down x, q') -> Just (x, MaxQ q') -- | \(O(\log n)\). Delete the top (maximum) element of the sequence, if there is one. delete :: Ord a => MaxQueue a -> Maybe (MaxQueue a) delete = fmap snd . maxView -- | \(O(1)\). Construct a priority queue with a single element. singleton :: a -> MaxQueue a singleton = MaxQ . Min.singleton . Down -- | \(O(1)\). Insert an element into the priority queue. insert :: Ord a => a -> MaxQueue a -> MaxQueue a x `insert` MaxQ q = MaxQ (Down x `Min.insert` q) -- | \(O(\log min(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) -- | Takes the union of a list of priority queues. Equivalent to @'foldl' 'union' 'empty'@. unions :: Ord a => [MaxQueue a] -> MaxQueue a unions qs = MaxQ (Min.unions [q | MaxQ q <- qs]) -- | \(O(k \log n)\)/. Returns the @(k+1)@th largest element of the queue. (!!) :: Ord a => MaxQueue a -> Int -> a MaxQ q !! n = unDown ((Min.!!) q n) {-# INLINE take #-} -- | \(O(k \log n)\)/. Returns the list of the @k@ largest elements of the queue, in descending order, or -- all elements of the queue, if @k >= n@. take :: Ord a => Int -> MaxQueue a -> [a] take k (MaxQ q) = [a | Down a <- Min.take k q] -- | \(O(k \log n)\)/. Returns the queue with the @k@ largest elements deleted, or the empty queue if @k >= n@. drop :: Ord a => Int -> MaxQueue a -> MaxQueue a drop k (MaxQ q) = MaxQ (Min.drop k q) -- | \(O(k \log n)\)/. Equivalent to @(take k queue, drop k queue)@. splitAt :: Ord a => Int -> MaxQueue a -> ([a], MaxQueue a) splitAt k (MaxQ q) = (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) = 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 dropWhile p (MaxQ q) = MaxQ (Min.dropWhile (p . unDown) q) -- | 'span', applied to a predicate @p@ and a queue @queue@, returns a tuple where -- first element is longest prefix (possibly empty) of @queue@ of elements that -- satisfy @p@ and second element is the remainder of the queue. -- span :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) span p (MaxQ q) = (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 -- first element is longest prefix (possibly empty) of @queue@ of elements that -- /do not satisfy/ @p@ and second element is the remainder of the queue. break :: Ord a => (a -> Bool) -> MaxQueue a -> ([a], MaxQueue a) break p = span (not . p) -- | \(O(n)\). Returns a queue of those elements which satisfy the predicate. filter :: Ord a => (a -> Bool) -> MaxQueue a -> MaxQueue a filter p (MaxQ q) = MaxQ (Min.filter (p . unDown) q) -- | \(O(n)\). Returns a pair of queues, where the left queue contains those elements that satisfy the predicate, -- and the right queue contains those that do not. partition :: Ord a => (a -> Bool) -> MaxQueue a -> (MaxQueue a, MaxQueue a) partition p (MaxQ q) = (MaxQ q0, MaxQ q1) where (q0, q1) = Min.partition (p . unDown) q -- | \(O(n)\). Maps a function over the elements of the queue, and collects the 'Just' values. mapMaybe :: Ord b => (a -> Maybe b) -> MaxQueue a -> MaxQueue b mapMaybe f (MaxQ q) = MaxQ (Min.mapMaybe (\(Down x) -> Down <$> f x) q) -- | \(O(n)\). Maps a function over the elements of the queue, and separates the 'Left' and 'Right' values. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MaxQueue a -> (MaxQueue b, MaxQueue c) mapEither f (MaxQ q) = (MaxQ q0, MaxQ q1) where (q0, q1) = Min.mapEither (either (Left . Down) (Right . Down) . f . unDown) q -- | \(O(n)\). 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. foldrU :: (a -> b -> b) -> b -> MaxQueue a -> b foldrU f z (MaxQ q) = Min.foldrU (flip (foldr f)) z q -- | \(O(n)\). Unordered monoidal fold on a priority queue. -- -- @since 1.4.2 foldMapU :: Monoid m => (a -> m) -> MaxQueue a -> m foldMapU f (MaxQ q) = Min.foldMapU (f . unDown) q -- | \(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. toListU :: MaxQueue a -> [a] 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. -- @'foldrAsc' f z q == 'foldlDesc' (flip f) z q@. foldrAsc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b foldrAsc = foldlDesc . flip -- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. -- @'foldlAsc' f z q == 'foldrDesc' (flip f) z q@. foldlAsc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b foldlAsc = foldrDesc . flip -- | \(O(n \log n)\). Performs a right-fold on the elements of a priority queue in descending order. foldrDesc :: Ord a => (a -> b -> b) -> b -> MaxQueue a -> b foldrDesc f z (MaxQ q) = Min.foldrAsc (flip (foldr f)) z q -- | \(O(n \log n)\). Performs a left-fold on the elements of a priority queue in descending order. foldlDesc :: Ord a => (b -> a -> b) -> b -> MaxQueue a -> b foldlDesc f z (MaxQ q) = Min.foldlAsc (foldl f) z q {-# INLINE toAscList #-} -- | \(O(n \log n)\). Extracts the elements of the priority queue in ascending order. toAscList :: Ord a => MaxQueue a -> [a] toAscList q = build (\c nil -> foldrAsc c nil q) -- 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. 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'. -- -- If the order of the elements is irrelevant, consider using 'toListU'. toList :: Ord a => MaxQueue a -> [a] toList (MaxQ q) = fmap unDown (Min.toList q) {-# INLINE fromAscList #-} -- | \(O(n)\). Constructs a priority queue from an ascending list. /Warning/: Does not check the precondition. fromAscList :: [a] -> MaxQueue a fromAscList = MaxQ . Min.fromDescList . fmap Down {-# INLINE fromDescList #-} -- | \(O(n)\). Constructs a priority queue from a descending list. /Warning/: Does not check the precondition. fromDescList :: [a] -> MaxQueue a fromDescList = MaxQ . Min.fromAscList . fmap Down {-# INLINE fromList #-} -- | \(O(n \log n)\). Constructs a priority queue from an unordered list. fromList :: Ord a => [a] -> MaxQueue a fromList = MaxQ . Min.fromList . fmap Down -- | \(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)\). @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 pqueue-1.4.3.0/src/Data/PQueue/Min.hs0000644000000000000000000001753507346545000015310 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Min -- Copyright : (c) Louis Wasserman 2010 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- General purpose priority queue, supporting extract-minimum operations. -- -- An amortized running time is given for each operation, with /n/ referring -- to the length of the sequence and /k/ being the integral index used by -- some operations. These bounds hold even in a persistent (shared) setting. -- -- This implementation is based on a binomial heap augmented with a global root. -- -- This implementation does not guarantee stable behavior. -- -- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for -- unordered. No guarantees whatsoever are made on the execution or traversal order of -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Min ( MinQueue, -- * Basic operations empty, null, size, -- * Query operations findMin, getMin, deleteMin, deleteFindMin, minView, -- * Construction operations singleton, insert, union, unions, -- * Subsets -- ** Extracting subsets (!!), take, drop, splitAt, -- ** Predicates takeWhile, dropWhile, span, break, -- * Filter/Map filter, partition, mapMaybe, mapEither, -- * Fold\/Functor\/Traversable variations map, foldrAsc, foldlAsc, foldrDesc, foldlDesc, -- * List operations toList, toAscList, toDescList, fromList, fromAscList, fromDescList, -- * Unordered operations mapU, foldrU, foldlU, foldlU', foldMapU, elemsU, toListU, -- * Miscellaneous operations keysQueue, 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 Data.PQueue.Internals import qualified BinomialQueue.Internals as BQ import qualified Data.PQueue.Prio.Internals as Prio #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif -- | \(O(1)\). Returns the minimum element. Throws an error on an empty queue. findMin :: MinQueue a -> a findMin = fromMaybe (error "Error: findMin called on empty queue") . getMin -- | \(O(\log n)\). Deletes the minimum element. If the queue is empty, does nothing. deleteMin :: Ord a => MinQueue a -> MinQueue a deleteMin q = case minView q of Nothing -> empty Just (_, q') -> q' -- | \(O(\log n)\). Extracts the minimum element. Throws an error on an empty queue. deleteFindMin :: Ord a => MinQueue a -> (a, MinQueue a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on empty queue") . minView -- | \(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 -- | 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)) 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) pqueue-1.4.3.0/src/Data/PQueue/Prio/0000755000000000000000000000000007346545000015127 5ustar0000000000000000pqueue-1.4.3.0/src/Data/PQueue/Prio/Internals.hs0000644000000000000000000007546207346545000017440 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Data.PQueue.Prio.Internals ( MinPQueue(..), BinomForest(..), BinomHeap, BinomTree(..), Zero(..), Succ(..), empty, null, size, singleton, insert, insertBehind, union, getMin, adjustMinWithKey, adjustMinWithKeyA', updateMinWithKey, updateMinWithKeyA', minViewWithKey, mapWithKey, mapKeysMonotonic, mapMaybeWithKey, mapEitherWithKey, foldrWithKey, foldlWithKey, foldrU, toAscList, toDescList, toListU, insertMin, insertMin', insertMax', fromList, fromAscList, foldrWithKeyU, foldMapWithKeyU, foldlWithKeyU, foldlWithKeyU', traverseWithKey, mapMWithKey, traverseWithKeyU, seqSpine, mapForest, unions ) where 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 ((<>)) #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 import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif #if __GLASGOW_HASKELL__ instance (Data k, Data a, Ord k) => Data (MinPQueue k a) where gfoldl f z m = z fromList `f` foldrWithKey (curry (:)) [] m toConstr _ = fromListConstr gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" 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 {-# INLINABLE stimes #-} #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) first' :: (a -> b) -> (a, c) -> (b, c) first' f (a, c) = (f a, c) second' :: (b -> c) -> (a, b) -> (a, c) second' f (a, b) = (a, f b) infixr 8 .: -- | A priority queue where values of type @a@ are annotated with keys of type @k@. -- The queue supports extracting the element with minimum key. data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a) data BinomForest rk k a = Nil | Skip (BinomForest (Succ rk) k a) | Cons {-# UNPACK #-} !(BinomTree rk k a) (BinomForest (Succ rk) k a) type BinomHeap = BinomForest Zero data BinomTree rk k a = BinomTree !k a !(rk k a) data Zero k a = Zero data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) !(rk k a) 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 instance (Ord k, Eq a) => Eq (MinPQueue k a) where MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 = n1 == n2 && eqExtract k1 a1 ts1 k2 a2 ts2 Empty == Empty = True _ == _ = False eqExtract :: (Ord k, Eq a) => k -> a -> BinomForest rk k a -> k -> a -> BinomForest rk k a -> Bool eqExtract k10 a10 ts10 k20 a20 ts20 = k10 == k20 && a10 == a20 && case (extract ts10, extract ts20) of (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) -> eqExtract k1 a1 ts1' k2 a2 ts2' (No, No) -> True _ -> False instance (Ord k, Ord a) => Ord (MinPQueue k a) where MinPQ _n1 k10 a10 ts10 `compare` MinPQ _n2 k20 a20 ts20 = cmpExtract k10 a10 ts10 k20 a20 ts20 Empty `compare` Empty = EQ Empty `compare` MinPQ{} = LT MinPQ{} `compare` Empty = GT cmpExtract :: (Ord k, Ord a) => k -> a -> BinomForest rk k a -> k -> a -> BinomForest rk k a -> Ordering cmpExtract k10 a10 ts10 k20 a20 ts20 = k10 `compare` k20 <> a10 `compare` a20 <> case (extract ts10, extract ts20) of (Yes (Extract k1 a1 _ ts1'), Yes (Extract k2 a2 _ ts2')) -> cmpExtract k1 a1 ts1' k2 a2 ts2' (No, Yes{}) -> LT (Yes{}, No) -> GT (No, No) -> EQ -- | \(O(1)\). Returns the empty priority queue. empty :: MinPQueue k a empty = Empty -- | \(O(1)\). Checks if this priority queue is empty. null :: MinPQueue k a -> Bool null Empty = True null _ = False -- | \(O(1)\). Returns the size of this priority queue. size :: MinPQueue k a -> Int size Empty = 0 size (MinPQ n _ _ _) = n -- | \(O(1)\). Constructs a singleton priority queue. singleton :: k -> a -> MinPQueue k a singleton k a = MinPQ 1 k a Nil -- | Amortized \(O(1)\), worst-case \(O(\log n)\). Inserts -- an element with the specified key into the queue. insert :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a insert k a Empty = singleton k a insert k a (MinPQ n k' a' ts) | k <= k' = MinPQ (n + 1) k a (incrMin (tip k' a') ts) | otherwise = MinPQ (n + 1) k' a' (incr (tip k a ) ts) -- | \(O(n)\) (an earlier implementation had \(O(1)\) but was buggy). -- Insert an element with the specified key into the priority queue, -- putting it behind elements whose key compares equal to the -- inserted one. insertBehind :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a insertBehind k v q = let (smaller, larger) = spanKey (<= k) q in foldr (uncurry insert) (insert k v larger) smaller spanKey :: Ord k => (k -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) spanKey p q = case minViewWithKey q of Just (t@(k, _), q') | p k -> let (kas, q'') = spanKey p q' in (t : kas, q'') _ -> ([], q) -- | 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 (MinPQ n1 k1 a1 ts1) (MinPQ n2 k2 a2 ts2) | k1 <= k2 = MinPQ (n1 + n2) k1 a1 (insMerge k2 a2) | otherwise = MinPQ (n1 + n2) k2 a2 (insMerge k1 a1) where insMerge k a = carryForest (tip k a) ts1 ts2 union Empty q2 = q2 union q1 Empty = q1 -- | \(O(1)\). The minimal (key, element) in the queue, if the queue is nonempty. getMin :: MinPQueue k a -> Maybe (k, a) getMin (MinPQ _ k a _) = Just (k, a) getMin _ = Nothing -- | \(O(1)\). Alter the value at the minimum key. If the queue is empty, does nothing. adjustMinWithKey :: (k -> a -> a) -> MinPQueue k a -> MinPQueue k a adjustMinWithKey _ Empty = Empty adjustMinWithKey f (MinPQ n k a ts) = MinPQ n k (f k a) ts -- | \(O(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 updateMinWithKey f (MinPQ n k a ts) = case f k a of Nothing -> extractHeap n ts Just a' -> MinPQ n k a' ts -- | \(O(\log n)\) 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. mapWithKey :: (k -> a -> b) -> MinPQueue k a -> MinPQueue k b mapWithKey f = runIdentity . traverseWithKeyU (Identity .: f) -- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when @f@ is strictly -- monotonic. /The precondition is not checked./ This function has better performance than -- 'mapKeys'. mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeysMonotonic _ Empty = Empty mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a (mapKeysMonoF f (const Zero) ts) -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b mapMaybeWithKey _ Empty = Empty mapMaybeWithKey f (MinPQ _ k a ts) = maybe id (insert k) (f k a) (mapMaybeF f (const Empty) ts) -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) mapEitherWithKey _ Empty = (Empty, Empty) mapEitherWithKey f (MinPQ _ k a ts) = either (first' . insert k) (second' . insert k) (f k a) (mapEitherF f (const (Empty, Empty)) ts) -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. -- -- If you do not care about the traversal order, consider using 'foldrWithKeyU'. foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> MinPQueue k a -> b foldrWithKey _ z Empty = z foldrWithKey f z (MinPQ _ k0 a0 ts0) = f k0 a0 (foldF ts0) where foldF ts = case extract ts of Yes (Extract k a _ ts') -> f k a (foldF ts') _ -> z -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. -- -- If you do not care about the traversal order, consider using 'foldlWithKeyU'. foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> MinPQueue k a -> b foldlWithKey _ z Empty = z foldlWithKey f z0 (MinPQ _ k0 a0 ts0) = foldF (f z0 k0 a0) ts0 where foldF z ts = case extract ts of Yes (Extract k a _ ts') -> foldF (f z k a) ts' _ -> z {-# 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) -- | 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 extract (fromListHeap xs) of No -> Empty -- Should we track the size as we go instead? That saves O(log n) -- at the end, but it needs an extra register all along the way. -- 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 :: Ord k => [(k, a)] -> BinomHeap k a fromListHeap xs = List.foldl' go Nil xs where go fr (k, a) = incr' (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. meld :: Ord k => BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a meld t1@(BinomTree k1 v1 ts1) t2@(BinomTree k2 v2 ts2) | k1 <= k2 = BinomTree k1 v1 (Succ t2 ts1) | otherwise = BinomTree k2 v2 (Succ t1 ts2) -- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. mergeForest :: Ord k => BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a mergeForest f1 f2 = case (f1, f2) of (Skip ts1, Skip ts2) -> Skip $! mergeForest ts1 ts2 (Skip ts1, Cons t2 ts2) -> Cons t2 $! mergeForest ts1 ts2 (Cons t1 ts1, Skip ts2) -> Cons t1 $! mergeForest ts1 ts2 (Cons t1 ts1, Cons t2 ts2) -> Skip $! carryForest (meld t1 t2) ts1 ts2 (Nil, _) -> f2 (_, Nil) -> f1 -- | Takes the union of two binomial forests, starting at the same rank, with an additional tree. -- Analogous to binary addition when a digit has been carried. carryForest :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a carryForest t0 f1 f2 = t0 `seq` case (f1, f2) of (Cons t1 ts1, Cons t2 ts2) -> Cons t0 $! carryMeld t1 t2 ts1 ts2 (Cons t1 ts1, Skip ts2) -> Skip $! carryMeld t0 t1 ts1 ts2 (Skip ts1, Cons t2 ts2) -> Skip $! carryMeld t0 t2 ts1 ts2 (Skip ts1, Skip ts2) -> Cons t0 $! mergeForest 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 t0 f2 (_, Nil) -> incr t0 f1 where carryMeld = carryForest .: meld -- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. incr :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incr t ts = t `seq` case ts of Nil -> Cons t Nil Skip ts' -> Cons t ts' Cons t' ts' -> ts' `seq` Skip (incr (meld t t') ts') -- | Inserts a binomial tree into a binomial forest. Analogous to binary incrementation. -- Forces the rebuilt portion of the spine. incr' :: Ord k => BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incr' t ts = t `seq` case ts of Nil -> Cons t Nil Skip ts' -> Cons t ts' Cons t' ts' -> Skip $! incr' (meld t t') ts' -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr' (\_ _ -> True)@. incrMin :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incrMin t@(BinomTree k a ts) tss = case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' Cons t' tss' -> 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 :: Ord k => Int -> BinomHeap k a -> MinPQueue k a extractHeap n ts = n `seq` case extract ts of No -> Empty Yes (Extract k a _ ts') -> MinPQ (n - 1) k a ts' -- | A specialized type intended to organize the return of extract-min queries -- from a binomial forest. We walk all the way through the forest, and then -- walk backwards. @Extract rk a@ is the result type of an extract-min -- operation that has walked as far backwards of rank @rk@ -- that is, it -- has visited every root of rank @>= rk@. -- -- The interpretation of @Extract minKey minVal children forest@ is -- -- * @minKey@ is the key of the minimum root visited so far. It may have -- any rank @>= rk@. We will denote the root corresponding to -- @minKey@ as @minRoot@. -- -- * @minVal@ is the value corresponding to @minKey@. -- -- * @children@ is those children of @minRoot@ which have not yet been -- merged with the rest of the forest. Specifically, these are -- the children with rank @< rk@. -- -- * @forest@ is an accumulating parameter that maintains the partial -- reconstruction of the binomial forest without @minRoot@. It is -- the union of all old roots with rank @>= rk@ (except @minRoot@), -- with the set of all children of @minRoot@ with rank @>= rk@. -- Note that @forest@ is lazy, so if we discover a smaller key -- than @minKey@ later, we haven't wasted significant work. data Extract rk k a = Extract !k a !(rk k a) !(BinomForest rk k a) data MExtract rk k a = No | Yes {-# UNPACK #-} !(Extract rk k a) incrExtract :: 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' :: Ord k => BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a incrExtract' t (Extract minKey minVal (Succ kChild kChildren) ts) = Extract minKey minVal kChildren (Skip $ incr (t `meld` kChild) ts) -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes -- amortized \(O(1)\) time, so applying it from the beginning takes \(O(\log n)\) time. extract :: Ord k => BinomForest rk k a -> MExtract rk k a extract = start where start :: Ord k => BinomForest rk k a -> MExtract rk k a start Nil = No start (Skip f) = case start f of No -> No Yes ex -> Yes (incrExtract ex) start (Cons t@(BinomTree k v ts) f) = Yes $ case go k f of No -> Extract k v ts (Skip f) Yes ex -> incrExtract' t ex go :: Ord k => k -> BinomForest rk k a -> MExtract rk k a go _min_above Nil = _min_above `seq` No go min_above (Skip f) = case go min_above f of No -> No Yes ex -> Yes (incrExtract ex) go min_above (Cons t@(BinomTree k v ts) f) | min_above <= k = case go min_above f of No -> No Yes ex -> Yes (incrExtract' t ex) | otherwise = case go k f of No -> Yes (Extract k v ts (Skip f)) Yes ex -> Yes (incrExtract' t ex) -- | Utility function for mapping over a forest. mapForest :: (k -> a -> b) -> (rk k a -> rk k b) -> BinomForest rk k a -> BinomForest rk k b mapForest f fCh ts0 = case ts0 of Nil -> Nil Skip ts' -> Skip (mapForest f fCh' ts') Cons (BinomTree k a ts) tss -> Cons (BinomTree k (f k a) (fCh ts)) (mapForest f fCh' tss) where fCh' (Succ (BinomTree k a ts) tss) = Succ (BinomTree k (f k a) (fCh ts)) (fCh tss) -- | Utility function for mapping a 'Maybe' function over a forest. mapMaybeF :: Ord k => (k -> a -> Maybe b) -> (rk k a -> MinPQueue k b) -> BinomForest rk k a -> MinPQueue k b mapMaybeF f fCh ts0 = case ts0 of Nil -> Empty Skip ts' -> mapMaybeF f fCh' ts' Cons (BinomTree k a ts) ts' -> insF k a (fCh ts) (mapMaybeF f fCh' ts') where insF k a = maybe id (insert k) (f k a) .: union fCh' (Succ (BinomTree k a ts) tss) = insF k a (fCh ts) (fCh tss) -- | Utility function for mapping an 'Either' function over a forest. mapEitherF :: Ord k => (k -> a -> Either b c) -> (rk k a -> (MinPQueue k b, MinPQueue k c)) -> BinomForest rk k a -> (MinPQueue k b, MinPQueue k c) mapEitherF f0 fCh ts0 = case ts0 of Nil -> (Empty, Empty) Skip ts' -> mapEitherF f0 fCh' ts' Cons (BinomTree k a ts) ts' -> insF k a (fCh ts) (mapEitherF f0 fCh' ts') where insF k a = either (first' . insert k) (second' . insert k) (f0 k a) .: (union `both` union) fCh' (Succ (BinomTree k a ts) tss) = insF k a (fCh ts) (fCh tss) both f g (x1, x2) (y1, y2) = (f x1 y1, g x2 y2) -- | \(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 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 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) = liftA2 (MinPQ n k) (f k a) (traverseForest f (const (pure Zero)) ts) {-# SPECIALIZE traverseForest :: (k -> a -> Identity b) -> (rk k a -> Identity (rk k b)) -> BinomForest rk k a -> Identity (BinomForest rk k b) #-} traverseForest :: (Applicative f) => (k -> a -> f b) -> (rk k a -> f (rk k b)) -> BinomForest rk k a -> f (BinomForest rk k b) traverseForest f fCh ts0 = case ts0 of Nil -> pure Nil Skip ts' -> Skip <$> traverseForest f fCh' ts' Cons (BinomTree k a ts) tss -> liftA3 (\p q -> Cons (BinomTree k p q)) (f k a) (fCh ts) (traverseForest f fCh' tss) where fCh' (Succ (BinomTree k a ts) tss) = Succ <$> (BinomTree k <$> f k a <*> fCh ts) <*> fCh tss -- | Unordered right fold on a binomial forest. foldrWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b foldrWithKeyF_ f fCh ts0 z0 = case ts0 of Nil -> z0 Skip ts' -> foldrWithKeyF_ f fCh' ts' z0 Cons (BinomTree k a ts) ts' -> f k a (fCh ts (foldrWithKeyF_ f fCh' ts' z0)) where fCh' (Succ (BinomTree k a ts) tss) z = f k a (fCh ts (fCh tss z)) -- | Unordered left fold on a binomial forest. foldlWithKeyF_ :: (k -> a -> b -> b) -> (rk k a -> b -> b) -> BinomForest rk k a -> b -> b foldlWithKeyF_ f fCh ts0 = case ts0 of Nil -> id Skip ts' -> foldlWithKeyF_ f fCh' ts' Cons (BinomTree k a ts) ts' -> foldlWithKeyF_ f fCh' ts' . fCh ts . f k a where fCh' (Succ (BinomTree k a ts) tss) = fCh tss . fCh ts . f k a -- | Maps a monotonic function over the keys in a binomial forest. mapKeysMonoF :: (k -> k') -> (rk k a -> rk k' a) -> BinomForest rk k a -> BinomForest rk k' a mapKeysMonoF f fCh ts0 = case ts0 of Nil -> Nil Skip ts' -> Skip (mapKeysMonoF f fCh' ts') Cons (BinomTree k a ts) ts' -> Cons (BinomTree (f k) a (fCh ts)) (mapKeysMonoF f fCh' ts') where fCh' (Succ (BinomTree k a ts) tss) = Succ (BinomTree (f k) a (fCh ts)) (fCh tss) -- | \(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 seqSpineF :: BinomForest rk k a -> b -> b seqSpineF ts z = case ts of Nil -> z Skip ts' -> seqSpineF ts' z Cons _ ts' -> seqSpineF ts' z class NFRank rk where rnfRk :: (NFData k, NFData a) => rk k a -> () instance NFRank Zero where rnfRk _ = () instance NFRank rk => NFRank (Succ rk) where rnfRk (Succ t ts) = t `deepseq` rnfRk ts instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where rnf (BinomTree k a ts) = k `deepseq` a `deepseq` rnfRk ts instance (NFData k, NFData a, NFRank rk) => NFData (BinomForest rk k a) where rnf Nil = () rnf (Skip tss) = rnf tss rnf (Cons t tss) = t `deepseq` rnf tss instance (NFData k, NFData a) => NFData (MinPQueue k a) where rnf Empty = () rnf (MinPQ _ k a ts) = k `deepseq` a `deepseq` rnf ts instance Functor (MinPQueue k) where fmap = map instance FunctorWithIndex k (MinPQueue k) where imap = mapWithKey instance Ord k => Foldable (MinPQueue k) where foldr = foldrWithKey . const foldl f = foldlWithKey (const . f) length = size null = null instance Ord k => FoldableWithIndex k (MinPQueue k) where ifoldr = foldrWithKey ifoldl f = foldlWithKey (flip f) -- | Traverses in ascending order. 'mapM' is strictly accumulating like -- 'mapMWithKey'. instance Ord k => Traversable (MinPQueue k) where traverse = traverseWithKey . const mapM = mapMWithKey . const sequence = mapM id instance Ord k => TraversableWithIndex k (MinPQueue k) where itraverse = traverseWithKey pqueue-1.4.3.0/src/Data/PQueue/Prio/Max.hs0000644000000000000000000000520507346545000016212 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Prio.Max -- Copyright : (c) Louis Wasserman 2010 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- General purpose priority queue. -- Each element is associated with a /key/, and the priority queue supports -- viewing and extracting the element with the maximum key. -- -- A worst-case bound is given for each operation. In some cases, an amortized -- bound is also specified; these bounds hold even in a persistent context. -- -- This implementation is based on a binomial heap augmented with a global root. -- -- We do not guarantee stable behavior. -- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there -- are no guarantees about the relative order in which @k1@, @k2@, and their associated -- elements are returned. (Unlike Data.Map, we allow multiple elements with the -- same key.) -- -- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for -- unordered. No guarantees whatsoever are made on the execution or traversal order of -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Prio.Max ( MaxPQueue, -- * Construction empty, singleton, insert, 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, foldrWithKeyU, foldMapWithKeyU, foldlU, foldlU', foldlWithKeyU, foldlWithKeyU', traverseU, traverseWithKeyU, keysU, elemsU, assocsU, toListU, -- * Helper methods seqSpine ) where import Data.PQueue.Prio.Max.Internals import Prelude () pqueue-1.4.3.0/src/Data/PQueue/Prio/Max/0000755000000000000000000000000007346545000015654 5ustar0000000000000000pqueue-1.4.3.0/src/Data/PQueue/Prio/Max/Internals.hs0000644000000000000000000005323507346545000020157 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- 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 MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid) #endif import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) import qualified Data.Foldable as F 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 import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #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) # else deriving (Eq, Ord) # endif instance (NFData k, NFData a) => NFData (MaxPQueue k a) where rnf (MaxPQ q) = rnf q first' :: (a -> b) -> (a, c) -> (b, c) first' f (a, c) = (f a, c) #if MIN_VERSION_base(4,9,0) instance Ord k => Semigroup (MaxPQueue k a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} #endif instance Ord k => Monoid (MaxPQueue k a) where mempty = empty #if !MIN_VERSION_base(4,11,0) mappend = union #endif 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 FunctorWithIndex k (MaxPQueue k) where imap = mapWithKey instance Ord k => Foldable (MaxPQueue k) where foldr f z (MaxPQ q) = foldr f z q foldl f z (MaxPQ q) = foldl f z q length = size null = null instance Ord k => FoldableWithIndex k (MaxPQueue k) where ifoldr = foldrWithKey ifoldl f = foldlWithKey (flip f) -- | Traverses in descending order. 'mapM' is strictly accumulating like -- 'mapMWithKey'. instance Ord k => Traversable (MaxPQueue k) where traverse f (MaxPQ q) = MaxPQ <$> traverse f q mapM = mapMWithKey . const sequence = mapM id instance Ord k => TraversableWithIndex k (MaxPQueue k) where itraverse = traverseWithKey -- | \(O(1)\). Returns the empty priority queue. empty :: MaxPQueue k a 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 pqueue-1.4.3.0/src/Data/PQueue/Prio/Min.hs0000644000000000000000000003063107346545000016211 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.PQueue.Prio.Min -- Copyright : (c) Louis Wasserman 2010 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- General purpose priority queue. -- Each element is associated with a /key/, and the priority queue supports -- viewing and extracting the element with the minimum key. -- -- A worst-case bound is given for each operation. In some cases, an amortized -- bound is also specified; these bounds hold even in a persistent context. -- -- This implementation is based on a binomial heap augmented with a global root. -- -- We do not guarantee stable behavior. -- Ties are broken arbitrarily -- that is, if @k1 <= k2@ and @k2 <= k1@, then there -- are no guarantees about the relative order in which @k1@, @k2@, and their associated -- elements are returned. (Unlike Data.Map, we allow multiple elements with the -- same key.) -- -- This implementation offers a number of methods of the form @xxxU@, where @U@ stands for -- unordered. No guarantees whatsoever are made on the execution or traversal order of -- these functions. ----------------------------------------------------------------------------- module Data.PQueue.Prio.Min ( MinPQueue, -- * Construction empty, singleton, insert, insertBehind, union, unions, -- * Query null, size, -- ** Minimum view findMin, getMin, deleteMin, deleteFindMin, adjustMin, adjustMinA, adjustMinWithKey, adjustMinWithKeyA, updateMin, updateMinA, updateMinWithKey, updateMinWithKeyA, minView, minViewWithKey, -- * 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 qualified Data.List as List import Data.Maybe (fromMaybe) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup((<>))) #endif import Data.PQueue.Prio.Internals import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d (f .: g) x y = f (g x y) uncurry' :: (a -> b -> c) -> (a, b) -> c uncurry' f (a, b) = f a b infixr 8 .: -- | \(O(1)\). The minimal (key, element) in the queue. Calls 'error' if empty. findMin :: MinPQueue k a -> (k, a) findMin = fromMaybe (error "Error: findMin called on an empty queue") . getMin -- | \(O(\log n)\). Deletes the minimal (key, element) in the queue. Returns an empty queue -- if the queue is empty. deleteMin :: Ord k => MinPQueue k a -> MinPQueue k a deleteMin = updateMin (const Nothing) -- | \(O(\log n)\). Delete and find the element with the minimum key. Calls 'error' if empty. deleteFindMin :: Ord k => MinPQueue k a -> ((k, a), MinPQueue k a) deleteFindMin = fromMaybe (error "Error: deleteFindMin called on an empty queue") . minViewWithKey -- | \(O(1)\). Alter the value at the minimum key. If the queue is empty, does nothing. adjustMin :: (a -> a) -> MinPQueue k a -> MinPQueue k a adjustMin = adjustMinWithKey . const -- | \(O(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)\) 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. map :: (a -> b) -> MinPQueue k a -> MinPQueue k b map = mapWithKey . const -- | \(O(n)\). @'mapKeys' f q@ is the queue obtained by applying @f@ to each key of @q@. mapKeys :: Ord k' => (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeys f q = fromList [(f k, a) | (k, a) <- toListU q] -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybe :: Ord k => (a -> Maybe b) -> MinPQueue k a -> MinPQueue k b mapMaybe = mapMaybeWithKey . const -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEither :: Ord k => (a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) mapEither = mapEitherWithKey . const -- | \(O(n)\). Filter all values that satisfy the predicate. filter :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a filter = filterWithKey . const -- | \(O(n)\). Filter all values that satisfy the predicate. filterWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a filterWithKey p = mapMaybeWithKey (\k a -> if p k a then Just a else Nothing) -- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partition :: Ord k => (a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) partition = partitionWithKey . const -- | \(O(n)\). Partition the queue according to a predicate. The first queue contains all elements -- which satisfy the predicate, the second all elements that fail the predicate. partitionWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> (MinPQueue k a, MinPQueue k a) partitionWithKey p = mapEitherWithKey (\k a -> if p k a then Left a else Right a) {-# INLINE take #-} -- | \(O(k \log n)\)/. Takes the first @k@ (key, value) pairs in the queue, or the first @n@ if @k >= n@. -- (@'take' k q == 'List.take' k ('toAscList' q)@) take :: Ord k => Int -> MinPQueue k a -> [(k, a)] take n = List.take n . toAscList -- | \(O(k \log n)\)/. Deletes the first @k@ (key, value) pairs in the queue, or returns an empty queue if @k >= n@. drop :: Ord k => Int -> MinPQueue k a -> MinPQueue k a drop n0 q0 | n0 <= 0 = q0 | n0 >= size q0 = empty | otherwise = drop' n0 q0 where drop' n q | n == 0 = q | otherwise = drop' (n - 1) (deleteMin q) -- | \(O(k \log n)\)/. Equivalent to @('take' k q, 'drop' k q)@. splitAt :: Ord k => Int -> MinPQueue k a -> ([(k, a)], MinPQueue k a) splitAt n q | n <= 0 = ([], q) | otherwise = n `seq` case minViewWithKey q of Just (ka, q') -> let (kas, q'') = splitAt (n - 1) q' in (ka : kas, q'') _ -> ([], q) {-# INLINE takeWhile #-} -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (p . 'snd') ('toAscList' q)@) takeWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> [(k, a)] takeWhile = takeWhileWithKey . const {-# INLINE takeWhileWithKey #-} -- | Takes the longest possible prefix of elements satisfying the predicate. -- (@'takeWhile' p q == 'List.takeWhile' (uncurry p) ('toAscList' q)@) takeWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> [(k, a)] takeWhileWithKey p0 = takeWhileFB (uncurry' p0) . toAscList where takeWhileFB p xs = build (\c n -> foldr (\x z -> if p x then x `c` z else n) n xs) -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a dropWhile = dropWhileWithKey . const -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhileWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> MinPQueue k a dropWhileWithKey p q = case minViewWithKey q of Just ((k, a), q') | p k a -> dropWhileWithKey p q' _ -> q -- | Equivalent to @('takeWhile' p q, 'dropWhile' p q)@. span :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) span = spanWithKey . const -- | Equivalent to @'span' ('not' . p)@. break :: Ord k => (a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) break p = span (not . p) -- | Equivalent to @('takeWhileWithKey' p q, 'dropWhileWithKey' p q)@. spanWithKey :: Ord k => (k -> a -> Bool) -> MinPQueue k a -> ([(k, a)], MinPQueue k a) spanWithKey p q = case minViewWithKey q of Just (t@(k, a), q') | p k a -> let (kas, q'') = spanWithKey p q' in (t : kas, q'') _ -> ([], q) -- | Equivalent to @'spanWithKey' (\ k a -> 'not' (p k a)) q@. 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 a descending list of (key, value) pairs. /The precondition is not checked./ fromDescList :: [(k, a)] -> MinPQueue k a {-# 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. keys :: Ord k => MinPQueue k a -> [k] keys = List.map fst . toAscList {-# INLINE elems #-} -- | \(O(n \log n)\). Return all elements of the queue in ascending order by key. elems :: Ord k => MinPQueue k a -> [a] elems = List.map snd . toAscList {-# INLINE toList #-} -- | \(O(n \log n)\). Equivalent to 'toAscList'. -- -- If the traversal order is irrelevant, consider using 'toListU'. toList :: Ord k => MinPQueue k a -> [(k, a)] toList = toAscList {-# INLINE assocs #-} -- | \(O(n \log n)\). Equivalent to 'toAscList'. assocs :: Ord k => MinPQueue k a -> [(k, a)] assocs = toAscList {-# INLINE keysU #-} -- | \(O(n)\). Return all keys of the queue in no particular order. keysU :: MinPQueue k a -> [k] keysU = List.map fst . toListU {-# INLINE elemsU #-} -- | \(O(n)\). Return all elements of the queue in no particular order. elemsU :: MinPQueue k a -> [a] elemsU = List.map snd . toListU {-# INLINE assocsU #-} -- | \(O(n)\). Equivalent to 'toListU'. assocsU :: MinPQueue k a -> [(k, a)] assocsU = toListU -- | \(O(n)\). 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 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 pqueue-1.4.3.0/tests/0000755000000000000000000000000007346545000012514 5ustar0000000000000000pqueue-1.4.3.0/tests/PQueueTests.hs0000644000000000000000000004163407346545000015307 0ustar0000000000000000{-# language ExtendedDefaultRules #-} {-# language ScopedTypeVariables #-} {-# language TupleSections #-} 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 Data.Ord (Down(..)) import Test.Tasty import Test.Tasty.QuickCheck 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 default (Int) main :: IO () 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 ] ]