packages feed

PSQueue 1.1.1 → 1.2.2

raw patch · 5 files changed

Files

ChangeLog.md view
@@ -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
PSQueue.cabal view
@@ -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
src/Data/PSQueue.hs view
@@ -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,
src/Data/PSQueue/Internal.hs view
@@ -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 '<' = "&lt;"+    subst '>' = "&gt;"+    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 +++               "<br/>&nbsp;(" ++ dotLitS k ++ ", " ++ dotLitS p ++ ") " +++               dotLitS m ++ "&nbsp;>;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
test/Test.hs view
@@ -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+        ]