diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 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.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 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(..) @@ -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 '<' = "<" + 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,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 + ]