packages feed

PSQueue 1.2.1 → 1.2.2

raw patch · 4 files changed

+234/−23 lines, 4 filesdep +tasty-hunitdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-hunit

Dependency ranges changed: base

API changes (from Hackage documentation)

+ Data.PSQueue.Internal: ltreeDot :: (Show k, Show p) => PSQ k p -> String
+ Data.PSQueue.Internal: pennantDot :: (Show k, Show p, Ord p) => PSQ k p -> String

Files

ChangeLog.md view
@@ -1,5 +1,10 @@ +### 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)@@ -14,13 +19,11 @@ - 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
PSQueue.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               PSQueue-version:            1.2.1+version:            1.2.2 build-type:         Simple license:            BSD3 license-file:       LICENSE@@ -49,3 +49,4 @@     , QuickCheck < 3     , tasty <1.6     , tasty-quickcheck <0.12+    , tasty-hunit <0.11
src/Data/PSQueue/Internal.hs view
@@ -1,4 +1,4 @@-module Data.PSQueue.Internal +module Data.PSQueue.Internal   (   -- * Binding Type     Binding(..)@@ -75,11 +75,14 @@   , 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)@@ -193,7 +196,7 @@       | 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.@@ -429,6 +432,11 @@  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)@@ -457,10 +465,18 @@ 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 ::@@ -481,26 +497,26 @@ {-# 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   @@ -626,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,17 +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)@@ -49,10 +55,118 @@         Nothing -> True         Just (b2,_) -> prio b1 <= prio b2 && prop_MinView t' -main = defaultMain $ testGroup "Tests"-  [ testProperty "Balanced" prop_Balanced-  , testProperty "OrderedKeys" prop_OrderedKeys-  , testProperty "MinView" prop_MinView-  , testProperty "AtMost" prop_AtMost-  , testProperty "AtMostRange" 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+        ]