PSQueue-1.2.2/0000755000000000000000000000000007346545000011234 5ustar0000000000000000PSQueue-1.2.2/ChangeLog.md0000644000000000000000000000252707346545000013413 0ustar0000000000000000 ### 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 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 - Maintenance release - Add support for `base-4.11.0.0` - Fix link to ICFP paper - Modernise packaging PSQueue-1.2.2/LICENSE0000644000000000000000000000267607346545000012254 0ustar0000000000000000Copyright (c) 2008, Ralf Hinze All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. PSQueue-1.2.2/PSQueue.cabal0000644000000000000000000000301007346545000013541 0ustar0000000000000000cabal-version: 2.0 name: PSQueue version: 1.2.2 build-type: Simple license: BSD3 license-file: LICENSE author: Ralf Hinze maintainer: Teo Camarasu bug-reports: https://github.com/TeofilC/PSQueue/issues synopsis: Priority Search Queue category: Data Structures description: A /priority search queue/ efficiently supports the 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.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 location: https://github.com/TeofilC/PSQueue.git library exposed-modules: Data.PSQueue Data.PSQueue.Internal default-language: Haskell2010 hs-source-dirs: src/ if impl(ghc >7.2) default-extensions: Safe build-depends: base >=4.3 && <4.22 test-suite test type: exitcode-stdio-1.0 default-language: Haskell2010 hs-source-dirs: test/ main-is: Test.hs build-depends: base , PSQueue , QuickCheck < 3 , tasty <1.6 , tasty-quickcheck <0.12 , tasty-hunit <0.11 PSQueue-1.2.2/src/Data/0000755000000000000000000000000007346545000012674 5ustar0000000000000000PSQueue-1.2.2/src/Data/PSQueue.hs0000644000000000000000000000256207346545000014564 0ustar0000000000000000{- | A /priority search queue/ (henceforth /queue/) efficiently supports the 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. This implementation is due to Ralf Hinze. * [Hinze, R., A Simple Implementation Technique for Priority Search Queues, ICFP 2001, pp. 110-121](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.18.1149) -} -- Some modifications by Scott Dillard module Data.PSQueue ( -- * Binding Type Binding((:->)) , key , prio -- * Priority Search Queue Type , PSQ -- * Query , size , null , lookup -- * Construction , empty , singleton -- * Insertion , insert , insertWith -- * Delete/Update , delete , adjust , adjustWithKey , update , updateWithKey , alter -- * Conversion , keys , toList , toAscList , toDescList , fromList , fromAscList , fromDistinctAscList -- * Priority Queue , findMin , deleteMin , minView , atMost , atMostRange -- * Fold , foldr , foldl ) where import Prelude () import Data.PSQueue.Internal PSQueue-1.2.2/src/Data/PSQueue/0000755000000000000000000000000007346545000014223 5ustar0000000000000000PSQueue-1.2.2/src/Data/PSQueue/Internal.hs0000644000000000000000000005377207346545000016351 0ustar0000000000000000module Data.PSQueue.Internal ( -- * Binding Type Binding(..) , key , prio -- * Priority Search Queue Type , PSQ(..) -- * Query , size , null , lookup -- * Construction , empty , singleton -- * Insertion , insert , insertWith , insertWithKey -- * Delete/Update , delete , adjust , adjustWithKey , update , updateWithKey , alter -- * Conversion , keys , fromList , fromAscList , fromDistinctAscList , foldm , toList , toAscList , toAscLists , toDescList , toDescLists -- * Priority Queue , findMin , deleteMin , minView , secondBest , atMost , atMosts , atMostRange , atMostRanges , inrange -- * Fold , foldr , foldl -- * Internals , Size , LTree(..) , size' , left , right , maxKey , lloser , rloser , omega , lbalance , rbalance , lbalanceLeft , lbalanceRight , rbalanceLeft , rbalanceRight , lsingleLeft , rsingleLeft , lsingleRight , rsingleRight , ldoubleLeft , ldoubleRight , rdoubleLeft , rdoubleRight , play , 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) infix 0 :-> -- | The key of a binding key :: Binding k p -> k key (k :-> _) = k -- | The priority of a binding prio :: Binding k p -> p prio (_ :-> p) = p -- | A mapping from keys @k@ to priorites @p@. data PSQ k p = Void | Winner !k !p !(LTree k p) !k 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. size :: PSQ k p -> Int size Void = 0 size (Winner _ _ lt _) = 1 + size' lt -- | /O(1)/ True if the queue is empty. null :: PSQ k p -> Bool null Void = True null (Winner _ _ _ _) = False -- | /O(log n)/ The priority of a given key, or Nothing if the key is not -- bound. {-# INLINABLE lookup #-} lookup :: Ord k => k -> PSQ k p -> Maybe p lookup k q = case tourView q of Null -> fail "PSQueue.lookup: Empty queue" Single k' p | k == k' -> return p | otherwise -> fail "PSQueue.lookup: Key not found" tl `Play` tr | k <= maxKey tl -> lookup k tl | otherwise -> lookup k tr empty :: PSQ k p empty = Void -- | O(1) Build a queue with one binding. 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 Null -> singleton k p Single k' p' -> case compare k k' of LT -> singleton k p `play` singleton k' p' EQ -> singleton k p GT -> singleton k' p' `play` singleton k p tl `Play` tr | k <= maxKey tl -> insert k p tl `play` tr | otherwise -> tl `play` insert k p tr -- | /O(log n)/ Insert a binding with a combining function. insertWith :: (Ord k, Ord p) => (p->p->p) -> k -> p -> PSQ k p -> PSQ k p 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 Null -> singleton k p Single k' p' -> case compare k k' of LT -> singleton k p `play` singleton k' p' 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 `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 Null -> empty Single k' p | k == k' -> empty | otherwise -> singleton k' p tl `Play` tr | k <= maxKey tl -> delete k tl `play` tr | 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 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 Null -> empty Single k' p | k == k' -> singleton k' (f k p) | otherwise -> singleton k' p tl `Play` 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 -- priority @p@ bound @k@ (if it is in the queue). If (@f p@) is 'Nothing', -- the binding is deleted. If it is (@'Just' z@), the key @k@ is bound -- to the new priority @z@. update :: (Ord k, Ord p) => (p -> Maybe p) -> k -> PSQ k p -> PSQ k p update f = updateWithKey (\_ p -> f p) -- | /O(log n)/. The expression (@updateWithKey f k q@) updates the -- priority @p@ bound @k@ (if it is in the queue). If (@f k p@) is 'Nothing', -- 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 Null -> empty Single k' p | k==k' -> case f k p of Nothing -> empty Just p' -> singleton k p' | otherwise -> singleton k' p tl `Play` 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 Null -> case f Nothing of Nothing -> empty Just p -> singleton k p Single k' p | k == k' -> case f (Just p) of Nothing -> empty Just p' -> singleton k' p' | otherwise -> case f Nothing of Nothing -> singleton k' p Just p' -> insert k p' $ singleton k' p tl `Play` 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 :: PSQ k p -> [k] keys = map key . toList -- | /O(n log n)/ Build a queue from a list of bindings. fromList :: (Ord k, Ord p) => [Binding k p] -> PSQ k p fromList = P.foldr (\(k:->p) q -> insert k p q) empty -- | /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. {-# INLINABLE fromAscList #-} fromAscList :: (Eq k, Ord p) => [Binding k p] -> PSQ k p fromAscList = fromDistinctAscList . stripEq where stripEq [] = [] stripEq (x:xs) = stripEq' x xs stripEq' x' [] = [x'] stripEq' x' (x:xs) | x' == x = stripEq' x' xs | otherwise = x' : stripEq' x xs -- | /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. {-# 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 foldm (*) e x | P.null x = e | otherwise = fst (rec (length x) x) where rec 1 (a : as) = (a, as) rec n as = (a1 * a2, as2) where m = n `div` 2 (a1, as1) = rec (n - m) as (a2, as2) = rec m as1 -- | /O(n)/ Convert a queue to a list. toList :: PSQ k p -> [Binding k p] toList = toAscList -- | /O(n)/ Convert a queue to a list in ascending order of keys. toAscList :: PSQ k p -> [Binding k p] toAscList q = seqToList (toAscLists q) 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 :: PSQ k p -> [ Binding k p ] toDescList q = seqToList (toDescLists q) toDescLists :: PSQ k p -> Sequ (Binding k p) toDescLists q = case tourView q of Null -> emptySequ Single k p -> singleSequ (k :-> p) tl `Play` tr -> toDescLists tr <+> toDescLists tl -- | /O(1)/ The binding with the lowest priority. 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 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 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 ) {-# 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' -- | /O(r(log n - log r)/ @atMost p q@ is a list of all the bindings in @q@ with -- priority less than @p@, in order of ascending keys. -- Effectively, -- -- @ -- atMost p' q = filter (\\(k:->p) -> p<=p') . toList -- @ atMost :: Ord p => p -> PSQ k p -> [Binding k p] atMost pt q = seqToList (atMosts pt q) 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 prune k p t | p > pt = emptySequ | otherwise = traverse k p t traverse k p Start = singleSequ (k :-> p) traverse k p (LLoser _ k' p' tl _m tr) = prune k' p' tl <+> traverse k p tr traverse k p (RLoser _ k' p' tl _m tr) = traverse k p tl <+> prune k' p' tr -- | /O(r(log n - log r))/ @atMostRange p (l,u) q@ is a list of all the bindings in -- @q@ with a priority less than @p@ and a key in the range @(l,u)@ inclusive. -- Effectively, -- -- @ -- 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 prune k p t | p > pt = emptySequ | otherwise = traverse k p t traverse k p Start | k `inrange` range = singleSequ (k :-> p) | otherwise = emptySequ traverse k p (LLoser _ k' p' tl m tr) = guard (kl <= m) (prune k' p' tl) <+> guard (m <= kr) (traverse k p tr) traverse k p (RLoser _ k' p' tl m tr) = guard (kl <= m) (traverse k p tl) <+> guard (m <= kr) (prune k' p' tr) {-# 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 :: (Binding k p -> b -> b) -> b -> PSQ k p -> b foldr f z q = case tourView q of Null -> z Single k p -> f (k:->p) z l`Play`r -> foldr f (foldr f z r) l -- | Left fold over the bindings in the queue, in key order. foldl :: (b -> Binding k p -> b) -> b -> PSQ k p -> b foldl f z q = case tourView q of Null -> z Single k p -> f z (k:->p) l`Play`r -> foldl f (foldl f z l) r ----------------------- ------- Internals ----- ---------------------- 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) size' :: LTree k p -> Size size' Start = 0 size' (LLoser s _ _ _ _ _) = s size' (RLoser s _ _ _ _ _) = s left, right :: LTree a b -> LTree a b left Start = error "left: empty loser tree" left (LLoser _ _ _ tl _ _ ) = tl left (RLoser _ _ _ tl _ _ ) = tl right Start = error "right: empty loser tree" right (LLoser _ _ _ _ _ tr) = tr right (RLoser _ _ _ _ _ tr) = tr maxKey :: PSQ k p -> k maxKey Void = error "maxKey: empty queue" maxKey (Winner _k _p _t m) = m lloser, rloser :: k -> p -> LTree k p -> k -> LTree k p -> LTree k p 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 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 p => k -> p -> LTree k p -> k -> LTree k p -> LTree k p lbalance 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 rbalance 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 {-# 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) < 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 | 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) < 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 | 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 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) rsingleRight k1 p1 (RLoser _ k2 p2 t1 m1 t2) m2 t3 | p1 <= p2 = rloser k1 p1 t1 m1 (lloser k2 p2 t2 m2 t3) | 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 {-# INLINABLE play #-} play :: Ord p => PSQ k p -> PSQ k p -> PSQ k p Void `play` t' = t' t `play` Void = t Winner k p t m `play` 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 :: PSQ k p -> TourView k p {-# INLINE tourView #-} tourView Void = Null tourView (Winner k p Start _m) = Single k p tourView (Winner k p (RLoser _ k' p' tl m tr) m') = Winner k p tl m `Play` Winner k' p' tr m' tourView (Winner k p (LLoser _ k' p' tl m tr) m') = Winner k' p' tl m `Play` Winner k p tr m' -------------------------------------- -- Hughes's efficient sequence type -- -------------------------------------- emptySequ :: Sequ a singleSequ :: a -> Sequ a (<+>) :: Sequ a -> Sequ a -> Sequ a seqFromList :: [a] -> Sequ a seqFromListT :: ([a] -> [a]) -> Sequ a seqToList :: Sequ a -> [a] infixr 5 <+> newtype Sequ a = Sequ ([a] -> [a]) emptySequ = Sequ (\as -> as) singleSequ a = Sequ (\as -> a : as) Sequ x1 <+> Sequ x2 = Sequ (\as -> x1 (x2 as)) seqFromList as = Sequ (\as' -> as ++ as') seqFromListT as = Sequ as seqToList (Sequ x) = x [] instance Show a => Show (Sequ a) where showsPrec d a = showsPrec d (seqToList a) 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 PSQueue-1.2.2/test/0000755000000000000000000000000007346545000012213 5ustar0000000000000000PSQueue-1.2.2/test/Test.hs0000644000000000000000000001416707346545000013477 0ustar0000000000000000{-# 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)) && 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)) && isBalanced l && isBalanced r instance (Ord k, Ord p, Arbitrary k, Arbitrary p) => Arbitrary (PSQ k p) where arbitrary = do ks <- arbitrary ps <- arbitrary return . fromList $ zipWith (:->) ks ps prop_Balanced :: PSQ Int Int -> Bool prop_Balanced Void = True prop_Balanced (Winner _ _ t _) = isBalanced t prop_OrderedKeys :: PSQ Int Int -> Bool prop_OrderedKeys t = let ks = map key . toAscList $ t in sort ks == ks prop_AtMost :: (PSQ Int Int,Int) -> Bool prop_AtMost (t,p) = let ps = map prio . atMost p $ t in all (<=p) ps prop_AtMostRange :: (PSQ Int Int,Int,Int,Int) -> Bool prop_AtMostRange (t,p,l_,r_) = let l = min (abs l_) (abs r_) r = max (abs l_) (abs r_) (ks,ps) = unzip . map (\b -> (key b,prio b)) . atMostRange p (l,r) $ t in all (flip inrange (l,r)) ks && all (<=p) ps prop_MinView :: PSQ Int Int -> Bool prop_MinView t = case minView t of Nothing -> True Just (b1,t') -> case minView t' of Nothing -> True Just (b2,_) -> prio b1 <= prio b2 && prop_MinView t' 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 ]