diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +- 0.2.3.0 + * Add an `atMostView` function to all PSQ flavours + * Bump HUnit dependency to 1.6 + * Bump QuickCheck dependency to 2.10 + * Clean up warnings on newer and older GHC versions + - 0.2.2.3 * Bump HUnit dependency to 1.5 diff --git a/psqueues.cabal b/psqueues.cabal --- a/psqueues.cabal +++ b/psqueues.cabal @@ -1,5 +1,5 @@ Name: psqueues -Version: 0.2.2.3 +Version: 0.2.3.0 License: BSD3 License-file: LICENSE Maintainer: Jasper Van der Jeugt @@ -85,17 +85,23 @@ Type: exitcode-stdio-1.0 Hs-source-dirs: src benchmarks Main-is: Main.hs + Ghc-options: -Wall Other-modules: BenchmarkTypes + Data.BitUtil Data.FingerTree.PSQueue.Benchmark + Data.HashPSQ Data.HashPSQ.Benchmark + Data.HashPSQ.Internal + Data.IntPSQ Data.IntPSQ.Benchmark + Data.IntPSQ.Internal + Data.OrdPSQ Data.OrdPSQ.Benchmark + Data.OrdPSQ.Internal Data.PSQueue.Benchmark - Ghc-options: -Wall - Build-depends: containers >= 0.5 , unordered-containers >= 0.2.4 @@ -119,17 +125,24 @@ Type: exitcode-stdio-1.0 Other-modules: + Data.BitUtil + Data.HashPSQ + Data.HashPSQ.Internal + Data.HashPSQ.Tests + Data.IntPSQ + Data.IntPSQ.Internal + Data.IntPSQ.Tests + Data.OrdPSQ + Data.OrdPSQ.Internal + Data.OrdPSQ.Tests Data.PSQ.Class Data.PSQ.Class.Gen Data.PSQ.Class.Tests Data.PSQ.Class.Util - Data.HashPSQ.Tests - Data.IntPSQ.Tests - Data.OrdPSQ.Tests Build-depends: - HUnit >= 1.2 && < 1.6 - , QuickCheck >= 2.7 && < 2.10 + HUnit >= 1.2 && < 1.7 + , QuickCheck >= 2.7 && < 2.11 , test-framework >= 0.8 && < 0.9 , test-framework-hunit >= 0.3 && < 0.4 , test-framework-quickcheck2 >= 0.3 && < 0.4 diff --git a/src/Data/HashPSQ.hs b/src/Data/HashPSQ.hs --- a/src/Data/HashPSQ.hs +++ b/src/Data/HashPSQ.hs @@ -37,6 +37,7 @@ , insertView , deleteView , minView + , atMostView -- * Traversal , map diff --git a/src/Data/HashPSQ/Internal.hs b/src/Data/HashPSQ/Internal.hs --- a/src/Data/HashPSQ/Internal.hs +++ b/src/Data/HashPSQ/Internal.hs @@ -39,6 +39,7 @@ , insertView , deleteView , minView + , atMostView -- * Traversal , map @@ -54,12 +55,12 @@ ) where import Control.DeepSeq (NFData (..)) -import Data.Foldable (Foldable (foldr)) +import Data.Foldable (Foldable) import Data.Hashable import qualified Data.List as List import Data.Maybe (isJust) -import Prelude hiding (foldr, lookup, map, null) import Data.Traversable +import Prelude hiding (foldr, lookup, map, null) import qualified Data.IntPSQ.Internal as IntPSQ import qualified Data.OrdPSQ as OrdPSQ @@ -340,6 +341,42 @@ (Just (k, p, x), Nothing) Just (k', p', x', os') -> (Just (k, p, x), Just (h, p', B k' x' os')) + +-- | Return a list of elements ordered by key whose priorities are at most @pt@, +-- and the rest of the queue stripped of these elements. The returned list of +-- elements can be in any order: no guarantees there. +{-# INLINABLE atMostView #-} +atMostView + :: (Hashable k, Ord k, Ord p) + => p -> HashPSQ k p v -> ([(k, p, v)], HashPSQ k p v) +atMostView pt (HashPSQ t0) = + (returns, HashPSQ t2) + where + -- First we use 'IntPSQ.atMostView' to get a collection of buckets that have + -- /AT LEAST/ one element with a low priority. Buckets will usually only + -- contain a single element. + (buckets, t1) = IntPSQ.atMostView pt t0 + + -- We now need to run through the buckets. This will give us a list of + -- elements to return and a bunch of buckets to re-insert. + (returns, reinserts) = go [] [] buckets + where + -- We use two accumulators, for returns and re-inserts. + go rets reins [] = (rets, reins) + go rets reins ((_, p, B k v opsq) : bs) = + -- Note that 'elems' should be very small, ideally a null list. + let (elems, opsq') = OrdPSQ.atMostView pt opsq + rets' = (k, p, v) : elems ++ rets + reins' = case toBucket opsq' of + Nothing -> reins + Just (p', b) -> ((p', b) : reins) + in go rets' reins' bs + + -- Now we can do the re-insertion pass. + t2 = List.foldl' + (\t (p, b@(B k _ _)) -> IntPSQ.unsafeInsertNew (hash k) p b t) + t1 + reinserts -------------------------------------------------------------------------------- diff --git a/src/Data/IntPSQ.hs b/src/Data/IntPSQ.hs --- a/src/Data/IntPSQ.hs +++ b/src/Data/IntPSQ.hs @@ -40,6 +40,7 @@ , insertView , deleteView , minView + , atMostView -- * Traversal , map diff --git a/src/Data/IntPSQ/Internal.hs b/src/Data/IntPSQ/Internal.hs --- a/src/Data/IntPSQ/Internal.hs +++ b/src/Data/IntPSQ/Internal.hs @@ -40,6 +40,7 @@ , insertView , deleteView , minView + , atMostView -- * Traversal , map @@ -63,21 +64,17 @@ import Control.Applicative ((<$>), (<*>)) import Control.DeepSeq (NFData (rnf)) - import Data.Bits import Data.BitUtil -import Data.Foldable (Foldable (foldr)) +import Data.Foldable (Foldable) import Data.List (foldl') +import qualified Data.List as List import Data.Maybe (isJust) +import Data.Traversable import Data.Word (Word) - -import qualified Data.List as List - import Prelude hiding (filter, foldl, foldr, lookup, map, null) -import Data.Traversable - -- TODO (SM): get rid of bang patterns {- @@ -197,9 +194,9 @@ -- | /O(1)/ The element with the lowest priority. findMin :: Ord p => IntPSQ p v -> Maybe (Int, p, v) findMin t = case t of - Nil -> Nothing - Tip k p x -> Just (k, p, x) - Bin k p x _ _ _ -> Just (k, p, x) + Nil -> Nothing + Tip k p x -> Just (k, p, x) + Bin k p x _ _ _ -> Just (k, p, x) ------------------------------------------------------------------------------ @@ -370,7 +367,7 @@ toList = go [] where - go acc Nil = acc + go acc Nil = acc go acc (Tip k' p' x') = (k', p', x') : acc go acc (Bin k' p' x' _m l r) = (k', p', x') : go (go acc r) l @@ -431,7 +428,27 @@ Tip k p x -> Just (k, p, x, Nil) Bin k p x m l r -> Just (k, p, x, merge m l r) +-- | Return a list of elements ordered by key whose priorities are at most @pt@, +-- and the rest of the queue stripped of these elements. The returned list of +-- elements can be in any order: no guarantees there. +{-# INLINABLE atMostView #-} +atMostView :: Ord p => p -> IntPSQ p v -> ([(Int, p, v)], IntPSQ p v) +atMostView pt t0 = go [] t0 + where + go acc t = case t of + Nil -> (acc, t) + Tip k p x + | p > pt -> (acc, t) + | otherwise -> ((k, p, x) : acc, Nil) + Bin k p x m l r + | p > pt -> (acc, t) + | otherwise -> + let (acc', l') = go acc l + (acc'', r') = go acc' r + in ((k, p, x) : acc'', merge m l' r') + + ------------------------------------------------------------------------------ -- Traversal ------------------------------------------------------------------------------ @@ -696,6 +713,6 @@ Just xoredKeys -> fromIntegral mask == highestBitMask (fromIntegral xoredKeys) - childKey Nil = Nothing - childKey (Tip k _ _) = Just k + childKey Nil = Nothing + childKey (Tip k _ _) = Just k childKey (Bin k _ _ _ _ _) = Just k diff --git a/src/Data/OrdPSQ.hs b/src/Data/OrdPSQ.hs --- a/src/Data/OrdPSQ.hs +++ b/src/Data/OrdPSQ.hs @@ -11,9 +11,8 @@ -- This means it is similar to the -- package but -- our benchmarks showed it perform quite a bit faster. +{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE BangPatterns #-} module Data.OrdPSQ ( -- * Type OrdPSQ @@ -48,6 +47,7 @@ , insertView , deleteView , minView + , atMostView -- * Traversals , map @@ -57,6 +57,6 @@ , valid ) where -import Prelude hiding (map, lookup, null, foldr) +import Prelude hiding (foldr, lookup, map, null) import Data.OrdPSQ.Internal diff --git a/src/Data/OrdPSQ/Internal.hs b/src/Data/OrdPSQ/Internal.hs --- a/src/Data/OrdPSQ/Internal.hs +++ b/src/Data/OrdPSQ/Internal.hs @@ -2,8 +2,8 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} module Data.OrdPSQ.Internal ( -- * Type OrdPSQ (..) @@ -40,6 +40,7 @@ , insertView , deleteView , minView + , atMostView -- * Traversals , map @@ -67,12 +68,12 @@ , valid ) where -import Control.DeepSeq (NFData (rnf)) -import Data.Foldable (Foldable (foldr)) -import qualified Data.List as List -import Data.Maybe (isJust) -import Prelude hiding (foldr, lookup, map, null) +import Control.DeepSeq (NFData (rnf)) +import Data.Foldable (Foldable (foldr)) +import qualified Data.List as List +import Data.Maybe (isJust) import Data.Traversable +import Prelude hiding (foldr, lookup, map, null) -------------------------------------------------------------------------------- -- Types @@ -349,6 +350,25 @@ secondBest Start _ = Void secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m' secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m' + +-- | Return a list of elements ordered by key whose priorities are at most @pt@, +-- and the rest of the queue stripped of these elements. The returned list of +-- elements can be in any order: no guarantees there. +atMostView :: (Ord k, Ord p) => p -> OrdPSQ k p v -> ([(k, p, v)], OrdPSQ k p v) +atMostView pt = go [] + where + go acc t@(Winner (E _ p _) _ _) + | p > pt = (acc, t) + go acc Void = (acc, Void) + go acc (Winner (E k p v) Start _) = ((k, p, v) : acc, Void) + go acc (Winner e (RLoser _ e' tl m tr) m') = + let (acc', t') = go acc (Winner e tl m) + (acc'', t'') = go acc' (Winner e' tr m') in + (acc'', t' `play` t'') + go acc (Winner e (LLoser _ e' tl m tr) m') = + let (acc', t') = go acc (Winner e' tl m) + (acc'', t'') = go acc' (Winner e tr m') in + (acc'', t' `play` t'') -------------------------------------------------------------------------------- diff --git a/tests/Data/PSQ/Class.hs b/tests/Data/PSQ/Class.hs --- a/tests/Data/PSQ/Class.hs +++ b/tests/Data/PSQ/Class.hs @@ -68,6 +68,8 @@ :: Ord p => Key psq -> psq p v -> Maybe (p, v, psq p v) minView :: Ord p => psq p v -> Maybe (Key psq, p, v, psq p v) + atMostView + :: Ord p => p -> psq p v -> ([(Key psq, p, v)], psq p v) -- Traversals map :: Ord p => (Key psq -> p -> v -> w) -> psq p v -> psq p w @@ -99,6 +101,7 @@ insertView = IntPSQ.insertView deleteView = IntPSQ.deleteView minView = IntPSQ.minView + atMostView = IntPSQ.atMostView map = IntPSQ.map fold' = IntPSQ.fold' valid = IntPSQ.valid @@ -124,6 +127,7 @@ insertView = OrdPSQ.insertView deleteView = OrdPSQ.deleteView minView = OrdPSQ.minView + atMostView = OrdPSQ.atMostView map = OrdPSQ.map fold' = OrdPSQ.fold' valid = OrdPSQ.valid @@ -149,6 +153,7 @@ insertView = HashPSQ.insertView deleteView = HashPSQ.deleteView minView = HashPSQ.minView + atMostView = HashPSQ.atMostView map = HashPSQ.map fold' = HashPSQ.fold' valid = HashPSQ.valid diff --git a/tests/Data/PSQ/Class/Tests.hs b/tests/Data/PSQ/Class/Tests.hs --- a/tests/Data/PSQ/Class/Tests.hs +++ b/tests/Data/PSQ/Class/Tests.hs @@ -73,6 +73,7 @@ , testProperty "fold'" (untag' prop_fold') , testProperty "foldr" (untag' prop_foldr) , testProperty "valid" (untag' prop_valid) + , testProperty "atMostView" (untag' prop_atMostView) ] where untag' :: Tagged psq test -> test @@ -439,3 +440,19 @@ Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_valid = Tagged valid + +prop_atMostView + :: forall psq. (PSQ psq, Show (Key psq), Show (psq Int Char)) + => Tagged psq (psq Int Char -> Property) +prop_atMostView = Tagged $ \t -> + forAll arbitraryPriority $ \p -> + let (elems, t') = atMostView p t in + -- 1. Test that priorities are at most 'p'. + and [p' <= p | (_, p', _) <- elems] && + -- 2. Test that the remaining priorities are larger than 'p'. + (case findMin t' of + Nothing -> True + Just (_, p', _) -> p' > p) && + -- 2. Test that the size of the removed elements and the new queue total + -- the original size. + length elems + size t' == size t diff --git a/tests/Data/PSQ/Class/Util.hs b/tests/Data/PSQ/Class/Util.hs --- a/tests/Data/PSQ/Class/Util.hs +++ b/tests/Data/PSQ/Class/Util.hs @@ -68,7 +68,7 @@ assertErrorCall handler x = handle (\e -> case fromException e of Just (ErrorCall str) -> handler str - Nothing -> assertFailure $ + _ -> assertFailure $ "assertErrorCall: expected `error` but got: " ++ show e) (x `seq` assertFailure "assertErrorCall: evaluated to WHNF and no exception was thrown")