From d7e2a2b2fc068ea27b89f18c547487ddddacdbc2 Mon Sep 17 00:00:00 2001 From: BurningWitness Date: Mon, 2 Sep 2024 16:55:08 +0300 Subject: [PATCH 1/2] Removing unwanted side cases from prefix checks and fixing Data.Zebra.Word.fillRange --- CHANGELOG.md | 9 +++++++ radix-tree.cabal | 2 +- src/Data/Patricia/Word/Lazy/Debug.hs | 10 +++---- src/Data/Patricia/Word/Strict/Debug.hs | 10 +++---- src/Data/RadixNTree/Word8/Lazy/Debug.hs | 8 +++--- src/Data/RadixNTree/Word8/Strict/Debug.hs | 10 +++---- src/Data/Zebra/Word/Debug.hs | 16 ++++++------ src/Data/Zebra/Word/Internal.hs | 32 ++++++++++++++++++----- src/Radix/Word/Debug.hs | 26 +++++++++++++----- src/Radix/Word8/Debug.hs | 28 +++++++++++++++----- 10 files changed, 103 insertions(+), 48 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 0b44dae..4893771 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 -- April 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..e92dcc9 100644 --- a/src/Data/Zebra/Word/Debug.hs +++ b/src/Data/Zebra/Word/Debug.hs @@ -19,7 +19,7 @@ import Numeric.Long import Radix.Word.Foundation import Radix.Word.Debug - +import Debug.Trace -- | \(\mathcal{O}(n)\). -- Shows the internal structure of the tree. @@ -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..d1140e1 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 even p && 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..d6c2947 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 even p && 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 From 5ae596c892c265c6f84071ee5ba70abf9f756faa Mon Sep 17 00:00:00 2001 From: BurningWitness Date: Mon, 2 Sep 2024 23:12:36 +0300 Subject: [PATCH 2/2] Cleanup --- CHANGELOG.md | 2 +- src/Data/Zebra/Word/Debug.hs | 2 +- src/Radix/Word/Debug.hs | 6 +++--- src/Radix/Word8/Debug.hs | 6 +++--- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4893771..efa5497 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,7 +3,7 @@ * Fixed `Data.Zebra.Word.fillRange`. Previously it produced malformed trees in certain cases. -## 1.0.0.1 -- April 2024 +## 1.0.0.1 -- May 2024 * Radix tree performance tweaks diff --git a/src/Data/Zebra/Word/Debug.hs b/src/Data/Zebra/Word/Debug.hs index e92dcc9..93d7684 100644 --- a/src/Data/Zebra/Word/Debug.hs +++ b/src/Data/Zebra/Word/Debug.hs @@ -19,7 +19,7 @@ import Numeric.Long import Radix.Word.Foundation import Radix.Word.Debug -import Debug.Trace + -- | \(\mathcal{O}(n)\). -- Shows the internal structure of the tree. diff --git a/src/Radix/Word/Debug.hs b/src/Radix/Word/Debug.hs index d1140e1..501e4ae 100644 --- a/src/Radix/Word/Debug.hs +++ b/src/Radix/Word/Debug.hs @@ -22,9 +22,9 @@ data S = L -- ^ Left. Masked bit of the prefix above this node must be @0@. validPrefix :: Prefix -> S -> Prefix -> Bool validPrefix p s o = let low = p .&. negate p - in even p && case s of - L -> o < p && p - o < low - R -> p < o && o - p < low + 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. validKey :: Prefix -> S -> Key -> Bool diff --git a/src/Radix/Word8/Debug.hs b/src/Radix/Word8/Debug.hs index d6c2947..5e3bd40 100644 --- a/src/Radix/Word8/Debug.hs +++ b/src/Radix/Word8/Debug.hs @@ -22,9 +22,9 @@ data S = L -- ^ Left. Masked bit of the prefix above this node must be @0@. validPrefix :: Prefix -> S -> Prefix -> Bool validPrefix p s o = let low = p .&. negate p - in even p && case s of - L -> o < p && p - o < low - R -> p < o && o - p < low + in case s of + L -> o < p && p - o < low + R -> p < o && o - p < low