Removing unwanted side cases from prefix checks and fixing Data.Zebra…

….Word.fillRange
sergv · Sep 2, 2024 · d7e2a2b · d7e2a2b
1 parent f89f3dc
commit d7e2a2b
Show file tree

Hide file tree

Showing 10 changed files with 103 additions and 48 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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