diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for min-max-pqueue + +## 0.1.0.0 + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ziyang Liu (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the author nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,149 @@ +# min-max-pqueue + +A min-max priority queue provides efficient access to both its least element +and its greatest element. Also known as +[double-ended priority queue](https://en.wikipedia.org/wiki/Double-ended_priority_queue). + +This library provides two variants of min-max priority queues: + +- [`MinMaxQueue prio a`](https://hackage.haskell.org/package/min-max-pqueue/docs/Data-MinMaxQueue.html), a general-purpose min-max priority queue. +- [`IntMinMaxQueue a`](https://hackage.haskell.org/package/min-max-pqueue/docs/Data-IntMinMaxQueue.html), a min-max priority queue where priority values are integers. + +A min-max priority queue can be configured with a maximum size. Each time an insertion +causes the queue to grow beyond the size limit, the greatest element +will be automatically removed (rather than rejecting the insertion). + +Their implementations are backed by `Map prio (NonEmpty a)` and +`IntMap (NonEmpty a)`, respectively. This means +that certain operations are asymptotically more expensive than +implementations [backed by mutable arrays](https://dl.acm.org/citation.cfm?id=6621), +e.g., `peekMin` and `peekMax` is *O(n* log *n)* vs. *O(n)*, `fromList` is +also *O(n* log *n)* vs. *O(n)*. In a pure language like Haskell, a +mutable array based implementation would be impure +and need to operate inside monads. And in many applications, regardless +of language, the additional time complexity would be a small or negligible +price to pay to avoid destructive updates anyway. + +If you only access one end of the queue (i.e., you need a regular +priority queue), an implementation based on a kind of heap that is more +amenable to purely functional implementations, such as binomial heap +and pairing heap, is *potentially* more efficient. But always benchmark +if performance is important; in my experience `Map` *always* wins, even for +regular priority queues. + +## Advantages over Using Maps Directly + +- `size` is *O(1)*, vs. *O(n)* for maps. Note that `Data.Map.size` is *O(1)* but it + returns the number of keys, which is not the same as the number of elements in + the queue. `Data.IntMap.size`, on the other hand, is *O(k)* where *k* is + the number of keys. +- A queue can have a size limit, and it is guaranteed that its size + does not grow beyond the limit. +- Many useful operations, such as `takeMin`, `dropMin`, are non-trivial to + implement with `Map prio (NonEmpty a)` and `IntMap (NonEmpty a)`. +- The queue's fold operations operate on individual elements, as opposed to + `NonEmpty a`. + + +## Alternative Implementation + +In Haskell, an alternative to the mutable array based implementation is +to use immutable, general purpose arrays such as `Seq`. This would achieve +*O(1)* `peekMin` and `peekMax`, but since `lookup` and `update` for `Seq` +cost *O(n* log *n)*, the cost of `insert`, `deleteMin` and `deleteMax` would +become *O(n* log2 *n)*. + +[A `Seq`-based implementation](https://github.com/zliu41/min-max-pqueue/blob/master/benchmark/SeqQueue.hs) is provided for benchmarking purposes, which, +as shown below, is more than an order of magnitude slower than the `Map`-based implementation +for enqueuing and dequeuing 200,000 elements, proving that the improved +time complexity of `peekMin` and `peekMax` is not worth the cost. In fact, +if you perform `peekMin` and `peekMax` much more often than enqueuing and +dequeuing operations, which means you perform `peekMin` and `peekMax` many times +on the same queue, you should simply memoize the results. + +## Benchmarks + +Benchmarking was done on my laptop in which 200,000 elements (which are +integers) are inserted into the queue and subsequently removed one after +another. + +- `pq`, `intpq` and `sq` represents `MinMaxQueue`, `IntMinMaxQueue` and + `SeqQueue`. +- `asc`, `desc` and `rand` represents inserting the elements in ascending, + descending and random order. +- `min` and `max` represents removing elements from the min-end and max-end. + +As seen in the following result, `IntMinMaxQueue` is twice as fast as +`MinMaxQueue` for integer keys, whereas `SeqQueue` is more than an order +of magnitude slower. + +``` +benchmarking intpq-asc-min +time 27.15 ms (23.85 ms .. 29.31 ms) + 0.972 R² (0.927 R² .. 0.997 R²) +mean 30.84 ms (29.67 ms .. 35.07 ms) +std dev 4.308 ms (1.160 ms .. 7.915 ms) +variance introduced by outliers: 57% (severely inflated) + +benchmarking intpq-desc-max +time 29.70 ms (29.23 ms .. 30.41 ms) + 0.998 R² (0.995 R² .. 1.000 R²) +mean 30.62 ms (30.29 ms .. 31.02 ms) +std dev 803.7 μs (548.0 μs .. 1.190 ms) + +benchmarking intpq-rand-min +time 31.00 ms (29.10 ms .. 33.05 ms) + 0.985 R² (0.973 R² .. 0.994 R²) +mean 28.39 ms (27.43 ms .. 29.46 ms) +std dev 2.216 ms (1.968 ms .. 2.591 ms) +variance introduced by outliers: 32% (moderately inflated) + +benchmarking intpq-rand-max +time 30.96 ms (28.98 ms .. 32.96 ms) + 0.987 R² (0.976 R² .. 0.996 R²) +mean 33.66 ms (32.71 ms .. 34.49 ms) +std dev 1.820 ms (1.473 ms .. 2.388 ms) +variance introduced by outliers: 18% (moderately inflated) + +benchmarking pq-asc-min +time 69.02 ms (61.94 ms .. 72.95 ms) + 0.988 R² (0.968 R² .. 0.997 R²) +mean 71.41 ms (68.99 ms .. 74.35 ms) +std dev 4.799 ms (3.401 ms .. 6.974 ms) +variance introduced by outliers: 17% (moderately inflated) + +benchmarking pq-desc-max +time 80.90 ms (78.68 ms .. 85.06 ms) + 0.997 R² (0.994 R² .. 0.999 R²) +mean 83.20 ms (80.91 ms .. 89.15 ms) +std dev 5.853 ms (2.234 ms .. 9.957 ms) +variance introduced by outliers: 19% (moderately inflated) + +benchmarking pq-rand-min +time 65.80 ms (60.01 ms .. 69.62 ms) + 0.987 R² (0.965 R² .. 0.996 R²) +mean 74.17 ms (70.93 ms .. 79.86 ms) +std dev 7.495 ms (4.557 ms .. 12.39 ms) +variance introduced by outliers: 35% (moderately inflated) + +benchmarking pq-rand-max +time 68.29 ms (65.07 ms .. 70.84 ms) + 0.997 R² (0.995 R² .. 1.000 R²) +mean 74.03 ms (71.64 ms .. 77.51 ms) +std dev 5.016 ms (3.110 ms .. 7.556 ms) +variance introduced by outliers: 17% (moderately inflated) + +benchmarking sq-asc-min +time 1.954 s (1.369 s .. 2.838 s) + 0.971 R² (NaN R² .. 1.000 R²) +mean 1.733 s (1.592 s .. 1.861 s) +std dev 160.1 ms (28.78 ms .. 203.2 ms) +variance introduced by outliers: 22% (moderately inflated) + +benchmarking sq-rand-min +time 2.889 s (2.000 s .. 3.658 s) + 0.989 R² (0.959 R² .. 1.000 R²) +mean 2.915 s (2.828 s .. 3.054 s) +std dev 130.7 ms (442.1 μs .. 159.9 ms) +variance introduced by outliers: 19% (moderately inflated) +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs new file mode 100644 --- /dev/null +++ b/benchmark/Main.hs @@ -0,0 +1,53 @@ +module Main where + +import qualified Criterion.Main as Criterion +import Data.List (sort, sortBy, unfoldr) +import System.Random + +import qualified Data.IntMinMaxQueue as IPQ +import qualified Data.MinMaxQueue as PQ +import qualified SeqQueue as SQ + +bench :: [Criterion.Benchmark] +bench = + [ Criterion.bench "intpq-asc-min" $ + Criterion.nf (unfoldr IPQ.pollMin) (IPQ.fromListWith id ascElems) + , Criterion.bench "intpq-desc-max" $ + Criterion.nf (unfoldr IPQ.pollMax) (IPQ.fromListWith id descElems) + , Criterion.bench "intpq-rand-min" $ + Criterion.nf (unfoldr IPQ.pollMin) (IPQ.fromListWith id randomElems) + , Criterion.bench "intpq-rand-max" $ + Criterion.nf (unfoldr IPQ.pollMax) (IPQ.fromListWith id randomElems) + + , Criterion.bench "pq-asc-min" $ + Criterion.nf (unfoldr PQ.pollMin) (PQ.fromListWith id ascElems) + , Criterion.bench "pq-desc-max" $ + Criterion.nf (unfoldr PQ.pollMax) (PQ.fromListWith id descElems) + , Criterion.bench "pq-rand-min" $ + Criterion.nf (unfoldr PQ.pollMin) (PQ.fromListWith id randomElems) + , Criterion.bench "pq-rand-max" $ + Criterion.nf (unfoldr PQ.pollMax) (PQ.fromListWith id randomElems) + + , Criterion.bench "sq-asc-min" $ + Criterion.nf (unfoldr SQ.pollMin) (SQ.fromList ascElems) + , Criterion.bench "sq-rand-min" $ + Criterion.nf (unfoldr SQ.pollMin) (SQ.fromList randomElems) + ] + +main :: IO () +main = Criterion.defaultMain bench + +numElems :: Int +numElems = 200000 + +gen :: StdGen +gen = mkStdGen 42 + +randomElems :: [Int] +randomElems = take numElems (randoms gen) + +ascElems :: [Int] +ascElems = sort randomElems + +descElems :: [Int] +descElems = sortBy (flip compare) randomElems diff --git a/benchmark/SeqQueue.hs b/benchmark/SeqQueue.hs new file mode 100644 --- /dev/null +++ b/benchmark/SeqQueue.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | A min-max priority queue implemented using a min-max heap +-- backed by a 'Seq', for benchmarking purposes. +module SeqQueue (fromList, pollMin) where + +import qualified Data.Foldable as Foldable +import Data.Maybe (catMaybes, fromJust) +import qualified Data.Sequence as Seq +import Data.Sequence (Seq, (|>), ViewL((:<)), ViewR((:>))) +import Math.NumberTheory.Logarithms (intLog2) + +import Prelude hiding (init) + +type SeqQueue a = Seq a +type Index = Int + +empty :: SeqQueue a +empty = Seq.empty + +fromList :: Ord a => [a] -> SeqQueue a +fromList = Foldable.foldr insert empty + +size :: SeqQueue a -> Int +size = Seq.length + +insert :: Ord a => a -> SeqQueue a -> SeqQueue a +insert a q = bubbleUp (size q') a q' + where q' = q |> a + +peekMin :: SeqQueue a -> Maybe a +peekMin q + | hd :< _ <- Seq.viewl q = Just hd + | otherwise = Nothing + +deleteMin :: Ord a => SeqQueue a -> SeqQueue a +deleteMin q + | init :> an <- Seq.viewr q = + trickleDown 1 an (update 1 an init) + | otherwise = empty + +pollMin :: Ord a => SeqQueue a -> Maybe (a, SeqQueue a) +pollMin q = (,) <$> peekMin q <*> pure (deleteMin q) + +(!) :: Seq a -> Index -> a +(!) xs i = fromJust $ Seq.lookup (i-1) xs + +(!?) :: Seq a -> Index -> Maybe a +(!?) xs i = Seq.lookup (i-1) xs + +bubbleUp :: Ord a => Index -> a -> SeqQueue a -> SeqQueue a +bubbleUp idx a q + | idx == 1 = q + | isMinLevel idx = + if a > parent + then bubbleUpMax parentIdx a (swap parentIdx parent idx a q) + else bubbleUpMin idx a q + | otherwise = + if a < parent + then bubbleUpMin parentIdx a (swap parentIdx parent idx a q) + else bubbleUpMax idx a q + where + parentIdx = idx `div` 2 + parent = q ! parentIdx + +bubbleUpMin :: Ord a => Index -> a -> SeqQueue a -> SeqQueue a +bubbleUpMin idx a q + | idx < 4 = q + | a < grandParent = bubbleUpMin grandParentIdx a (swap grandParentIdx grandParent idx a q) + | otherwise = q + where + grandParentIdx = idx `div` 4 + grandParent = q ! grandParentIdx + +bubbleUpMax :: Ord a => Index -> a -> SeqQueue a -> SeqQueue a +bubbleUpMax idx a q + | idx < 4 = q + | a > grandParent = bubbleUpMax grandParentIdx a (swap grandParentIdx grandParent idx a q) + | otherwise = q + where + grandParentIdx = idx `div` 4 + grandParent = q ! grandParentIdx + +isMinLevel :: Int -> Bool +isMinLevel = even . intLog2 + +swap :: Index -> a -> Index -> a -> SeqQueue a -> SeqQueue a +swap idx1 a1 idx2 a2 = update idx1 a2 . update idx2 a1 + +trickleDown :: Ord a => Index -> a -> SeqQueue a -> SeqQueue a +trickleDown idx a q + | fmly@(_:_) <- family idx q = + let (a',idx') = Foldable.minimum fmly + in if a' >= a + then q + else if idx' > 2 * idx + 1 + then let q' = swap idx' a' idx a q + parentIdx = idx' `div` 2 + parent = fst . fromJust $ Foldable.find ((== parentIdx) . snd) fmly + in if a > parent then trickleDown idx' parent (swap parentIdx parent idx' a q') else trickleDown idx' a q' + else swap idx' a' idx a q + | otherwise = q + +family :: Index -> SeqQueue a -> [(a, Index)] +family idx q = catMaybes + [ (,l) <$> (q !? l) + , (,r) <$> (q !? r) + , (,ll) <$> (q !? ll) + , (,lr) <$> (q !? lr) + , (,rl) <$> (q !? rl) + , (,rr) <$> (q !? rr) + ] + where + l = idx * 2 + r = l + 1 + ll = idx * 4 + lr = ll + 1 + rl = ll + 2 + rr = ll + 3 + +update :: Int -> a -> SeqQueue a -> SeqQueue a +update x = Seq.update (x-1) diff --git a/min-max-pqueue.cabal b/min-max-pqueue.cabal new file mode 100644 --- /dev/null +++ b/min-max-pqueue.cabal @@ -0,0 +1,74 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: b4c26d035b2f2c698fa2c783190f06ef770dca9eb7fe551a97330979179847a1 + +name: min-max-pqueue +version: 0.1.0.0 +synopsis: Double-ended priority queues. +description: Min-max priority queues, also known as double-ended priority queues. +category: Data Structures +homepage: https://github.com/zliu41/min-max-pqueue#readme +bug-reports: https://github.com/zliu41/min-max-pqueue/issues +author: Ziyang Liu +maintainer: Ziyang Liu +copyright: 2019 Ziyang Liu +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/zliu41/min-max-pqueue + +library + exposed-modules: + Data.IntMinMaxQueue + Data.MinMaxQueue + other-modules: + Paths_min_max_pqueue + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers >=0.5.11 && <0.7 + default-language: Haskell2010 + +test-suite hedgehog + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + IntMinMaxQueueSpec + MinMaxQueueSpec + Paths_min_max_pqueue + hs-source-dirs: + test/hedgehog + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers >=0.5.11 && <0.7 + , hedgehog >=0.6.1 && <0.7 + , min-max-pqueue + default-language: Haskell2010 + +benchmark benchmark + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + SeqQueue + Paths_min_max_pqueue + hs-source-dirs: + benchmark + build-depends: + base >=4.7 && <5 + , containers >=0.5.11 && <0.7 + , criterion >=1.4.1 && <1.6 + , integer-logarithms >=1.0.2.2 && <1.1 + , min-max-pqueue + , random >=1.1 && <1.2 + default-language: Haskell2010 diff --git a/src/Data/IntMinMaxQueue.hs b/src/Data/IntMinMaxQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntMinMaxQueue.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.IntMinMaxQueue +-- Maintainer : Ziyang Liu +-- +-- Double-ended priority queues where priority values are integers, allowing +-- efficient retrieval and removel from both ends of the queue. +-- +-- A queue can be configured with a maximum size. Each time an insertion +-- causes the queue to grow beyond the size limit, the greatest element +-- will be automatically removed (rather than rejecting the insertion). +-- +-- The implementation is backed by an @'IntMap' ('NonEmpty' a)@. This means +-- that certain operations, including 'peekMin', 'peekMax' and 'fromList', +-- are asymptotically more expensive than a mutable array based implementation. +-- In a pure language like Haskell, a +-- mutable array based implementation would be impure +-- and need to operate inside monads. And in many applications, regardless +-- of language, the additional time complexity would be a small or negligible +-- price to pay to avoid destructive updates anyway. +-- +-- If you only access one end of the queue (i.e., you need a regular +-- priority queue), an implementation based on a kind of heap that is more +-- amenable to purely functional implementations, such as binomial heap +-- and pairing heap, is /potentially/ more efficient. But always benchmark +-- if performance is important; in my experience @Map@ /always/ wins, even for +-- regular priority queues. +-- +-- See +-- for more information. +module Data.IntMinMaxQueue ( + -- * IntMinMaxQueue type + IntMinMaxQueue + , Prio + + -- * Construction + , empty + , singleton + , fromList + , fromListWith + , fromMap + + -- * Size + , null + , notNull + , size + + -- * Maximum size + , withMaxSize + , maxSize + + -- * Queue operations + , insert + , peekMin + , peekMax + , deleteMin + , deleteMax + , pollMin + , pollMax + , takeMin + , takeMax + , dropMin + , dropMax + + -- * Traversal + -- ** Map + , map + , mapWithPriority + + -- ** Folds + , foldr + , foldl + , foldrWithPriority + , foldlWithPriority + , foldMapWithPriority + + -- ** Strict Folds + , foldr' + , foldl' + , foldrWithPriority' + , foldlWithPriority' + + -- * Lists + , elems + , toList + , toAscList + , toDescList + + -- * Maps + , toMap + ) where + +import Data.Data (Data) +import qualified Data.Foldable as Foldable +import Data.Functor.Classes +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as Map +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import qualified Data.List.NonEmpty as Nel + +import Prelude hiding (drop, foldl, foldr, lookup, map, null, take) +import qualified Prelude + +type Size = Int +type MaxSize = Maybe Int +type Prio = Int + +-- | A double-ended priority queue whose elements are compared +-- on an 'Int' field. +data IntMinMaxQueue a = IntMinMaxQueue {-# UNPACK #-} !Size !MaxSize !(IntMap (NonEmpty a)) + deriving (Eq, Ord, Data) + +instance Eq1 IntMinMaxQueue where + liftEq eqv q1 q2 = + Map.size (toMap q1) == Map.size (toMap q2) + && liftEq (liftEq eqv) (toList q1) (toList q2) + +instance Ord1 IntMinMaxQueue where + liftCompare cmpv q1 q2 = + liftCompare (liftCompare cmpv) (toList q1) (toList q2) + +instance Show a => Show (IntMinMaxQueue a) where + showsPrec d q = showParen (d > 10) $ + showString "fromList " . shows (toList q) + +instance Show1 IntMinMaxQueue where + liftShowsPrec spv slv d m = + showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) + where + sp = liftShowsPrec spv slv + sl = liftShowList spv slv + +instance Read a => Read (IntMinMaxQueue a) where + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + pure (fromList xs,t) + +instance Read1 IntMinMaxQueue where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance Functor IntMinMaxQueue where + fmap = map + +instance Foldable.Foldable IntMinMaxQueue where + foldMap = foldMapWithPriority . const + +-- | /O(1)/. The empty queue. +empty :: IntMinMaxQueue a +empty = IntMinMaxQueue 0 Nothing Map.empty + +-- | /O(1)/. A queue with a single element. +singleton :: (a -> Prio) -> a -> IntMinMaxQueue a +singleton f a = IntMinMaxQueue 1 Nothing (Map.singleton (f a) (pure a)) + +-- | /O(n * log n)/. Build a queue from a list of (priority, element) pairs. +fromList :: [(Prio, a)] -> IntMinMaxQueue a +fromList = Foldable.foldr (uncurry (insert . const)) empty + +-- | /O(n * log n)/. Build a queue from a list of elements and a function +-- from elements to priorities. +fromListWith :: (a -> Prio) -> [a] -> IntMinMaxQueue a +fromListWith f = Foldable.foldr (insert f) empty + +-- | /O(n)/ (due to calculating the queue size). +fromMap :: IntMap (NonEmpty a) -> IntMinMaxQueue a +fromMap m = IntMinMaxQueue (sum (fmap length m)) Nothing m + +-- | /O(1)/. Is the queue empty? +null :: IntMinMaxQueue a -> Bool +null = (== 0) . size + +-- | /O(1)/. Is the queue non-empty? +notNull :: IntMinMaxQueue a -> Bool +notNull = not . null + +-- | /O(1)/. The total number of elements in the queue. +size :: IntMinMaxQueue a -> Int +size (IntMinMaxQueue sz _ _) = sz + +-- | Return a queue that is limited to the given number of elements. +-- If the original queue has more elements than the size limit, the greatest +-- elements will be dropped until the size limit is satisfied. +withMaxSize :: IntMinMaxQueue a -> Int -> IntMinMaxQueue a +withMaxSize q ms = IntMinMaxQueue sz (Just ms) m + where (IntMinMaxQueue sz _ m) = takeMin ms q + +-- | /O(1)/. The size limit of the queue. It returns either @Nothing@ (if +-- the queue does not have a size limit) or @Just n@ where @n >= 0@. +maxSize :: IntMinMaxQueue a -> Maybe Int +maxSize (IntMinMaxQueue _ ms _) = max 0 <$> ms + +-- | /O(log n)/. Add the given element to the queue. If the queue has +-- a size limit, and the insertion causes the queue to grow beyond +-- its size limit, the greatest element will be removed from the +-- queue, which may be the element just added. +insert :: (a -> Prio) -> a -> IntMinMaxQueue a -> IntMinMaxQueue a +insert f a q@(IntMinMaxQueue sz ms _) = case ms of + Just ms' | sz >= ms' -> deleteMax (insert' f a q) + _ -> insert' f a q + +insert' :: (a -> Prio) -> a -> IntMinMaxQueue a -> IntMinMaxQueue a +insert' f a (IntMinMaxQueue sz ms m) = IntMinMaxQueue (sz+1) ms (Map.alter g (f a) m) + where + g Nothing = Just (pure a) + g (Just as) = Just (a <| as) + +-- | /O(log n)/. Retrieve the least element of the queue, if exists. +peekMin :: IntMinMaxQueue a -> Maybe a +peekMin (IntMinMaxQueue _ _ m) = Nel.head . snd <$> Map.lookupMin m + +-- | /O(log n)/. Retrieve the greatest element of the queue, if exists. +peekMax :: IntMinMaxQueue a -> Maybe a +peekMax (IntMinMaxQueue _ _ m) = Nel.head . snd <$> Map.lookupMax m + +-- | /O(log n)/. Remove the least element of the queue, if exists. +deleteMin :: IntMinMaxQueue a -> IntMinMaxQueue a +deleteMin q@(IntMinMaxQueue sz ms m) + | Just (prio,_) <- Map.lookupMin m = IntMinMaxQueue (sz-1) ms (Map.update (Nel.nonEmpty . Nel.tail) prio m) + | otherwise = q + +-- | /O(log n)/. Remove the greatest element of the queue, if exists. +deleteMax :: IntMinMaxQueue a -> IntMinMaxQueue a +deleteMax q@(IntMinMaxQueue sz ms m) + | Just (prio,_) <- Map.lookupMax m = IntMinMaxQueue (sz-1) ms (Map.update (Nel.nonEmpty . Nel.tail) prio m) + | otherwise = q + +-- | /O(log n)/. Remove and return the least element of the queue, if exists. +pollMin :: IntMinMaxQueue a -> Maybe (a, IntMinMaxQueue a) +pollMin q = (,) <$> peekMin q <*> pure (deleteMin q) + +-- | /O(log n)/. Remove and return the greatest element of the queue, if exists. +pollMax :: IntMinMaxQueue a -> Maybe (a, IntMinMaxQueue a) +pollMax q = (,) <$> peekMax q <*> pure (deleteMax q) + +-- | @'takeMin' n q@ returns a queue with the @n@ least elements in @q@, or +-- @q@ itself if @n >= 'size' q@. +takeMin :: Int -> IntMinMaxQueue a -> IntMinMaxQueue a +takeMin n q@(IntMinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 <= sz = IntMinMaxQueue newSz ms (take Map.lookupMin newSz m) + | otherwise = IntMinMaxQueue newSz ms (drop Map.lookupMax (sz - newSz) m) + where newSz = max 0 (min sz n) + +-- | @'takeMin' n q@ returns a queue with the @n@ greatest elements in @q@, or +-- @q@ itself if @n >= 'size' q@. +takeMax :: Int -> IntMinMaxQueue a -> IntMinMaxQueue a +takeMax n q@(IntMinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 <= sz = IntMinMaxQueue newSz ms (take Map.lookupMax newSz m) + | otherwise = IntMinMaxQueue newSz ms (drop Map.lookupMin (sz - newSz) m) + where newSz = max 0 (min sz n) + +-- | @'dropMin' n q@ returns a queue with the @n@ least elements +-- dropped from @q@, or 'empty' if @n >= 'size' q@. +dropMin :: Int -> IntMinMaxQueue a -> IntMinMaxQueue a +dropMin n q@(IntMinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 > sz = IntMinMaxQueue newSz ms (drop Map.lookupMin (sz - newSz) m) + | otherwise = IntMinMaxQueue newSz ms (take Map.lookupMax newSz m) + where newSz = max 0 (min sz (sz - n)) + +-- | @'dropMax' n q@ returns a queue with the @n@ greatest elements +-- dropped from @q@, or 'empty' if @n >= 'size' q@. +dropMax :: Int -> IntMinMaxQueue a -> IntMinMaxQueue a +dropMax n q@(IntMinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 > sz = IntMinMaxQueue newSz ms (drop Map.lookupMax (sz - newSz) m) + | otherwise = IntMinMaxQueue newSz ms (take Map.lookupMin newSz m) + where newSz = max 0 (min sz (sz - n)) + +take + :: (forall b. IntMap b -> Maybe (Int, b)) + -> Int -> IntMap (NonEmpty a) -> IntMap (NonEmpty a) +take lookup n m = go 0 m Map.empty + where + go sz mIn mOut + | sz >= n = mOut + | Just (prio, hd :| tl) <- lookup mIn = + let as = hd :| Prelude.take (n - sz - 1) tl + len = Nel.length as + mOut' = Map.insert prio as mOut + mIn' = Map.delete prio mIn + in go (sz + len) mIn' mOut' + | otherwise = mOut + +drop + :: (forall b. IntMap b -> Maybe (Int, b)) + -> Int -> IntMap (NonEmpty a) -> IntMap (NonEmpty a) +drop lookup n = go 0 + where + go sz mOut + | sz >= n = mOut + | Just (prio, hd :| tl) <- lookup mOut = + let len = length tl + 1 + in if sz + len <= n + then go (sz + len) (Map.delete prio mOut) + else Map.insert prio (hd :| Prelude.drop (n - sz) tl) mOut + | otherwise = mOut + +-- | Map a function over all elements in the queue. +map :: (a -> b) -> IntMinMaxQueue a -> IntMinMaxQueue b +map = mapWithPriority . const + +-- | Map a function over all elements in the queue. +mapWithPriority :: (Prio -> a -> b) -> IntMinMaxQueue a -> IntMinMaxQueue b +mapWithPriority f (IntMinMaxQueue sz ms m) = + IntMinMaxQueue sz ms (Map.mapWithKey (fmap . f) m) + +-- | Fold the elements in the queue using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +foldr :: (a -> b -> b) -> b -> IntMinMaxQueue a -> b +foldr = foldrWithPriority . const + +-- | Fold the elements in the queue using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +foldl :: (a -> b -> a) -> a -> IntMinMaxQueue b -> a +foldl = foldlWithPriority . (const .) + +-- | Fold the elements in the queue using the given right-associative +-- binary operator, such that +-- @'foldrWithPriority' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +foldrWithPriority :: (Prio -> a -> b -> b) -> b -> IntMinMaxQueue a -> b +foldrWithPriority f b (IntMinMaxQueue _ _ m) = Map.foldrWithKey f' b m + where + f' = flip . Foldable.foldr . f + +-- | Fold the elements in the queue using the given left-associative +-- binary operator, such that +-- @'foldlWithPriority' f z == 'Prelude.foldr' ('uncurry' . f) z . 'toAscList'@. +foldlWithPriority :: (a -> Prio -> b -> a) -> a -> IntMinMaxQueue b -> a +foldlWithPriority f a (IntMinMaxQueue _ _ m) = Map.foldlWithKey f' a m + where + f' = flip (Foldable.foldl . flip f) + +-- | A strict version of 'foldr'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldr' :: (a -> b -> b) -> b -> IntMinMaxQueue a -> b +foldr' = foldrWithPriority' . const + +-- | A strict version of 'foldl'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldl' :: (a -> b -> a) -> a -> IntMinMaxQueue b -> a +foldl' = foldlWithPriority' . (const .) + +-- | A strict version of 'foldrWithPriority'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldrWithPriority' :: (Prio -> a -> b -> b) -> b -> IntMinMaxQueue a -> b +foldrWithPriority' f b (IntMinMaxQueue _ _ m) = Map.foldrWithKey' f' b m + where + f' = flip . Foldable.foldr . f + +-- | A strict version of 'foldlWithPriority'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldlWithPriority' :: (a -> Prio -> b -> a) -> a -> IntMinMaxQueue b -> a +foldlWithPriority' f a (IntMinMaxQueue _ _ m) = Map.foldlWithKey' f' a m + where + f' = flip (Foldable.foldl' . flip f) + +-- | Fold the elements in the queue using the given monoid, such that +-- @'foldMapWithPriority' f == 'Foldable.foldMap' (uncurry f) . 'elems'@. +foldMapWithPriority :: Monoid m => (Prio -> a -> m) -> IntMinMaxQueue a -> m +foldMapWithPriority f (IntMinMaxQueue _ _ m) = + Map.foldMapWithKey (Foldable.foldMap . f) m + +-- | Elements in the queue in ascending order of priority. +-- Elements with the same priority are returned in no particular order. +elems :: IntMinMaxQueue a -> [a] +elems (IntMinMaxQueue _ _ m) = Foldable.foldMap Nel.toList m + +-- | An alias for 'toAscList'. +toList :: IntMinMaxQueue a -> [(Prio, a)] +toList = toAscList + +-- | Convert the queue to a list in ascending order of priority. +-- Elements with the same priority are returned in no particular order. +toAscList :: IntMinMaxQueue a -> [(Prio, a)] +toAscList (IntMinMaxQueue _ _ m) = + Map.toAscList m >>= uncurry (\prio -> fmap (prio,) . Nel.toList) + +-- | Convert the queue to a list in descending order of priority. +-- Elements with the same priority are returned in no particular order. +toDescList :: IntMinMaxQueue a -> [(Prio, a)] +toDescList (IntMinMaxQueue _ _ m) = + Map.toDescList m >>= uncurry (\prio -> fmap (prio,) . Nel.toList) + +-- | /O(n)/. Convert the queue to an 'IntMap'. +toMap :: IntMinMaxQueue a -> IntMap (NonEmpty a) +toMap (IntMinMaxQueue _ _ m) = m diff --git a/src/Data/MinMaxQueue.hs b/src/Data/MinMaxQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/MinMaxQueue.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.MinMaxQueue +-- Maintainer : Ziyang Liu +-- +-- Double-ended priority queues, allowing efficient retrieval and removel +-- from both ends of the queue. +-- +-- A queue can be configured with a maximum size. Each time an insertion +-- causes the queue to grow beyond the size limit, the greatest element +-- will be automatically removed (rather than rejecting the insertion). +-- +-- If the priority values are 'Int's, use "Data.IntMinMaxQueue". +-- +-- The implementation is backed by a @'Map' prio ('NonEmpty' a)@. This means +-- that certain operations, including 'peekMin', 'peekMax' and 'fromList', +-- are asymptotically more expensive than a mutable array based implementation. +-- In a pure language like Haskell, a +-- mutable array based implementation would be impure +-- and need to operate inside monads. And in many applications, regardless +-- of language, the additional time complexity would be a small or negligible +-- price to pay to avoid destructive updates anyway. +-- +-- If you only access one end of the queue (i.e., you need a regular +-- priority queue), an implementation based on a kind of heap that is more +-- amenable to purely functional implementations, such as binomial heap +-- and pairing heap, is /potentially/ more efficient. But always benchmark +-- if performance is important; in my experience @Map@ /always/ wins, even for +-- regular priority queues. +-- +-- See +-- for more information. +module Data.MinMaxQueue ( + -- * MinMaxQueue type + MinMaxQueue + + -- * Construction + , empty + , singleton + , fromList + , fromListWith + , fromMap + + -- * Size + , null + , notNull + , size + + -- * Maximum size + , withMaxSize + , maxSize + + -- * Queue operations + , insert + , peekMin + , peekMax + , deleteMin + , deleteMax + , pollMin + , pollMax + , takeMin + , takeMax + , dropMin + , dropMax + + -- * Traversal + -- ** Map + , map + , mapWithPriority + + -- ** Folds + , foldr + , foldl + , foldrWithPriority + , foldlWithPriority + , foldMapWithPriority + + -- ** Strict Folds + , foldr' + , foldl' + , foldrWithPriority' + , foldlWithPriority' + + -- * Lists + , elems + , toList + , toAscList + , toDescList + + -- * Maps + , toMap + ) where + +import Data.Data (Data) +import qualified Data.Foldable as Foldable +import Data.Functor.Classes +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import qualified Data.List.NonEmpty as Nel + +import Prelude hiding (drop, foldl, foldr, lookup, map, null, take) +import qualified Prelude + +type Size = Int +type MaxSize = Maybe Int + +-- | A double-ended priority queue whose elements are of type @a@ and +-- are compared on @prio@. +data MinMaxQueue prio a = MinMaxQueue {-# UNPACK #-} !Size !MaxSize !(Map prio (NonEmpty a)) + deriving (Eq, Ord, Data) + +instance Eq prio => Eq1 (MinMaxQueue prio) where + liftEq = liftEq2 (==) + +instance Eq2 MinMaxQueue where + liftEq2 eqk eqv q1 q2 = + Map.size (toMap q1) == Map.size (toMap q2) + && liftEq (liftEq2 eqk eqv) (toList q1) (toList q2) + +instance Ord prio => Ord1 (MinMaxQueue prio) where + liftCompare = liftCompare2 compare + +instance Ord2 MinMaxQueue where + liftCompare2 cmpk cmpv q1 q2 = + liftCompare (liftCompare2 cmpk cmpv) (toList q1) (toList q2) + +instance (Show prio, Show a) => Show (MinMaxQueue prio a) where + showsPrec d q = showParen (d > 10) $ + showString "fromList " . shows (toList q) + +instance Show prio => Show1 (MinMaxQueue prio) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + +instance Show2 MinMaxQueue where + liftShowsPrec2 spk slk spv slv d m = + showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m) + where + sp = liftShowsPrec2 spk slk spv slv + sl = liftShowList2 spk slk spv slv + +instance (Ord prio, Read prio, Read a) => Read (MinMaxQueue prio a) where + readsPrec p = readParen (p > 10) $ \r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + pure (fromList xs,t) + +instance (Ord prio, Read prio) => Read1 (MinMaxQueue prio) where + liftReadsPrec rp rl = readsData $ + readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList + where + rp' = liftReadsPrec rp rl + rl' = liftReadList rp rl + +instance Functor (MinMaxQueue prio) where + fmap = map + +instance Foldable.Foldable (MinMaxQueue prio) where + foldMap = foldMapWithPriority . const + +-- | /O(1)/. The empty queue. +empty :: MinMaxQueue prio a +empty = MinMaxQueue 0 Nothing Map.empty + +-- | /O(1)/. A queue with a single element. +singleton :: (a -> prio) -> a -> MinMaxQueue prio a +singleton f a = MinMaxQueue 1 Nothing (Map.singleton (f a) (pure a)) + +-- | /O(n * log n)/. Build a queue from a list of (priority, element) pairs. +fromList :: Ord prio => [(prio, a)] -> MinMaxQueue prio a +fromList = Foldable.foldr (uncurry (insert . const)) empty + +-- | /O(n * log n)/. Build a queue from a list of elements and a function +-- from elements to priorities. +fromListWith :: Ord prio => (a -> prio) -> [a] -> MinMaxQueue prio a +fromListWith f = Foldable.foldr (insert f) empty + +-- | /O(n)/ (due to calculating the queue size). +fromMap :: Map prio (NonEmpty a) -> MinMaxQueue prio a +fromMap m = MinMaxQueue (sum (fmap length m)) Nothing m + +-- | /O(1)/. Is the queue empty? +null :: MinMaxQueue prio a -> Bool +null = (== 0) . size + +-- | /O(1)/. Is the queue non-empty? +notNull :: MinMaxQueue prio a -> Bool +notNull = not . null + +-- | /O(1)/. The total number of elements in the queue. +size :: MinMaxQueue prio a -> Int +size (MinMaxQueue sz _ _) = sz + +-- | Return a queue that is limited to the given number of elements. +-- If the original queue has more elements than the size limit, the greatest +-- elements will be dropped until the size limit is satisfied. +withMaxSize :: Ord prio => MinMaxQueue prio a -> Int -> MinMaxQueue prio a +withMaxSize q ms = MinMaxQueue sz (Just ms) m + where (MinMaxQueue sz _ m) = takeMin ms q + +-- | /O(1)/. The size limit of the queue. It returns either @Nothing@ (if +-- the queue does not have a size limit) or @Just n@ where @n >= 0@. +maxSize :: MinMaxQueue prio a -> Maybe Int +maxSize (MinMaxQueue _ ms _) = max 0 <$> ms + +-- | /O(log n)/. Add the given element to the queue. If the queue has +-- a size limit, and the insertion causes the queue to grow beyond +-- its size limit, the greatest element will be removed from the +-- queue, which may be the element just added. +insert :: Ord prio => (a -> prio) -> a -> MinMaxQueue prio a -> MinMaxQueue prio a +insert f a q@(MinMaxQueue sz ms _) = case ms of + Just ms' | sz >= ms' -> deleteMax (insert' f a q) + _ -> insert' f a q + +insert' :: Ord prio => (a -> prio) -> a -> MinMaxQueue prio a -> MinMaxQueue prio a +insert' f a (MinMaxQueue sz ms m) = MinMaxQueue (sz+1) ms (Map.alter g (f a) m) + where + g Nothing = Just (pure a) + g (Just as) = Just (a <| as) + +-- | /O(log n)/. Retrieve the least element of the queue, if exists. +peekMin :: Ord prio => MinMaxQueue prio a -> Maybe a +peekMin (MinMaxQueue _ _ m) = Nel.head . snd <$> Map.lookupMin m + +-- | /O(log n)/. Retrieve the greatest element of the queue, if exists. +peekMax :: Ord prio => MinMaxQueue prio a -> Maybe a +peekMax (MinMaxQueue _ _ m) = Nel.head . snd <$> Map.lookupMax m + +-- | /O(log n)/. Remove the least element of the queue, if exists. +deleteMin :: Ord prio => MinMaxQueue prio a -> MinMaxQueue prio a +deleteMin q@(MinMaxQueue sz ms m) + | Just (prio,_) <- Map.lookupMin m = MinMaxQueue (sz-1) ms (Map.update (Nel.nonEmpty . Nel.tail) prio m) + | otherwise = q + +-- | /O(log n)/. Remove the greatest element of the queue, if exists. +deleteMax :: Ord prio => MinMaxQueue prio a -> MinMaxQueue prio a +deleteMax q@(MinMaxQueue sz ms m) + | Just (prio,_) <- Map.lookupMax m = MinMaxQueue (sz-1) ms (Map.update (Nel.nonEmpty . Nel.tail) prio m) + | otherwise = q + +-- | /O(log n)/. Remove and return the least element of the queue, if exists. +pollMin :: Ord prio => MinMaxQueue prio a -> Maybe (a, MinMaxQueue prio a) +pollMin q = (,) <$> peekMin q <*> pure (deleteMin q) + +-- | /O(log n)/. Remove and return the greatest element of the queue, if exists. +pollMax :: Ord prio => MinMaxQueue prio a -> Maybe (a, MinMaxQueue prio a) +pollMax q = (,) <$> peekMax q <*> pure (deleteMax q) + +-- | @'takeMin' n q@ returns a queue with the @n@ least elements in @q@, or +-- @q@ itself if @n >= 'size' q@. +takeMin :: Ord prio => Int -> MinMaxQueue prio a -> MinMaxQueue prio a +takeMin n q@(MinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 <= sz = MinMaxQueue newSz ms (take Map.lookupMin newSz m) + | otherwise = MinMaxQueue newSz ms (drop Map.lookupMax (sz - newSz) m) + where newSz = max 0 (min sz n) + +-- | @'takeMin' n q@ returns a queue with the @n@ greatest elements in @q@, or +-- @q@ itself if @n >= 'size' q@. +takeMax :: Ord prio => Int -> MinMaxQueue prio a -> MinMaxQueue prio a +takeMax n q@(MinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 <= sz = MinMaxQueue newSz ms (take Map.lookupMax newSz m) + | otherwise = MinMaxQueue newSz ms (drop Map.lookupMin (sz - newSz) m) + where newSz = max 0 (min sz n) + +-- | @'dropMin' n q@ returns a queue with the @n@ least elements +-- dropped from @q@, or 'empty' if @n >= 'size' q@. +dropMin :: Ord prio => Int -> MinMaxQueue prio a -> MinMaxQueue prio a +dropMin n q@(MinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 > sz = MinMaxQueue newSz ms (drop Map.lookupMin (sz - newSz) m) + | otherwise = MinMaxQueue newSz ms (take Map.lookupMax newSz m) + where newSz = max 0 (min sz (sz - n)) + +-- | @'dropMax' n q@ returns a queue with the @n@ greatest elements +-- dropped from @q@, or 'empty' if @n >= 'size' q@. +dropMax :: Ord prio => Int -> MinMaxQueue prio a -> MinMaxQueue prio a +dropMax n q@(MinMaxQueue sz ms m) + | newSz >= sz = q + | newSz * 2 > sz = MinMaxQueue newSz ms (drop Map.lookupMax (sz - newSz) m) + | otherwise = MinMaxQueue newSz ms (take Map.lookupMin newSz m) + where newSz = max 0 (min sz (sz - n)) + +take + :: Ord prio + => (forall b. Map prio b -> Maybe (prio, b)) + -> Int -> Map prio (NonEmpty a) -> Map prio (NonEmpty a) +take lookup n m = go 0 m Map.empty + where + go sz mIn mOut + | sz >= n = mOut + | Just (prio, hd :| tl) <- lookup mIn = + let as = hd :| Prelude.take (n - sz - 1) tl + len = Nel.length as + mOut' = Map.insert prio as mOut + mIn' = Map.delete prio mIn + in go (sz + len) mIn' mOut' + | otherwise = mOut + +drop + :: Ord prio + => (forall b. Map prio b -> Maybe (prio, b)) + -> Int -> Map prio (NonEmpty a) -> Map prio (NonEmpty a) +drop lookup n = go 0 + where + go sz mOut + | sz >= n = mOut + | Just (prio, hd :| tl) <- lookup mOut = + let len = length tl + 1 + in if sz + len <= n + then go (sz + len) (Map.delete prio mOut) + else Map.insert prio (hd :| Prelude.drop (n - sz) tl) mOut + | otherwise = mOut + +-- | Map a function over all elements in the queue. +map :: (a -> b) -> MinMaxQueue prio a -> MinMaxQueue prio b +map = mapWithPriority . const + +-- | Map a function over all elements in the queue. +mapWithPriority :: (prio -> a -> b) -> MinMaxQueue prio a -> MinMaxQueue prio b +mapWithPriority f (MinMaxQueue sz ms m) = + MinMaxQueue sz ms (Map.mapWithKey (fmap . f) m) + +-- | Fold the elements in the queue using the given right-associative +-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@. +foldr :: (a -> b -> b) -> b -> MinMaxQueue prio a -> b +foldr = foldrWithPriority . const + +-- | Fold the elements in the queue using the given left-associative +-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@. +foldl :: (a -> b -> a) -> a -> MinMaxQueue prio b -> a +foldl = foldlWithPriority . (const .) + +-- | Fold the elements in the queue using the given right-associative +-- binary operator, such that +-- @'foldrWithPriority' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +foldrWithPriority :: (prio -> a -> b -> b) -> b -> MinMaxQueue prio a -> b +foldrWithPriority f b (MinMaxQueue _ _ m) = Map.foldrWithKey f' b m + where + f' = flip . Foldable.foldr . f + +-- | Fold the elements in the queue using the given left-associative +-- binary operator, such that +-- @'foldlWithPriority' f z == 'Prelude.foldr' ('uncurry' . f) z . 'toAscList'@. +foldlWithPriority :: (a -> prio -> b -> a) -> a -> MinMaxQueue prio b -> a +foldlWithPriority f a (MinMaxQueue _ _ m) = Map.foldlWithKey f' a m + where + f' = flip (Foldable.foldl . flip f) + +-- | A strict version of 'foldr'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldr' :: (a -> b -> b) -> b -> MinMaxQueue prio a -> b +foldr' = foldrWithPriority' . const + +-- | A strict version of 'foldl'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldl' :: (a -> b -> a) -> a -> MinMaxQueue prio b -> a +foldl' = foldlWithPriority' . (const .) + +-- | A strict version of 'foldrWithPriority'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldrWithPriority' :: (prio -> a -> b -> b) -> b -> MinMaxQueue prio a -> b +foldrWithPriority' f b (MinMaxQueue _ _ m) = Map.foldrWithKey' f' b m + where + f' = flip . Foldable.foldr . f + +-- | A strict version of 'foldlWithPriority'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +foldlWithPriority' :: (a -> prio -> b -> a) -> a -> MinMaxQueue prio b -> a +foldlWithPriority' f a (MinMaxQueue _ _ m) = Map.foldlWithKey' f' a m + where + f' = flip (Foldable.foldl' . flip f) + +-- | Fold the elements in the queue using the given monoid, such that +-- @'foldMapWithPriority' f == 'Foldable.foldMap' (uncurry f) . 'elems'@. +foldMapWithPriority :: Monoid m => (prio -> a -> m) -> MinMaxQueue prio a -> m +foldMapWithPriority f (MinMaxQueue _ _ m) = + Map.foldMapWithKey (Foldable.foldMap . f) m + +-- | Elements in the queue in ascending order of priority. +-- Elements with the same priority are returned in no particular order. +elems :: MinMaxQueue prio a -> [a] +elems (MinMaxQueue _ _ m) = Foldable.foldMap Nel.toList m + +-- | An alias for 'toAscList'. +toList :: MinMaxQueue prio a -> [(prio, a)] +toList = toAscList + +-- | Convert the queue to a list in ascending order of priority. +-- Elements with the same priority are returned in no particular order. +toAscList :: MinMaxQueue prio a -> [(prio, a)] +toAscList (MinMaxQueue _ _ m) = + Map.toAscList m >>= uncurry (\prio -> fmap (prio,) . Nel.toList) + +-- | Convert the queue to a list in descending order of priority. +-- Elements with the same priority are returned in no particular order. +toDescList :: MinMaxQueue prio a -> [(prio, a)] +toDescList (MinMaxQueue _ _ m) = + Map.toDescList m >>= uncurry (\prio -> fmap (prio,) . Nel.toList) + +-- | /O(n)/. Convert the queue to a 'Map'. +toMap :: MinMaxQueue prio a -> Map prio (NonEmpty a) +toMap (MinMaxQueue _ _ m) = m diff --git a/test/hedgehog/IntMinMaxQueueSpec.hs b/test/hedgehog/IntMinMaxQueueSpec.hs new file mode 100644 --- /dev/null +++ b/test/hedgehog/IntMinMaxQueueSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TemplateHaskell #-} + +module IntMinMaxQueueSpec where + +import qualified Data.Foldable as Foldable +import qualified Data.List as List + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Data.IntMinMaxQueue (IntMinMaxQueue) +import qualified Data.IntMinMaxQueue as PQ + +genQueue :: Gen (IntMinMaxQueue Int) +genQueue = do + xs <- Gen.list (Range.linear 0 500) (Gen.int (Range.linear 0 50)) + pure $ PQ.fromListWith id xs + +prop_ascendingOrder :: Property +prop_ascendingOrder = property $ do + q <- forAll genQueue + let ascList = dequeueAllAsc q + ascList === List.sort ascList + PQ.size q === length ascList + +prop_descendingOrder :: Property +prop_descendingOrder = property $ do + q <- forAll genQueue + let descList = dequeueAllDesc q + descList === List.sortBy (flip compare) descList + PQ.size q === length descList + +prop_takeMin :: Property +prop_takeMin = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + take n (dequeueAllAsc q) === dequeueAllAsc (PQ.takeMin n q) + length (take n (dequeueAllAsc q)) === PQ.size (PQ.takeMin n q) + +prop_takeMax :: Property +prop_takeMax = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + take n (dequeueAllDesc q) === dequeueAllDesc (PQ.takeMax n q) + length (take n (dequeueAllDesc q)) === PQ.size (PQ.takeMax n q) + +prop_dropMin :: Property +prop_dropMin = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + drop n (dequeueAllAsc q) === dequeueAllAsc (PQ.dropMin n q) + length (drop n (dequeueAllAsc q)) === PQ.size (PQ.dropMin n q) + +prop_dropMax :: Property +prop_dropMax = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + drop n (dequeueAllDesc q) === dequeueAllDesc (PQ.dropMax n q) + length (drop n (dequeueAllDesc q)) === PQ.size (PQ.dropMax n q) + +prop_maxSize :: Property +prop_maxSize = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + let q' = q `PQ.withMaxSize` n + PQ.size q' === max 0 (min (PQ.size q) n) + PQ.maxSize q' === Just (max 0 n) + dequeueAllAsc q' === take (PQ.size q') (dequeueAllAsc q) + +prop_insertWithMaxSize :: Property +prop_insertWithMaxSize = property $ do + q <- forAll genQueue + let q' = q `PQ.withMaxSize` PQ.size q + PQ.insert id maxBound q' === q' + PQ.insert id minBound q' === PQ.insert id minBound (PQ.deleteMax q') + +prop_fold :: Property +prop_fold = property $ do + q <- forAll genQueue + let f a s = show a ++ s + g = flip f + f' prio a s = show prio ++ show a ++ s + g' s prio a = f' prio a s + h prio a = show prio ++ show a + PQ.foldr f "" q === foldr f "" (PQ.elems q) + PQ.foldl g "" q === foldl g "" (PQ.elems q) + PQ.foldrWithPriority f' "" q === foldr (uncurry f') "" (PQ.toAscList q) + PQ.foldlWithPriority g' "" q === foldl (uncurry . g') "" (PQ.toAscList q) + Foldable.foldMap show q === Foldable.foldMap show (PQ.elems q) + PQ.foldMapWithPriority h q === Foldable.foldMap (uncurry h) (PQ.toAscList q) + +dequeueAllAsc :: IntMinMaxQueue a -> [a] +dequeueAllAsc = List.unfoldr PQ.pollMin + +dequeueAllDesc :: IntMinMaxQueue a -> [a] +dequeueAllDesc = List.unfoldr PQ.pollMax + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/test/hedgehog/Main.hs b/test/hedgehog/Main.hs new file mode 100644 --- /dev/null +++ b/test/hedgehog/Main.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Control.Monad (unless) +import GHC.IO.Encoding (utf8) +import System.Exit (exitFailure) +import System.IO (hSetEncoding, stdout, stderr) + +import qualified IntMinMaxQueueSpec +import qualified MinMaxQueueSpec + +main :: IO () +main = do + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + passed <- sequenceA [MinMaxQueueSpec.tests, IntMinMaxQueueSpec.tests] + unless (and passed) exitFailure diff --git a/test/hedgehog/MinMaxQueueSpec.hs b/test/hedgehog/MinMaxQueueSpec.hs new file mode 100644 --- /dev/null +++ b/test/hedgehog/MinMaxQueueSpec.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TemplateHaskell #-} + +module MinMaxQueueSpec where + +import qualified Data.Foldable as Foldable +import qualified Data.List as List + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Data.MinMaxQueue (MinMaxQueue) +import qualified Data.MinMaxQueue as PQ + +genQueue :: Gen (MinMaxQueue Int Int) +genQueue = do + xs <- Gen.list (Range.linear 0 500) (Gen.int (Range.linear 0 50)) + pure $ PQ.fromListWith id xs + +prop_ascendingOrder :: Property +prop_ascendingOrder = property $ do + q <- forAll genQueue + let ascList = dequeueAllAsc q + ascList === List.sort ascList + PQ.size q === length ascList + +prop_descendingOrder :: Property +prop_descendingOrder = property $ do + q <- forAll genQueue + let descList = dequeueAllDesc q + descList === List.sortBy (flip compare) descList + PQ.size q === length descList + +prop_takeMin :: Property +prop_takeMin = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + take n (dequeueAllAsc q) === dequeueAllAsc (PQ.takeMin n q) + length (take n (dequeueAllAsc q)) === PQ.size (PQ.takeMin n q) + +prop_takeMax :: Property +prop_takeMax = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + take n (dequeueAllDesc q) === dequeueAllDesc (PQ.takeMax n q) + length (take n (dequeueAllDesc q)) === PQ.size (PQ.takeMax n q) + +prop_dropMin :: Property +prop_dropMin = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + drop n (dequeueAllAsc q) === dequeueAllAsc (PQ.dropMin n q) + length (drop n (dequeueAllAsc q)) === PQ.size (PQ.dropMin n q) + +prop_dropMax :: Property +prop_dropMax = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + drop n (dequeueAllDesc q) === dequeueAllDesc (PQ.dropMax n q) + length (drop n (dequeueAllDesc q)) === PQ.size (PQ.dropMax n q) + +prop_maxSize :: Property +prop_maxSize = property $ do + q <- forAll genQueue + n <- forAll $ Gen.int (Range.linear (-100) (PQ.size q + 100)) + let q' = q `PQ.withMaxSize` n + PQ.size q' === max 0 (min (PQ.size q) n) + PQ.maxSize q' === Just (max 0 n) + dequeueAllAsc q' === take (PQ.size q') (dequeueAllAsc q) + +prop_insertWithMaxSize :: Property +prop_insertWithMaxSize = property $ do + q <- forAll genQueue + let q' = q `PQ.withMaxSize` PQ.size q + PQ.insert id maxBound q' === q' + PQ.insert id minBound q' === PQ.insert id minBound (PQ.deleteMax q') + +prop_fold :: Property +prop_fold = property $ do + q <- forAll genQueue + let f a s = show a ++ s + g = flip f + f' prio a s = show prio ++ show a ++ s + g' s prio a = f' prio a s + h prio a = show prio ++ show a + PQ.foldr f "" q === foldr f "" (PQ.elems q) + PQ.foldl g "" q === foldl g "" (PQ.elems q) + PQ.foldrWithPriority f' "" q === foldr (uncurry f') "" (PQ.toAscList q) + PQ.foldlWithPriority g' "" q === foldl (uncurry . g') "" (PQ.toAscList q) + Foldable.foldMap show q === Foldable.foldMap show (PQ.elems q) + PQ.foldMapWithPriority h q === Foldable.foldMap (uncurry h) (PQ.toAscList q) + +dequeueAllAsc :: Ord prio => MinMaxQueue prio a -> [a] +dequeueAllAsc = List.unfoldr PQ.pollMin + +dequeueAllDesc :: Ord prio => MinMaxQueue prio a -> [a] +dequeueAllDesc = List.unfoldr PQ.pollMax + +tests :: IO Bool +tests = + checkParallel $$(discover)