diff --git a/CHANGELOG.md b/CHANGELOG.md index 0b44dae..efa5497 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## 1.0.0.0 -- September 2024 + +* Fixed `Data.Zebra.Word.fillRange`. + Previously it produced malformed trees in certain cases. + +## 1.0.0.1 -- May 2024 + +* Radix tree performance tweaks + ## 1.0.0.0 -- April 2024 * Initial rewrite diff --git a/radix-tree.cabal b/radix-tree.cabal index db26971..1bd1f2f 100644 --- a/radix-tree.cabal +++ b/radix-tree.cabal @@ -1,5 +1,5 @@ name: radix-tree -version: 1.0.0.1 +version: 1.0.0.2 category: Data Structures synopsis: Radix trees diff --git a/src/Data/Patricia/Word/Lazy/Debug.hs b/src/Data/Patricia/Word/Lazy/Debug.hs index bcbafe2..6d23f4b 100644 --- a/src/Data/Patricia/Word/Lazy/Debug.hs +++ b/src/Data/Patricia/Word/Lazy/Debug.hs @@ -58,15 +58,15 @@ validate t = go s q x = case x of Bin p l r - | p == 0 -> Invalid ZeroPrefix - | not $ validBelow q s p -> Invalid $ PrefixBelow q p - | otherwise -> + | p == 0 -> Invalid ZeroPrefix + | not $ validPrefix q s p -> Invalid $ PrefixBelow q p + | otherwise -> case go L p l of Valid -> go R p r err -> err Tip k _ - | not $ validBelow q s k -> Invalid $ KeyBelow q k - | otherwise -> Valid + | not $ validKey q s k -> Invalid $ KeyBelow q k + | otherwise -> Valid Nil -> Invalid $ MalformedBin q diff --git a/src/Data/Patricia/Word/Strict/Debug.hs b/src/Data/Patricia/Word/Strict/Debug.hs index 298eba7..79ade15 100644 --- a/src/Data/Patricia/Word/Strict/Debug.hs +++ b/src/Data/Patricia/Word/Strict/Debug.hs @@ -58,15 +58,15 @@ validate t = go s q x = case x of Bin p l r - | p == 0 -> Invalid ZeroPrefix - | not $ validBelow q s p -> Invalid $ PrefixBelow q p - | otherwise -> + | p == 0 -> Invalid ZeroPrefix + | not $ validPrefix q s p -> Invalid $ PrefixBelow q p + | otherwise -> case go L p l of Valid -> go R p r err -> err Tip k _ - | not $ validBelow q s k -> Invalid $ KeyBelow q k - | otherwise -> Valid + | not $ validKey q s k -> Invalid $ KeyBelow q k + | otherwise -> Valid Nil -> Invalid $ MalformedBin q diff --git a/src/Data/RadixNTree/Word8/Lazy/Debug.hs b/src/Data/RadixNTree/Word8/Lazy/Debug.hs index dd7821a..66d641c 100644 --- a/src/Data/RadixNTree/Word8/Lazy/Debug.hs +++ b/src/Data/RadixNTree/Word8/Lazy/Debug.hs @@ -90,16 +90,16 @@ validate1 = go Lin goBin s b q x = case x of Bin p l r - | p == 0 -> Invalid (Build b) ZeroPrefix - | not $ validBelow q s p -> Invalid (Build b) $ PrefixBelow q p + | p == 0 -> Invalid (Build b) ZeroPrefix + | not $ validPrefix q s p -> Invalid (Build b) $ PrefixBelow q p | otherwise -> case goBin L b p l of Valid -> goBin R b p r err -> err Tip arr mx dx - | sizeofByteArray arr <= 0 -> Invalid (Build b) EmptyByteArray - | not $ validBelow q s (indexByteArray arr 0) -> + | sizeofByteArray arr <= 0 -> Invalid (Build b) EmptyByteArray + | not $ validKey q s (indexByteArray arr 0) -> Invalid (Build b) $ KeyBelow q (indexByteArray arr 0) | Nothing <- mx, Tip _ _ _ <- dx -> Invalid (Build b) UncompressedTip diff --git a/src/Data/RadixNTree/Word8/Strict/Debug.hs b/src/Data/RadixNTree/Word8/Strict/Debug.hs index dfd40f6..d7bd179 100644 --- a/src/Data/RadixNTree/Word8/Strict/Debug.hs +++ b/src/Data/RadixNTree/Word8/Strict/Debug.hs @@ -90,16 +90,16 @@ validate1 = go Lin goBin s b q x = case x of Bin p l r - | p == 0 -> Invalid (Build b) ZeroPrefix - | not $ validBelow q s p -> Invalid (Build b) $ PrefixBelow q p - | otherwise -> + | p == 0 -> Invalid (Build b) ZeroPrefix + | not $ validPrefix q s p -> Invalid (Build b) $ PrefixBelow q p + | otherwise -> case goBin L b p l of Valid -> goBin R b p r err -> err Tip arr mx dx - | sizeofByteArray arr <= 0 -> Invalid (Build b) EmptyByteArray - | not $ validBelow q s (indexByteArray arr 0) -> + | sizeofByteArray arr <= 0 -> Invalid (Build b) EmptyByteArray + | not $ validKey q s (indexByteArray arr 0) -> Invalid (Build b) $ KeyBelow q (indexByteArray arr 0) | Nothing <- mx, Tip _ _ _ <- dx -> Invalid (Build b) UncompressedTip diff --git a/src/Data/Zebra/Word/Debug.hs b/src/Data/Zebra/Word/Debug.hs index 74d9c89..93d7684 100644 --- a/src/Data/Zebra/Word/Debug.hs +++ b/src/Data/Zebra/Word/Debug.hs @@ -95,9 +95,9 @@ validate t0 = go s q x cL = case x of Bin p l r - | p == 0 -> Break ZeroPrefix - | not $ validBelow q s p -> Break $ PrefixBelow q p - | otherwise -> + | p == 0 -> Break ZeroPrefix + | not $ validPrefix q s p -> Break $ PrefixBelow q p + | otherwise -> case go L p l cL of Carry cR -> go R p r (Just cR) err -> err @@ -108,7 +108,7 @@ validate t0 = Nil _ -> Break FoundNil goTip s q k cL c - | k == 0 = Break ZeroKey - | not $ validBelow q s k = Break $ KeyBelow q k - | Just x <- cL, x == c = Break $ NoSwitch c k - | otherwise = Carry c + | k == 0 = Break ZeroKey + | not $ validKey q s k = Break $ KeyBelow q k + | Just x <- cL, x == c = Break $ NoSwitch c k + | otherwise = Carry c diff --git a/src/Data/Zebra/Word/Internal.hs b/src/Data/Zebra/Word/Internal.hs index 37e6198..1173602 100644 --- a/src/Data/Zebra/Word/Internal.hs +++ b/src/Data/Zebra/Word/Internal.hs @@ -1963,17 +1963,37 @@ fillRange_ !x !wL !wR = go goTip k c t | wR < k = if c == x - then join k t pM binM + then if xor wL wR < xor wR k + then join k t pM binM + else let !(# o #) = invert x + + !mJ = branchingBit wR k + + !pJ = mask wR mJ .|. mJ + + in join + wL (tip wL x) + pJ (Bin pJ (tip wR o) t) else t | k < wL = if c == x then t - else if k == 0 - then binM - else join k t pM binM + else if xor k wL > xor wL wR + then join k t pM binM + else let !mJ = branchingBit k wL + + !pJ = mask k mJ .|. mJ + + in join + pJ (Bin pJ t (tip wL x)) + wR (tip wR c) + + | otherwise = + let w = if c == x + then wL + else wR - | c == x = tip wL c - | otherwise = tip wR c + in tip w c diff --git a/src/Radix/Word/Debug.hs b/src/Radix/Word/Debug.hs index cb1e28d..501e4ae 100644 --- a/src/Radix/Word/Debug.hs +++ b/src/Radix/Word/Debug.hs @@ -1,6 +1,8 @@ module Radix.Word.Debug ( S (..) - , validBelow + + , validPrefix + , validKey ) where import Radix.Word.Foundation @@ -14,10 +16,20 @@ data S = L -- ^ Left. Masked bit of the prefix above this node must be @0@. | R -- ^ Right. Masked bit of the prefix above this node must be @1@. deriving Show + + +-- | Check whether the prefix below aligns with the side the branch is on. +validPrefix :: Prefix -> S -> Prefix -> Bool +validPrefix p s o = + let low = p .&. negate p + in case s of + L -> o < p && p - o < low + R -> p < o && o - p < low + -- | Check whether the key below aligns with the side the branch is on. -validBelow :: Prefix -> S -> Key -> Bool -validBelow p1 s p2 = - let q = p2 .&. (p1 .&. negate p1) - in not (beyond p1 p2) && case s of - L -> q == 0 - R -> q /= 0 +validKey :: Prefix -> S -> Key -> Bool +validKey p s k = + let low = p .&. negate p + in case s of + L -> k < p && p - k <= low + R -> p <= k && k - p < low diff --git a/src/Radix/Word8/Debug.hs b/src/Radix/Word8/Debug.hs index a68f299..5e3bd40 100644 --- a/src/Radix/Word8/Debug.hs +++ b/src/Radix/Word8/Debug.hs @@ -1,6 +1,8 @@ module Radix.Word8.Debug ( S (..) - , validBelow + + , validPrefix + , validKey ) where import Radix.Word8.Foundation @@ -14,10 +16,22 @@ data S = L -- ^ Left. Masked bit of the prefix above this node must be @0@. | R -- ^ Right. Masked bit of the prefix above this node must be @1@. deriving Show + + +-- | Check whether the prefix below aligns with the side the branch is on. +validPrefix :: Prefix -> S -> Prefix -> Bool +validPrefix p s o = + let low = p .&. negate p + in case s of + L -> o < p && p - o < low + R -> p < o && o - p < low + + + -- | Check whether the key below aligns with the side the branch is on. -validBelow :: Prefix -> S -> Key -> Bool -validBelow p1 s p2 = - let q = p2 .&. (p1 .&. negate p1) - in not (beyond p1 p2) && case s of - L -> q == 0 - R -> q /= 0 +validKey :: Prefix -> S -> Key -> Bool +validKey p s k = + let low = p .&. negate p + in case s of + L -> k < p && p - k <= low + R -> p <= k && k - p < low