psqueues 0.2.7.3 → 0.2.8.3
raw patch · 8 files changed
Files
- CHANGELOG +39/−0
- benchmarks/Data/FingerTree/PSQueue/Benchmark.hs +0/−61
- benchmarks/Main.hs +0/−4
- psqueues.cabal +8/−18
- src/Data/BitUtil.hs +2/−3
- src/Data/IntPSQ/Internal.hs +9/−17
- src/Data/OrdPSQ/Internal.hs +94/−17
- tests/Data/PSQ/Class/Tests.hs +5/−2
CHANGELOG view
@@ -1,5 +1,44 @@ # CHANGELOG +- 0.2.8.3 (2025-12-28)+ * Fix compilation with MicroHS++- 0.2.8.2 (2025-08-08)+ * Use Straka's balancing algorithm for OrdPSQ (#64):++ Milan Straka's paper 'Adams’ Trees Revisited' argues that Adams'+ balancing algorithm previously did not have a correct proof. It+ provides a proof of a slightly modified balancing algorithm that+ prefers single rotations in many more cases. The small change+ specified in that paper fixes the frequent quickcheck failures+ exposed when the balance test was made more precise.++ * Remove unnecessary dependencies: array, containers, ghc-prim, mtl,+ unordered-containers++- 0.2.8.1 (2025-01-28)+ * Fix performance issue in OrdPSQ relating to balancing (#61).+ * Relax hashable upper bound to 1.5+ * Relax QuickCheck upper bound to 2.15+ * Relax tasty-quickcheck upper bound to 0.11++- 0.2.8.0 (2022-10-27)+ * Add a number of minor optimizations and INLINE pragmas:+ - The previous `INLINABLE` pragmas were insufficient to fully specialize+ functions. Add a bunch more. I believe they now do the job they were+ meant to.+ - Change the way we check for very short queues in `lbalance` and+ `rbalance` to avoid redundant size comparisons in the non-short+ case.+ - Make the fields of `Play` strict. I doubt this makes any practical+ difference, since `tourView` is `INLINE`, but in fact the fields are+ always in WHNF, so we might as well make that explicitly clear.+ * Fix a bug in `fromList`. It previously used the *first* occurrence+ of a duplicated key; it now uses the *last* occurrence, as documented.+ * Cleanup: refactor `binShrinkL` and `binShrinkR` into `bin`.+ * Bump deepseq upper bound to 1.6+ * Bump tasty upper bound to 1.6+ - 0.2.7.3 (2021-11-05) * Relax hashable, tasty and QuickCheck upper bounds * Bump Cabal-version to 1.10
− benchmarks/Data/FingerTree/PSQueue/Benchmark.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- | This module contains benchmarks for the 'PSQueue' type from the--- `fingertree-psqueue` package.-module Data.FingerTree.PSQueue.Benchmark- ( benchmark- ) where--import Data.List (foldl')-import Data.FingerTree.PSQueue (Binding (..))-import qualified Data.FingerTree.PSQueue as PSQueue-import Criterion.Main-import Prelude hiding (lookup)-import BenchmarkTypes-import Data.Maybe (fromMaybe)--benchmark :: String -> [BElem] -> BenchmarkSet-benchmark name elems = BenchmarkSet- { bGroupName = name- , bMinView = whnf bench_minView initialPSQ- , bLookup = whnf (bench_lookup keys) initialPSQ- , bInsertEmpty = nf' (bench_insert firstElems) PSQueue.empty- , bInsertNew = nf' (bench_insert secondElems) initialPSQ- , bInsertDuplicates = nf' (bench_insert firstElems) initialPSQ- , bDelete = nf' (bench_delete firstKeys) initialPSQ- }- where- (firstElems, secondElems) = splitAt (numElems `div` 2) elems- numElems = length elems- keys = map (\(x, _, _) -> x) elems- firstKeys = map (\(x, _, _) -> x) firstElems-- initialPSQ :: PSQueue.PSQ Int Int- initialPSQ = PSQueue.fromList $ map toBinding firstElems-- toBinding :: BElem -> Binding Int Int- toBinding (k, p, _) = k :-> p-- -- Get the size of the resulting PSQs, since there's no NFData instance- nf' f x = whnf (PSQueue.size . f) x--bench_lookup :: [Int] -> PSQueue.PSQ Int Int -> Int-bench_lookup xs m = foldl' (\n k -> fromMaybe n (PSQueue.lookup k m)) 0 xs--bench_insert :: [BElem] -> PSQueue.PSQ Int Int -> PSQueue.PSQ Int Int-bench_insert xs m0 = foldl' (\m (k, p, _) -> fingerInsert k p m) m0 xs- where- fingerInsert- :: (Ord k, Ord v) => k -> v -> PSQueue.PSQ k v -> PSQueue.PSQ k v- fingerInsert k v m = PSQueue.alter (const $ Just v) k m--bench_minView :: PSQueue.PSQ Int Int -> Int-bench_minView = go 0- where- go !n t = case PSQueue.minView t of- Nothing -> n- Just ((k :-> x), t') -> go (n + k + x) t'---- Empty a queue by sequentially removing all elements-bench_delete :: [Int] -> PSQueue.PSQ Int Int -> PSQueue.PSQ Int Int-bench_delete keys t0 = foldl' (\t k -> PSQueue.delete k t) t0 keys
benchmarks/Main.hs view
@@ -10,7 +10,6 @@ import qualified Data.IntPSQ.Benchmark as IntPSQ import qualified Data.HashPSQ.Benchmark as HashPSQ import qualified Data.PSQueue.Benchmark as PSQueue-import qualified Data.FingerTree.PSQueue.Benchmark as FingerPSQ benchmarkSize :: Int benchmarkSize = 2 ^ (12 :: Int)@@ -47,7 +46,4 @@ , PSQueue.benchmark "PSQueue increasing" increasing , PSQueue.benchmark "PSQueue decreasing" decreasing , PSQueue.benchmark "PSQueue semirandom" semirandom- , FingerPSQ.benchmark "FingerTree PSQueue increasing" increasing- , FingerPSQ.benchmark "FingerTree PSQueue decreasing" decreasing- , FingerPSQ.benchmark "FingerTree PSQueue semirandom" semirandom ]
psqueues.cabal view
@@ -1,5 +1,5 @@ Name: psqueues-Version: 0.2.7.3+Version: 0.2.8.3 License: BSD3 License-file: LICENSE Maintainer: Jasper Van der Jeugt <jaspervdj@gmail.com>@@ -8,6 +8,7 @@ Category: Data Structures Build-type: Simple Cabal-version: >=1.10+Tested-with: GHC==9.6.4, GHC==9.4.2, GHC==9.2.2, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 Description: The psqueues package provides@@ -66,11 +67,8 @@ Build-depends: base >= 4.2 && < 5- , deepseq >= 1.2 && < 1.5- , hashable >= 1.1.2.3 && < 1.5-- if impl(ghc>=6.10)- Build-depends: ghc-prim+ , deepseq >= 1.2 && < 1.6+ , hashable >= 1.1.2.3 && < 1.6 Exposed-modules: Data.HashPSQ@@ -92,7 +90,6 @@ Other-modules: BenchmarkTypes Data.BitUtil- Data.FingerTree.PSQueue.Benchmark Data.HashPSQ Data.HashPSQ.Benchmark Data.HashPSQ.Internal@@ -105,17 +102,12 @@ Data.PSQueue.Benchmark Build-depends:- containers >= 0.5- , unordered-containers >= 0.2.4- , criterion >= 0.8- , mtl >= 2.1- , fingertree-psqueue >= 0.3+ criterion >= 0.8 , PSQueue >= 1.1 , random >= 1.0 , base , deepseq- , ghc-prim , hashable , psqueues @@ -145,15 +137,13 @@ Build-depends: HUnit >= 1.2 && < 1.7- , QuickCheck >= 2.7 && < 2.15- , tasty >= 1.2 && < 1.5+ , QuickCheck >= 2.7 && < 2.16+ , tasty >= 1.2 && < 1.6 , tasty-hunit >= 0.9 && < 0.11- , tasty-quickcheck >= 0.8 && < 0.11+ , tasty-quickcheck >= 0.8 && < 0.12 , base- , array , deepseq- , ghc-prim , hashable , psqueues , tagged
src/Data/BitUtil.hs view
@@ -28,10 +28,9 @@ import Data.Bits ((.|.), xor) #if __GLASGOW_HASKELL__-import GHC.Exts (Word(..), Int(..))-import GHC.Prim (uncheckedShiftRL#)+import GHC.Exts (Word(..), Int(..), uncheckedShiftRL#) #else-import Data.Word (shiftL, shiftR)+import Data.Bits (shiftR) #endif -- The highestBitMask implementation is based on
src/Data/IntPSQ/Internal.hs view
@@ -282,8 +282,8 @@ Bin k' p' x' m l r | nomatch k k' m -> t | k == k' -> merge m l r- | zero k m -> binShrinkL k' p' x' m (go l) r- | otherwise -> binShrinkR k' p' x' m l (go r)+ | zero k m -> bin k' p' x' m (go l) r+ | otherwise -> bin k' p' x' m l (go r) -- | /O(min(n,W))/ Delete the binding with the least priority, and return the -- rest of the queue stripped of that binding. In case the queue is empty, the@@ -336,19 +336,11 @@ | p' <= p -> (b, Bin k p' x' m l r) | otherwise -> (b, unsafeInsertNew k p' x' (merge m l r)) --- | Smart constructor for a 'Bin' node whose left subtree could have become--- 'Nil'.-{-# INLINE binShrinkL #-}-binShrinkL :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v-binShrinkL k p x m Nil r = case r of Nil -> Tip k p x; _ -> Bin k p x m Nil r-binShrinkL k p x m l r = Bin k p x m l r---- | Smart constructor for a 'Bin' node whose right subtree could have become--- 'Nil'.-{-# INLINE binShrinkR #-}-binShrinkR :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v-binShrinkR k p x m l Nil = case l of Nil -> Tip k p x; _ -> Bin k p x m l Nil-binShrinkR k p x m l r = Bin k p x m l r+-- | Smart constructor for a 'Bin' node.+{-# INLINE bin #-}+bin :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v+bin k p x _ Nil Nil = Tip k p x+bin k p x m l r = Bin k p x m l r ------------------------------------------------------------------------------@@ -413,11 +405,11 @@ in t' `seq` (# t', Just (p', x') #) | zero k m -> case delFrom l of- (# l', mbPX #) -> let t' = binShrinkL k' p' x' m l' r+ (# l', mbPX #) -> let t' = bin k' p' x' m l' r in t' `seq` (# t', mbPX #) | otherwise -> case delFrom r of- (# r', mbPX #) -> let t' = binShrinkR k' p' x' m l r'+ (# r', mbPX #) -> let t' = bin k' p' x' m l r' in t' `seq` (# t', mbPX #) -- | /O(min(n,W))/ Retrieve the binding with the least priority, and the
src/Data/OrdPSQ/Internal.hs view
@@ -71,9 +71,9 @@ ) where import Control.DeepSeq (NFData (rnf))-import Data.Foldable (Foldable (foldr))+import Data.Foldable (Foldable (foldl')) import qualified Data.List as List-import Data.Maybe (isJust)+import Data.Maybe (isJust, fromMaybe) import Data.Traversable #if MIN_VERSION_base(4,11,0) import Prelude hiding (foldr, lookup, map, null, (<>))@@ -290,7 +290,7 @@ -- last priority and value for the key is retained. {-# INLINABLE fromList #-} fromList :: (Ord k, Ord p) => [(k, p, v)] -> OrdPSQ k p v-fromList = foldr (\(k, p, v) q -> insert k p v q) empty+fromList = foldl' (\q (k, p, v) -> insert k p v q) empty -- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The -- order of the list is not specified.@@ -302,7 +302,7 @@ keys t = [k | (k, _, _) <- toList t] -- TODO (jaspervdj): There must be faster implementations. --- | /O(n)/ Convert to an ascending list.+-- | /O(n)/ Convert to a list in ascending order by key. toAscList :: OrdPSQ k p v -> [(k, p, v)] toAscList q = seqToList (toAscLists q) where@@ -352,6 +352,7 @@ minView Void = Nothing minView (Winner (E k p v) t m) = Just (k, p, v, secondBest t m) +{-# INLINABLE secondBest #-} secondBest :: (Ord k, Ord p) => LTree k p v -> k -> OrdPSQ k p v secondBest Start _ = Void secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m'@@ -360,6 +361,7 @@ -- | 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 k, Ord p) => p -> OrdPSQ k p v -> ([(k, p, v)], OrdPSQ k p v) atMostView pt = go [] where@@ -448,7 +450,7 @@ data TourView k p v = Null | Single {-# UNPACK #-} !(Elem k p v)- | Play (OrdPSQ k p v) (OrdPSQ k p v)+ | Play !(OrdPSQ k p v) !(OrdPSQ k p v) tourView :: OrdPSQ k p v -> TourView k p v tourView Void = Null@@ -481,10 +483,14 @@ -- Balancing internals -------------------------------------------------------------------------------- --- | Balance factor+-- Balance factors, see Milan Straka - Adams' Trees Revisited+-- currently available at https://ufal.mff.cuni.cz/~straka/papers/2011-bbtree.pdf omega :: Int omega = 4 -- Has to be greater than 3.75 because Hinze's paper said so. +alpha :: Int+alpha = 2 -- Has to be 2 when omega is 4, by Straka's paper.+ size' :: LTree k p v -> Size size' Start = 0 size' (LLoser s _ _ _ _) = s@@ -508,49 +514,56 @@ lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr +{-# INLINABLE lbalance #-}+{-# INLINABLE rbalance #-} lbalance, rbalance :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lbalance k p v l m r- | size' l + size' r < 2 = lloser k p v l m r+ | size' r + size' l < 2 = lloser k p v l m r | size' r > omega * size' l = lbalanceLeft k p v l m r | size' l > omega * size' r = lbalanceRight k p v l m r | otherwise = lloser k p v l m r rbalance k p v l m r- | size' l + size' r < 2 = rloser k p v l m r+ | size' r + size' l < 2 = rloser k p v l m r | size' r > omega * size' l = rbalanceLeft k p v l m r | size' l > omega * size' r = rbalanceRight k p v l m r | otherwise = rloser k p v l m r +{-# INLINABLE lbalanceLeft #-} lbalanceLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lbalanceLeft k p v l m r- | size' (left r) < size' (right r) = lsingleLeft k p v l m r- | otherwise = ldoubleLeft k p v l m r+ | size' (left r) < alpha * size' (right r) = lsingleLeft k p v l m r+ | otherwise = ldoubleLeft k p v l m r +{-# INLINABLE lbalanceRight #-} lbalanceRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lbalanceRight k p v l m r- | size' (left l) > size' (right l) = lsingleRight k p v l m r- | otherwise = ldoubleRight k p v l m r+ | alpha * size' (left l) > size' (right l) = lsingleRight k p v l m r+ | otherwise = ldoubleRight k p v l m r +{-# INLINABLE rbalanceLeft #-} rbalanceLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rbalanceLeft k p v l m r- | size' (left r) < size' (right r) = rsingleLeft k p v l m r- | otherwise = rdoubleLeft k p v l m r+ | size' (left r) < alpha * size' (right r) = rsingleLeft k p v l m r+ | otherwise = rdoubleLeft k p v l m r +{-# INLINABLE rbalanceRight #-} rbalanceRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rbalanceRight k p v l m r- | size' (left l) > size' (right l) = rsingleRight k p v l m r- | otherwise = rdoubleRight k p v l m r+ | alpha * size' (left l) > size' (right l) = rsingleRight k p v l m r+ | otherwise = rdoubleRight k p v l m r +{-# INLINABLE lsingleLeft #-} lsingleLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v@@ -577,6 +590,7 @@ lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree" +{-# INLINABLE rsingleRight #-} rsingleRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v@@ -589,6 +603,7 @@ rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree" +{-# INLINABLE ldoubleLeft #-} ldoubleLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v@@ -598,6 +613,7 @@ lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree" +{-# INLINABLE ldoubleRight #-} ldoubleRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v@@ -607,6 +623,7 @@ lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree" +{-# INLINABLE rdoubleLeft #-} rdoubleLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v@@ -616,6 +633,7 @@ rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree" +{-# INLINABLE rdoubleRight #-} rdoubleRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v@@ -637,7 +655,12 @@ not (hasDuplicateKeys t) && hasMinHeapProperty t && hasBinarySearchTreeProperty t &&- hasCorrectSizeAnnotations t+ hasCorrectSizeAnnotations t &&+ hasBalancedTreeProperty t &&+ hasLTreeBST t &&+ hasLTreeKeyCondition t &&+ hasLTreeOrigins t &&+ hasPennantHeap t hasDuplicateKeys :: Ord k => OrdPSQ k p v -> Bool hasDuplicateKeys = any (> 1) . List.map length . List.group . List.sort . keys@@ -680,6 +703,60 @@ calculateSize (LLoser _ _ l _ r) = 1 + calculateSize l + calculateSize r calculateSize (RLoser _ _ l _ r) = 1 + calculateSize l + calculateSize r +hasBalancedTreeProperty :: OrdPSQ k p v -> Bool+hasBalancedTreeProperty Void = True+hasBalancedTreeProperty (Winner _ t _) = go t+ where+ go Start = True+ go (LLoser _ _ l _ r) = withinOmegaFactor l r && go l && go r+ go (RLoser _ _ l _ r) = withinOmegaFactor l r && go l && go r++ withinOmegaFactor t1 t2 = l + u < 2 || l * omega >= u+ where+ (l, u)+ | s1 < s2 = (s1, s2)+ | otherwise = (s2, s1)+ s1 = size' t1+ s2 = size' t2++hasLTreeBST :: Ord k => OrdPSQ k p v -> Bool+hasLTreeBST Void = True+hasLTreeBST (Winner (E qk _ _) t qm) = qk <= qm && go (<= qm) t+ where+ go _ Start = True+ go p (LLoser _ (E k _ _) l m r) =+ p k && go (\x -> p x && x <= m) l && go (\x -> p x && x > m) r+ go p (RLoser _ (E k _ _) l m r) =+ p k && go (\x -> p x && x <= m) l && go (\x -> p x && x > m) r++hasLTreeKeyCondition :: Ord k => OrdPSQ k p v -> Bool+hasLTreeKeyCondition Void = True+hasLTreeKeyCondition p@(Winner _ t qm) = hasKey qm && go t+ where+ hasKey k = isJust (lookup k p)++ go Start = True+ go (LLoser _ _ l m r) = hasKey m && go l && go r+ go (RLoser _ _ l m r) = hasKey m && go l && go r++hasLTreeOrigins :: Ord k => OrdPSQ k p v -> Bool+hasLTreeOrigins Void = True+hasLTreeOrigins (Winner _ lt _) = go lt+ where+ go Start = True+ go (LLoser _ (E k _ _) l m r) = k <= m && go l && go r+ go (RLoser _ (E k _ _) l m r) = k > m && go l && go r++hasPennantHeap :: Ord p => OrdPSQ k p v -> Bool+hasPennantHeap Void = True+hasPennantHeap p@(Winner (E _ mp _) _ _) = go mp (tourView p)+ where+ go _ Null = True+ go d (Single (E _ prio _)) = prio >= d+ go d (Play l r) = fromMaybe False $ do+ (_, pl, _) <- findMin l+ (_, pr, _) <- findMin r+ pure $ pl >= d && pr >= d && go pl (tourView l) && go pr (tourView r) -------------------------------------------------------------------------------- -- Utility functions
tests/Data/PSQ/Class/Tests.hs view
@@ -178,9 +178,12 @@ :: forall psq. (PSQ psq, TestKey (Key psq), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq Assertion-test_fromList = Tagged $+test_fromList = Tagged $ do let ls = [(1, 0, 'A'), (2, 0, 'B'), (3, 0, 'C'), (4, 0, 'D')]- in (fromList ls :: psq Int Char) @?= fromList (reverse ls)+ in (fromList ls :: psq Int Char) @?= fromList (reverse ls)+ let qs = [(4, 0, 'D'), (1, 5, 'Q'), (2, 0, 'B'), (1, 0, 'A'), (3, 0, 'C'), (2, 5, 'Z')]+ qs' = [(1, 0, 'A'), (2, 5, 'Z'), (3, 0, 'C'), (4, 0, 'D')]+ in List.sort (toList (fromList qs :: psq Int Char)) @?= qs' test_foldr :: forall psq. (PSQ psq, TestKey (Key psq),