pqueue-1.5.0.0/0000755000000000000000000000000007346545000011350 5ustar0000000000000000pqueue-1.5.0.0/CHANGELOG.md0000644000000000000000000001051307346545000013161 0ustar0000000000000000# Revision history for pqueue ## 1.5.0.0 -- 2023-08-08 * Fix incorrect behavior of `mapMaybe` and `mapEither` for `MinQueue`. These previously worked only for monotonic functions. * Fix a performance bug that caused queue performance not to improve when the queue shrinks. ([#109](https://github.com/lspitzner/pqueue/pull/109)) * Make `minView` more eager, improving performance in typical cases. ([#107](https://github.com/lspitzner/pqueue/pull/107)) * Make mapping and traversal functions force the full data structure spine. This should make performance more predictable, and removes the last remaining reasons to use the `seqSpine` functions. As these are no longer useful, deprecate them. ([#103](https://github.com/lspitzner/pqueue/pull/103)) * Deprecate `insertBehind`. This function does not play nicely with merges, we lack tests to verify it works properly without merges, it imposes a substantial maintenance burden on the rest of the package, and it is quite slow. ([#35](https://github.com/lspitzner/pqueue/issues/35)) * Add pattern synonyms to work with `MinQueue` and `MinPQueue`. ([#92](http://github.com/lspitzner/pqueue/pull/92)) * Make the `Data` instances respect the queue invariants. Make the `Constr`s match the pattern synonyms. Make the `Data` instance for `MinPQueue` work "incrementally", like the one for `MinQueue`. ([#92](http://github.com/lspitzner/pqueue/pull/92)) ## 1.4.3.0 -- 2022-10-30 * Add instances for [indexed-traversable](https://hackage.haskell.org/package/indexed-traversable). ([#85](https://github.com/lspitzner/pqueue/pull/85)) * Add ghc-9.4 support. ([#86](https://github.com/lspitzner/pqueue/pull/86)) ## 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.5.0.0/LICENSE0000644000000000000000000000005307346545000012353 0ustar0000000000000000Copyright Louis Wasserman 2010 BSD license pqueue-1.5.0.0/README.md0000644000000000000000000000026107346545000012626 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.5.0.0/Setup.lhs0000644000000000000000000000011607346545000013156 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain pqueue-1.5.0.0/benchmarks/0000755000000000000000000000000007346545000013465 5ustar0000000000000000pqueue-1.5.0.0/benchmarks/BenchMinPQueue.hs0000644000000000000000000000337407346545000016640 0ustar0000000000000000import System.Random import Test.Tasty.Bench import qualified KWay.PrioMergeAlg as KWay import qualified PHeapSort as HS import qualified Data.PQueue.Prio.Min as P kWay :: Int -> Int -> Benchmark kWay i n = bench ("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)) filterQ :: Int -> Benchmark filterQ n = bench ("filter with " ++ show n ++ " elements") (whnf (P.drop 1 . P.filterWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 977209486631198655) partitionQ :: Int -> Benchmark partitionQ n = bench ("partition with " ++ show n ++ " elements") (whnf (P.drop 1 . snd . P.partitionWithKey (>) . (P.fromList :: [(Int, Int)] -> P.MinPQueue Int Int) . take n . randoms) $ mkStdGen 781928047937198) main :: IO () main = defaultMain [ bgroup "heapSort" [ 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 ] , bgroup "filter" [ filterQ (10^3) , filterQ (10^4) , filterQ (10^5) , filterQ (10^6) , filterQ (3*10^6) ] , bgroup "partition" [ partitionQ (10^3) , partitionQ (10^4) , partitionQ (10^5) , partitionQ (10^6) , partitionQ (3*10^6) ] ] pqueue-1.5.0.0/benchmarks/BenchMinQueue.hs0000644000000000000000000000326007346545000016512 0ustar0000000000000000import System.Random import Test.Tasty.Bench import qualified KWay.MergeAlg as KWay import qualified HeapSort as HS import qualified Data.PQueue.Min as P kWay :: Int -> Int -> Benchmark kWay i n = bench (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)) filterQ :: Int -> Benchmark filterQ n = bench ("filter with " ++ show n ++ " elements") (whnf (P.drop 1 . P.filter (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 977209486631198655) partitionQ :: Int -> Benchmark partitionQ n = bench ("partition with " ++ show n ++ " elements") (whnf (P.drop 1 . snd . P.partition (>0) . (P.fromList :: [Int] -> P.MinQueue Int) . take n . randoms) $ mkStdGen 781928047937198) main :: IO () main = defaultMain [ bgroup "heapSort" [ 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 ] , bgroup "filter" [ filterQ (10^3) , filterQ (10^4) , filterQ (10^5) , filterQ (10^6) , filterQ (3*10^6) ] , bgroup "partition" [ partitionQ (10^3) , partitionQ (10^4) , partitionQ (10^5) , partitionQ (10^6) , partitionQ (3*10^6) ] ] pqueue-1.5.0.0/benchmarks/HeapSort.hs0000644000000000000000000000043407346545000015547 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.5.0.0/benchmarks/KWay/0000755000000000000000000000000007346545000014340 5ustar0000000000000000pqueue-1.5.0.0/benchmarks/KWay/MergeAlg.hs0000644000000000000000000000155007346545000016360 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.5.0.0/benchmarks/KWay/PrioMergeAlg.hs0000644000000000000000000000106007346545000017206 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.5.0.0/benchmarks/KWay/RandomIncreasing.hs0000644000000000000000000000124307346545000020117 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.5.0.0/benchmarks/PHeapSort.hs0000644000000000000000000000053007346545000015664 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.5.0.0/pqueue.cabal0000644000000000000000000000744107346545000013646 0ustar0000000000000000name: pqueue version: 1.5.0.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.7, GHC == 9.4.5, GHC == 9.6.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.19 , 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 Nattish 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: src, tests default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: PQueueTests.hs build-depends: { base >= 4.8 && < 4.19 , deepseq >= 1.3 && < 1.5 , indexed-traversable >= 0.1 && < 0.2 , tasty , tasty-quickcheck } other-modules: Data.PQueue.Prio.Min Data.PQueue.Prio.Max Data.PQueue.Min Data.PQueue.Max Data.PQueue.Prio.Internals Data.PQueue.Internals BinomialQueue.Internals BinomialQueue.Min BinomialQueue.Max Data.PQueue.Internals.Down Data.PQueue.Internals.Foldable Data.PQueue.Prio.Max.Internals Nattish Validity.BinomialQueue Validity.PQueue.Min Validity.PQueue.Prio.BinomialQueue Validity.PQueue.Prio.Min Validity.PQueue.Prio.Max if impl(ghc) { default-extensions: DeriveDataTypeable } ghc-options: -Wall -fno-warn-type-defaults 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.5.0.0/src/BinomialQueue/0000755000000000000000000000000007346545000014676 5ustar0000000000000000pqueue-1.5.0.0/src/BinomialQueue/Internals.hs0000644000000000000000000006714207346545000017203 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, insertEager, 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. According to our benchmarks, it -- doesn't make a significant or consistent difference even in non-persistent -- code (heap sort and k-way merge). -- -- Debit invariant: -- -- 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) -- | \(O(\log n)\), but a fast \(O(1)\) average when inserting repeatedly in -- an empty queue or at least around \(O(\log n)\) times into a nonempty one. -- Insert an element into the priority queue. This is good for 'fromList'-like -- operations. insertEager :: Ord a => a -> MinQueue a -> MinQueue a insertEager x (MinQueue ts) = MinQueue (incr' (tip x) ts) {-# INLINE insertEager #-} -- | Amortized \(O(\log \min(n,m))\), worst-case \(O(\log \max(n,m))\). Take the union of two priority queues. union :: Ord a => MinQueue a -> MinQueue a -> MinQueue a union (MinQueue f1) (MinQueue f2) = MinQueue (merge f1 f2) -- | 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 = flip foldlU' empty $ \q a -> case f a of Nothing -> q Just b -> insertEager b q -- This seems to be needed for specialization. {-# INLINABLE mapMaybe #-} -- | \(O(n)\). Map elements and separate the 'Left' and 'Right' results. mapEither :: (Ord b, Ord c) => (a -> Either b c) -> MinQueue a -> (MinQueue b, MinQueue c) mapEither f = fromPartition . foldlU' (\(Partition ls rs) a -> case f a of Left b -> Partition (insertEager b ls) rs Right b -> Partition ls (insertEager b rs)) (Partition empty empty) -- This seems to be needed for specialization. {-# INLINABLE mapEither #-} -- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, -- as in 'fmap'. If it is not, the result is undefined. 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) -- Note: We used to apply Skip lazily here, and to use the lazy incr, for fear -- that the potential cascade of carries would be more expensive than leaving -- those carries suspended and letting subsequent operations force them. -- However, our benchmarks indicated that doing these strictly was -- faster. Note that even if we chose to go back to incr (rather than incr'), -- it's even more clearly worse to apply Skip lazily— forcing the result of -- incr in this context doesn't cause a cascade, because the child of any Cons -- will come from an Extract, and therefore be in WHNF already. incrExtract' :: Ord a => BinomTree rk a -> Extract (Succ rk) a -> Extract rk a incrExtract' t (Extract minKey (Succ kChild kChildren) ts) = Extract minKey kChildren (Skip $! incr' (t `joinBin` kChild) ts) -- | 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) -- | When the heap size is a power of two and we extract from it, we have -- to shrink the spine by one. This function takes care of that. skip :: BinomForest (Succ rk) a -> BinomForest rk a skip Nil = Nil skip f = Skip f {-# INLINE skip #-} data Partition a b = Partition !(MinQueue a) !(MinQueue b) fromPartition :: Partition a b -> (MinQueue a, MinQueue b) fromPartition (Partition p q) = (p, q) {-# INLINE tip #-} -- | Constructs a binomial tree of rank 0. 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 = foldl' (flip insertEager) empty xs -- | Given two binomial forests starting at rank @rk@, takes their union. -- Each successive application of this function costs \(O(1)\), so applying it -- 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.5.0.0/src/BinomialQueue/Max.hs0000644000000000000000000002443707346545000015771 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 = toDescList q List.!! n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MaxQueue a -> [a] takeWhile p = fmap unDown . MinQ.takeWhile (p . unDown) . unMaxQueue -- | '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.5.0.0/src/BinomialQueue/Min.hs0000644000000000000000000001630207346545000015757 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 = toAscList q List.!! n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] takeWhile p = List.takeWhile p . toAscList -- | '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.5.0.0/src/Data/PQueue/0000755000000000000000000000000007346545000014214 5ustar0000000000000000pqueue-1.5.0.0/src/Data/PQueue/Internals.hs0000644000000000000000000003166007346545000016515 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__ -- | Treats the priority queue as an empty queue or a minimal element and a -- priority queue. The constructors, conceptually, are 'Data.PQueue.Min.Empty' -- and '(Data.PQueue.Min.:<)'. All constructed queues maintain the queue -- invariants. instance (Ord a, Data a) => Data (MinQueue a) where gfoldl f z q = case minView q of Nothing -> z Empty Just (x, q') -> z insert `f` x `f` q' gunfold k z c = case constrIndex c of 1 -> z Empty 2 -> k (k (z insert)) _ -> error "gunfold: invalid constructor for MinQueue" 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.insertEager` 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 -> let !l' = fromBare (BQ.insertEager y l) !r' = fromBare r in (l', r') Right z -> let !l' = fromBare l !r' = fromBare (BQ.insertEager z r) in (l', r') -- | \(O(n)\). Assumes that the function it is given is monotonic, and applies this function to every element of the priority queue, -- as in 'fmap'. If it is not, the result is undefined. 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) -- | \(O(n)\). Assumes that the function it is given is (weakly) monotonic, and -- applies this function to every element of the priority queue, as in 'fmap'. -- If the function is not monotonic, the result is undefined. 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. In earlier -- versions of this package, some operations could produce chains of thunks -- along the spine, occasionally necessitating manual forcing. Now, all -- operations are careful to force enough to avoid this problem. {-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MinQueue a -> b -> b seqSpine Empty z = z seqSpine (MinQueue _ _ ts) z = BQ.seqSpine ts z 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.5.0.0/src/Data/PQueue/Internals/0000755000000000000000000000000007346545000016153 5ustar0000000000000000pqueue-1.5.0.0/src/Data/PQueue/Internals/Down.hs0000644000000000000000000000145207346545000017420 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.5.0.0/src/Data/PQueue/Internals/Foldable.hs0000644000000000000000000000117707346545000020225 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' (..) ) where class Foldr t where foldr_ :: (a -> b -> b) -> b -> t a -> b class Foldl t where foldl_ :: (b -> a -> b) -> b -> t a -> b class FoldMap t where foldMap_ :: Monoid m => (a -> m) -> t a -> m class Foldl' t where foldl'_ :: (b -> a -> b) -> b -> t a -> b pqueue-1.5.0.0/src/Data/PQueue/Max.hs0000644000000000000000000003256407346545000015307 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. In earlier -- versions of this package, some operations could produce chains of thunks -- along the spine, occasionally necessitating manual forcing. Now, all -- operations are careful to force enough to avoid this problem. {-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MaxQueue a -> b -> b seqSpine (MaxQ q) = Min.seqSpine q pqueue-1.5.0.0/src/Data/PQueue/Min.hs0000644000000000000000000002146107346545000015277 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef __GLASGOW_HASKELL__ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #endif ----------------------------------------------------------------------------- -- | -- 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 ( #if __GLASGOW_HASKELL__ >= 802 MinQueue (Data.PQueue.Min.Empty, (:<)), #elif defined (__GLASGOW_HASKELL__) MinQueue, pattern Data.PQueue.Min.Empty, pattern (:<), #endif -- * Basic operations empty, null, 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 hiding (MinQueue (..)) import Data.PQueue.Internals (MinQueue (MinQueue)) import qualified Data.PQueue.Internals as Internals import qualified BinomialQueue.Internals as BQ import qualified Data.PQueue.Prio.Internals as Prio #ifdef __GLASGOW_HASKELL__ import GHC.Exts (build) #else build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif #ifdef __GLASGOW_HASKELL__ -- | A bidirectional pattern synonym for an empty priority queue. -- -- @since 1.5.0 pattern Empty :: MinQueue a pattern Empty = Internals.Empty # if __GLASGOW_HASKELL__ >= 902 {-# INLINE CONLIKE Empty #-} # endif infixr 5 :< -- | A bidirectional pattern synonym for working with the minimum view of a -- 'MinQueue'. Using @:<@ to construct a queue performs an insertion in -- \(O(1)\) amortized time. When matching on @a :< q@, forcing @q@ takes -- \(O(\log n)\) time. -- -- @since 1.5.0 # if __GLASGOW_HASKELL__ >= 800 pattern (:<) :: Ord a => a -> MinQueue a -> MinQueue a # else pattern (:<) :: () => Ord a => a -> MinQueue a -> MinQueue a # endif pattern a :< q <- (minView -> Just (a, q)) where a :< q = insert a q # if __GLASGOW_HASKELL__ >= 902 {-# INLINE (:<) #-} # endif {-# COMPLETE Empty, (:<) #-} #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 = toAscList q List.!! n {-# INLINE takeWhile #-} -- | 'takeWhile', applied to a predicate @p@ and a queue @queue@, returns the -- longest prefix (possibly empty) of @queue@ of elements that satisfy @p@. takeWhile :: Ord a => (a -> Bool) -> MinQueue a -> [a] takeWhile p = List.takeWhile p . toAscList -- | '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 = Internals.Empty keysQueue (Prio.MinPQ n k _ ts) = MinQueue n k (BQ.MinQueue (keysF (const Zero) ts)) keysF :: (pRk k a -> rk k) -> Prio.BinomForest pRk k a -> BinomForest rk k keysF f ts0 = case ts0 of Prio.Nil -> Nil Prio.Skip ts' -> Skip $! keysF f' ts' Prio.Cons (Prio.BinomTree k ts) ts' -> Cons (BinomTree k (f ts)) $! keysF f' ts' where f' (Prio.Succ (Prio.BinomTree k ts) tss) = Succ (BinomTree k (f ts)) (f tss) pqueue-1.5.0.0/src/Data/PQueue/Prio/0000755000000000000000000000000007346545000015125 5ustar0000000000000000pqueue-1.5.0.0/src/Data/PQueue/Prio/Internals.hs0000644000000000000000000007633607346545000017437 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.PQueue.Prio.Internals ( MinPQueue(..), BinomForest(..), BinomHeap, BinomTree(..), Zero(..), Succ(..), empty, null, size, singleton, insert, insertBehind, insertEager, 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, unions ) where import Control.Applicative (liftA2, liftA3, Const (..)) import Control.DeepSeq (NFData(rnf), deepseq) import Data.Coerce (coerce) import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Data.List as List #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup(..), stimesMonoid, Endo (..), Dual (..)) #else import Data.Monoid ((<>), Endo (..), Dual (..)) #endif import Prelude hiding (null, map) #ifdef __GLASGOW_HASKELL__ import Data.Data import GHC.Exts (build, inline) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, readListPrecDefault) #endif import Data.Functor.WithIndex import Data.Foldable.WithIndex import Data.Traversable.WithIndex import Nattish (Nattish (..)) #ifndef __GLASGOW_HASKELL__ build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build f = f (:) [] #endif #if __GLASGOW_HASKELL__ -- | Treats the priority queue as an empty queue or a minimal -- key-value pair and a priority queue. The constructors, conceptually, -- are 'Data.PQueue.Prio.Min.Empty' and '(Data.PQueue.Prio.Min.:<)'. -- -- 'gfoldl' is nondeterministic; any minimal pair may be chosen as -- the first. All constructed queues maintain the queue invariants. instance (Ord k, Data k, Data a) => Data (MinPQueue k a) where gfoldl f z q = case minViewWithKey q of Nothing -> z Empty Just (x, q') -> z (\(k, a) -> insert k a) `f` x `f` q' gunfold k z c = case constrIndex c of 1 -> z Empty 2 -> k (k (z (\(key, val) -> insert key val))) _ -> error "gunfold: invalid constructor for MinPQueue" toConstr q | null q = emptyConstr | otherwise = consConstr dataTypeOf _ = queueDataType dataCast1 f = gcast1 f dataCast2 f = gcast2 f queueDataType :: DataType queueDataType = mkDataType "Data.PQueue.Prio.Min.MinPQueue" [emptyConstr, consConstr] emptyConstr, consConstr :: Constr emptyConstr = mkConstr queueDataType "Empty" [] Prefix consConstr = mkConstr queueDataType ":<" [] Infix #endif #if MIN_VERSION_base(4,9,0) instance Ord k => Semigroup (MinPQueue k a) where (<>) = union stimes = stimesMonoid {-# INLINABLE stimes #-} #endif instance Ord k => Monoid (MinPQueue k a) where mempty = empty #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) infixr 8 .: -- | A priority queue where keys of type @k@ are annotated with values of type -- @a@. The queue supports extracting the key-value pair with minimum key. data MinPQueue k a = Empty | MinPQ {-# UNPACK #-} !Int !k a !(BinomHeap k a) data BinomForest rk k a = 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 (rk k a) newtype Zero k a = Zero a data Succ rk k a = Succ {-# UNPACK #-} !(BinomTree rk k a) (rk k a) instance (Ord k, Eq a) => Eq (MinPQueue k a) where MinPQ n1 k1 a1 ts1 == MinPQ n2 k2 a2 ts2 = n1 == n2 && eqExtract k1 a1 ts1 k2 a2 ts2 Empty == Empty = True _ == _ = False eqExtract :: (Ord k, Eq a) => k -> a -> BinomHeap k a -> k -> a -> BinomHeap k a -> Bool eqExtract k10 a10 ts10 k20 a20 ts20 = k10 == k20 && a10 == a20 && case (extract ts10, extract ts20) of (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero 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 -> BinomHeap k a -> k -> a -> BinomHeap k a -> Ordering cmpExtract k10 a10 ts10 k20 a20 ts20 = k10 `compare` k20 <> a10 `compare` a20 <> case (extract ts10, extract ts20) of (Yes (Extract k1 (Zero a1) ts1'), Yes (Extract k2 (Zero 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) insertEager :: Ord k => k -> a -> MinPQueue k a -> MinPQueue k a insertEager k a Empty = singleton k a insertEager k a (MinPQ n k' a' ts) | k <= k' = MinPQ (n + 1) k a (insertEagerHeap k' a' ts) | otherwise = MinPQ (n + 1) k' a' (insertEagerHeap k a ts) -- | \(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. {-# DEPRECATED insertBehind "This function is not reliable." #-} 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 (coerce f) -- | \(O(n)\). @'mapKeysMonotonic' f q == 'mapKeys' f q@, but only works when -- @f@ is (weakly) monotonic. /The precondition is not checked./ This function -- has better performance than 'mapKeys'. -- -- Note: if the given function returns bottom for any of the keys in the queue, then the -- portion of the queue which is bottom is /unspecified/. mapKeysMonotonic :: (k -> k') -> MinPQueue k a -> MinPQueue k' a mapKeysMonotonic _ Empty = Empty mapKeysMonotonic f (MinPQ n k a ts) = MinPQ n (f k) a $! mapKeysMonoHeap f ts mapKeysMonoHeap :: forall k k' a. (k -> k') -> BinomHeap k a -> BinomHeap k' a mapKeysMonoHeap f = mapKeysMonoForest Zeroy where mapKeysMonoForest :: Ranky rk -> BinomForest rk k a -> BinomForest rk k' a mapKeysMonoForest !_rky Nil = Nil mapKeysMonoForest !rky (Skip rest) = Skip $! mapKeysMonoForest (Succy rky) rest mapKeysMonoForest !rky (Cons t rest) = Cons (mapKeysMonoTree rky t) $! mapKeysMonoForest (Succy rky) rest {-# INLINE mapKeysMonoTree #-} mapKeysMonoTree :: Ranky rk -> BinomTree rk k a -> BinomTree rk k' a mapKeysMonoTree Zeroy (BinomTree k (Zero a)) = -- We've reached a value, which we must not force. BinomTree (f k) (Zero a) -- We're not at a value; we force the result. mapKeysMonoTree (Succy rky) (BinomTree k ts) = BinomTree (f k) $! mapKeysMonoTrees rky ts mapKeysMonoTrees :: Ranky rk -> Succ rk k a -> Succ rk k' a mapKeysMonoTrees Zeroy (Succ t (Zero a)) = -- Don't force the value! Succ (mapKeysMonoTree Zeroy t) (Zero a) mapKeysMonoTrees (Succy rky) (Succ t ts) = -- Whew, no values; force the trees. Succ (mapKeysMonoTree (Succy rky) t) $! mapKeysMonoTrees rky ts -- | \(O(n)\). Map values and collect the 'Just' results. mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> MinPQueue k a -> MinPQueue k b mapMaybeWithKey f = fromBare . foldlWithKeyU' (\q k a -> case f k a of Nothing -> q Just b -> insertEagerHeap k b q) Nil {-# INLINABLE mapMaybeWithKey #-} -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (MinPQueue k b, MinPQueue k c) mapEitherWithKey f q | (l, r) <- mapEitherHeap f q , let !l' = fromBare l !r' = fromBare r = (l', r') {-# INLINABLE mapEitherWithKey #-} data Partition k a b = Partition !(BinomHeap k a) !(BinomHeap k b) fromPartition :: Partition k a b -> (BinomHeap k a, BinomHeap k b) fromPartition (Partition p q) = (p, q) mapEitherHeap :: Ord k => (k -> a -> Either b c) -> MinPQueue k a -> (BinomHeap k b, BinomHeap k c) mapEitherHeap f = fromPartition . foldlWithKeyU' (\(Partition ls rs) k a -> case f k a of Left b -> Partition (insertEagerHeap k b ls) rs Right b -> Partition ls (insertEagerHeap k b rs)) (Partition Nil Nil) insertEagerHeap :: Ord k => k -> a -> BinomHeap k a -> BinomHeap k a insertEagerHeap k a h = incr' (tip k a) h {-# INLINE insertEagerHeap #-} -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldrWithKey' f z q == 'List.foldr' ('uncurry' f) z ('toAscList' q)@. -- -- 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 (Zero a) ts') -> f k a (foldF ts') No -> z -- | \(O(n \log n)\). Fold the keys and values in the map, such that -- @'foldlWithKey' f z q == 'List.foldl' ('uncurry' . f) z ('toAscList' q)@. -- -- 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 (Zero a) ts') -> foldF (f z k a) ts' No -> z {-# INLINABLE [1] toAscList #-} -- | \(O(n \log n)\). Return all (key, value) pairs in ascending order by key. 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 typically saves us one -- comparison per element, which roughly halves comparisons. fromList xs = fromBare (fromListHeap xs) fromBare :: Ord k => BinomHeap k a -> MinPQueue k a fromBare xs = case extract xs of No -> Empty -- Should we track the size as we go instead? That saves O(log n) -- at the end, but it needs an extra register all along the way. -- The nodes should probably all be in L1 cache already thanks to the -- extractHeap. Yes (Extract k (Zero v) f) -> MinPQ (sizeHeap f + 1) k v f {-# INLINE fromListHeap #-} fromListHeap :: Ord k => [(k, a)] -> BinomHeap k a fromListHeap xs = List.foldl' go Nil xs where go fr (k, a) = insertEagerHeap 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 (Zero a) -- | \(O(1)\). Takes the union of two binomial trees of the same rank. meld :: Ord k => BinomTree rk k a -> BinomTree rk k a -> BinomTree (Succ rk) k a meld t1@(BinomTree k1 ts1) t2@(BinomTree k2 ts2) | k1 <= k2 = BinomTree k1 (Succ t2 ts1) | otherwise = BinomTree k2 (Succ t1 ts2) -- | Takes the union of two binomial forests, starting at the same rank. Analogous to binary addition. mergeForest :: Ord k => BinomForest rk k a -> BinomForest rk k a -> BinomForest rk k a 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 ts) tss = case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' Cons t' tss' -> tss' `seq` Skip (incrMin (BinomTree k (Succ t' ts)) tss') -- | Inserts a binomial tree into a binomial forest. Assumes that the root of this tree -- is less than all other roots. Analogous to binary incrementation. Equivalent to -- @'incr'' (\_ _ -> True)@. Forces the rebuilt portion of the spine. incrMin' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incrMin' t@(BinomTree k ts) tss = case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' Cons t' tss' -> Skip $! incrMin' (BinomTree k (Succ t' ts)) tss' -- | See 'insertMax'' for invariant info. incrMax' :: BinomTree rk k a -> BinomForest rk k a -> BinomForest rk k a incrMax' t tss = t `seq` case tss of Nil -> Cons t Nil Skip tss' -> Cons t tss' Cons (BinomTree k ts) tss' -> Skip $! incrMax' (BinomTree k (Succ t ts)) tss' extractHeap :: Ord k => Int -> BinomHeap k a -> MinPQueue k a extractHeap n ts = n `seq` case extract ts of No -> Empty Yes (Extract k (Zero a) ts') -> MinPQ (n - 1) k a ts' -- | A specialized type intended to organize the return of extract-min queries -- from a binomial forest. We walk all the way through the forest, and then -- 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 (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 (Succ kChild kChildren) ts) = Extract minKey kChildren (Cons kChild ts) incrExtract' :: Ord k => BinomTree rk k a -> Extract (Succ rk) k a -> Extract rk k a incrExtract' t (Extract minKey (Succ kChild kChildren) ts) = Extract minKey kChildren (Skip $! incr' (t `meld` kChild) ts) -- | Walks backward from the biggest key in the forest, as far as rank @rk@. -- Returns its progress. Each successive application of @extractBin@ takes -- 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 ts) f) = Yes $ case go k f of No -> Extract k ts (skip f) Yes ex -> incrExtract' t ex go :: Ord k => k -> BinomForest rk k a -> MExtract rk k a 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 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 ts (skip f)) Yes ex -> Yes (incrExtract' t ex) skip :: BinomForest (Succ rk) k a -> BinomForest rk k a skip Nil = Nil skip f = Skip f {-# INLINE skip #-} -- | \(O(n)\). An unordered right fold over the elements of the queue, in no particular order. foldrWithKeyU :: (k -> a -> b -> b) -> b -> MinPQueue k a -> b foldrWithKeyU c n = flip appEndo n . inline foldMapWithKeyU (coerce c) -- | \(O(n)\). An unordered monoidal fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldMapWithKeyU :: forall m k a. Monoid m => (k -> a -> m) -> MinPQueue k a -> m foldMapWithKeyU = coerce (inline traverseWithKeyU :: (k -> a -> Const m ()) -> MinPQueue k a -> Const m (MinPQueue k ())) -- | \(O(n)\). An unordered left fold over the elements of the queue, in no -- particular order. This is rarely what you want; 'foldrWithKeyU' and -- 'foldlWithKeyU'' are more likely to perform well. foldlWithKeyU :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b foldlWithKeyU f b = flip appEndo b . getDual . foldMapWithKeyU (\k a -> Dual $ Endo $ \r -> f r k a) -- | \(O(n)\). An unordered strict left fold over the elements of the queue, in no particular order. -- -- @since 1.4.2 foldlWithKeyU' :: (b -> k -> a -> b) -> b -> MinPQueue k a -> b foldlWithKeyU' f !b q = case q of Empty -> b MinPQ _n k a ts -> foldlHeapU' f (f b k a) ts foldlHeapU' :: forall k a b. (b -> k -> a -> b) -> b -> BinomHeap k a -> b foldlHeapU' f = \b -> foldlForest' Zeroy b where foldlForest' :: Ranky rk -> b -> BinomForest rk k a -> b foldlForest' !_rky !acc Nil = acc foldlForest' !rky !acc (Skip rest) = foldlForest' (Succy rky) acc rest foldlForest' !rky !acc (Cons t rest) = foldlForest' (Succy rky) (foldlTree' rky acc t) rest {-# INLINE foldlTree' #-} foldlTree' :: Ranky rk -> b -> BinomTree rk k a -> b foldlTree' !rky !acc (BinomTree k ts) = foldlTrees' rky acc k ts foldlTrees' :: Ranky rk -> b -> k -> rk k a -> b foldlTrees' Zeroy !acc !k (Zero a) = f acc k a foldlTrees' (Succy rky) !acc !k (Succ t ts) = foldlTrees' rky (foldlTree' rky acc t) k ts -- | \(O(n \log n)\). Traverses the elements of the queue in ascending order by key. -- (@'traverseWithKey' f q == 'fromAscList' <$> 'traverse' ('uncurry' f) ('toAscList' q)@) -- -- 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' -- | Natural numbers revealing whether something is 'Zero' or 'Succ'. type Ranky = Nattish Zero Succ -- | \(O(n)\). An unordered traversal over a priority queue, in no particular order. -- While there is no guarantee in which order the elements are traversed, the resulting -- priority queue will be perfectly valid. {-# INLINABLE traverseWithKeyU #-} traverseWithKeyU :: forall f k a b. Applicative f => (k -> a -> f b) -> MinPQueue k a -> f (MinPQueue k b) traverseWithKeyU _ Empty = pure Empty traverseWithKeyU f (MinPQ n k a ts) = liftA2 (\a' !ts' -> MinPQ n k a' ts') (f k a) (traverseHeapU f ts) {-# INLINABLE traverseHeapU #-} traverseHeapU :: forall f k a b. Applicative f => (k -> a -> f b) -> BinomHeap k a -> f (BinomHeap k b) traverseHeapU f = traverseForest Zeroy where traverseForest :: Ranky rk -> BinomForest rk k a -> f (BinomForest rk k b) traverseForest !_rky Nil = pure Nil traverseForest !rky (Skip rest) = (Skip $!) <$> traverseForest (Succy rky) rest traverseForest !rky (Cons t rest) = liftA2 (\ !t' !rest' -> Cons t' rest') (traverseTree rky t) (traverseForest (Succy rky) rest) {-# INLINE traverseTree #-} traverseTree :: Ranky rk -> BinomTree rk k a -> f (BinomTree rk k b) traverseTree Zeroy (BinomTree k (Zero a)) = -- We've reached a value, so we don't force the result. BinomTree k . Zero <$> f k a traverseTree (Succy rky) (BinomTree k ts) = -- We're not at a value, so we force the tree list. (BinomTree k $!) <$> traverseTrees rky k ts traverseTrees :: Ranky rk -> k -> Succ rk k a -> f (Succ rk k b) traverseTrees Zeroy !k2 (Succ (BinomTree k1 (Zero a1)) (Zero a2)) = -- The right subtree is a value, so we don't force it. liftA2 (\b1 b2 -> Succ (BinomTree k1 (Zero b1)) (Zero b2)) (f k1 a1) (f k2 a2) traverseTrees (Succy rky) !k (Succ t ts) = -- Whew; no values. We're safe to force. liftA2 (\ !t' !ts' -> Succ t' ts') (traverseTree (Succy rky) t) (traverseTrees rky k ts) -- | \(O(\log n)\). @seqSpine q r@ forces the spine of @q@ and returns @r@. -- -- Note: The spine of a 'MinPQueue' is stored somewhat lazily. In earlier -- versions of this package, some operations could produce chains of thunks -- along the spine, occasionally necessitating manual forcing. Now, all -- operations are careful to force enough to avoid this problem. {-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MinPQueue k a -> b -> b seqSpine Empty z0 = z0 seqSpine (MinPQ _ _ _ ts0) z0 = ts0 `seqSpineF` z0 where 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 (Zero a) = rnf a instance NFRank rk => NFRank (Succ rk) where rnfRk (Succ t ts) = t `deepseq` rnfRk ts instance (NFData k, NFData a, NFRank rk) => NFData (BinomTree rk k a) where rnf (BinomTree k ts) = k `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 = imap . const instance FunctorWithIndex k (MinPQueue k) where imap = coerce (traverseWithKeyU :: (k -> a -> Identity b) -> MinPQueue k a -> Identity (MinPQueue k b)) 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.5.0.0/src/Data/PQueue/Prio/Max.hs0000644000000000000000000000520507346545000016210 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.5.0.0/src/Data/PQueue/Prio/Max/0000755000000000000000000000000007346545000015652 5ustar0000000000000000pqueue-1.5.0.0/src/Data/PQueue/Prio/Max/Internals.hs0000644000000000000000000005336507346545000020161 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. {-# DEPRECATED insertBehind "This function is not reliable." #-} 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. In earlier -- versions of this package, some operations could produce chains of thunks -- along the spine, occasionally necessitating manual forcing. Now, all -- operations are careful to force enough to avoid this problem. {-# DEPRECATED seqSpine "This function is no longer necessary or useful." #-} seqSpine :: MaxPQueue k a -> b -> b seqSpine (MaxPQ q) = Q.seqSpine q pqueue-1.5.0.0/src/Data/PQueue/Prio/Min.hs0000644000000000000000000003265607346545000016220 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- 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 ( #if __GLASGOW_HASKELL__ >= 802 MinPQueue (Data.PQueue.Prio.Min.Empty, (:<)), #elif defined (__GLASGOW_HASKELL__) MinPQueue, pattern Data.PQueue.Prio.Min.Empty, pattern (:<), #endif -- * Construction empty, singleton, insert, insertBehind, union, unions, -- * Query 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 hiding (MinPQueue (..)) import Data.PQueue.Prio.Internals (MinPQueue) import qualified Data.PQueue.Prio.Internals as Internals import Prelude hiding (map, filter, break, span, takeWhile, dropWhile, splitAt, take, drop, (!!), null) #ifdef __GLASGOW_HASKELL__ -- | A bidirectional pattern synonym for an empty priority queue. -- -- @since 1.5.0 pattern Empty :: MinPQueue k a pattern Empty = Internals.Empty # if __GLASGOW_HASKELL__ >= 902 {-# INLINE CONLIKE Empty #-} # endif infixr 5 :< -- | A bidirectional pattern synonym for working with the minimum view of a -- 'MinPQueue'. Using @:<@ to construct a queue performs an insertion in -- \(O(1)\) amortized time. When matching on @(k, a) :< q@, forcing @q@ takes -- \(O(\log n)\) time. -- -- @since 1.5.0 # if __GLASGOW_HASKELL__ >= 800 pattern (:<) :: Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a # else pattern (:<) :: () => Ord k => (k, a) -> MinPQueue k a -> MinPQueue k a # endif pattern ka :< q <- (minViewWithKey -> Just (ka, q)) where (k, a) :< q = insert k a q # if __GLASGOW_HASKELL__ >= 902 {-# INLINE (:<) #-} # endif {-# COMPLETE Empty, (:<) #-} #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 = List.takeWhile (uncurry' p0) . toAscList -- | Removes the longest possible prefix of elements satisfying the predicate. dropWhile :: Ord k => (a -> Bool) -> MinPQueue k a -> MinPQueue k a 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.5.0.0/src/0000755000000000000000000000000007346545000012137 5ustar0000000000000000pqueue-1.5.0.0/src/Nattish.hs0000644000000000000000000000472107346545000014111 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 904 {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE ViewPatterns #-} #endif -- | A facility for faking GADTs that work sufficiently similarly -- to unary natural numbers. module Nattish ( Nattish (Zeroy, Succy) ) where import Unsafe.Coerce (unsafeCoerce) #if __GLASGOW_HASKELL__ >= 800 import Data.Kind (Type) #endif -- | Conceptually, -- -- @ -- data Nattish :: forall k. k -> (k -> k) -> k -> Type where -- Zeroy :: Nattish zero succ zero -- Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n) -- @ -- -- This abstracts over the zero and successor constructors, so it can be used -- in any sufficiently Nat-like context. In our case, we can use it for the @Zero@ -- and @Succ@ constructors of both @MinQueue@ and @MinPQueue@. With recent -- versions of GHC, @Nattish@ is actually represented as a machine integer, so -- it is very fast to work with. #if __GLASGOW_HASKELL__ < 904 data Nattish :: k -> (k -> k) -> k -> * where Zeroy :: Nattish zero succ zero Succy :: !(Nattish zero succ n) -> Nattish zero succ (succ n) toWord :: Nattish zero succ n -> Word toWord = go 0 where go :: Word -> Nattish zero succ n -> Word go !acc Zeroy = acc go !acc (Succy n) = go (acc + 1) n instance Show (Nattish zero succ n) where showsPrec p n = showParen (p > 10) $ showString "Nattish " . showsPrec 11 (toWord n) #else type Nattish :: forall k. k -> (k -> k) -> k -> Type newtype Nattish zero succ n = Nattish Word deriving (Show) type role Nattish nominal nominal nominal data Res zero succ n where ResZero :: Res zero succ zero ResSucc :: !(Nattish zero succ n) -> Res zero succ (succ n) check :: Nattish zero succ n -> Res zero succ n check (Nattish 0) = unsafeCoerce ResZero check (Nattish n) = unsafeCoerce $ ResSucc (Nattish (n - 1)) pattern Zeroy :: forall {k} zero succ (n :: k). () => n ~ zero => Nattish zero succ n pattern Zeroy <- (check -> ResZero) where Zeroy = Nattish 0 {-# INLINE Zeroy #-} pattern Succy :: forall {k} zero succ (n :: k). () => forall (n' :: k). n ~ succ n' => Nattish zero succ n' -> Nattish zero succ n pattern Succy n <- (check -> ResSucc n) where Succy (Nattish n) = Nattish (n + 1) {-# INLINE Succy #-} {-# COMPLETE Zeroy, Succy #-} #endif pqueue-1.5.0.0/tests/0000755000000000000000000000000007346545000012512 5ustar0000000000000000pqueue-1.5.0.0/tests/PQueueTests.hs0000644000000000000000000005053307346545000015303 0ustar0000000000000000{-# language CPP #-} {-# language BangPatterns #-} {-# language ExtendedDefaultRules #-} {-# language ScopedTypeVariables #-} {-# language TupleSections #-} {-# language ViewPatterns #-} module Main (main) where import Data.Bifunctor (bimap, first, second) import qualified Data.Either as Either import Data.Function (on) import Data.Functor.Identity import qualified Data.List as List import qualified Data.Maybe as Maybe import Data.Ord (Down(..)) import Test.Tasty 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 import qualified Validity.PQueue.Min as VMin import qualified Validity.PQueue.Prio.Min as VPMin import qualified Validity.PQueue.Prio.Max as VPMax default (Int) validMinQueue :: Ord a => Min.MinQueue a -> Property validMinQueue q = VMin.validShape q .&&. VMin.validSize q .&&. VMin.validOrder q validPMinQueue :: Ord k => PMin.MinPQueue k a -> Property validPMinQueue q = VPMin.validShape q .&&. VPMin.validSize q .&&. VPMin.validOrder q validPMaxQueue :: Ord k => PMax.MaxPQueue k a -> Property validPMaxQueue q = VPMax.validShape q .&&. VPMax.validSize q .&&. VPMax.validOrder q main :: IO () main = defaultMain $ testGroup "pqueue" [ testGroup "Data.PQueue.Min" [ 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 -> case Min.minView (Min.fromList xs) of Nothing -> xs === [] Just (the_min, xs') -> validMinQueue xs' .&&. the_min : Min.toList xs' === List.sort xs , testProperty "insert" $ \x xs -> Min.insert x (Min.fromList xs) === Min.fromList (x : xs) , testProperty "union" $ \xs ys -> Min.union (Min.fromList xs) (Min.fromList ys) === Min.fromList (xs ++ ys) , testProperty "filter" $ \xs -> let xs' = Min.filter even (Min.fromList xs) in validMinQueue xs' .&&. Min.toList xs' === List.sort (List.filter even xs) , testProperty "partition" $ \xs -> let xs' = Min.fromList xs (ys, zs) = Min.partition even xs' in validMinQueue ys .&&. validMinQueue zs .&&. (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (List.partition even xs) , testProperty "mapMaybe" $ \(Fn f) xs -> let xs' :: Min.MinQueue Char xs' = Min.mapMaybe f (Min.fromList xs) in validMinQueue xs' .&&. Min.toList xs' === List.sort (Maybe.mapMaybe f xs) , testProperty "mapEither" $ \(Fn f) xs -> let (ys, zs) = Min.mapEither f (Min.fromList xs) in validMinQueue ys .&&. validMinQueue zs .&&. (Min.toList ys, Min.toList zs) === bimap List.sort List.sort (Either.partitionEithers . List.map f $ xs) , testProperty "map" $ \xs -> Min.map negate (Min.fromList xs) === Min.fromList (List.map negate xs) , testProperty "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 -> let -- Monotonic, but not strictly so fun x | even x = x | otherwise = x + 1 res = Min.mapU fun (Min.fromList xs) in validMinQueue res .&&. Min.toList res === List.map fun (List.sort 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, Int)]) -> case PMin.minViewWithKey (PMin.fromList xs) of Nothing -> xs === [] Just ((the_min, the_min_val), xs') -> validPMinQueue xs' .&&. List.sort ((the_min, the_min_val) : PMin.toList xs') === List.sort xs , testProperty "map" $ \(xs :: [(Int, ())]) -> PMin.map id (PMin.fromList xs) === PMin.fromList xs , testProperty "mapKeysMonotonic" $ \xs -> let -- Monotonic, but not strictly so fun x | even x = x | otherwise = x + 1 res = PMin.mapKeysMonotonic fun (PMin.fromList xs) in validPMinQueue res .&&. List.sort (PMin.toList res) === List.sort (List.map (first fun) xs) , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMin.take n (PMin.fromList xs) === List.take n (List.sort xs) , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMin.drop n (PMin.fromList xs) === PMin.fromList (List.drop n (List.sort xs)) , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMin.splitAt n (PMin.fromList xs) === second PMin.fromList (List.splitAt n (List.sort xs)) , 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, Int)]) -> let -- The probability of a number not being divisible by 3 is 2/3. -- The probability of a number not being divisible by 4 is 3/4. -- So the probability of a number being divisible by neither is -- 1/2. f x y = x `rem` 3 == 0 || y `rem` 4 == 0 xs' = PMin.filterWithKey f (PMin.fromList xs) in validPMinQueue xs' .&&. List.sort (PMin.toList xs') === List.sort (List.filter (uncurry f) xs) , testProperty "partition" $ \(xs :: [(Int, Int)]) -> let f x y = x `rem` 3 == 0 || y `rem` 4 == 0 (ys, zs) = PMin.partitionWithKey f (PMin.fromList xs) in validPMinQueue ys .&&. validPMinQueue zs .&&. (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) === bimap List.sort List.sort (List.partition (uncurry f) xs) , testProperty "mapMaybe" $ \(Fn2 f) (xs :: [(Int, Int)]) -> let xs' = PMin.mapMaybeWithKey f (PMin.fromList xs) in validPMinQueue xs' .&&. List.sort (PMin.toList xs') === List.sort (Maybe.mapMaybe (\(k,v) -> fmap (k,) (f k v)) xs) , testProperty "mapEither" $ \(Fn2 f) (xs :: [(Int, Int)]) -> let (ys, zs) = PMin.mapEitherWithKey f (PMin.fromList xs) in validPMinQueue ys .&&. validPMinQueue zs .&&. (List.sort (PMin.toList ys), List.sort (PMin.toList zs)) === bimap List.sort List.sort (Either.partitionEithers . List.map (\(k,v) -> bimap (k,) (k,) (f k v)) $ xs) , testProperty "toAscList" $ \(xs :: [(Int, ())]) -> PMin.toAscList (PMin.fromList xs) === List.sort xs , testProperty "toDescList" $ \(xs :: [(Int, ())]) -> PMin.toDescList (PMin.fromList xs) === List.sortOn Down xs , testProperty "fromAscList" $ \(xs :: [(Int, ())]) -> PMin.fromAscList (List.sort xs) === PMin.fromList xs , 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 -> let -- Monotonic, but not strictly so fun x | even x = x | otherwise = x + 1 res = PMax.mapKeysMonotonic fun (PMax.fromList xs) in validPMaxQueue res .&&. List.sort (PMax.toList res) === List.sort (List.map (first fun) xs) , testProperty "take" $ \n (xs :: [(Int, ())]) -> PMax.take n (PMax.fromList xs) === List.take n (List.sortOn Down xs) , testProperty "drop" $ \n (xs :: [(Int, ())]) -> PMax.drop n (PMax.fromList xs) === PMax.fromList (List.drop n (List.sortOn Down xs)) , testProperty "splitAt" $ \n (xs :: [(Int, ())]) -> PMax.splitAt n (PMax.fromList xs) === second PMax.fromList (List.splitAt n (List.sortOn Down xs)) , 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 ] ] pqueue-1.5.0.0/tests/Validity/0000755000000000000000000000000007346545000014277 5ustar0000000000000000pqueue-1.5.0.0/tests/Validity/BinomialQueue.hs0000644000000000000000000000370407346545000017376 0ustar0000000000000000-- | Validity testing module Validity.BinomialQueue ( validShape , precedesProperly ) where import BinomialQueue.Internals -- | Does the heap have a valid shape? validShape :: MinQueue a -> Bool validShape (MinQueue f) = validShapeF f validShapeF :: BinomForest rk a -> Bool validShapeF (Cons _ f) = validShapeF f validShapeF (Skip Nil) = False validShapeF (Skip _f) = True validShapeF Nil = True -- | Takes an element and a priority queue. Checks that the queue is in heap -- order and that the element is less than or equal to all elements of the -- queue. precedesProperly :: Ord a => a -> MinQueue a -> Bool precedesProperly a (MinQueue q) = precedesProperlyF a q -- | Takes an element and a forest. Checks that the forest is in heap order -- and that the element is less than or equal to all elements of the forest. precedesProperlyF :: (Ord a, TreeValidity rk) => a -> BinomForest rk a -> Bool precedesProperlyF _ Nil = True precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t && precedesProperlyF the_min ts -- | Takes an element and a tree. Checks that the tree is in heap order -- and that the element is less than or equal to all elements of the tree. precedesProperlyTree :: (Ord a, TreeValidity rk) => a -> BinomTree rk a -> Bool precedesProperlyTree the_min (BinomTree a ts) = the_min <= a && precedesProperlyRk a ts -- | A helper class for order validity checking class TreeValidity rk where -- | Takes an element and a collection of trees. Checks that the collection -- is in heap order and that the element is less than or equal to all -- elements of the collection. precedesProperlyRk :: Ord a => a -> rk a -> Bool instance TreeValidity Zero where precedesProperlyRk _ ~Zero = True instance TreeValidity rk => TreeValidity (Succ rk) where precedesProperlyRk the_min (Succ t q) = precedesProperlyTree the_min t && precedesProperlyRk the_min q pqueue-1.5.0.0/tests/Validity/PQueue/0000755000000000000000000000000007346545000015503 5ustar0000000000000000pqueue-1.5.0.0/tests/Validity/PQueue/Min.hs0000644000000000000000000000103407346545000016560 0ustar0000000000000000module Validity.PQueue.Min ( validShape , validSize , validOrder ) where import Data.PQueue.Internals import qualified BinomialQueue.Internals as BQ import qualified Validity.BinomialQueue as VBQ validShape :: MinQueue a -> Bool validShape Empty = True validShape (MinQueue _ _ f) = VBQ.validShape f validSize :: MinQueue a -> Bool validSize Empty = True validSize (MinQueue sz _ f) = sz == BQ.size f + 1 validOrder :: Ord a => MinQueue a -> Bool validOrder Empty = True validOrder (MinQueue _sz a f) = VBQ.precedesProperly a f pqueue-1.5.0.0/tests/Validity/PQueue/Prio/0000755000000000000000000000000007346545000016414 5ustar0000000000000000pqueue-1.5.0.0/tests/Validity/PQueue/Prio/BinomialQueue.hs0000644000000000000000000000320207346545000021504 0ustar0000000000000000-- | Validity testing module Validity.PQueue.Prio.BinomialQueue ( validShapeF , precedesProperlyF ) where import Data.PQueue.Prio.Internals -- | Does the heap have a valid shape? validShapeF :: BinomForest rk k a -> Bool validShapeF (Cons _ f) = validShapeF f validShapeF (Skip Nil) = False validShapeF (Skip _f) = True validShapeF Nil = True -- | Takes an element and a forest. Checks that the forest is in heap order -- and that the element is less than or equal to all elements of the forest. precedesProperlyF :: (Ord k, TreeValidity rk) => k -> BinomForest rk k a -> Bool precedesProperlyF _ Nil = True precedesProperlyF the_min (Skip f) = precedesProperlyF the_min f precedesProperlyF the_min (Cons t ts) = precedesProperlyTree the_min t && precedesProperlyF the_min ts -- | Takes an element and a tree. Checks that the tree is in heap order -- and that the element is less than or equal to all elements of the tree. precedesProperlyTree :: (Ord k, TreeValidity rk) => k -> BinomTree rk k a -> Bool precedesProperlyTree the_min (BinomTree k ts) = the_min <= k && precedesProperlyRk k ts -- | A helper class for order validity checking class TreeValidity rk where -- | Takes an element and a collection of trees. Checks that the collection -- is in heap order and that the element is less than or equal to all -- elements of the collection. precedesProperlyRk :: Ord k => k -> rk k a -> Bool instance TreeValidity Zero where precedesProperlyRk _ (Zero _) = True instance TreeValidity rk => TreeValidity (Succ rk) where precedesProperlyRk the_min (Succ t q) = precedesProperlyTree the_min t && precedesProperlyRk the_min q pqueue-1.5.0.0/tests/Validity/PQueue/Prio/Max.hs0000644000000000000000000000064607346545000017503 0ustar0000000000000000module Validity.PQueue.Prio.Max ( validShape , validSize , validOrder ) where import Data.PQueue.Prio.Max.Internals as PQM import qualified Validity.PQueue.Prio.Min as VMin validShape :: MaxPQueue k a -> Bool validShape (MaxPQ q) = VMin.validShape q validSize :: MaxPQueue k a -> Bool validSize (MaxPQ q) = VMin.validSize q validOrder :: Ord k => MaxPQueue k a -> Bool validOrder (MaxPQ q) = VMin.validOrder q pqueue-1.5.0.0/tests/Validity/PQueue/Prio/Min.hs0000644000000000000000000000137007346545000017474 0ustar0000000000000000module Validity.PQueue.Prio.Min ( validShape , validSize , validOrder ) where import Data.PQueue.Prio.Internals as BQ import qualified Validity.PQueue.Prio.BinomialQueue as VBQ validShape :: MinPQueue k a -> Bool validShape Empty = True validShape (MinPQ _ _ _ f) = VBQ.validShapeF f validSize :: MinPQueue k a -> Bool validSize Empty = True validSize (MinPQ sz _ _ f) = sz == sizeH f + 1 validOrder :: Ord k => MinPQueue k a -> Bool validOrder Empty = True validOrder (MinPQ _sz k _ f) = VBQ.precedesProperlyF k f sizeH :: BinomHeap k a -> Int sizeH = go 0 1 where go :: Int -> Int -> BinomForest rk k a -> Int go acc rk Nil = rk `seq` acc go acc rk (Skip f) = go acc (2 * rk) f go acc rk (Cons _t f) = go (acc + rk) (2 * rk) f