diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,29 @@ + +### 1.2.2 + +- Fix tree balancing issue [#20](https://github.com/PSQueue/PSQueue/pull/20) + +### 1.2.1 + +- Move Changelog.md to extra-doc-files section [#17](https://github.com/PSQueue/PSQueue/pull/17) +- Use tasty in test suite [#16](https://github.com/PSQueue/PSQueue/pull/16) +- Fix tree balancing logic (Thanks to @chowells79) [#15](https://github.com/PSQueue/PSQueue/pull/15) +- Support GHC-9.12 [#13](https://github.com/PSQueue/PSQueue/pull/13) +- Support GHC-9.10 [#12](https://github.com/PSQueue/PSQueue/pull/12) +- Support GHC-9.8 [#11](https://github.com/PSQueue/PSQueue/pull/11) + +### 1.2.0 + +- Fix typos (Thanks to @Moiman) [#8](https://github.com/PSQueue/PSQueue/pull/8) +- Improve performance, strictness, and remove redundant constraints (Thanks to @treeowl) [#9](https://github.com/PSQueue/PSQueue/pull/9) +- Support GHC-9.4 [#6](https://github.com/PSQueue/PSQueue/pull/6) +- Support GHC-9.6 [#9](https://github.com/PSQueue/PSQueue/pull/9) + ### 1.1.1 - Teo Camarasu takes over as maintainer [#1](https://github.com/TeofilC/PSQueue/pull/1) -- Relax base bound to allow compatiblity with GHC-9.0 and GHC-9.2 [#2](https://github.com/TeofilC/PSQueue/pull/2) +- Relax base bound to allow compatibility with GHC-9.0 and GHC-9.2 [#2](https://github.com/TeofilC/PSQueue/pull/2) - Add test suite and basic Github Actions CI [#3](https://github.com/TeofilC/PSQueue/pull/3) - ### 1.1.0.1 diff --git a/PSQueue.cabal b/PSQueue.cabal --- a/PSQueue.cabal +++ b/PSQueue.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: PSQueue -version: 1.1.1 +version: 1.2.2 build-type: Simple license: BSD3 license-file: LICENSE @@ -11,15 +11,15 @@ category: Data Structures description: A /priority search queue/ efficiently supports the - opperations of both a search tree and a priority queue. A + operations of both a search tree and a priority queue. A 'Binding' is a product of a key and a priority. Bindings can be inserted, deleted, modified and queried in logarithmic time, and the binding with the least priority can be retrieved in constant time. A queue can be built from a list of bindings, sorted by keys, in linear time. -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 -extra-source-files: ChangeLog.md +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1 || ==9.6.1 || ==9.8.1 || ==9.10.1 || ==9.12.1 +extra-doc-files: ChangeLog.md source-repository head type: git @@ -36,7 +36,7 @@ if impl(ghc >7.2) default-extensions: Safe - build-depends: base >=4.3 && <4.17 + build-depends: base >=4.3 && <4.22 test-suite test type: exitcode-stdio-1.0 @@ -46,4 +46,7 @@ build-depends: base , PSQueue - , QuickCheck + , QuickCheck < 3 + , tasty <1.6 + , tasty-quickcheck <0.12 + , tasty-hunit <0.11 diff --git a/src/Data/PSQueue.hs b/src/Data/PSQueue.hs --- a/src/Data/PSQueue.hs +++ b/src/Data/PSQueue.hs @@ -1,7 +1,7 @@ {- | A /priority search queue/ (henceforth /queue/) efficiently supports the -opperations of both a search tree and a priority queue. A 'Binding' is a +operations of both a search tree and a priority queue. A 'Binding' is a product of a key and a priority. Bindings can be inserted, deleted, modified and queried in logarithmic time, and the binding with the least priority can be retrieved in constant time. A queue can be built from a list of bindings, diff --git a/src/Data/PSQueue/Internal.hs b/src/Data/PSQueue/Internal.hs --- a/src/Data/PSQueue/Internal.hs +++ b/src/Data/PSQueue/Internal.hs @@ -1,4 +1,4 @@ -module Data.PSQueue.Internal +module Data.PSQueue.Internal ( -- * Binding Type Binding(..) @@ -73,16 +73,19 @@ , rdoubleLeft , rdoubleRight , play - , unsafePlay , TourView(..) , tourView + , ltreeDot + , pennantDot ) where +import Data.Function (on) import Prelude hiding (foldl, foldr, lookup, null) import qualified Prelude as P +import Data.Char (ord, isSpace, isAlphaNum) -- | @k :-> p@ binds the key @k@ with the priority @p@. -data Binding k p = k :-> p deriving (Eq,Ord,Show,Read) +data Binding k p = !k :-> !p deriving (Eq,Ord,Show,Read) infix 0 :-> @@ -97,14 +100,15 @@ -- | A mapping from keys @k@ to priorites @p@. -data PSQ k p = Void | Winner k p (LTree k p) k +data PSQ k p = Void | Winner !k !p !(LTree k p) !k -instance (Show k, Show p, Ord k, Ord p) => Show (PSQ k p) where +instance (Show k, Show p) => Show (PSQ k p) where show = show . toAscList --show Void = "[]" --show (Winner k1 p lt k2) = "Winner "++show k1++" "++show p++" ("++show lt++") "++show k2 - +instance (Eq k, Eq p) => Eq (PSQ k p) where + (==) = (==) `on` toAscList -- | /O(1)/ The number of bindings in a queue. @@ -119,7 +123,8 @@ -- | /O(log n)/ The priority of a given key, or Nothing if the key is not -- bound. -lookup :: (Ord k, Ord p) => k -> PSQ k p -> Maybe p +{-# INLINABLE lookup #-} +lookup :: Ord k => k -> PSQ k p -> Maybe p lookup k q = case tourView q of Null -> fail "PSQueue.lookup: Empty queue" @@ -132,15 +137,16 @@ -empty :: (Ord k, Ord p) => PSQ k p +empty :: PSQ k p empty = Void -- | O(1) Build a queue with one binding. -singleton :: (Ord k, Ord p) => k -> p -> PSQ k p +singleton :: k -> p -> PSQ k p singleton k p = Winner k p Start k -- | /O(log n)/ Insert a binding into the queue. +{-# INLINABLE insert #-} insert :: (Ord k, Ord p) => k -> p -> PSQ k p -> PSQ k p insert k p q = case tourView q of @@ -160,6 +166,7 @@ insertWith f = insertWithKey (\_ p p'-> f p p') -- | /O(log n)/ Insert a binding with a combining function. +{-# INLINABLE insertWithKey #-} insertWithKey :: (Ord k, Ord p) => (k->p->p->p) -> k -> p -> PSQ k p -> PSQ k p insertWithKey f k p q = case tourView q of @@ -170,12 +177,13 @@ EQ -> singleton k (f k p p') GT -> singleton k' p' `play` singleton k p tl `Play` tr - | k <= maxKey tl -> insertWithKey f k p tl `unsafePlay` tr - | otherwise -> tl `unsafePlay` insertWithKey f k p tr + | k <= maxKey tl -> insertWithKey f k p tl `play` tr + | otherwise -> tl `play` insertWithKey f k p tr -- | /O(log n)/ Remove a binding from the queue. +{-# INLINABLE delete #-} delete :: (Ord k, Ord p) => k -> PSQ k p -> PSQ k p delete k q = case tourView q of @@ -188,10 +196,11 @@ | otherwise -> tl `play` delete k tr -- | /O(log n)/ Adjust the priority of a key. -adjust :: (Ord p, Ord k) => (p -> p) -> k -> PSQ k p -> PSQ k p +adjust :: (Ord p, Ord k) => (p -> p) -> k -> PSQ k p -> PSQ k p adjust f = adjustWithKey (\_ p -> f p) -- | /O(log n)/ Adjust the priority of a key. +{-# INLINABLE adjustWithKey #-} adjustWithKey :: (Ord k, Ord p) => (k -> p -> p) -> k -> PSQ k p -> PSQ k p adjustWithKey f k q = case tourView q of @@ -200,8 +209,8 @@ | k == k' -> singleton k' (f k p) | otherwise -> singleton k' p tl `Play` tr - | k <= maxKey tl -> adjustWithKey f k tl `unsafePlay` tr - | otherwise -> tl `unsafePlay` adjustWithKey f k tr + | k <= maxKey tl -> adjustWithKey f k tl `play` tr + | otherwise -> tl `play` adjustWithKey f k tr -- | /O(log n)/ The expression (@update f k q@) updates the @@ -217,6 +226,7 @@ -- the binding is deleted. If it is (@'Just' z@), the key @k@ is bound -- to the new priority @z@. +{-# INLINABLE updateWithKey #-} updateWithKey :: (Ord k, Ord p) => (k -> p -> Maybe p) -> k -> PSQ k p -> PSQ k p updateWithKey f k q = case tourView q of @@ -227,12 +237,14 @@ Just p' -> singleton k p' | otherwise -> singleton k' p tl `Play` tr - | k <= maxKey tl -> updateWithKey f k tl `unsafePlay` tr - | otherwise -> tl `unsafePlay` updateWithKey f k tr + | k <= maxKey tl -> updateWithKey f k tl `play` tr + | otherwise -> tl `play` updateWithKey f k tr -- | /O(log n)/. The expression (@'alter' f k q@) alters the priority @p@ bound to @k@, or absence thereof. -- alter can be used to insert, delete, or update a priority in a queue. + +{-# INLINABLE alter #-} alter :: (Ord k, Ord p) => (Maybe p -> Maybe p) -> k -> PSQ k p -> PSQ k p alter f k q = case tourView q of @@ -248,13 +260,13 @@ Nothing -> singleton k' p Just p' -> insert k p' $ singleton k' p tl `Play` tr - | k <= maxKey tl -> alter f k tl `unsafePlay` tr - | otherwise -> tl `unsafePlay` alter f k tr + | k <= maxKey tl -> alter f k tl `play` tr + | otherwise -> tl `play` alter f k tr -- | /O(n)/ The keys of a priority queue -keys :: (Ord k, Ord p) => PSQ k p -> [k] +keys :: PSQ k p -> [k] keys = map key . toList -- | /O(n log n)/ Build a queue from a list of bindings. @@ -263,7 +275,8 @@ -- | /O(n)/ Build a queue from a list of bindings in order of -- ascending keys. The precondition that the keys are ascending is not checked. -fromAscList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p +{-# INLINABLE fromAscList #-} +fromAscList :: (Eq k, Ord p) => [Binding k p] -> PSQ k p fromAscList = fromDistinctAscList . stripEq where stripEq [] = [] stripEq (x:xs) = stripEq' x xs @@ -274,8 +287,9 @@ -- | /O(n)/ Build a queue from a list of distinct bindings in order of -- ascending keys. The precondition that keys are distinct and ascending is not checked. -fromDistinctAscList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p -fromDistinctAscList = foldm unsafePlay empty . map (\(k:->p) -> singleton k p) +{-# INLINABLE fromDistinctAscList #-} +fromDistinctAscList :: Ord p => [Binding k p] -> PSQ k p +fromDistinctAscList = foldm play empty . map (\(k:->p) -> singleton k p) -- Folding a list in a binary-subdivision scheme. foldm :: (a -> a -> a) -> a -> [a] -> a @@ -289,24 +303,24 @@ (a2, as2) = rec m as1 -- | /O(n)/ Convert a queue to a list. -toList :: (Ord k, Ord p) => PSQ k p -> [Binding k p] +toList :: PSQ k p -> [Binding k p] toList = toAscList -- | /O(n)/ Convert a queue to a list in ascending order of keys. -toAscList :: (Ord k, Ord p) => PSQ k p -> [Binding k p] +toAscList :: PSQ k p -> [Binding k p] toAscList q = seqToList (toAscLists q) -toAscLists :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p) +toAscLists :: PSQ k p -> Sequ (Binding k p) toAscLists q = case tourView q of Null -> emptySequ Single k p -> singleSequ (k :-> p) tl `Play` tr -> toAscLists tl <+> toAscLists tr -- | /O(n)/ Convert a queue to a list in descending order of keys. -toDescList :: (Ord k, Ord p) => PSQ k p -> [ Binding k p ] +toDescList :: PSQ k p -> [ Binding k p ] toDescList q = seqToList (toDescLists q) -toDescLists :: (Ord k, Ord p) => PSQ k p -> Sequ (Binding k p) +toDescLists :: PSQ k p -> Sequ (Binding k p) toDescLists q = case tourView q of Null -> emptySequ Single k p -> singleSequ (k :-> p) @@ -314,22 +328,23 @@ -- | /O(1)/ The binding with the lowest priority. -findMin :: (Ord k, Ord p) => PSQ k p -> Maybe (Binding k p) +findMin :: PSQ k p -> Maybe (Binding k p) findMin Void = Nothing findMin (Winner k p t m) = Just (k :-> p) -- | /O(log n)/ Remove the binding with the lowest priority. -deleteMin :: (Ord k, Ord p) => PSQ k p -> PSQ k p +deleteMin :: Ord p => PSQ k p -> PSQ k p deleteMin Void = Void deleteMin (Winner k p t m) = secondBest t m -- | /O(log n)/ Retrieve the binding with the least priority, and the rest of -- the queue stripped of that binding. -minView :: (Ord k, Ord p) => PSQ k p -> Maybe (Binding k p, PSQ k p) +minView :: Ord p => PSQ k p -> Maybe (Binding k p, PSQ k p) minView Void = Nothing minView (Winner k p t m) = Just ( k :-> p , secondBest t m ) -secondBest :: (Ord k, Ord p) => LTree k p -> k -> PSQ k p +{-# INLINABLE secondBest #-} +secondBest :: Ord p => LTree k p -> k -> PSQ k p secondBest Start _m = Void secondBest (LLoser _ k p tl m tr) m' = Winner k p tl m `play` secondBest tr m' secondBest (RLoser _ k p tl m tr) m' = secondBest tl m `play` Winner k p tr m' @@ -343,10 +358,10 @@ -- @ -- atMost p' q = filter (\\(k:->p) -> p<=p') . toList -- @ -atMost :: (Ord k, Ord p) => p -> PSQ k p -> [Binding k p] +atMost :: Ord p => p -> PSQ k p -> [Binding k p] atMost pt q = seqToList (atMosts pt q) -atMosts :: (Ord k, Ord p) => p -> PSQ k p -> Sequ (Binding k p) +atMosts :: Ord p => p -> PSQ k p -> Sequ (Binding k p) atMosts _pt Void = emptySequ atMosts pt (Winner k p t _) = prune k p t where @@ -364,11 +379,12 @@ -- @ -- atMostRange p' (l,u) q = filter (\\(k:->p) -> l<=k && k<=u ) . 'atMost' p' -- @ +{-# INLINABLE atMostRange #-} atMostRange :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> [Binding k p] atMostRange pt (kl, kr) q = seqToList (atMostRanges pt (kl, kr) q) +{-# INLINABLE atMostRanges #-} atMostRanges :: (Ord k, Ord p) => p -> (k, k) -> PSQ k p -> Sequ (Binding k p) - atMostRanges _pt _range Void = emptySequ atMostRanges pt range@(kl, kr) (Winner k p t _) = prune k p t where @@ -383,14 +399,15 @@ traverse k p (RLoser _ k' p' tl m tr) = guard (kl <= m) (traverse k p tl) <+> guard (m <= kr) (prune k' p' tr) -inrange :: (Ord a) => a -> (a, a) -> Bool +{-# INLINE inrange #-} +inrange :: Ord a => a -> (a, a) -> Bool a `inrange` (l, r) = l <= a && a <= r -- | Right fold over the bindings in the queue, in key order. -foldr :: (Ord k,Ord p) => (Binding k p -> b -> b) -> b -> PSQ k p -> b +foldr :: (Binding k p -> b -> b) -> b -> PSQ k p -> b foldr f z q = case tourView q of Null -> z @@ -399,7 +416,7 @@ -- | Left fold over the bindings in the queue, in key order. -foldl :: (Ord k,Ord p) => (b -> Binding k p -> b) -> b -> PSQ k p -> b +foldl :: (b -> Binding k p -> b) -> b -> PSQ k p -> b foldl f z q = case tourView q of Null -> z @@ -415,9 +432,14 @@ type Size = Int +-- LTree type from +-- https://www.cs.ox.ac.uk/ralf.hinze/publications/ICFP01.pdf +-- +-- This uses the augmented definition as outlined in Remark 3 in +-- section 5.2 of the paper above. data LTree k p = Start - | LLoser {-# UNPACK #-}!Size !k !p (LTree k p) !k (LTree k p) - | RLoser {-# UNPACK #-}!Size !k !p (LTree k p) !k (LTree k p) + | LLoser {-# UNPACK #-}!Size !k !p !(LTree k p) !k !(LTree k p) + | RLoser {-# UNPACK #-}!Size !k !p !(LTree k p) !k !(LTree k p) size' :: LTree k p -> Size @@ -443,45 +465,63 @@ lloser k p tl m tr = LLoser (1 + size' tl + size' tr) k p tl m tr rloser k p tl m tr = RLoser (1 + size' tl + size' tr) k p tl m tr ---balance factor +-- balance factors, taken from Milan Straka - Adams' Trees Revisited +-- https://ufal.mff.cuni.cz/~straka/papers/2011-bbtree.pdf +-- +-- This paper provides proofs of the correctness of the balancing +-- scheme, fixing some edge cases where a double rotation was +-- preferred despite not restoring balance in a single update. omega :: Int omega = 4 +alpha :: Int +alpha = 2 + +{-# INLINABLE lbalance #-} +{-# INLINABLE rbalance #-} lbalance, rbalance :: - (Ord k, Ord p) => k-> p -> LTree k p -> k -> LTree k p -> LTree k p + Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p lbalance k p l m r - | size' l + size' r < 2 = lloser k p l m r + | size' r + size' l < 2 = lloser k p l m r | size' r > omega * size' l = lbalanceLeft k p l m r | size' l > omega * size' r = lbalanceRight k p l m r - | otherwise = lloser k p l m r + | otherwise = lloser k p l m r rbalance k p l m r - | size' l + size' r < 2 = rloser k p l m r + | size' r + size' l < 2 = rloser k p l m r | size' r > omega * size' l = rbalanceLeft k p l m r | size' l > omega * size' r = rbalanceRight k p l m r - | otherwise = rloser k p l m r + | otherwise = rloser k p l m r +{-# INLINABLE lbalanceLeft #-} +lbalanceLeft :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p lbalanceLeft k p l m r - | size' (left r) < size' (right r) = lsingleLeft k p l m r - | otherwise = ldoubleLeft k p l m r + | size' (left r) < alpha * size' (right r) = lsingleLeft k p l m r + | otherwise = ldoubleLeft k p l m r +{-# INLINABLE lbalanceRight #-} +lbalanceRight :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p lbalanceRight k p l m r - | size' (left l) > size' (right l) = lsingleRight k p l m r - | otherwise = ldoubleRight k p l m r - + | alpha * size' (left l) > size' (right l) = lsingleRight k p l m r + | otherwise = ldoubleRight k p l m r +{-# INLINABLE rbalanceLeft #-} +rbalanceLeft :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p rbalanceLeft k p l m r - | size' (left r) < size' (right r) = rsingleLeft k p l m r - | otherwise = rdoubleLeft k p l m r + | size' (left r) < alpha * size' (right r) = rsingleLeft k p l m r + | otherwise = rdoubleLeft k p l m r +{-# INLINABLE rbalanceRight #-} +rbalanceRight :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p rbalanceRight k p l m r - | size' (left l) > size' (right l) = rsingleRight k p l m r - | otherwise = rdoubleRight k p l m r - + | alpha * size' (left l) > size' (right l) = rsingleRight k p l m r + | otherwise = rdoubleRight k p l m r +{-# INLINABLE lsingleLeft #-} +lsingleLeft :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p lsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) | p1 <= p2 = lloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3 | otherwise = lloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3 @@ -489,18 +529,22 @@ lsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) = rloser k2 p2 (lloser k1 p1 t1 m1 t2) m2 t3 +rsingleLeft :: k -> p -> LTree k p -> k -> LTree k p -> LTree k p rsingleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) = rloser k1 p1 (rloser k2 p2 t1 m1 t2) m2 t3 rsingleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) = rloser k2 p2 (rloser k1 p1 t1 m1 t2) m2 t3 +lsingleRight :: k -> p -> LTree k p -> k -> LTree k p -> LTree k p lsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 = lloser k2 p2 t1 m1 (lloser k1 p1 t2 m2 t3) lsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 = lloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3) +{-# INLINABLE rsingleRight #-} +rsingleRight :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p rsingleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 = lloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3) @@ -509,33 +553,40 @@ | otherwise = rloser k2 p2 t1 m1 (rloser k1 p1 t2 m2 t3) - +{-# INLINABLE ldoubleLeft #-} +ldoubleLeft :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p ldoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) = lsingleLeft k1 p1 t1 m1 (lsingleRight k2 p2 t2 m2 t3) ldoubleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) = lsingleLeft k1 p1 t1 m1 (rsingleRight k2 p2 t2 m2 t3) +{-# INLINABLE ldoubleRight #-} +ldoubleRight :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p ldoubleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 = lsingleRight k1 p1 (lsingleLeft k2 p2 t1 m1 t2) m2 t3 ldoubleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 = lsingleRight k1 p1 (rsingleLeft k2 p2 t1 m1 t2) m2 t3 +{-# INLINABLE rdoubleLeft #-} +rdoubleLeft :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p rdoubleLeft k1 p1 t1 m1 (LLoser _ k2 p2 t2 m2 t3) = rsingleLeft k1 p1 t1 m1 (lsingleRight k2 p2 t2 m2 t3) rdoubleLeft k1 p1 t1 m1 (RLoser _ k2 p2 t2 m2 t3) = rsingleLeft k1 p1 t1 m1 (rsingleRight k2 p2 t2 m2 t3) +{-# INLINABLE rdoubleRight #-} +rdoubleRight :: Ord p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p rdoubleRight k1 p1 (LLoser _ k2 p2 t1 m1 t2) m2 t3 = rsingleRight k1 p1 (lsingleLeft k2 p2 t1 m1 t2) m2 t3 rdoubleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 = rsingleRight k1 p1 (rsingleLeft k2 p2 t1 m1 t2) m2 t3 - -play :: (Ord k, Ord p) => PSQ k p -> PSQ k p -> PSQ k p +{-# INLINABLE play #-} +play :: Ord p => PSQ k p -> PSQ k p -> PSQ k p Void `play` t' = t' t `play` Void = t @@ -544,21 +595,11 @@ | p <= p' = Winner k p (rbalance k' p' t m t') m' | otherwise = Winner k' p' (lbalance k p t m t') m' -unsafePlay :: (Ord k, Ord p) => PSQ k p -> PSQ k p -> PSQ k p -Void `unsafePlay` t' = t' -t `unsafePlay` Void = t - -Winner k p t m `unsafePlay` Winner k' p' t' m' - | p <= p' = Winner k p (rbalance k' p' t m t') m' - | otherwise = Winner k' p' (lbalance k p t m t') m' - - - -data TourView k p = Null | Single k p | PSQ k p `Play` PSQ k p - -tourView :: (Ord k) => PSQ k p -> TourView k p +data TourView k p = Null | Single !k !p | !(PSQ k p) `Play` !(PSQ k p) +tourView :: PSQ k p -> TourView k p +{-# INLINE tourView #-} tourView Void = Null tourView (Winner k p Start _m) = Single k p @@ -601,3 +642,80 @@ guard :: Bool -> Sequ a -> Sequ a guard False _as = emptySequ guard True as = as + + + +------------------------------------------------------- +-- Helpers for rendering PSQs in graphviz dot format -- +------------------------------------------------------- + +dotLitS :: Show a => a -> String +dotLitS = dotLit . show + +dotLit :: String -> String +dotLit = concatMap subst + where + subst '<' = "<" + subst '>' = ">" + subst x + | isAlphaNum x = pure x + | isSpace x = pure x + | otherwise = "&#" ++ show (ord x) ++ ";" + + +ltreeDot :: (Show k, Show p) => PSQ k p -> String +ltreeDot x = "digraph g {\n" ++ inner x ++ "}\n" + where + inner Void = " Void\n" + inner (Winner k p ltree m) = here ++ edge ++ children + where + here = " 0 [label=<(" ++ dotLitS k ++ ", " ++ dotLitS p ++ ") " ++ + dotLitS m ++ ">]\n" + edge | n > 1 = " 0 -> 1\n" + | otherwise = "" + (n, children) = go 1 ltree + + go n Start = (n, "") + go n (LLoser s k p l m r) = node n s k p l m r "larrow" + go n (RLoser s k p l m r) = node n s k p l m r "rarrow" + + node n s k p l m r shape = (n'', here ++ ledge ++ redge ++ lc ++ rc) + where + pre = " " ++ show n + here = pre ++ " [shape=" ++ shape ++ ";label=<" ++ show s ++ + "
 (" ++ dotLitS k ++ ", " ++ dotLitS p ++ ") " ++ + dotLitS m ++ " >;margin=0.1]\n" + ledge | n' > n + 1 = pre ++ " -> " ++ show (n + 1) ++ " [label=L]\n" + | otherwise = "" + redge | n'' > n' = pre ++ " -> " ++ show n' ++ " [label=R]\n" + | otherwise = "" + (n', lc) = go (n + 1) l + (n'', rc) = go n' r + + +pennantDot :: (Show k, Show p, Ord p) => PSQ k p -> String +pennantDot x = "digraph g {\n" ++ inner ++ "}\n" + where + inner = case x of + Void -> " Null\n" + _ -> snd (go 1 (tourView x)) + + go n Null = (n, "") + go n (Single k p) = (n + 1, here) + where + here = " " ++ show n ++ " [label=<" ++ dotLitS k ++ ", " ++ + dotLitS p ++ ">]\n" + go n (Play l r) = (n'', here ++ left ++ right) + where + (n', left) = go (n + 1) (tourView l) + (n'', right) = go n' (tourView r) + here = maybe "" id $ do + bLeft <- findMin l + bRight <- findMin r + let (k :-> p, s) | prio bLeft <= prio bRight = (bLeft, "larrow") + | otherwise = (bRight, "rarrow") + res = " " ++ show n ++ " [label=<" ++ dotLitS k ++ ", " ++ + dotLitS p ++ ">;shape=" ++ s ++ "]\n" ++ " " ++ + show n ++ " -> " ++ show (n + 1) ++ " [label=L]\n" ++ + " " ++ show n ++ " -> " ++ show n' ++ " [label=R]\n" + pure res diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,15 +1,23 @@ +{-# Language FlexibleContexts, StandaloneDeriving #-} +import Prelude hiding (lookup) + import Data.PSQueue.Internal import Test.QuickCheck +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import Data.List (sort) +import Data.Maybe (fromMaybe, isJust) +isBalanced :: LTree Int Int -> Bool isBalanced Start = True isBalanced (LLoser s k p l m r) = - (size' l + size' r <= 2 ||(size' l<=omega*size' r && size' r<=omega*size' l)) + (size' l + size' r <= 2 || (size' l <= omega * size' r && size' r <= omega * size' l)) && isBalanced l && isBalanced r isBalanced (RLoser s k p l m r) = - (size' l + size' r <= 2 ||(size' l<=omega*size' r && size' r<=omega*size' l)) + (size' l + size' r <= 2 || (size' l <= omega * size' r && size' r <= omega * size' l)) && isBalanced l && isBalanced r instance (Ord k, Ord p, Arbitrary k, Arbitrary p) => Arbitrary (PSQ k p) @@ -47,15 +55,118 @@ Nothing -> True Just (b2,_) -> prio b1 <= prio b2 && prop_MinView t' -main = - do - putStrLn "Balanced" - quickCheck prop_Balanced - putStrLn "OrderedKeys" - quickCheck prop_OrderedKeys - putStrLn "MinView" - quickCheck prop_MinView - putStrLn "AtMost" - quickCheck prop_AtMost - putStrLn "AtMostRange" - quickCheck prop_AtMostRange +prop_SizeValid :: PSQ Int Int -> Bool +prop_SizeValid p@Void = size p == 0 +prop_SizeValid p@(Winner _ _ t _) = size p == 1 + count t && go t + where + go Start = True + go ll@(LLoser s _ _ l _ r) = s == count ll && go l && go r + go rl@(RLoser s _ _ l _ r) = s == count rl && go l && go r + + count Start = 0 + count (LLoser _ _ _ l _ r) = 1 + count l + count r + count (RLoser _ _ _ l _ r) = 1 + count l + count r + +prop_LTreeBSTValid :: PSQ Int Int -> Bool +prop_LTreeBSTValid Void = True +prop_LTreeBSTValid (Winner qk _ l qm) = qk <= qm && go (<= qm) l + where + go _ Start = True + go p (LLoser _ k _ l m r) = + p k && go (\x -> p x && x <= m) l && go (\x -> p x && x > m) r + go p (RLoser _ k _ l m r) = + p k && go (\x -> p x && x <= m) l && go (\x -> p x && x > m) r + +prop_LTreeKeysValid :: PSQ Int Int -> Bool +prop_LTreeKeysValid Void = True +prop_LTreeKeysValid p@(Winner _ _ l qm) = hasKey qm && go l + 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 + +prop_LTreeSemiHeap :: PSQ Int Int -> Bool +prop_LTreeSemiHeap Void = True +prop_LTreeSemiHeap (Winner _ mp lt _) = go mp lt + where + go _ Start = True + go d (LLoser _ _ p l _ r) = p >= d && go p l && go d r + go d (RLoser _ _ p l _ r) = p >= d && go d l && go p r + +prop_LTreeOriginates :: PSQ Int Int -> Bool +prop_LTreeOriginates Void = True +prop_LTreeOriginates (Winner _ _ lt _) = go lt + where + go Start = True + go (LLoser _ k _ l m r) = k <= m && go l && go r + go (RLoser _ k _ l m r) = k > m && go l && go r + +prop_PennantHeap :: PSQ Int Int -> Bool +prop_PennantHeap Void = True +prop_PennantHeap p@(Winner _ mp _ _) = go mp (tourView p) + where + go _ Null = True + go d (Single _ p) = p >= 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) + +prop_PennantBST :: PSQ Int Int -> Bool +prop_PennantBST Void = True +prop_PennantBST p = go (const True) (tourView p) + where + go _ Null = True + go p (Single k _) = p k + go p (Play l r) = fromMaybe False $ do + (kl :-> _) <- findMin l + (kr :-> _) <- findMin r + pure $ kl < kr && p kl && p kr && + go (\x -> p x && x <= kr) (tourView l) && + go (\x -> p x && x >= kl) (tourView r) + + +assertion_BalanceFromlist :: Assertion +assertion_BalanceFromlist = + assertBool "fromList builds a balanced tree" (prop_Balanced (fromList ls)) + where + ls :: [Binding Int Int] + ls = [ 63 :-> 19, 60 :-> 24, -10 :-> -27, 66 :-> 7, 60 :-> -25 + , -5 :-> -48, -3 :-> 37, -1 :-> -38, 12 :-> 67, 52 :-> -43 + , 40 :-> -29, 50 :-> -38, -30 :-> -65, 4 :-> -64, 53 :-> -5 + , -22 :-> -22, -34 :-> -51, 51 :-> 49, -43 :-> 18 + ] + +assertion_BalancePlay :: Assertion +assertion_BalancePlay = + assertBool "play gives a balanced tree" (prop_Balanced (ql `play` qr)) + where + ql :: PSQ Int Int + ql = Winner (-30) (-65) (LLoser 3 (-34) (-51) (LLoser 1 (-43) 18 Start (-43) Start) (-34) (RLoser 1 (-22) (-22) Start (-30) Start)) (-22) + + qr :: PSQ Int Int + qr = Winner 4 (-64) (RLoser 13 52 (-43) (RLoser 6 40 (-29) (LLoser 4 (-5) (-48) (RLoser 2 (-3) 37 (LLoser 1 (-10) (-27) Start (-10) Start) (-5) Start) (-3) (LLoser 1 (-1) (-38) Start (-1) Start)) 4 (LLoser 1 12 67 Start 12 Start)) 40 (LLoser 6 50 (-38) (RLoser 1 51 49 Start 50 Start) 51 (RLoser 4 66 7 (RLoser 1 53 (-5) Start 52 Start) 53 (LLoser 2 60 24 Start 60 (LLoser 1 63 19 Start 63 Start))))) 66 + + +main = defaultMain $ testGroup "Tests" [properties, regressions] + where + properties = testGroup "PropertyTests" + [ testProperty "Balanced" prop_Balanced + , testProperty "OrderedKeys" prop_OrderedKeys + , testProperty "MinView" prop_MinView + , testProperty "AtMost" prop_AtMost + , testProperty "AtMostRange" prop_AtMostRange + , testProperty "SizeValid" prop_SizeValid + , testProperty "LTreeBSTValid" prop_LTreeBSTValid + , testProperty "LTreeKeysValid" prop_LTreeKeysValid + , testProperty "LTreeSemiHeap" prop_LTreeSemiHeap + , testProperty "LTreeOriginates" prop_LTreeOriginates + , testProperty "PennantHeap" prop_PennantHeap + , testProperty "PennantBST" prop_PennantBST + ] + regressions = testGroup "RegressionTests" + [ testCase "BalanceFromlist" assertion_BalanceFromlist + , testCase "BalancePlay" assertion_BalancePlay + ]