packages feed

pqueue 1.4.1.4 → 1.4.2.0

raw patch · 25 files changed

+3169/−1319 lines, 25 filesdep +randomdep +tastydep +tasty-benchdep −QuickCheckdep ~basenew-uploader

Dependencies added: random, tasty, tasty-bench, tasty-quickcheck

Dependencies removed: QuickCheck

Dependency ranges changed: base

Files

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