diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/benchmarks/Data/FingerTree/PSQueue/Benchmark.hs b/benchmarks/Data/FingerTree/PSQueue/Benchmark.hs deleted file mode 100644 --- a/benchmarks/Data/FingerTree/PSQueue/Benchmark.hs +++ /dev/null @@ -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 diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -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 ] diff --git a/psqueues.cabal b/psqueues.cabal --- a/psqueues.cabal +++ b/psqueues.cabal @@ -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 @@ -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 diff --git a/src/Data/BitUtil.hs b/src/Data/BitUtil.hs --- a/src/Data/BitUtil.hs +++ b/src/Data/BitUtil.hs @@ -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 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 @@ -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 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 @@ -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 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 @@ -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),